Changeset 12409
- Timestamp:
- 01/30/10 23:08:35 (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
r12401 r12409 140 140 rest allow-others-p 141 141 (nreverse aux) whole env))) 142 143 (define-condition lambda-list-mismatch (error) 144 ((mismatch-type :reader lambda-list-mismatch-type :initarg :mismatch-type))) 145 146 (defmacro push-argument-binding (var form temp-bindings bindings) 147 (let ((g (gensym))) 148 `(let ((,g (gensym (symbol-name '#:temp)))) 149 (push (list ,g ,form) ,temp-bindings) 150 (push (list ,var ,g) ,bindings)))) 151 152 (defun match-lambda-list (parsed-lambda-list arguments) 153 (flet ((pop-required-argument () 154 (if (null arguments) 155 (error 'lambda-list-mismatch :mismatch-type :too-few-arguments) 156 (pop arguments))) 157 (var (var-info) (car var-info)) 158 (initform (var-info) (cadr var-info)) 159 (p-var (var-info) (caddr var-info))) 160 (destructuring-bind (req opt key key-p rest allow-others-p aux whole env) 161 parsed-lambda-list 162 (declare (ignore whole env)) 163 (let (req-bindings temp-bindings bindings ignorables) 164 ;;Required arguments. 165 (setf req-bindings 166 (loop :for var :in req :collect `(,var ,(pop-required-argument)))) 167 168 ;;Optional arguments. 169 (when opt 170 (dolist (var-info opt) 171 (if arguments 172 (progn 173 (push-argument-binding (var var-info) (pop arguments) 174 temp-bindings bindings) 175 (when (p-var var-info) 176 (push `(,(p-var var-info) t) bindings))) 177 (progn 178 (push `(,(var var-info) ,(initform var-info)) bindings) 179 (when (p-var var-info) 180 (push `(,(p-var var-info) nil) bindings))))) 181 (setf bindings (nreverse bindings))) 182 183 (unless (or key-p rest (null arguments)) 184 (error 'lambda-list-mismatch :mismatch-type :too-many-arguments)) 185 186 ;;Keyword and rest arguments. 187 (if key-p 188 (multiple-value-bind (kbindings ktemps kignor) 189 (match-keyword-and-rest-args 190 key allow-others-p rest arguments) 191 (setf bindings (append bindings kbindings) 192 temp-bindings (append temp-bindings ktemps) 193 ignorables (append kignor ignorables))) 194 (when rest 195 (let (rest-binding) 196 (push-argument-binding (var rest) `(list ,@arguments) 197 temp-bindings rest-binding) 198 (setf bindings (append bindings rest-binding))))) 199 200 ;;Aux parameters. 201 (when aux 202 (setf bindings 203 `(,@bindings 204 ,@(loop 205 :for var-info :in aux 206 :collect `(,(var var-info) ,(initform var-info)))))) 207 208 (values 209 (append req-bindings temp-bindings bindings) 210 ignorables))))) 211 212 (defun match-keyword-and-rest-args (key allow-others-p rest arguments) 213 (flet ((var (var-info) (car var-info)) 214 (initform (var-info) (cadr var-info)) 215 (p-var (var-info) (caddr var-info)) 216 (keyword (var-info) (cadddr var-info))) 217 (when (oddp (list-length arguments)) 218 (error 'lambda-list-mismatch 219 :mismatch-type :odd-number-of-keyword-arguments)) 220 221 (let (temp-bindings bindings other-keys-found-p ignorables) 222 ;;If necessary, make up a fake argument to hold :allow-other-keys, 223 ;;needed later. This also handles nicely: 224 ;; 3.4.1.4.1 Suppressing Keyword Argument Checking 225 ;;third statement. 226 (unless (find :allow-other-keys key :key #'keyword) 227 (let ((allow-other-keys-temp (gensym (symbol-name :allow-other-keys)))) 228 (push allow-other-keys-temp ignorables) 229 (push (list allow-other-keys-temp nil nil :allow-other-keys) key))) 230 231 ;;First, let's bind the keyword arguments that have been passed by 232 ;;the caller. If we encounter an unknown keyword, remember it. 233 ;;As per the above, :allow-other-keys will never be considered 234 ;;an unknown keyword. 235 (loop 236 :for var :in arguments :by #'cddr 237 :for value :in (cdr arguments) by #'cddr 238 :do (let ((var-info (find var key :key #'keyword))) 239 (if var-info 240 ;;var is one of the declared keyword arguments 241 (progn 242 (push-argument-binding (var var-info) value 243 temp-bindings bindings) 244 ;(push `(,(var var-info) ,value) bindings) 245 (when (p-var var-info) 246 (push `(,(p-var var-info) t) bindings))) 247 (setf other-keys-found-p t)))) 248 249 ;;Then, let's bind those arguments that haven't been passed in 250 ;;to their default value, in declaration order. 251 (loop 252 :for var-info :in key 253 :do (unless (find (var var-info) bindings :key #'car) 254 (push `(,(var var-info) ,(initform var-info)) bindings) 255 (when (p-var var-info) 256 (push `(,(p-var var-info) nil) bindings)))) 257 258 ;;If necessary, check for unrecognized keyword arguments. 259 (when (and other-keys-found-p (not allow-others-p)) 260 (if (loop 261 :for var :in arguments :by #'cddr 262 :if (eq var :allow-other-keys) 263 :do (return t)) 264 ;;We know that :allow-other-keys has been passed, so we 265 ;;can access the binding for it and be sure to get the 266 ;;value passed by the user and not an initform. 267 (let* ((arg (var (find :allow-other-keys key :key #'keyword))) 268 (binding (find arg bindings :key #'car)) 269 (form (cadr binding))) 270 (if (constantp form) 271 (unless (eval form) 272 (error 'lambda-list-mismatch 273 :mismatch-type :unknown-keyword)) 274 (setf (cadr binding) 275 `(or ,(cadr binding) 276 (error 'program-error 277 "Unrecognized keyword argument"))))) 278 ;;TODO: it would be nice to report *which* keyword 279 ;;is unknown 280 (error 'lambda-list-mismatch :mismatch-type :unknown-keyword))) 281 (when rest 282 (push `(,(var rest) 283 (list ,@(let (list) 284 (loop 285 :for var :in arguments :by #'cddr 286 :for val :in (cdr arguments) :by #'cddr 287 :do (let ((bound-var 288 (var (find var key :key #'keyword)))) 289 (push var list) 290 (if bound-var 291 (push bound-var list) 292 (push val list)))) 293 (nreverse list)))) 294 bindings)) 295 (values 296 (nreverse bindings) 297 temp-bindings 298 ignorables)))) 299 300 #||test for the above 301 (handler-case 302 (let ((lambda-list 303 (multiple-value-list 304 (jvm::parse-lambda-list 305 '(a b &optional (c 42) &rest foo &key (bar c) baz ((kaz kuz) bar)))))) 306 (jvm::match-lambda-list 307 lambda-list 308 '((print 1) 3 (print 32) :bar 2))) 309 (jvm::lambda-list-mismatch (x) (jvm::lambda-list-mismatch-type x))) 310 ||# 142 311 143 312 ;; Returns a list of declared free specials, if any are found. … … 1056 1225 (defknown rewrite-function-call (t) t) 1057 1226 (defun rewrite-function-call (form) 1058 (let ((args (cdr form))) 1059 (if (unsafe-p args) 1060 (let ((arg1 (car args))) 1061 (cond ((and (consp arg1) (eq (car arg1) 'GO)) 1062 arg1) 1063 (t 1064 (let ((syms ()) 1065 (lets ())) 1066 ;; Preserve the order of evaluation of the arguments! 1067 (dolist (arg args) 1068 (cond ((constantp arg) 1069 (push arg syms)) 1070 ((and (consp arg) (eq (car arg) 'GO)) 1071 (return-from rewrite-function-call 1072 (list 'LET* (nreverse lets) arg))) 1073 (t 1074 (let ((sym (gensym))) 1075 (push sym syms) 1076 (push (list sym arg) lets))))) 1077 (list 'LET* (nreverse lets) 1078 (list* (car form) (nreverse syms))))))) 1079 form))) 1227 (let ((op (car form)) 1228 (args (cdr form))) 1229 (if (and (listp op) 1230 (eq (car op) 'lambda)) 1231 (handler-case 1232 (let ((lambda-list 1233 (multiple-value-list (parse-lambda-list (cadr op)))) 1234 (body (cddr op))) 1235 (multiple-value-bind (bindings ignorables) 1236 (match-lambda-list lambda-list args) 1237 `(let* ,bindings 1238 (declare (ignorable ,@ignorables)) 1239 ,@body))) 1240 (lambda-list-mismatch (x) 1241 (warn "Invalid function call: ~S (mismatch type: ~A)" 1242 form (lambda-list-mismatch-type x)) 1243 form)) 1244 (if (unsafe-p args) 1245 (let ((arg1 (car args))) 1246 (cond ((and (consp arg1) (eq (car arg1) 'GO)) 1247 arg1) 1248 (t 1249 (let ((syms ()) 1250 (lets ())) 1251 ;; Preserve the order of evaluation of the arguments! 1252 (dolist (arg args) 1253 (cond ((constantp arg) 1254 (push arg syms)) 1255 ((and (consp arg) (eq (car arg) 'GO)) 1256 (return-from rewrite-function-call 1257 (list 'LET* (nreverse lets) arg))) 1258 (t 1259 (let ((sym (gensym))) 1260 (push sym syms) 1261 (push (list sym arg) lets))))) 1262 (list 'LET* (nreverse lets) 1263 (list* (car form) (nreverse syms))))))) 1264 form)))) 1080 1265 1081 1266 (defknown p1-function-call (t) t) … … 1185 1370 (p1-function-call form)))) 1186 1371 ((and (consp op) (eq (%car op) 'LAMBDA)) 1187 (p1 ( list* 'FUNCALLform)))1372 (p1 (rewrite-function-call form))) 1188 1373 (t 1189 1374 form))))))
Note: See TracChangeset
for help on using the changeset viewer.