Changeset 11796


Ignore:
Timestamp:
04/29/09 17:27:00 (13 years ago)
Author:
ehuelsmann
Message:

Move &AUX vars argument list rewriting from the preprocessor
to the compiler: the interpreter doesn't need it.

In the process, replace the "simple" rewriting in the compiler
with the more advanced approach (taking declarations into account)
available after the move.

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

Legend:

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

    r11790 r11796  
    417417      ,@body2)))
    418418
     419(defun rewrite-aux-vars-process-decls (forms arg-vars aux-vars)
     420  (declare (ignore aux-vars))
     421  (let ((lambda-decls nil)
     422        (let-decls nil))
     423    (dolist (form forms)
     424      (unless (and (consp form) (eq (car form) 'DECLARE)) ; shouldn't happen
     425        (return))
     426      (dolist (decl (cdr form))
     427        (case (car decl)
     428          ((OPTIMIZE DECLARATION DYNAMIC-EXTENT FTYPE INLINE NOTINLINE)
     429           (push (list 'DECLARE decl) lambda-decls))
     430          (SPECIAL
     431           (dolist (name (cdr decl))
     432             (if (memq name arg-vars)
     433                 (push (list 'DECLARE (list 'SPECIAL name)) lambda-decls)
     434                 (push (list 'DECLARE (list 'SPECIAL name)) let-decls))))
     435          (TYPE
     436           (dolist (name (cddr decl))
     437             (if (memq name arg-vars)
     438                 (push (list 'DECLARE (list 'TYPE (cadr decl) name)) lambda-decls)
     439                 (push (list 'DECLARE (list 'TYPE (cadr decl) name)) let-decls))))
     440          (t
     441           (dolist (name (cdr decl))
     442             (if (memq name arg-vars)
     443                 (push (list 'DECLARE (list (car decl) name)) lambda-decls)
     444                 (push (list 'DECLARE (list (car decl) name)) let-decls)))))))
     445    (setq lambda-decls (nreverse lambda-decls))
     446    (setq let-decls (nreverse let-decls))
     447    (values lambda-decls let-decls)))
     448
     449(defun maybe-rewrite-aux-vars (form)
     450  (let* ((lambda-list (cadr form))
     451         (lets (cdr (memq '&AUX lambda-list)))
     452         aux-vars)
     453    (unless lets
     454      ;; no rewriting required
     455      (return-from maybe-rewrite-aux-vars form))
     456    (multiple-value-bind (body decls)
     457        (parse-body (cddr form))
     458      (dolist (form lets)
     459        (cond ((consp form)
     460               (push (%car form) aux-vars))
     461              (t
     462               (push form aux-vars))))
     463      (setq lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
     464      (multiple-value-bind (lambda-decls let-decls)
     465          (rewrite-aux-vars-process-decls decls
     466                                          (lambda-list-names lambda-list)
     467                                          (nreverse aux-vars))
     468        `(lambda ,lambda-list
     469           ,@lambda-decls
     470           (let* ,lets
     471             ,@let-decls
     472             ,@body))))))
     473
    419474(defun p1-flet (form)
    420   (with-local-functions-for-flet/labels 
     475  (with-local-functions-for-flet/labels
    421476      form local-functions 'FLET lambda-list name body
    422477      ((let ((local-function (make-local-function :name name
     
    444499
    445500(defun p1-labels (form)
    446   (with-local-functions-for-flet/labels 
     501  (with-local-functions-for-flet/labels
    447502      form local-functions 'LABELS lambda-list name body
    448503      ((let* ((variable (make-variable :name (gensym)))
     
    512567               (setf (compiland-lambda-expression compiland)
    513568                     ;; if there still was a doc-string present, remove it
    514                      `(lambda ,lambda-list ,@decls ,@body))
     569                     (maybe-rewrite-aux-vars
     570                      `(lambda ,lambda-list ,@decls ,@body)))
    515571               (let ((*visible-variables* *visible-variables*)
    516572                     (*current-compiland* compiland))
     
    528584
    529585(defun p1-lambda (form)
    530   (let* ((lambda-list (cadr form))
    531          (body (cddr form))
    532          (auxvars (memq '&AUX lambda-list)))
     586  (let* ((lambda-list (cadr form)))
    533587    (when (or (memq '&optional lambda-list)
    534588              (memq '&key lambda-list))
     
    542596                   (compiler-unsupported
    543597                    "P1-LAMBDA: can't handle optional argument with non-constant initform.")))))))
    544     (when auxvars
    545       (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
    546       (setf body (list (append (list 'LET* (cdr auxvars)) body))))
    547     (p1-function (list 'FUNCTION (list* 'LAMBDA lambda-list body)))))
     598    (p1-function (list 'FUNCTION
     599                        (maybe-rewrite-aux-vars form)))))
    548600
    549601(defun p1-eval-when (form)
     
    869921  (let ((form (compiland-lambda-expression compiland)))
    870922    (aver (eq (car form) 'LAMBDA))
     923    (setf form (maybe-rewrite-aux-vars form))
    871924    (process-optimization-declarations (cddr form))
    872925
    873926    (let* ((lambda-list (cadr form))
    874            (body (cddr form))
    875            (auxvars (memq '&AUX lambda-list)))
    876       (when auxvars
    877         (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
    878         (setf body (list (append (list 'LET* (cdr auxvars)) body))))
     927           (body (cddr form)))
    879928
    880929      (when (and (null (compiland-parent compiland))
  • trunk/abcl/src/org/armedbear/lisp/precompiler.lisp

    r11794 r11796  
    552552  (precompile-psetf form))
    553553
    554 (defun rewrite-aux-vars-process-decls (forms arg-vars aux-vars)
    555   (declare (ignore aux-vars))
    556   (let ((lambda-decls nil)
    557         (let-decls nil))
    558     (dolist (form forms)
    559       (unless (and (consp form) (eq (car form) 'DECLARE)) ; shouldn't happen
    560         (return))
    561       (dolist (decl (cdr form))
    562         (case (car decl)
    563           ((OPTIMIZE DECLARATION DYNAMIC-EXTENT FTYPE INLINE NOTINLINE)
    564            (push (list 'DECLARE decl) lambda-decls))
    565           (SPECIAL
    566            (dolist (name (cdr decl))
    567              (if (memq name arg-vars)
    568                  (push (list 'DECLARE (list 'SPECIAL name)) lambda-decls)
    569                  (push (list 'DECLARE (list 'SPECIAL name)) let-decls))))
    570           (TYPE
    571            (dolist (name (cddr decl))
    572              (if (memq name arg-vars)
    573                  (push (list 'DECLARE (list 'TYPE (cadr decl) name)) lambda-decls)
    574                  (push (list 'DECLARE (list 'TYPE (cadr decl) name)) let-decls))))
    575           (t
    576            (dolist (name (cdr decl))
    577              (if (memq name arg-vars)
    578                  (push (list 'DECLARE (list (car decl) name)) lambda-decls)
    579                  (push (list 'DECLARE (list (car decl) name)) let-decls)))))))
    580     (setq lambda-decls (nreverse lambda-decls))
    581     (setq let-decls (nreverse let-decls))
    582     (values lambda-decls let-decls)))
    583 
    584 (defun rewrite-aux-vars (form)
    585   (multiple-value-bind (body decls doc)
    586       (parse-body (cddr form))
    587     (declare (ignore doc)) ; FIXME
    588     (let* ((lambda-list (cadr form))
    589            (lets (cdr (memq '&AUX lambda-list)))
    590            aux-vars)
    591       (dolist (form lets)
    592         (cond ((consp form)
    593                (push (%car form) aux-vars))
    594               (t
    595                (push form aux-vars))))
    596       (setq aux-vars (nreverse aux-vars))
    597       (setq lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
    598       (multiple-value-bind (lambda-decls let-decls)
    599           (rewrite-aux-vars-process-decls decls
    600                                           (lambda-list-names lambda-list)
    601                                           aux-vars)
    602         `(lambda ,lambda-list
    603            ,@lambda-decls
    604            (let* ,lets
    605              ,@let-decls
    606              ,@body))))))
    607 
    608554(defun maybe-rewrite-lambda (form)
    609555  (let* ((lambda-list (cadr form)))
    610     (when (memq '&AUX lambda-list)
    611       (setq form (rewrite-aux-vars form))
    612       (setq lambda-list (cadr form)))
    613556    (multiple-value-bind (body decls doc)
    614557        (parse-body (cddr form))
Note: See TracChangeset for help on using the changeset viewer.