Changeset 11805


Ignore:
Timestamp:
04/30/09 06:03:30 (14 years ago)
Author:
ehuelsmann
Message:

Stop rewriting the lambda list in the precompiler;
we've decided this compiler-specific rewrite should
be in the compiler.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

    r11804 r11805  
    470470             ,@body))))))
    471471
     472(defun rewrite-lambda (form)
     473  (setf form (rewrite-aux-vars form))
     474  (let* ((lambda-list (cadr form)))
     475    (if (not (or (memq '&optional lambda-list)
     476                 (memq '&key lambda-list)))
     477        ;; no need to rewrite: no arguments with possible initforms anyway
     478        form
     479      (multiple-value-bind (body decls doc)
     480          (parse-body (cddr form))
     481        (let (state let-bindings new-lambda-list
     482                    (non-constants 0))
     483          (do* ((vars lambda-list (cdr vars))
     484                (var (car vars) (car vars)))
     485               ((endp vars))
     486            (push (car vars) new-lambda-list)
     487            (let ((replacement (gensym)))
     488              (flet ((parse-compound-argument (arg)
     489                       "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P,
     490   SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument."
     491                       (destructuring-bind
     492                             (name &optional (initform nil initform-supplied-p)
     493                                   (supplied-p nil supplied-p-supplied-p))
     494                           (if (listp arg) arg (list arg))
     495                         (if (listp name)
     496                             (values (cadr name) (car name)
     497                                     initform initform-supplied-p
     498                                     supplied-p supplied-p-supplied-p)
     499                             (values name (make-keyword name)
     500                                     initform initform-supplied-p
     501                                     supplied-p supplied-p-supplied-p)))))
     502                (case var
     503                  (&optional (setf state :optional))
     504                  (&key (setf state :key))
     505                  ((&whole &environment &rest &body &allow-other-keys)
     506                   ;; do nothing special
     507                   )
     508                  (t
     509                   (cond
     510                     ((atom var)
     511                      (setf (car new-lambda-list)
     512                            (if (eq state :key)
     513                                (list (list (make-keyword var) replacement))
     514                                replacement))
     515                      (push (list var replacement) let-bindings))
     516                     ((constantp (second var))
     517                      ;; so, we must have a consp-type var we're looking at
     518                      ;; and it has a constantp initform
     519                      (multiple-value-bind
     520                            (name keyword initform initform-supplied-p
     521                                  supplied-p supplied-p-supplied-p)
     522                          (parse-compound-argument var)
     523                        (let ((var-form (if (eq state :key)
     524                                            (list keyword replacement)
     525                                            replacement))
     526                              (supplied-p-replacement (gensym)))
     527                          (setf (car new-lambda-list)
     528                                (cond
     529                                  ((not initform-supplied-p)
     530                                   (list var-form))
     531                                  ((not supplied-p-supplied-p)
     532                                   (list var-form initform))
     533                                  (t
     534                                   (list var-form initform
     535                                         supplied-p-replacement))))
     536                          (push (list name replacement) let-bindings)
     537                          ;; if there was a 'supplied-p' variable, it might
     538                          ;; be used in the declarations. Since those will be
     539                          ;; moved below the LET* block, we need to move the
     540                          ;; supplied-p parameter too.
     541                          (when supplied-p-supplied-p
     542                            (push (list supplied-p supplied-p-replacement)
     543                                  let-bindings)))))
     544                     (t
     545                      (incf non-constants)
     546                      ;; this is either a keyword or an optional argument
     547                      ;; with a non-constantp initform
     548                      (multiple-value-bind
     549                            (name keyword initform initform-supplied-p
     550                                  supplied-p supplied-p-supplied-p)
     551                          (parse-compound-argument var)
     552                        (declare (ignore initform-supplied-p))
     553                        (let ((var-form (if (eq state :key)
     554                                            (list keyword replacement)
     555                                            replacement))
     556                              (supplied-p-replacement (gensym)))
     557                          (setf (car new-lambda-list)
     558                                (list var-form nil supplied-p-replacement))
     559                          (push (list name `(if ,supplied-p-replacement
     560                                                ,replacement ,initform))
     561                                let-bindings)
     562                          (when supplied-p-supplied-p
     563                            (push (list supplied-p supplied-p-replacement)
     564                                  let-bindings)))))))))))
     565          (if (zerop non-constants)
     566              ;; there was no reason to rewrite...
     567              form
     568              (let ((rv
     569                     `(lambda ,(nreverse new-lambda-list)
     570                        ,@(when doc (list doc))
     571                        (let* ,(nreverse let-bindings)
     572                          ,@decls ,@body))))
     573                rv)))))))
     574
    472575(defun p1-flet (form)
    473576  (with-local-functions-for-flet/labels
     
    478581     (let* ((block-name (fdefinition-block-name name))
    479582      (lambda-expression
    480                    (rewrite-aux-vars
     583                   (rewrite-lambda
    481584       `(lambda ,lambda-list ,@decls (block ,block-name ,@body))))
    482585      (*visible-variables* *visible-variables*)
     
    506609   (multiple-value-bind (body decls) (parse-body body)
    507610     (setf (compiland-lambda-expression compiland)
    508                  (rewrite-aux-vars
     611                 (rewrite-lambda
    509612     `(lambda ,lambda-list ,@decls (block ,name ,@body)))))
    510613   (push variable *all-variables*)
     
    567670               (setf (compiland-lambda-expression compiland)
    568671                     ;; if there still was a doc-string present, remove it
    569                      (rewrite-aux-vars
     672                     (rewrite-lambda
    570673                      `(lambda ,lambda-list ,@decls ,@body)))
    571674               (let ((*visible-variables* *visible-variables*)
     
    597700                    "P1-LAMBDA: can't handle optional argument with non-constant initform.")))))))
    598701    (p1-function (list 'FUNCTION
    599                         (rewrite-aux-vars form)))))
     702                        (rewrite-lambda form)))))
    600703
    601704(defun p1-eval-when (form)
     
    9141017  (let ((form (compiland-lambda-expression compiland)))
    9151018    (aver (eq (car form) 'LAMBDA))
    916     (setf form (rewrite-aux-vars form))
     1019    (setf form (rewrite-lambda form))
    9171020    (process-optimization-declarations (cddr form))
    9181021
  • trunk/abcl/src/org/armedbear/lisp/precompiler.lisp

    r11801 r11805  
    552552  (precompile-psetf form))
    553553
    554 (defun maybe-rewrite-lambda (form)
    555   (let* ((lambda-list (cadr form)))
    556     (if (not (or (memq '&optional lambda-list)
    557                  (memq '&key lambda-list)))
    558         ;; no need to rewrite: no arguments with possible initforms anyway
    559         form
    560       (multiple-value-bind (body decls doc)
    561           (parse-body (cddr form))
    562         (let (state let-bindings new-lambda-list
    563                     (non-constants 0))
    564           (do* ((vars lambda-list (cdr vars))
    565                 (var (car vars) (car vars)))
    566                ((or (endp vars) (eq '&aux (car vars)))
    567                 (setf new-lambda-list
    568                       (append (reverse vars) new-lambda-list)))
    569             (push (car vars) new-lambda-list)
    570             (let ((replacement (gensym)))
    571               (flet ((parse-compound-argument (arg)
    572                        "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P,
    573    SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument."
    574                        (destructuring-bind
    575                              (name &optional (initform nil initform-supplied-p)
    576                                    (supplied-p nil supplied-p-supplied-p))
    577                            (if (listp arg) arg (list arg))
    578                          (if (listp name)
    579                              (values (cadr name) (car name)
    580                                      initform initform-supplied-p
    581                                      supplied-p supplied-p-supplied-p)
    582                              (values name (make-keyword name)
    583                                      initform initform-supplied-p
    584                                      supplied-p supplied-p-supplied-p)))))
    585                 (case var
    586                   (&optional (setf state :optional))
    587                   (&key (setf state :key))
    588                   ((&whole &environment &rest &body &allow-other-keys)
    589                    ;; do nothing special
    590                    )
    591                   (t
    592                    (cond
    593                      ((atom var)
    594                       (setf (car new-lambda-list)
    595                             (if (eq state :key)
    596                                 (list (list (make-keyword var) replacement))
    597                                 replacement))
    598                       (push (list var replacement) let-bindings))
    599                      ((constantp (second var))
    600                       ;; so, we must have a consp-type var we're looking at
    601                       ;; and it has a constantp initform
    602                       (multiple-value-bind
    603                             (name keyword initform initform-supplied-p
    604                                   supplied-p supplied-p-supplied-p)
    605                           (parse-compound-argument var)
    606                         (let ((var-form (if (eq state :key)
    607                                             (list keyword replacement)
    608                                             replacement))
    609                               (supplied-p-replacement (gensym)))
    610                           (setf (car new-lambda-list)
    611                                 (cond
    612                                   ((not initform-supplied-p)
    613                                    (list var-form))
    614                                   ((not supplied-p-supplied-p)
    615                                    (list var-form initform))
    616                                   (t
    617                                    (list var-form initform
    618                                          supplied-p-replacement))))
    619                           (push (list name replacement) let-bindings)
    620                           ;; if there was a 'supplied-p' variable, it might
    621                           ;; be used in the declarations. Since those will be
    622                           ;; moved below the LET* block, we need to move the
    623                           ;; supplied-p parameter too.
    624                           (when supplied-p-supplied-p
    625                             (push (list supplied-p supplied-p-replacement)
    626                                   let-bindings)))))
    627                      (t
    628                       (incf non-constants)
    629                       ;; this is either a keyword or an optional argument
    630                       ;; with a non-constantp initform
    631                       (multiple-value-bind
    632                             (name keyword initform initform-supplied-p
    633                                   supplied-p supplied-p-supplied-p)
    634                           (parse-compound-argument var)
    635                         (declare (ignore initform-supplied-p))
    636                         (let ((var-form (if (eq state :key)
    637                                             (list keyword replacement)
    638                                             replacement))
    639                               (supplied-p-replacement (gensym)))
    640                           (setf (car new-lambda-list)
    641                                 (list var-form nil supplied-p-replacement))
    642                           (push (list name `(if ,supplied-p-replacement
    643                                                 ,replacement ,initform))
    644                                 let-bindings)
    645                           (when supplied-p-supplied-p
    646                             (push (list supplied-p supplied-p-replacement)
    647                                   let-bindings)))))))))))
    648           (if (zerop non-constants)
    649               ;; there was no reason to rewrite...
    650               form
    651               (let ((rv
    652                      `(lambda ,(nreverse new-lambda-list)
    653                         ,@(when doc (list doc))
    654                         (let* ,(nreverse let-bindings)
    655                           ,@decls ,@body))))
    656                 rv)))))))
    657554
    658555(defun precompile-lambda-list (form)
     
    679576
    680577(defun precompile-lambda (form)
    681   (setq form (maybe-rewrite-lambda form))
    682578  (let ((body (cddr form))
    683579        (precompiled-lambda-list
     
    690586(defun precompile-named-lambda (form)
    691587  (let ((lambda-form (list* 'LAMBDA (caddr form) (cdddr form))))
    692     (setf lambda-form (maybe-rewrite-lambda lambda-form))
    693588    (let ((body (cddr lambda-form))
    694589          (precompiled-lambda-list
     
    842737(defun precompile-local-function-def (def)
    843738  (let ((name (car def))
    844         (arglist (cadr def))
    845739        (body (cddr def)))
    846740    ;; Macro names are shadowed by local functions.
    847741    (environment-add-function-definition *compile-file-environment* name body)
    848     (list* name arglist (mapcar #'precompile1 body))))
     742    (cdr (precompile-named-lambda (list* 'NAMED-LAMBDA def)))))
    849743
    850744(defun precompile-local-functions (defs)
Note: See TracChangeset for help on using the changeset viewer.