Fix a bug related to SETQ which DO* uncovered

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 8574222..cb89dfc 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -301,6 +301,34 @@
       `(let ,(mapcar #'cdr assignments)
         (setq ,@(!reduce #'append (mapcar #'butlast assignments) '())))))
 
+  (defmacro do (varlist endlist &body body)
+    `(block nil
+       (let ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+        (while t
+          (when ,(car endlist)
+            (return (progn ,(cdr endlist))))
+          (tagbody ,@body)
+          (psetq
+           ,@(apply #'append
+                    (mapcar (lambda (v)
+                              (and (consp (cddr v))
+                                   (list (first v) (third v))))
+                            varlist)))))))
+
+  (defmacro do* (varlist endlist &body body)
+    `(block nil
+       (let* ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+        (while t
+          (when ,(car endlist)
+            (return (progn ,(cdr endlist))))
+          (tagbody ,@body)
+          (setq
+           ,@(apply #'append
+                    (mapcar (lambda (v)
+                              (and (consp (cddr v))
+                                   (list (first v) (third v))))
+                            varlist)))))))
+
   (defun list-length (list)
     (let ((l 0))
       (while (not (null list))
@@ -1051,7 +1079,7 @@
 (defun extend-local-env (args)
   (let ((new (copy-lexenv *environment*)))
     (dolist (symbol args new)
-      (let ((b (make-binding symbol 'lexical-variable (gvarname symbol))))
+      (let ((b (make-binding symbol 'variable (gvarname symbol))))
         (push-to-lexenv b new 'variable)))))
 
 ;;; Toplevel compilations
@@ -1234,7 +1262,9 @@
 
 (defun setq-pair (var val)
   (let ((b (lookup-in-lexenv var *environment* 'variable)))
-    (if (eq (binding-type b) 'lexical-variable)
+    (if (and (eq (binding-type b) 'variable)
+             (not (member 'special (binding-declarations b)))
+             (not (member 'constant (binding-declarations b))))
         (concat (binding-value b) " = " (ls-compile val))
         (ls-compile `(set ',var ,val)))))
 
@@ -1410,7 +1440,7 @@
 
 
 ;;; Return the code to initialize BINDING, and push it extending the
-;;; current lexical environment if the variable is special.
+;;; current lexical environment if the variable is not special.
 (defun let*-initialize-value (binding)
   (let ((var (first binding))
         (value (second binding)))
@@ -2118,12 +2148,12 @@
             boundp butlast caar cadddr caddr cadr car car case catch cdar cdddr
             cddr cdr cdr char char-code char= code-char cond cons consp copy-list
             decf declaim defparameter defun defmacro defvar digit-char-p
-            disassemble documentation dolist dotimes ecase eq eql equal error eval
-            every export fdefinition find-package find-symbol first fourth fset
-            funcall function functionp gensym get-universal-time go identity if
-            in-package incf integerp integerp intern keywordp lambda last length
-            let let* list-all-packages list listp make-array make-package
-            make-symbol mapcar member minusp mod multiple-value-bind
+            disassemble do do* documentation dolist dotimes ecase eq eql equal
+           error eval every export fdefinition find-package find-symbol first
+           fourth fset funcall function functionp gensym get-universal-time go
+           identity if in-package incf integerp integerp intern keywordp lambda
+           last length let let* list-all-packages list listp make-array
+           make-package make-symbol mapcar member minusp mod multiple-value-bind
             multiple-value-call multiple-value-list multiple-value-prog1 nil not
             nth nthcdr null numberp or package-name package-use-list packagep
             plusp prin1-to-string print proclaim prog1 prog2 progn psetq push