[armedbear-cvs] r11799 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Wed Apr 29 16:50:07 2009
New Revision: 11799

Log:
Check LET/LET* and &AUX bindings validity.

Also fixes an incorrectly placed paren in clos.lisp
found as a result.

Modified:
   trunk/abcl/src/org/armedbear/lisp/clos.lisp
   trunk/abcl/src/org/armedbear/lisp/precompiler.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Wed Apr 29 16:50:07 2009
@@ -1737,8 +1737,8 @@
 (defun add-reader-method (class function-name slot-name)
   (let* ((lambda-expression
           (if (eq (class-of class) (find-class 'standard-class))
-              `(lambda (object) (std-slot-value object ',slot-name)))
-              `(lambda (object) (slot-value object ',slot-name)))
+              `(lambda (object) (std-slot-value object ',slot-name))
+              `(lambda (object) (slot-value object ',slot-name))))
          (method-function (compute-method-function lambda-expression))
          (fast-function (compute-method-fast-function lambda-expression)))
     (let ((method-lambda-list '(object))

Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp	Wed Apr 29 16:50:07 2009
@@ -654,12 +654,23 @@
                 rv)))))))
 
 (defun precompile-lambda-list (form)
-  (let (new)
+  (let (new aux-tail)
     (dolist (arg form (nreverse new))
        (if (or (atom arg) (> 2 (length arg)))
-          (push arg new)
+           (progn
+             (when (eq arg '&aux)
+               (setf aux-tail t))
+             (push arg new))
           ;; must be a cons of more than 1 cell
           (let ((new-arg (copy-list arg)))
+            (unless (<= 1 (length arg) (if aux-tail 2 3))
+              ;; the aux-vars have a maximum length of 2 conses
+              ;; optional and key vars may have 3
+              (error 'program-error
+                     :format-control
+                     "The ~A binding specification ~S is invalid."
+                     :format-arguments (list (if aux-tail "&AUX"
+                                                 "&OPTIONAL/&KEY") arg)))
              (setf (second new-arg)
                    (precompile1 (second arg)))
              (push new-arg new))))))
@@ -756,10 +767,11 @@
   (let ((result nil))
     (dolist (var vars)
       (cond ((consp var)
-;;              (when (> (length var) 2)
-;;                (error 'program-error
-;;                       :format-control "The LET/LET* binding specification ~S is invalid."
-;;                       :format-arguments (list var)))
+             (unless (<= 1 (length var) 2)
+               (error 'program-error
+                       :format-control
+                       "The LET/LET* binding specification ~S is invalid."
+                       :format-arguments (list var)))
              (let ((v (%car var))
                    (expr (cadr var)))
                (unless (symbolp v)