Ignore:
Timestamp:
09/02/12 11:38:30 (9 years ago)
Author:
ehuelsmann
Message:

Close #241: Fix "part 2": ABCL accepts disallowed lambda list ordering.

Note: Solved by rewriting PARSE-LAMBDA-LIST.

File:
1 edited

Legend:

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

    r14138 r14147  
    9595  (let ((remaining lambda-list)
    9696        (state :req)
     97        keyword-required
    9798        req opt key rest whole env aux key-p allow-others-p)
    9899    (when (eq (car lambda-list) '&WHOLE)
     
    105106        (setf whole (list var))
    106107        (setf remaining (nthcdr 2 lambda-list))))
    107     (dolist (arg remaining)
    108       (case arg
    109         (&optional (setf state :opt))
    110         (&key (setf state :key
    111                     key-p t))
    112         (&rest (setf state :rest))
    113         (&aux (setf state :aux))
    114         (&allow-other-keys (setf state :none
    115                                  allow-others-p t))
    116         (&whole (setf state :whole))
    117         (&environment (setf state :env))
    118         (&whole
    119          (error 'program-error
    120                 :format-control "&WHOLE must appear first in lambda list ~A."
    121                 :format-arguments (list lambda-list)))
    122         (t
    123          (case state
    124            (:req (push (list arg) req))
    125            (:rest (setf rest (list arg)
    126                         state :none))
    127            (:env (setf env (list arg)
    128                        state :req))
    129            (:none
    130             (error "Invalid lambda list: argument found in :none state."))
    131            (:opt
    132             (cond
    133               ((symbolp arg)
    134                (push (list arg nil nil nil) opt))
    135               ((consp arg)
    136                (push (list (car arg) (cadr arg) (caddr arg)) opt))
    137               (t
    138                (error "Invalid state."))))
    139            (:aux
    140             (cond
    141               ((symbolp arg)
    142                (push (list arg nil nil nil) aux))
    143               ((consp arg)
    144                (push (list (car arg) (cadr arg) nil nil) aux))
    145               (t
    146                (error "Invalid :aux state."))))
    147            (:key
    148             (cond
    149               ((symbolp arg)
    150                (push (list arg nil nil (sys::keywordify arg)) key))
    151               ((and (consp arg)
    152                     (consp (car arg)))
    153                (push (list (cadar arg) (cadr arg) (caddr arg) (caar arg)) key))
    154               ((consp arg)
    155                (push (list (car arg) (cadr arg) (caddr arg)
    156                            (sys::keywordify (car arg))) key))
    157               (t
    158                (error "Invalid :key state."))))
    159            (t (error "Invalid state found."))))))
     108
     109    (do* ((arg (pop remaining) (pop tail))
     110          (tail remaining tail))
     111         ((and (null arg)
     112               (endp tail)))
     113      (let* ((allowable-previous-states
     114              ;; even if the arglist could theoretically contain the
     115              ;; keyword :req, this still works, because the cdr will
     116              ;; be NIL, meaning that the code below thinks we DIDN'T
     117              ;; find a new state. Which happens to be true.
     118              (cdr (member arg '(&whole &environment &aux &allow-other-keys
     119                                 &key &rest &optional :req)))))
     120        (cond
     121          (allowable-previous-states
     122           (setf keyword-required nil) ;; we have a keyword...
     123           (case arg
     124             (&key
     125              (setf key-p t))
     126             (&rest
     127              (when (endp tail)
     128                (error 'program-error
     129                       :format-control "&REST without variable in lambda list ~A."
     130                       :format-arguments (list lambda-list)))
     131              (setf rest (list (pop tail))
     132                    keyword-required t))
     133             (&allow-other-keys
     134              (unless (eq state '&KEY)
     135                (error 'program-error
     136                       :format-control "&ALLOW-OTHER-KEYS outside of &KEY ~
     137                                        section in lambda list ~A"
     138                       :format-arguments (list lambda-list)))
     139              (setf allow-others-p t
     140                    keyword-required t
     141                    arg nil))
     142             (&environment
     143              (setf env (list (pop tail))
     144                    keyword-required t
     145                    ;; &ENVIRONMENT can appear anywhere; retain our last
     146                    ;; state so we know what next keywords are valid
     147                    arg state))
     148             (&whole
     149              (error 'program-error
     150                     :format-control "&WHOLE must appear first in lambda list ~A."
     151                     :format-arguments (list lambda-list))))
     152           (when arg
     153             ;; ### verify that the next state is valid
     154             (unless (or (null state)
     155                         (member state allowable-previous-states))
     156               (error 'program-error
     157                      :format-control "~A not allowed after ~A ~
     158                                       in lambda-list ~S"
     159                      :format-arguments (list arg state lambda-list)))
     160             (setf state arg)))
     161          (keyword-required
     162           ;; a keyword was required, but none was found...
     163           (error 'program-error
     164                  :format-control "Lambda list keyword expected, but found ~
     165                                   ~A in lambda list ~A"
     166                  :format-arguments (list arg lambda-list)))
     167          (t ;; a variable specification
     168           (case state
     169             (:req (push (list arg) req))
     170             (&optional
     171              (cond ((symbolp arg)
     172                     (push (list arg) opt))
     173                    ((consp arg)
     174                     (push (list (car arg) (cadr arg)
     175                                 (caddr arg)) opt))
     176                    (t
     177                     (error "Invalid &OPTIONAL variable."))))
     178             (&key
     179              (cond ((symbolp arg)
     180                     (push (list arg nil nil (sys::keywordify arg)) key))
     181                    ((consp arg)
     182                     (push (list (if (consp (car arg))
     183                                     (cadar arg) (car arg))
     184                                 (cadr arg) (caddr arg)
     185                                 (if (consp (car arg))
     186                                     (caar arg)
     187                                     (sys::keywordify (car arg)))) key))
     188                    (t
     189                     (error "Invalid &KEY variable."))))
     190             (&aux
     191              (cond ((symbolp arg)
     192                     (push (list arg nil nil nil) aux))
     193                    ((consp arg)
     194                     (push (list (car arg) (cadr arg) nil nil) aux))
     195                    (t
     196                     (error "Invalid &aux state."))))
     197             (t
     198              (error 'program-error
     199                     :format-control "Invalid state found: ~A."
     200                     :format-arguments (list state))))))))
    160201    (values
    161202     (nreverse req)
Note: See TracChangeset for help on using the changeset viewer.