Ignore:
Timestamp:
Aug 5, 2009, 11:52:56 PM (11 years ago)
Author:
gz
Message:

Merge r12534

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/level-2.lisp

    r12210 r12535  
    4949; that have been scarfed out of a macro-like lambda list.
    5050; The returned value is supposed to be suitable for splicing ...
     51#+not-used
    5152(defun hoist-special-decls (sym decls)
    5253  (when sym
     
    6566    (error "Invalid lambda list ~s" arglist))
    6667  (multiple-value-bind (lambda-list whole environment)
    67                        (normalize-lambda-list arglist t t)
     68      (normalize-lambda-list arglist t t)
    6869    (multiple-value-bind (body local-decs doc)
    69                          (parse-body body env t)
    70       (unless whole (setq whole (gensym)))
    71       (unless environment (setq environment (gensym)))
    72       (multiple-value-bind (bindings binding-decls)
    73           (%destructure-lambda-list lambda-list whole nil nil
    74                                     :cdr-p t
    75                                     :whole-p nil
    76                                     :use-whole-var t
    77                                     :default-initial-value default-initial-value)
    78         (values
    79          `(lambda (,whole ,environment)
    80            (declare (ignorable ,environment))
    81            ,@(hoist-special-decls whole local-decs)
    82            ,@(hoist-special-decls environment local-decs)
    83            (block ,name
    84              (let* ,(nreverse bindings)
    85                ,@(when binding-decls `((declare ,@binding-decls)))
    86                ,@local-decs
    87                ,@body)))
    88        doc)))))
     70        (parse-body body env t)
     71      (let ((whole-var (gensym "WHOLE"))
     72            (env-var (gensym "ENVIRONMENT")))
     73        (multiple-value-bind (bindings binding-decls)
     74            (%destructure-lambda-list lambda-list whole-var nil nil
     75                                      :cdr-p t
     76                                      :whole-p nil
     77                                      :use-whole-var t
     78                                      :default-initial-value default-initial-value)
     79          (when environment
     80            (setq bindings (nconc bindings (list `(,environment ,env-var)))))
     81          (when whole
     82            (setq bindings (nconc bindings (list `(,whole ,whole-var)))))
     83          (values
     84            `(lambda (,whole-var ,env-var)
     85               (declare (ignorable ,whole-var ,env-var))
     86               (block ,name
     87                 (let* ,(nreverse bindings)
     88                   ,@(when binding-decls `((declare ,@binding-decls)))
     89                   ,@local-decs
     90                   ,@body)))
     91            doc))))))
    8992
    9093
Note: See TracChangeset for help on using the changeset viewer.