Changeset 11788


Ignore:
Timestamp:
04/27/09 20:24:57 (13 years ago)
Author:
ehuelsmann
Message:

Rewriting version 2: cleaner code and rewrite SUPPLIED-P parameters too.

File:
1 edited

Legend:

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

    r11787 r11788  
    613613    (multiple-value-bind (body decls doc)
    614614        (parse-body (cddr form))
    615       (let (state let-bindings symbols new-lambda-list
     615      (let (state let-bindings new-lambda-list
    616616            (non-constants 0))
    617617        (do* ((vars lambda-list (cdr vars))
     
    620620          (push (car vars) new-lambda-list)
    621621          (let ((replacement (gensym)))
     622            (flet ((parse-compound-argument (arg)
     623                     "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P,
     624   SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument."
     625                     (destructuring-bind
     626                           (name &optional (initform nil initform-supplied-p)
     627                                 (supplied-p nil supplied-p-supplied-p))
     628                         (if (listp arg) arg (list arg))
     629                       (if (listp name)
     630                           (values (cadr name) (car name)
     631                                   initform initform-supplied-p
     632                                   supplied-p supplied-p-supplied-p)
     633                           (values name (make-keyword name)
     634                                   initform initform-supplied-p
     635                                   supplied-p supplied-p-supplied-p)))))
    622636            (case var
    623637              (&optional (setf state :optional))
    624638              (&key (setf state :key))
    625639              ((&whole &environment &rest &body &allow-other-keys)
    626                ;; do nothing
     640               ;; do nothing special
    627641               )
    628642              (t
    629                (when (and (atom var)
    630                           (eq state :key))
    631                  (setf var (list var)))
    632643               (cond
    633                  ((and (atom var)
    634                        (neq state :key))
    635                   (setf (car new-lambda-list) replacement)
    636                   (push (list var replacement)
    637                         let-bindings)) ;; do nothing
    638                  (t ;; "(x (some-function))" "((:x q) (some-function))"
    639                   ;; or even "(x (some-function) x-supplied-p)"
    640                   (destructuring-bind
    641                         (name &optional (initform nil initform-supplied-p)
    642                               (supplied-p nil supplied-p-supplied-p))
    643                       var
    644                     (when (and initform-supplied-p
    645                                (not (constantp initform)))
    646                       (incf non-constants))
    647                     (let* ((symbol (if (listp name) (second name) name))
    648                            (keyword (if (listp name) (car name)
    649                                         (intern (symbol-name symbol)
    650                                                 (find-package "KEYWORD"))))
    651                            (supplied-p-replacement
    652                             (if supplied-p-supplied-p
    653                                 supplied-p (gensym))))
     644                 ((atom var)
     645                  (setf (car new-lambda-list)
     646                        (if (eq state :key)
     647                            (list (list (make-keyword var) replacement))
     648                            replacement))
     649                  (push (list var replacement) let-bindings))
     650                 ((constantp (second var))
     651                  ;; so, we must have a consp-type var we're looking at
     652                  ;; and it has a constantp initform
     653                  (multiple-value-bind
     654                        (name keyword initform initform-supplied-p
     655                              supplied-p supplied-p-supplied-p)
     656                      (parse-compound-argument var)
     657                    (let ((var-form (if (eq state :key)
     658                                        (list keyword replacement)
     659                                        replacement))
     660                          (supplied-p-replacement (gensym)))
    654661                      (setf (car new-lambda-list)
    655                             `(,(if (eq state :key)
    656                                    (list keyword replacement) replacement)
    657                                nil ,supplied-p-replacement))
    658                       (push `(,symbol (if ,supplied-p-replacement
    659                                           ,replacement ,initform))
    660                             let-bindings)
    661                       (push symbol symbols)))))))))
     662                            (cond
     663                              ((not initform-supplied-p)
     664                               (list var-form))
     665                              ((not supplied-p-supplied-p)
     666                               (list var-form initform))
     667                              (t
     668                               (list var-form initform
     669                                     supplied-p-replacement))))
     670                      (push (list name replacement) let-bindings)
     671                      ;; if there was a 'supplied-p' variable, it might
     672                      ;; be used in the declarations. Since those will be
     673                      ;; moved below the LET* block, we need to move the
     674                      ;; supplied-p parameter too.
     675                      (when supplied-p-supplied-p
     676                        (push (list supplied-p supplied-p-replacement)
     677                              let-bindings)))))
     678                 (t
     679                  (incf non-constants)
     680                  ;; this is either a keyword or an optional argument
     681                  ;; with a non-constantp initform
     682                  (multiple-value-bind
     683                        (name keyword initform initform-supplied-p
     684                              supplied-p supplied-p-supplied-p)
     685                      (parse-compound-argument var)
     686                    (declare (ignore initform-supplied-p))
     687                    (let ((var-form (if (eq state :key)
     688                                        (list keyword replacement)
     689                                        replacement))
     690                          (supplied-p-replacement (gensym)))
     691                      (setf (car new-lambda-list)
     692                            (list var-form nil supplied-p-replacement))
     693                      (push (list name `(if ,supplied-p-replacement
     694                                            ,replacement ,initform))
     695                                  let-bindings)
     696                      (when supplied-p-supplied-p
     697                        (push (list supplied-p supplied-p-replacement)
     698                              let-bindings)))))))))))
    662699        (if (zerop non-constants)
    663700            ;; there was no reason to rewrite...
    664701            form
    665             `(lambda ,(nreverse new-lambda-list)
    666                ,@(when doc (list doc))
    667                (let* ,(nreverse let-bindings)
    668                  ,@decls ,@body)))))))
     702            (let ((rv
     703                   `(lambda ,(nreverse new-lambda-list)
     704                      ,@(when doc (list doc))
     705                      (let* ,(nreverse let-bindings)
     706                        ,@decls ,@body))))
     707              rv))))))
    669708
    670709(defun precompile-lambda (form)
     
    11901229      (parse-body body)
    11911230    (let* ((block-name (fdefinition-block-name name))
    1192            (lambda-expression `(named-lambda ,name ,lambda-list ,@decls ,@(when doc `(,doc))
    1193                                              (block ,block-name ,@body))))
     1231           (lambda-expression
     1232            `(named-lambda ,name ,lambda-list
     1233                           ,@decls
     1234                           ,@(when doc `(,doc))
     1235                           (block ,block-name ,@body))))
    11941236      (cond ((and (boundp 'jvm::*file-compilation*)
    11951237                  ;; when JVM.lisp isn't loaded yet, this variable isn't bound
     
    12071249                (%defun ',name ,lambda-expression)
    12081250                ,@(when doc
    1209                     `((%set-documentation ',name 'function ,doc)))))))))
     1251                   `((%set-documentation ',name 'function ,doc)))))))))
Note: See TracChangeset for help on using the changeset viewer.