[armedbear-cvs] r12409 - trunk/abcl/src/org/armedbear/lisp
Alessio Stalla
astalla at common-lisp.net
Sat Jan 30 23:08:38 UTC 2010
Author: astalla
Date: Sat Jan 30 18:08:35 2010
New Revision: 12409
Log:
Rewriting of function calls with (lambda ...) as the operator to let* forms.
Modified:
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sat Jan 30 18:08:35 2010
@@ -140,6 +140,175 @@
rest allow-others-p
(nreverse aux) whole env)))
+(define-condition lambda-list-mismatch (error)
+ ((mismatch-type :reader lambda-list-mismatch-type :initarg :mismatch-type)))
+
+(defmacro push-argument-binding (var form temp-bindings bindings)
+ (let ((g (gensym)))
+ `(let ((,g (gensym (symbol-name '#:temp))))
+ (push (list ,g ,form) ,temp-bindings)
+ (push (list ,var ,g) ,bindings))))
+
+(defun match-lambda-list (parsed-lambda-list arguments)
+ (flet ((pop-required-argument ()
+ (if (null arguments)
+ (error 'lambda-list-mismatch :mismatch-type :too-few-arguments)
+ (pop arguments)))
+ (var (var-info) (car var-info))
+ (initform (var-info) (cadr var-info))
+ (p-var (var-info) (caddr var-info)))
+ (destructuring-bind (req opt key key-p rest allow-others-p aux whole env)
+ parsed-lambda-list
+ (declare (ignore whole env))
+ (let (req-bindings temp-bindings bindings ignorables)
+ ;;Required arguments.
+ (setf req-bindings
+ (loop :for var :in req :collect `(,var ,(pop-required-argument))))
+
+ ;;Optional arguments.
+ (when opt
+ (dolist (var-info opt)
+ (if arguments
+ (progn
+ (push-argument-binding (var var-info) (pop arguments)
+ temp-bindings bindings)
+ (when (p-var var-info)
+ (push `(,(p-var var-info) t) bindings)))
+ (progn
+ (push `(,(var var-info) ,(initform var-info)) bindings)
+ (when (p-var var-info)
+ (push `(,(p-var var-info) nil) bindings)))))
+ (setf bindings (nreverse bindings)))
+
+ (unless (or key-p rest (null arguments))
+ (error 'lambda-list-mismatch :mismatch-type :too-many-arguments))
+
+ ;;Keyword and rest arguments.
+ (if key-p
+ (multiple-value-bind (kbindings ktemps kignor)
+ (match-keyword-and-rest-args
+ key allow-others-p rest arguments)
+ (setf bindings (append bindings kbindings)
+ temp-bindings (append temp-bindings ktemps)
+ ignorables (append kignor ignorables)))
+ (when rest
+ (let (rest-binding)
+ (push-argument-binding (var rest) `(list , at arguments)
+ temp-bindings rest-binding)
+ (setf bindings (append bindings rest-binding)))))
+
+ ;;Aux parameters.
+ (when aux
+ (setf bindings
+ `(, at bindings
+ ,@(loop
+ :for var-info :in aux
+ :collect `(,(var var-info) ,(initform var-info))))))
+
+ (values
+ (append req-bindings temp-bindings bindings)
+ ignorables)))))
+
+(defun match-keyword-and-rest-args (key allow-others-p rest arguments)
+ (flet ((var (var-info) (car var-info))
+ (initform (var-info) (cadr var-info))
+ (p-var (var-info) (caddr var-info))
+ (keyword (var-info) (cadddr var-info)))
+ (when (oddp (list-length arguments))
+ (error 'lambda-list-mismatch
+ :mismatch-type :odd-number-of-keyword-arguments))
+
+ (let (temp-bindings bindings other-keys-found-p ignorables)
+ ;;If necessary, make up a fake argument to hold :allow-other-keys,
+ ;;needed later. This also handles nicely:
+ ;; 3.4.1.4.1 Suppressing Keyword Argument Checking
+ ;;third statement.
+ (unless (find :allow-other-keys key :key #'keyword)
+ (let ((allow-other-keys-temp (gensym (symbol-name :allow-other-keys))))
+ (push allow-other-keys-temp ignorables)
+ (push (list allow-other-keys-temp nil nil :allow-other-keys) key)))
+
+ ;;First, let's bind the keyword arguments that have been passed by
+ ;;the caller. If we encounter an unknown keyword, remember it.
+ ;;As per the above, :allow-other-keys will never be considered
+ ;;an unknown keyword.
+ (loop
+ :for var :in arguments :by #'cddr
+ :for value :in (cdr arguments) by #'cddr
+ :do (let ((var-info (find var key :key #'keyword)))
+ (if var-info
+ ;;var is one of the declared keyword arguments
+ (progn
+ (push-argument-binding (var var-info) value
+ temp-bindings bindings)
+ ;(push `(,(var var-info) ,value) bindings)
+ (when (p-var var-info)
+ (push `(,(p-var var-info) t) bindings)))
+ (setf other-keys-found-p t))))
+
+ ;;Then, let's bind those arguments that haven't been passed in
+ ;;to their default value, in declaration order.
+ (loop
+ :for var-info :in key
+ :do (unless (find (var var-info) bindings :key #'car)
+ (push `(,(var var-info) ,(initform var-info)) bindings)
+ (when (p-var var-info)
+ (push `(,(p-var var-info) nil) bindings))))
+
+ ;;If necessary, check for unrecognized keyword arguments.
+ (when (and other-keys-found-p (not allow-others-p))
+ (if (loop
+ :for var :in arguments :by #'cddr
+ :if (eq var :allow-other-keys)
+ :do (return t))
+ ;;We know that :allow-other-keys has been passed, so we
+ ;;can access the binding for it and be sure to get the
+ ;;value passed by the user and not an initform.
+ (let* ((arg (var (find :allow-other-keys key :key #'keyword)))
+ (binding (find arg bindings :key #'car))
+ (form (cadr binding)))
+ (if (constantp form)
+ (unless (eval form)
+ (error 'lambda-list-mismatch
+ :mismatch-type :unknown-keyword))
+ (setf (cadr binding)
+ `(or ,(cadr binding)
+ (error 'program-error
+ "Unrecognized keyword argument")))))
+ ;;TODO: it would be nice to report *which* keyword
+ ;;is unknown
+ (error 'lambda-list-mismatch :mismatch-type :unknown-keyword)))
+ (when rest
+ (push `(,(var rest)
+ (list ,@(let (list)
+ (loop
+ :for var :in arguments :by #'cddr
+ :for val :in (cdr arguments) :by #'cddr
+ :do (let ((bound-var
+ (var (find var key :key #'keyword))))
+ (push var list)
+ (if bound-var
+ (push bound-var list)
+ (push val list))))
+ (nreverse list))))
+ bindings))
+ (values
+ (nreverse bindings)
+ temp-bindings
+ ignorables))))
+
+#||test for the above
+(handler-case
+ (let ((lambda-list
+ (multiple-value-list
+ (jvm::parse-lambda-list
+ '(a b &optional (c 42) &rest foo &key (bar c) baz ((kaz kuz) bar))))))
+ (jvm::match-lambda-list
+ lambda-list
+ '((print 1) 3 (print 32) :bar 2)))
+ (jvm::lambda-list-mismatch (x) (jvm::lambda-list-mismatch-type x)))
+||#
+
;; Returns a list of declared free specials, if any are found.
(declaim (ftype (function (list list block-node) list)
process-declarations-for-vars))
@@ -1055,28 +1224,44 @@
(defknown rewrite-function-call (t) t)
(defun rewrite-function-call (form)
- (let ((args (cdr form)))
- (if (unsafe-p args)
- (let ((arg1 (car args)))
- (cond ((and (consp arg1) (eq (car arg1) 'GO))
- arg1)
- (t
- (let ((syms ())
- (lets ()))
- ;; Preserve the order of evaluation of the arguments!
- (dolist (arg args)
- (cond ((constantp arg)
- (push arg syms))
- ((and (consp arg) (eq (car arg) 'GO))
- (return-from rewrite-function-call
- (list 'LET* (nreverse lets) arg)))
- (t
- (let ((sym (gensym)))
- (push sym syms)
- (push (list sym arg) lets)))))
- (list 'LET* (nreverse lets)
- (list* (car form) (nreverse syms)))))))
- form)))
+ (let ((op (car form))
+ (args (cdr form)))
+ (if (and (listp op)
+ (eq (car op) 'lambda))
+ (handler-case
+ (let ((lambda-list
+ (multiple-value-list (parse-lambda-list (cadr op))))
+ (body (cddr op)))
+ (multiple-value-bind (bindings ignorables)
+ (match-lambda-list lambda-list args)
+ `(let* ,bindings
+ (declare (ignorable , at ignorables))
+ , at body)))
+ (lambda-list-mismatch (x)
+ (warn "Invalid function call: ~S (mismatch type: ~A)"
+ form (lambda-list-mismatch-type x))
+ form))
+ (if (unsafe-p args)
+ (let ((arg1 (car args)))
+ (cond ((and (consp arg1) (eq (car arg1) 'GO))
+ arg1)
+ (t
+ (let ((syms ())
+ (lets ()))
+ ;; Preserve the order of evaluation of the arguments!
+ (dolist (arg args)
+ (cond ((constantp arg)
+ (push arg syms))
+ ((and (consp arg) (eq (car arg) 'GO))
+ (return-from rewrite-function-call
+ (list 'LET* (nreverse lets) arg)))
+ (t
+ (let ((sym (gensym)))
+ (push sym syms)
+ (push (list sym arg) lets)))))
+ (list 'LET* (nreverse lets)
+ (list* (car form) (nreverse syms)))))))
+ form))))
(defknown p1-function-call (t) t)
(defun p1-function-call (form)
@@ -1184,7 +1369,7 @@
(t
(p1-function-call form))))
((and (consp op) (eq (%car op) 'LAMBDA))
- (p1 (list* 'FUNCALL form)))
+ (p1 (rewrite-function-call form)))
(t
form))))))
More information about the armedbear-cvs
mailing list