Changeset 11797


Ignore:
Timestamp:
04/29/09 19:11:44 (13 years ago)
Author:
ehuelsmann
Message:

Fix the build. Removal of &aux variables rewriting broke it.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/precompiler.lisp

    r11796 r11797  
    554554(defun maybe-rewrite-lambda (form)
    555555  (let* ((lambda-list (cadr form)))
    556     (multiple-value-bind (body decls doc)
    557         (parse-body (cddr form))
    558       (let (state let-bindings new-lambda-list
    559             (non-constants 0))
    560         (do* ((vars lambda-list (cdr vars))
    561               (var (car vars) (car vars)))
    562              ((endp vars))
    563           (push (car vars) new-lambda-list)
    564           (let ((replacement (gensym)))
    565             (flet ((parse-compound-argument (arg)
    566                      "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P,
     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            (push (car vars) new-lambda-list)
     568            (let ((replacement (gensym)))
     569              (flet ((parse-compound-argument (arg)
     570                       "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P,
    567571   SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument."
    568                      (destructuring-bind
    569                            (name &optional (initform nil initform-supplied-p)
    570                                  (supplied-p nil supplied-p-supplied-p))
    571                          (if (listp arg) arg (list arg))
    572                        (if (listp name)
    573                            (values (cadr name) (car name)
    574                                    initform initform-supplied-p
    575                                    supplied-p supplied-p-supplied-p)
    576                            (values name (make-keyword name)
    577                                    initform initform-supplied-p
    578                                    supplied-p supplied-p-supplied-p)))))
    579             (case var
    580               (&optional (setf state :optional))
    581               (&key (setf state :key))
    582               ((&whole &environment &rest &body &allow-other-keys)
    583                ;; do nothing special
    584                )
    585               (t
    586                (cond
    587                  ((atom var)
    588                   (setf (car new-lambda-list)
    589                         (if (eq state :key)
    590                             (list (list (make-keyword var) replacement))
    591                             replacement))
    592                   (push (list var replacement) let-bindings))
    593                  ((constantp (second var))
    594                   ;; so, we must have a consp-type var we're looking at
    595                   ;; and it has a constantp initform
    596                   (multiple-value-bind
    597                         (name keyword initform initform-supplied-p
    598                               supplied-p supplied-p-supplied-p)
    599                       (parse-compound-argument var)
    600                     (let ((var-form (if (eq state :key)
    601                                         (list keyword replacement)
    602                                         replacement))
    603                           (supplied-p-replacement (gensym)))
     572                       (destructuring-bind
     573                             (name &optional (initform nil initform-supplied-p)
     574                                   (supplied-p nil supplied-p-supplied-p))
     575                           (if (listp arg) arg (list arg))
     576                         (if (listp name)
     577                             (values (cadr name) (car name)
     578                                     initform initform-supplied-p
     579                                     supplied-p supplied-p-supplied-p)
     580                             (values name (make-keyword name)
     581                                     initform initform-supplied-p
     582                                     supplied-p supplied-p-supplied-p)))))
     583                (case var
     584                  (&optional (setf state :optional))
     585                  (&key (setf state :key))
     586                  ((&whole &environment &rest &body &allow-other-keys)
     587                   ;; do nothing special
     588                   )
     589                  (t
     590                   (cond
     591                     ((atom var)
    604592                      (setf (car new-lambda-list)
    605                             (cond
    606                               ((not initform-supplied-p)
    607                                (list var-form))
    608                               ((not supplied-p-supplied-p)
    609                                (list var-form initform))
    610                               (t
    611                                (list var-form initform
    612                                      supplied-p-replacement))))
    613                       (push (list name replacement) let-bindings)
    614                       ;; if there was a 'supplied-p' variable, it might
    615                       ;; be used in the declarations. Since those will be
    616                       ;; moved below the LET* block, we need to move the
    617                       ;; supplied-p parameter too.
    618                       (when supplied-p-supplied-p
    619                         (push (list supplied-p supplied-p-replacement)
    620                               let-bindings)))))
    621                  (t
    622                   (incf non-constants)
    623                   ;; this is either a keyword or an optional argument
    624                   ;; with a non-constantp initform
    625                   (multiple-value-bind
    626                         (name keyword initform initform-supplied-p
    627                               supplied-p supplied-p-supplied-p)
    628                       (parse-compound-argument var)
    629                     (declare (ignore initform-supplied-p))
    630                     (let ((var-form (if (eq state :key)
    631                                         (list keyword replacement)
    632                                         replacement))
    633                           (supplied-p-replacement (gensym)))
    634                       (setf (car new-lambda-list)
    635                             (list var-form nil supplied-p-replacement))
    636                       (push (list name `(if ,supplied-p-replacement
    637                                             ,replacement ,initform))
    638                                   let-bindings)
    639                       (when supplied-p-supplied-p
    640                         (push (list supplied-p supplied-p-replacement)
    641                               let-bindings)))))))))))
    642         (if (zerop non-constants)
    643             ;; there was no reason to rewrite...
    644             form
    645             (let ((rv
    646                    `(lambda ,(nreverse new-lambda-list)
    647                       ,@(when doc (list doc))
    648                       (let* ,(nreverse let-bindings)
    649                         ,@decls ,@body))))
    650               rv))))))
     593                            (if (eq state :key)
     594                                (list (list (make-keyword var) replacement))
     595                                replacement))
     596                      (push (list var replacement) let-bindings))
     597                     ((constantp (second var))
     598                      ;; so, we must have a consp-type var we're looking at
     599                      ;; and it has a constantp initform
     600                      (multiple-value-bind
     601                            (name keyword initform initform-supplied-p
     602                                  supplied-p supplied-p-supplied-p)
     603                          (parse-compound-argument var)
     604                        (let ((var-form (if (eq state :key)
     605                                            (list keyword replacement)
     606                                            replacement))
     607                              (supplied-p-replacement (gensym)))
     608                          (setf (car new-lambda-list)
     609                                (cond
     610                                  ((not initform-supplied-p)
     611                                   (list var-form))
     612                                  ((not supplied-p-supplied-p)
     613                                   (list var-form initform))
     614                                  (t
     615                                   (list var-form initform
     616                                         supplied-p-replacement))))
     617                          (push (list name replacement) let-bindings)
     618                          ;; if there was a 'supplied-p' variable, it might
     619                          ;; be used in the declarations. Since those will be
     620                          ;; moved below the LET* block, we need to move the
     621                          ;; supplied-p parameter too.
     622                          (when supplied-p-supplied-p
     623                            (push (list supplied-p supplied-p-replacement)
     624                                  let-bindings)))))
     625                     (t
     626                      (incf non-constants)
     627                      ;; this is either a keyword or an optional argument
     628                      ;; with a non-constantp initform
     629                      (multiple-value-bind
     630                            (name keyword initform initform-supplied-p
     631                                  supplied-p supplied-p-supplied-p)
     632                          (parse-compound-argument var)
     633                        (declare (ignore initform-supplied-p))
     634                        (let ((var-form (if (eq state :key)
     635                                            (list keyword replacement)
     636                                            replacement))
     637                              (supplied-p-replacement (gensym)))
     638                          (setf (car new-lambda-list)
     639                                (list var-form nil supplied-p-replacement))
     640                          (push (list name `(if ,supplied-p-replacement
     641                                                ,replacement ,initform))
     642                                let-bindings)
     643                          (when supplied-p-supplied-p
     644                            (push (list supplied-p supplied-p-replacement)
     645                                  let-bindings)))))))))))
     646          (if (zerop non-constants)
     647              ;; there was no reason to rewrite...
     648              form
     649              (let ((rv
     650                     `(lambda ,(nreverse new-lambda-list)
     651                        ,@(when doc (list doc))
     652                        (let* ,(nreverse let-bindings)
     653                          ,@decls ,@body))))
     654                rv)))))))
    651655
    652656(defun precompile-lambda-list (form)
Note: See TracChangeset for help on using the changeset viewer.