Changeset 14138

Timestamp:

08/26/12 21:43:53 (9 years ago)

Author:

ehuelsmann

Message:

Re #241: Fix cases

(compile nil '(lambda (&rest foo &aux x)))

and (compile nil '(lambda (&aux x &rest)))

Note: Since the other 2 cases mentioned in the ticket are still

open, this commit doesn't actually close it.

File:

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

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

@@ -93 +93 @@
 
 "
-  (let ((state :req)
+  (let ((remaining lambda-list)
+        (state :req)
         req opt key rest whole env aux key-p allow-others-p)
-    (dolist (arg lambda-list)
+    (when (eq (car lambda-list) '&WHOLE)
+      (let ((var (second lambda-list)))
+        (when (memq var lambda-list-keywords)
+          (error 'program-error
+                 :format-control "Lambda list keyword ~A found where &WHOLE ~
+                                  variable expected in lambda list ~A."
+                 :format-arguments (list var lambda-list)))
+        (setf whole (list var))
+        (setf remaining (nthcdr 2 lambda-list))))
+    (dolist (arg remaining)
       (case arg
         (&optional (setf state :opt))
@@ -106 +116 @@
         (&whole (setf state :whole))
         (&environment (setf state :env))
+        (&whole
+         (error 'program-error
+                :format-control "&WHOLE must appear first in lambda list ~A."
+                :format-arguments (list lambda-list)))
         (t
          (case state
@@ -113 +127 @@
            (:env (setf env (list arg)
                        state :req))
-           (:whole (setf whole (list arg)
-                         state :req))
            (:none
             (error "Invalid lambda list: argument found in :none state."))
@@ -768 +780 @@
     (mapcan (lambda (x)
               (mapcar #'first x))
-            (list req opt key aux rest whole env))))
-
+            (list req opt key aux (list rest) (list whole) (list env)))))
+
+(defun lambda-list-keyword-p (x)
+  (memq x lambda-list-keywords))
 
 (defun rewrite-aux-vars (form)
   (let* ((lambda-list (cadr form))
          (aux-p (memq '&AUX lambda-list))
-         (lets (cdr aux-p))
+         (post-aux-&environment (memq '&ENVIRONMENT aux-p))
+         (lets (ldiff (cdr aux-p) post-aux-&environment)) ; strip trailing &environment
          aux-vars)
     (unless aux-p
       ;; no rewriting required
       (return-from rewrite-aux-vars form))
+    (dolist (var lets)
+      (when (lambda-list-keyword-p var)
+        (error 'program-error
+               :format-control "Lambda list keyword ~A not allowed after &AUX in ~A."
+               :format-arguments (list var lambda-list))))
     (multiple-value-bind (body decls)
         (parse-body (cddr form))
@@ -786 +806 @@
               (t
                (push form aux-vars))))
-      (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
+      (setf lambda-list
+            (append (subseq lambda-list 0 (position '&AUX lambda-list))
+                    post-aux-&environment))
       (multiple-value-bind (let-decls lambda-decls)
           (split-decls decls (lambda-list-names lambda-list))