From 71ad2ab08a9151f8ec34f9eec144f8d157e02f9b Mon Sep 17 00:00:00 2001
From: Bart Botta <00003b@gmail.com>
Date: Thu, 27 Nov 2008 00:54:52 -0600
Subject: [PATCH] minimal PSETF,SETQ,PSETQ, add DO,DO*, fix RETURN,LET, add
 block to DEFUN, tests

RETURN is (return-from nil ...) as specified, instead of (:return-value)

LET was overflowing stack in cleanups when there were multiple bindings
---
 compile/defun.lisp         | 12 +++++++-----
 compile/special-forms.lisp |  6 +++---
 file/write.lisp            |  2 +-
 lib/cl-conses2.lisp        |  2 +-
 lib/cl.lisp                | 31 +++++++++++++++++++++++++++++++
 lib/sicl-iteration.lisp    |  7 ++++---
 test/test.lisp             | 18 +++++++++++++++++-
 7 files changed, 64 insertions(+), 14 deletions(-)

diff --git a/compile/defun.lisp b/compile/defun.lisp
index cdf43fe..44ebda5 100644
--- a/compile/defun.lisp
+++ b/compile/defun.lisp
@@ -2,7 +2,8 @@
 
 ;;;; defun and similar
 
-(defun %compile-defun (args body method constructor &key (nil-block t))
+(defun %compile-defun (name args body method constructor &key (nil-block t))
+  ;; fixme: is the nil-block stuff still valid?
   (with-lambda-context (:args args :blocks (when nil-block (list nil)))
     (append
      (if (or method constructor)
@@ -14,10 +15,11 @@
            (:construct-super 0))
          nil)
      (if constructor
-         `(,@(scompile `(progn ,@body))
+         `(,@(scompile `(block ,name ,@body))
              ;;(pop)
              (:return-void))
-         (scompile `(return (progn ,@body))))
+         `(,@(scompile `(block ,name ,@body))
+             (:return-value)))
      (compile-lambda-context-cleanup))))
 
 (defun %swf-defun (name args body &key method constructor)
@@ -66,7 +68,7 @@
         (loop repeat count collect 0)  ;; arg types, 0 = t/*/any
         0                              ;; return type, 0 = any
         (if rest-p #x04 0)             ;; flags, #x04 = &rest
-        (%compile-defun names body method constructor))
+        (%compile-defun name names body method constructor))
        (gethash name (functions *symbol-table*) (list))
        ;;:test 'equal
        ;;:key 'car
@@ -144,7 +146,7 @@
 (defmacro dump-defun-asm (args &body body)
   "debugging function to compile a defun to asm, and print results"
   (let ((asm (gensym)))
-    `(let ((,asm (%compile-defun
+    `(let ((,asm (%compile-defun 'foo
                   ',args
                   ',body
                   nil nil)))
diff --git a/compile/special-forms.lisp b/compile/special-forms.lisp
index b51798f..84d6114 100644
--- a/compile/special-forms.lisp
+++ b/compile/special-forms.lisp
@@ -56,7 +56,7 @@
 
 ;; (scompile '(progn "foo" "bar" :true))
 
-(define-special return (value)
+#+nil(define-special return (value)
   `(,@(scompile value)
       (:return-value)))
 
@@ -76,8 +76,8 @@
     (with-cleanup ((gensym "LET-CLEANUP")
                      `(%asm (:comment "let-kill")
                            ,@(loop for (nil nil . index) in bindings-indices
-                                collect `(:kill ,index)
-                                collect `(:push-null))))
+                                collect `(:kill ,index))
+                           (:push-null)))
      (append
       ;; set up bindings
       (loop for (init nil . index) in bindings-indices
diff --git a/file/write.lisp b/file/write.lisp
index 065dba8..dde6682 100644
--- a/file/write.lisp
+++ b/file/write.lisp
@@ -395,7 +395,7 @@
                            0 0
                            :body
                            (avm2-asm::assemble-method-body
-                            (%compile-defun (first constructor)
+                            (%compile-defun name (first constructor)
                                             (second constructor) t t))))
          ;; fixme: probably should make this configurable at some point
          (class-init (avm2-asm::avm2-method 0 nil 0 0 ;; meta-class init
diff --git a/lib/cl-conses2.lisp b/lib/cl-conses2.lisp
index 55d7f02..ad4ec9b 100644
--- a/lib/cl-conses2.lisp
+++ b/lib/cl-conses2.lisp
@@ -70,7 +70,7 @@
           (tagbody
            :start
              (unless (consp (cdr a))
-               (return a))
+               (return-from last a))
              (setf a (cdr a))
              (go :start))))
 
diff --git a/lib/cl.lisp b/lib/cl.lisp
index 5eb0e81..67090e9 100644
--- a/lib/cl.lisp
+++ b/lib/cl.lisp
@@ -6,6 +6,10 @@
 
 (let ((*symbol-table* *cl-symbol-table*))
 
+  (swf-defmacro return (value)
+    `(return-from nil ,value))
+
+
   ;; partial implementation of setf, only handles setting local vars,
   ;;  so we can start using it while waiting on real implementation
   (swf-defmacro setf (&rest args)
@@ -13,6 +17,33 @@
        ,@(loop for (var value) on args by #'cddr
             collect `(%set-local ,var ,value))))
 
+  ;; partial implementation of psetf, only handles setting local vars,
+  ;;  so we can start using it while waiting on real implementation
+  (swf-defmacro psetf (&rest args)
+    (let ((temps (loop repeat (/ (length args) 2)
+                    collect (gensym))))
+      `(let (,@(loop
+                  for temp in temps
+                  for (nil value) on args by #'cddr
+                  collect `(,temp ,value)))
+         ,@(loop
+              for temp in temps
+              for (var nil) on args by #'cddr
+              collect `(setf ,var ,temp)))))
+
+  ;; setq and psetq just calling setf/psetf for now, after checking vars
+  (swf-defmacro setq (&rest args)
+    (loop for (var nil) on args by #'cddr
+       unless (atom var)
+       do (error "variable name is not a symbol in SETQ: ~s" var))
+    `(setf ,@args))
+
+  (swf-defmacro psetq (&rest args)
+    (loop for (var nil) on args by #'cddr
+       unless (atom var)
+       do (error "variable name is not a symbol in PSETQ: ~s" var))
+    `(psetf ,@args))
+
   (swf-defmemfun random (a)
     ;;todo: return int for int args
     ;;fixme: don't seem to be able to set seeds, so can't do random-state arg
diff --git a/lib/sicl-iteration.lisp b/lib/sicl-iteration.lisp
index 4a058e7..febe2be 100644
--- a/lib/sicl-iteration.lisp
+++ b/lib/sicl-iteration.lisp
@@ -195,7 +195,7 @@
                      (extract-updates (cdr variable-clauses)))
               (extract-updates (cdr variable-clauses))))))
 
-  #+nil(swf-defmacro do (variable-clauses end-test &body body)
+  (swf-defmacro do (variable-clauses end-test &body body)
     ;; do some syntax checking
     (check-variable-clauses variable-clauses)
     (unless (proper-list-p body)
@@ -238,7 +238,7 @@
                   (return
                     (progn ,@(cdr end-test))))
                 ,@forms
-                (setf ,@(extract-updates variable-clauses))
+                (setq ,@(extract-updates variable-clauses))
                 (go ,start-tag))))))))
 
 
@@ -246,4 +246,5 @@
   (let (temp)
     (dolist (a (cons "a" (cons "b" (cons "c" nil)))
              temp)
-      (%set-local temp (+ temp (:to-string  a))))))
\ No newline at end of file
+      (%set-local temp (+ temp (:to-string  a))))))
+
diff --git a/test/test.lisp b/test/test.lisp
index 68f29df..eca9b6c 100644
--- a/test/test.lisp
+++ b/test/test.lisp
@@ -62,6 +62,21 @@
                               (setf temp (+ temp a)))
                             "}"))))
 
+    (swf-defmemfun do/do*-tests ()
+      (+ ""
+         ;; examples from clhs
+         (do ((temp-one 1 (1+ temp-one))
+              (temp-two 0 (1- temp-two)))
+             ((> (- temp-one temp-two) 5) temp-one))
+         " "
+         (do ((temp-one 1 (1+ temp-one))
+              (temp-two 0 (1+ temp-one)))
+             ((= 3 temp-two) temp-one))
+         " "
+         (do* ((temp-one 1 (1+ temp-one))
+               (temp-two 0 (1+ temp-one)))
+              ((= 3 temp-two) temp-one))))
+
     (swf-defmemfun rest-test (a b c &arest d)
       (+ "(" a " " b " " c " " d ")"))
 
@@ -211,7 +226,8 @@
             (let ((foo 4))
               (when (and (> foo 0) (> (random 1.0) 0.2))
                 (incf str "||rand")))
-            (incf str (+ " || nconc test="  (list->str (nconc (cons 1 2) (cons 3 4))))))
+            (incf str (+ " || nconc test="  (list->str (nconc (cons 1 2) (cons 3 4)))))
+            (incf str (+ " || do test: 4,3,2=" (do/do*-tests))))
 
           (%set-property foo :text (+ str " || " (%call-property (%array 1 2 3) :to-string))))
         (:add-child arg canvas)
-- 
2.11.4.GIT