Changeset 14147
- Timestamp:
- 09/02/12 11:38:30 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
r14138 r14147 95 95 (let ((remaining lambda-list) 96 96 (state :req) 97 keyword-required 97 98 req opt key rest whole env aux key-p allow-others-p) 98 99 (when (eq (car lambda-list) '&WHOLE) … … 105 106 (setf whole (list var)) 106 107 (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)))))))) 160 201 (values 161 202 (nreverse req)
Note: See TracChangeset
for help on using the changeset viewer.