Changeset 12409

Timestamp:

01/30/10 23:08:35 (11 years ago)

Author:

astalla

Message:

Rewriting of function calls with (lambda ...) as the operator to let* forms.

File:

• trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (modified) (3 diffs)

trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

@@ -140 +140 @@
      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 ,@arguments)
+               temp-bindings rest-binding)
+    (setf bindings (append bindings rest-binding)))))
+
+  ;;Aux parameters.
+  (when aux
+    (setf bindings
+    `(,@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.
@@ -1056 +1225 @@
 (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 ,@ignorables))
+       ,@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)
@@ -1185 +1370 @@
                          (p1-function-call form))))
                  ((and (consp op) (eq (%car op) 'LAMBDA))
-                  (p1 (list* 'FUNCALL form)))
+                  (p1 (rewrite-function-call form)))
                  (t
                   form))))))