Changeset 15526


Ignore:
Timestamp:
Dec 6, 2012, 9:09:50 PM (7 years ago)
Author:
gb
Message:

Change the way that (APPLY inlined-functon args) inlines: don't use the
ancient DEBIND mechanism (which depends on a hairy subprim in the kernel
and which generates fairly bad code), but "manually" do a LET* and a
DESTRUCTURING-BIND with some environment hacking in NX1-DESTRUCTURE.

The environment hacking (processing the inlined function in the lexical
environment in which it was defined) was the argument for using the
magical DEBIND mechanism. However, it's been a while (if ever) since
we inlined anything that was defined in a non-null lexical environment,
so we didn't really retain the environment of definition. Hack things
up to do so, at least in the case where the inlined function is defined
in the current (file-)compilation environment. This involved changing
some of the def-info.* acccessors, and bootstrapping it involved moving
some of those accessors from l1-readloop.lisp to nx.lisp, at least for
the time being.

Change the implementation of DESTRUCTURING-BIND: don't use a
DESTRUCTURE-STATE object, do generate code to explicitly check the
length of the list wrt the lambda-list (and try to signal clear errors
if the check fails), and don't be so sloppy about binding SUPPLIED-P
variables for &optional/&key before the corresponding variables.
(This sloppiness caused us to not warn about an unused supplied-p
variable in PPRINT-LOGICAL-BLOCK.)

Since the new DESTRUCTURING-BIND code expands into many POPs, try
to make PROG1 better about unnecessary pushes/pops to the stack
in the x86 backend. (Should do this on ARM too; it's not that
critical in the DESTRUCTURING-BIND case but may matter elsewhere.)

Location:
trunk/source
Files:
9 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/X86/x862.lisp

    r15518 r15526  
    68086808                 (null (cdr forms)))
    68096809          (x862-form seg vreg xfer first)
    6810           (progn
    6811             (x862-push-register seg
     6810          (let* ((push-vinsn
     6811                  (x862-push-register seg
    68126812                                (if (or node-p crf-p)
    68136813                                  (x862-one-untargeted-reg-form seg first *x862-arg-z*)
    6814                                   (x862-one-targeted-reg-form seg first vreg)))
     6814                                  (x862-one-targeted-reg-form seg first vreg)))))
    68156815            (dolist (form forms)
    68166816              (x862-form seg nil nil form))
    68176817            (if crf-p
    68186818              (progn
    6819                 (x862-vpop-register seg *x862-arg-z*)
     6819                (x862-elide-pushes seg push-vinsn (x862-vpop-register seg *x862-arg-z*))
    68206820                (<- *x862-arg-z*))
    6821               (x862-pop-register seg vreg))
     6821              (x862-elide-pushes seg push-vinsn (x862-pop-register seg vreg)))
    68226822            (^)))))))
    68236823
  • trunk/source/compiler/nx.lisp

    r15307 r15526  
    3737(defparameter *nx-start* (cons nil nil))
    3838
     39
     40
     41
     42
     43(defun %def-info.lambda (def-info)
     44  (and def-info
     45       (let ((data (svref def-info 3)))
     46         (or (and (consp (car data)) (eq (caar data) 'lambda) (car data))
     47             (and (eq (car data) 'lambda) data)))))
     48
     49
     50
     51(defun %def-info.environment (def-info)
     52  (and def-info
     53       (let* ((data (svref def-info 3)))
     54         (and (consp (car data))
     55              (eq (caar data) 'lambda)
     56              (cdr data)))))
     57
     58(defun def-info.function-type (def-info)
     59  (if (null def-info)
     60    nil ;; ftype only, for the purposes here, is same as nothing.
     61    (let ((data (svref def-info 3)))
     62      (if (and (consp (car data)) (eq 'lambda (caar data)))
     63        'defun
     64        (ecase (car data)
     65          ((nil lambda) 'defun)
     66          (:methods 'defgeneric)
     67          (macro 'defmacro)
     68          (ftype nil)
     69          (type nil))))))
     70
     71;;; Return T if and only if the lexical environment contains variable
     72;;; or function bindings (other than macros or symbol-macros).
     73(defun binding-free-environment-p (env)
     74  (do* ((env env (lexenv.parent-env env)))
     75       ((or (null env) (typep env 'definition-environment)) t)
     76    (let* ((vars (lexenv.variables env)))
     77      (unless (or (atom vars)
     78                  (dolist (var vars t)
     79                    (let* ((ea (var-ea var)))
     80                      (unless (and (consp ea)
     81                                 (eq (car ea) :symbol-macro))
     82                        (return)))))
     83        (return)))
     84    (unless (dolist (f (lexenv.functions env) t)
     85              (unless (and (consp f)
     86                           (consp (cdr f))
     87                           (eq 'macro (cadr f)))
     88                (return))))))
     89         
     90
     91(defun retain-lambda-expression (name lambda-expression env)
     92  (if (and (let* ((lambda-list (cadr lambda-expression)))
     93             (and (not (memq '&lap lambda-list))
     94                  (not (memq '&method lambda-list))
     95                  (not (memq '&lexpr lambda-list))))
     96           (nx-declared-inline-p name env)
     97           (not (gethash name *nx1-alphatizers*))
     98           (binding-free-environment-p env))
     99    (cons lambda-expression env)))
    39100
    40101(defvar *host-backend*)
  • trunk/source/compiler/nx0.lisp

    r15420 r15526  
    12141214        (setq info (cdr (retrieve-environment-function-info sym env)))
    12151215        (if (def-info.lambda info)
    1216             (setq lambda-form (def-info.lambda info)
    1217                   token sym
    1218                   containing-env (new-lexical-environment (definition-environment env)))
    1219             (unless info
    1220               (if (cdr (setq info (assq sym *nx-globally-inline*)))
    1221                 (setq lambda-form (%cdr info)
    1222                       token sym
    1223                       containing-env (new-lexical-environment (new-definition-environment nil))))))))
     1216          (setq lambda-form (%def-info.lambda info)
     1217                token sym
     1218                containing-env (new-lexical-environment (%def-info.environment info)))
     1219          (unless info
     1220            (if (cdr (setq info (assq sym *nx-globally-inline*)))
     1221              (setq lambda-form (%cdr info)
     1222                    token sym
     1223                    containing-env (new-lexical-environment (new-definition-environment nil))))))))
    12241224    (values lambda-form (nx-closed-environment env containing-env) token)))
    12251225
     
    16511651       lexpr))))
    16521652
    1653 (defun nx-new-structured-var (pending sym)
    1654   (if sym
    1655     (nx-new-var pending sym t)
    1656     (nx-new-temp-var pending)))
    1657 
    1658 (defun nx-parse-structured-lambda-list (pending ll &optional no-acode whole-p &aux
    1659                                            req
    1660                                            opt
    1661                                            rest
    1662                                            keys
    1663                                            sym)
    1664   (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail all whole structured-p)
    1665                        (verify-lambda-list ll t whole-p nil)
    1666     (declare (ignore all))
    1667     (unless ok (nx-error "Bad lambda list : ~S" ll))
    1668     (if (or whole (and whole-p structured-p)) (setq whole (nx-new-structured-var pending whole)))
    1669     (dolist (var reqsyms)
    1670       (push (if (symbolp var)
    1671                     (nx-new-structured-var pending var)
    1672                     (nx-structured-lambda-form pending var no-acode))
    1673                   req))
    1674     (when (eq (pop opttail) '&optional)
    1675       (let* (optvars optinits optsuppliedp)
    1676         (until (eq opttail resttail)
    1677           (setq sym (pop opttail))
    1678           (let* ((var sym)
    1679                  (initform nil)
    1680                  (spvar nil))
    1681             (when (consp var)
    1682               (setq sym (pop var) initform (pop var) spvar (%car var)))
    1683             (push (if no-acode initform (nx1-form :value initform)) optinits)
    1684             (push (if (symbolp sym)
    1685                           (nx-new-structured-var pending sym)
    1686                           (nx-structured-lambda-form pending sym no-acode))
    1687                         optvars)
    1688             (push (if spvar (nx-new-var pending spvar)) optsuppliedp)))
    1689         (if optvars
    1690           (setq opt (list (nreverse optvars) (nreverse optinits) (nreverse optsuppliedp)))
    1691           (nx1-whine :lambda ll))))
    1692     (let ((var (pop resttail)))
    1693       (when (or (eq var '&rest)
    1694                 (eq var '&body))
    1695         (setq var (pop resttail)
    1696               rest (if (symbolp var)
    1697                      (nx-new-structured-var pending var)
    1698                      (nx-structured-lambda-form pending var no-acode)))))
    1699     (when (eq (%car keytail) '&key)
    1700       (setq keytail (%cdr keytail))
    1701       (let* ((keysyms ())
    1702              (keykeys ())
    1703              (keyinits ())
    1704              (keysupp ())
    1705              (kallowother (not (null (memq '&allow-other-keys ll))))
    1706              (kvar ())
    1707              (kkey ())
    1708              (kinit ())
    1709              (ksupp))
    1710         (until (eq keytail auxtail)
    1711           (unless (eq (setq sym (pop keytail)) '&allow-other-keys)     
    1712             (setq kinit (make-nx-nil) ksupp nil)
    1713             (if (atom sym)
    1714               (setq kvar sym kkey (make-keyword sym))
    1715               (progn
    1716                 (if (consp (%car sym))
    1717                   (setq kkey (%caar sym) kvar (%cadar sym))
    1718                   (progn
    1719                     (setq kvar (%car sym))
    1720                     (setq kkey (make-keyword kvar))))
    1721                 (setq kinit (if no-acode (%cadr sym) (nx1-form :value (%cadr sym))))
    1722                 (setq ksupp (%caddr sym))))
    1723             (push (if (symbolp kvar)
    1724                           (nx-new-structured-var pending kvar)
    1725                           (nx-structured-lambda-form pending kvar no-acode))
    1726                         keysyms)
    1727             (push kkey keykeys)
    1728             (push kinit keyinits)
    1729             (push (if ksupp (nx-new-var pending ksupp)) keysupp)))
    1730         (setq
    1731          keys
    1732          (list
    1733           kallowother
    1734           (nreverse keysyms)
    1735           (nreverse keysupp)
    1736           (nreverse keyinits)
    1737           (apply #'vector (nreverse keykeys))))))
    1738     (let (auxvals auxvars)
    1739       (dolist (pair (%cdr auxtail))
    1740         (let ((auxvar (nx-pair-name pair))
    1741               (auxval (nx-pair-initform pair)))
    1742           (push (if no-acode auxval (nx1-form :value auxval)) auxvals)
    1743           (push (nx-new-var pending auxvar) auxvars)))
    1744       (values
    1745        (nreverse req)
    1746        opt
    1747        rest
    1748        keys
    1749        (list (nreverse auxvars) (nreverse auxvals))
    1750        whole))))
    1751 
    1752 (defun nx-structured-lambda-form (pending l &optional no-acode)
    1753   (multiple-value-bind (req opt rest keys auxen whole)
    1754                        (nx-parse-structured-lambda-list pending l no-acode t)
    1755     (list (%nx1-operator lambda-list) whole req opt rest keys auxen)))
    17561653
    17571654
  • trunk/source/compiler/nx1.lisp

    r15495 r15526  
    690690;;; application.)
    691691(defun nx1-destructure (context lambda-list bindform cdr-p &whole-allowed-p forms &optional (body-env *nx-lexical-environment*))
     692  (declare (ignore cdr-p))
    692693  (let* ((old-env body-env)
    693694         (*nx-bound-vars* *nx-bound-vars*)
     
    695696    (if (not (verify-lambda-list lambda-list t &whole-allowed-p))
    696697      (nx-error "Invalid lambda-list ~s" lambda-list)
    697       (let* ((*nx-lexical-environment* body-env))
     698      (let* ((*nx-lexical-environment* body-env)
     699             (*nx-bound-vars* *nx-bound-vars*))
    698700        (with-nx-declarations (pending)
    699           (multiple-value-bind (body decls)
    700                                (parse-body forms *nx-lexical-environment*)
    701             (nx-process-declarations pending decls)
    702             (multiple-value-bind (req opt rest keys auxen whole)
    703                                  (nx-parse-structured-lambda-list pending lambda-list nil &whole-allowed-p)
    704               (nx-effect-other-decls pending *nx-lexical-environment*)
    705               (make-acode
    706                (%nx1-operator debind)
    707                nil
    708                bindform
    709                req
    710                opt
    711                rest
    712                keys
    713                auxen
    714                whole
    715                (nx1-env-body context body old-env)
    716                *nx-new-p2decls*
    717                cdr-p))))))))
    718 
    719 
     701          (multiple-value-bind (body decls) (parse-body forms body-env t)
     702          (let* ((temp-name (gensym))
     703                 (temp-var (nx-new-var pending temp-name))
     704                 (vars (list temp-var))
     705                 (vals (list bindform))
     706                 (binding (nx1-note-var-binding temp-var bindform))
     707                 (var-bound-vars (if binding (list binding))))
     708            (let* ((acode (make-acode (%nx1-operator let*)
     709                                      (list temp-var)
     710                                      (list bindform)
     711                                      (nx1-env-body context
     712                                                    `((destructuring-bind ,lambda-list ,temp-name
     713                                                      ,@decls
     714                                                      ,@body))
     715                                                    old-env)
     716                                      *nx-new-p2decls*)))
     717              (nx1-check-var-bindings var-bound-vars)
     718              (nx1-punt-bindings vars vals)
     719              acode))))))))
    720720
    721721(defnx1 nx1-%setf-macptr ((%setf-macptr)) context (ptr newval)
  • trunk/source/level-0/l0-misc.lisp

    r15500 r15526  
    828828
    829829(defun store-gvector-conditional (index gvector old new)
    830   (%store-node-conditional (+ target::misc-data-offset
    831                               (ash index target::word-shift))
     830  (declare (index index))
     831  (%store-node-conditional (the fixnum
     832                             (+ target::misc-data-offset
     833                                (the fixnum (ash index target::word-shift))))
    832834                           gvector
    833835                           old
  • trunk/source/level-1/l1-readloop.lisp

    r15331 r15526  
    411411  (values form won))
    412412
    413 (defun retain-lambda-expression (name lambda-expression env)
    414   (if (and (let* ((lambda-list (cadr lambda-expression)))
    415              (and (not (memq '&lap lambda-list))
    416                   (not (memq '&method lambda-list))
    417                   (not (memq '&lexpr lambda-list))))
    418            (nx-declared-inline-p name env)
    419            (not (gethash name *nx1-alphatizers*))
    420            ; A toplevel definition defined inside a (symbol-)macrolet should
    421            ; be inlineable.  It isn't; call DEFINITION-ENVIRONMENT with a
    422            ; "clean-only" argument to ensure that there are no lexically
    423            ; bound macros or symbol-macros.
    424            (definition-environment env t))
    425     lambda-expression))
    426 
    427 
    428413(defun %cons-def-info (type &optional lfbits keyvect data specializers qualifiers)
    429414  (ecase type
     
    450435
    451436(defun def-info.lambda (def-info)
    452   (and def-info
    453        (let ((data (svref def-info 3)))
    454          (and (eq (car data) 'lambda) data))))
     437  (%def-info.lambda def-info))
     438
     439(defun def-info.environment (def-info)
     440  (%def-info.environment def-info))
     441
     442
    455443
    456444(defun def-info.methods (def-info)
     
    458446       (let ((data (svref def-info 3)))
    459447         (and (eq (car data) :methods) (%cdr data)))))
     448
    460449
    461450(defun %cons-def-info-method (lfbits keyvect qualifiers specializers)
     
    494483  (not (and def-info (eq (car (svref def-info 3)) 'type))))
    495484
    496 (defun def-info.function-type (def-info)
    497   (if (null def-info)
    498     nil ;; ftype only, for the purposes here, is same as nothing.
    499     (let ((data (svref def-info 3)))
    500       (ecase (car data)
    501         ((nil lambda) 'defun)
    502         (:methods 'defgeneric)
    503         (macro 'defmacro)
    504         (ftype nil)
    505         (type nil)))))
     485
    506486
    507487(defun def-info.deftype (def-info)
     
    517497       (svref def-info 1)))
    518498
    519 (defparameter *one-arg-defun-def-info* (%cons-def-info 'defun (encode-lambda-list '(x))))
     499
    520500
    521501(defvar *compiler-warn-on-duplicate-definitions* t)
  • trunk/source/level-1/l1-utils.lisp

    r14577 r15526  
    123123(setf (type-predicate 'macptr) 'macptrp)
    124124
     125;;; Once we're bootstrapped, we should move the real PREPARE-TO-DESTRUCTURE
     126;;; here.
     127(defun %early-prepare-to-destructure (list &rest ignore)
     128  (declare (ignore ignore))
     129  list)
     130
     131(setf (fdefinition 'prepare-to-destructure) #'%early-prepare-to-destructure)
    125132
    126133
  • trunk/source/lib/level-2.lisp

    r14947 r15526  
    9191            doc))))))
    9292
     93(defun lambda-list-bounds (lambda-list)
     94  (let* ((state :required)
     95         (min 0)
     96         (max 0))
     97    (do* ((lambda-list lambda-list (cdr lambda-list)))
     98         ((null lambda-list) (values min max))
     99      (case (car lambda-list)
     100        ((&rest &key &body) (return (values min nil)))
     101        (&aux (return (values min max)))
     102        (&optional (setq state :optional))
     103        (t (ecase state
     104             (:required (incf min) (incf max))
     105             (:optional (incf max))))))))
     106 
     107(defun prepare-to-destructure (list lambda-list min max)
     108  (if (if max
     109        (and (proper-list-p list)
     110             (let* ((len (length list)))
     111               (<= min len max)))
     112             (do* ((tail list (cdr tail))
     113                   (n min (1- n)))
     114                  ((zerop n) t)
     115               (when (atom tail)
     116                 (return))))
     117    list
     118    (let* ((reason
     119            (if max
     120              (if (not (proper-list-p list))
     121                "it is not a proper list"
     122                (let* ((len (length list)))
     123                  (if (eql min max)
     124                    (format nil "it contains ~d elements, and exactly ~d are expected" len min)
     125                    (if (< len min)
     126                      (format nil "it contains ~d elements, and at least ~d are expected" len min)
     127                      (format nil "it contains ~d elements, and at most ~d are expected" len max)))))
     128              (format nil "it does not contain at least ~d elements" min))))
     129      (signal-program-error "~s can't be destructured against the lambda list ~s, because ~a."
     130                          list lambda-list reason))))
     131   
    93132
    94133(defun %destructure-lambda-list (lambda-list wholeform  lets decls
    95                                              &key cdr-p (whole-p t) use-whole-var default-initial-value)
     134                                              &key cdr-p (whole-p t) use-whole-var default-initial-value)
    96135  (unless (and (listp lambda-list)
    97136               (verify-lambda-list lambda-list t whole-p))
     
    105144           (argptr (gensym "ARGS"))
    106145           (has-&key nil)
    107            (most-recent-binding nil)
    108146           (keywords ())
    109147           (first-keyword-init ())
     
    111149      (labels ((simple-var (var &optional (initform `,default-initial-value))
    112150                 (let* ((binding `(,var ,initform)))
    113                    (unless (eq argstate :aux)
    114                      (setq most-recent-binding binding))
    115151                   (push  binding lets)
    116152                   binding))
     
    125161                      decls
    126162                      :default-initial-value default-initial-value
    127 ))
     163                      ))
    128164                   v)))
    129165        (unless use-whole-var
     
    133169              (setq w (structured-var "WHOLE" w (if cdr-p `(cdr ,wholeform) wholeform))
    134170                    cdr-p nil))))
    135         (simple-var argptr `(make-destructure-state ,@(if cdr-p `((cdr ,w)) `(,w)) ,w ',lambda-list))
    136         (setq most-recent-binding nil)
    137         (push `(dynamic-extent ,argptr) decls)
    138         (do* ((tail normalized (cdr tail)))
    139              ((null tail)
    140               (if has-&key
    141                 (let* ((key-check-form `(check-keywords
    142                                          ',(nreverse keywords)
    143                                          ,rest-arg-name ,allow-other-keys)))
    144                   (if first-keyword-init
    145                     (rplaca (cdr first-keyword-init)
    146                             `(progn
    147                               ,key-check-form
    148                               ,(cadr first-keyword-init)))
    149                     (let* ((check-var (gensym "CHECK")))
    150                       (push `(ignorable ,check-var) decls)
    151                       (simple-var check-var key-check-form))))
    152                 (unless restp
    153                   (let* ((checkform `(%check-extra-arguments ,argptr))
    154                          (b most-recent-binding)
    155                          (b-init (cadr b)))
    156                     (if b
    157                       (rplaca (cdr b) `(prog1 ,b-init ,checkform))
    158                       (let* ((junk (gensym "JUNK")))
    159                         (simple-var junk checkform)
    160                         (push `(ignorable ,junk) decls))))))
    161               (values lets decls))
    162           (let* ((var (car tail)))
    163             (cond ((or (eq var '&rest) (eq var '&body))
    164                    (let* ((r (cadr tail))
    165                           (init `(destructure-state.current ,argptr)))
    166                      (if (listp r)
    167                        (setq rest-arg-name
    168                              (structured-var "REST" r init))
    169                        (progn
    170                          (setq rest-arg-name (gensym "REST"))
    171                          (simple-var rest-arg-name init)
    172                          (simple-var r rest-arg-name ))))
    173                    (setq restp t)
    174                    (setq tail (cdr tail)))
    175                   ((eq var '&optional) (setq argstate :optional))
    176                   ((eq var '&key)
    177                    (setq argstate :key)
    178                    (setq has-&key t)
    179                    (unless restp
    180                      (setq restp t
    181                            rest-arg-name (gensym "KEYS"))
    182                      (push `(ignorable ,rest-arg-name) decls)
    183                      (simple-var rest-arg-name
    184                                  `(destructure-state.current ,argptr))))
    185                   ((eq var '&allow-other-keys)
    186                    (setq allow-other-keys t))
    187                   ((eq var '&aux)
    188                    (setq argstate :aux))
    189                   ((listp var)
    190                    (case argstate
    191                      (:required
    192                       (structured-var "REQ" var `(%pop-required-arg-ptr ,argptr)))
    193                      (:optional
    194                       (let* ((variable (car var))
    195                              (initform (if (cdr var)
    196                                          (cadr var)
    197                                          `,default-initial-value))
    198                              (spvar (if (cddr var)
    199                                       (caddr var)
    200                                       (gensym "OPT-SUPPLIED-P")))
    201                              (varinit `(if ,spvar
    202                                         (%default-optional-value ,argptr)
    203                                         ,initform)))
    204                         (simple-var spvar
    205                                     `(not (null (destructure-state.current ,argptr))))
    206                         (if (listp variable)
    207                           (structured-var "OPT" variable varinit)
    208                           (simple-var variable varinit))))
    209                      (:key
    210                       (let* ((explicit-key (consp (car var)))
    211                              (variable (if explicit-key
    212                                          (cadar var)
    213                                          (car var)))
    214                              (keyword (if explicit-key
    215                                         (caar var)
    216                                         (make-keyword variable)))
    217                              (initform (if (cdr var)
    218                                          (cadr var)
    219                                          `,default-initial-value))
    220                              (spvar (if (cddr var)
    221                                       (caddr var)
    222                                       (gensym "KEY-SUPPLIED-P"))))
    223                         (push keyword keywords)
    224                         (let* ((sp-init (simple-var spvar
    225                                                     `(%keyword-present-p
    226                                                       ,rest-arg-name
    227                                                       ',keyword)))
    228                                (var-init `(if ,spvar
    229                                            (getf ,rest-arg-name ',keyword)
    230                                            ,initform)))
    231                           (unless first-keyword-init
    232                             (setq first-keyword-init sp-init))
    233                           (if (listp variable)
    234                             (structured-var "KEY" variable var-init)
    235                             (simple-var variable var-init)))))
    236                      (:aux
    237                       (simple-var (car var) (cadr var)))
    238                      (t (error "NYI: ~s" argstate))))
    239                   ((symbolp var)
    240                    (case argstate
    241                      (:required
    242                       (simple-var var `(%pop-required-arg-ptr ,argptr)))
    243                      (:optional
    244                       (simple-var var `(%default-optional-value ,argptr
    245                                         ',default-initial-value)))
    246                      (:key
    247                       (let* ((keyword (make-keyword var)))
    248                         (push keyword keywords)
    249                         (let* ((init (simple-var
    250                                       var
    251                                       `(getf ,rest-arg-name
    252                                         ',keyword
    253                                         ,@(if default-initial-value
    254                                              `(',default-initial-value))))))
    255                           (unless first-keyword-init
    256                             (setq first-keyword-init init)))))
    257                      (:aux
    258                       (simple-var var)))))))))))
     171        (multiple-value-bind (min max) (lambda-list-bounds normalized)
     172          (simple-var argptr `(prepare-to-destructure ,@(if cdr-p `((cdr ,w)) `(,w)) ',lambda-list ,min ,max))
     173          (push `(ignorable ,argptr) decls)
     174          (when max
     175            (push `(list ,argptr) decls))
     176          (do* ((tail normalized (cdr tail)))
     177               ((null tail)
     178                (if has-&key
     179                  (let* ((key-check-form `(check-keywords
     180                                           ',(nreverse keywords)
     181                                           ,rest-arg-name ,allow-other-keys)))
     182                    (if first-keyword-init
     183                      (rplaca (cdr first-keyword-init)
     184                              `(progn
     185                                ,key-check-form
     186                                ,(cadr first-keyword-init)))
     187                      (let* ((check-var (gensym "CHECK")))
     188                        (push `(ignorable ,check-var) decls)
     189                        (simple-var check-var key-check-form)))))
     190                (values lets decls))
     191            (let* ((var (car tail)))
     192              (cond ((or (eq var '&rest) (eq var '&body))
     193                     (let* ((r (cadr tail))
     194                            (init argptr))
     195                            (if (listp r)
     196                              (setq rest-arg-name
     197                                    (structured-var "REST" r init))
     198                              (progn
     199                                (setq rest-arg-name (gensym "REST"))
     200                                (simple-var rest-arg-name init)
     201                                (simple-var r rest-arg-name ))))
     202                       (setq restp t)
     203                       (setq tail (cdr tail)))
     204                     ((eq var '&optional) (setq argstate :optional))
     205                     ((eq var '&key)
     206                      (setq argstate :key)
     207                      (setq has-&key t)
     208                      (unless restp
     209                        (setq restp t
     210                              rest-arg-name (gensym "KEYS"))
     211                        (push `(ignorable ,rest-arg-name) decls)
     212                        (simple-var rest-arg-name
     213                                    argptr)))
     214                     ((eq var '&allow-other-keys)
     215                      (setq allow-other-keys t))
     216                     ((eq var '&aux)
     217                      (setq argstate :aux))
     218                     ((listp var)
     219                      (case argstate
     220                        (:required
     221                         (structured-var "REQ" var `(pop ,argptr)))
     222                        (:optional
     223                         (let* ((variable (car var))
     224                                (initform (if (cdr var)
     225                                            (cadr var)
     226                                            `,default-initial-value))
     227                                (anon-spvar (gensym "OPT-SUPPLIED-P"))
     228                                (spvar (if (cddr var)
     229                                         (caddr var)))
     230                                (varinit `(if ,anon-spvar
     231                                           (pop ,argptr)
     232                                           ,initform)))
     233                           (simple-var anon-spvar
     234                                       `(not (null  ,argptr)))
     235                           (if (listp variable)
     236                             (structured-var "OPT" variable varinit)
     237                             (simple-var variable varinit))
     238                           (if spvar
     239                             (simple-var spvar anon-spvar))))
     240                        (:key
     241                         (let* ((explicit-key (consp (car var)))
     242                                (variable (if explicit-key
     243                                            (cadar var)
     244                                            (car var)))
     245                                (keyword (if explicit-key
     246                                           (caar var)
     247                                           (make-keyword variable)))
     248                                (initform (if (cdr var)
     249                                            (cadr var)
     250                                            `,default-initial-value))
     251                                (anon-spvar (gensym "KEY-SUPPLIED-P"))
     252                                (spvar (if (cddr var)
     253                                         (caddr var))))
     254                           (push keyword keywords)
     255                           (let* ((sp-init (simple-var anon-spvar
     256                                                       `(%keyword-present-p
     257                                                         ,rest-arg-name
     258                                                         ',keyword)))
     259                                  (var-init `(if ,anon-spvar
     260                                              (getf ,rest-arg-name ',keyword)
     261                                              ,initform)))
     262                             (unless first-keyword-init
     263                               (setq first-keyword-init sp-init))
     264                             (if (listp variable)
     265                               (structured-var "KEY" variable var-init)
     266                               (simple-var variable var-init))
     267                             (if spvar
     268                               (simple-var spvar anon-spvar)))))
     269                        (:aux
     270                         (simple-var (car var) (cadr var)))
     271                        (t (error "NYI: ~s" argstate))))
     272                     ((symbolp var)
     273                      (case argstate
     274                        (:required
     275                         (simple-var var `(pop ,argptr)))
     276                        (:optional
     277                         (simple-var var `(if ,argptr
     278                                           (pop ,argptr)
     279                                           ',default-initial-value)))
     280                        (:key
     281                         (let* ((keyword (make-keyword var)))
     282                           (push keyword keywords)
     283                           (let* ((init (simple-var
     284                                         var
     285                                         `(getf ,rest-arg-name
     286                                           ',keyword
     287                                           ,@(if default-initial-value
     288                                                 `(',default-initial-value))))))
     289                             (unless first-keyword-init
     290                               (setq first-keyword-init init)))))
     291                        (:aux
     292                         (simple-var var))))))))))))
    259293
    260294
  • trunk/source/lib/macros.lisp

    r15500 r15526  
    28782878                                 &key (prefix "" prefixp)
    28792879                                      (per-line-prefix "" per-line-prefix-p)
    2880                                       (suffix "" suffixp))
     2880                                      (suffix ""))
    28812881                                &body body)
    28822882  (cond ((eq stream-symbol nil) (setq stream-symbol '*standard-output*))
Note: See TracChangeset for help on using the changeset viewer.