From 712a3ca8b06f843b15df22a4b42f677685b3b9d9 Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Tue, 1 May 2012 19:33:36 +0000
Subject: 	* interp/vmlisp.lisp (REMOVE-FLUIDS): Move to
 lisp-backend.boot. 	Rename to removeFluids. 	(SIMPLE-ARGLIST): Move
 to lisp-backend.boot.  Rename to 	simpleParameterList?.

---
 src/ChangeLog                |  7 +++++++
 src/interp/lisp-backend.boot | 21 +++++++++++++++++++++
 src/interp/vmlisp.lisp       | 40 +++++++++-------------------------------
 3 files changed, 37 insertions(+), 31 deletions(-)

diff --git a/src/ChangeLog b/src/ChangeLog
index 68bae94d..dcdab929 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,10 @@
+2012-05-01  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
+	* interp/vmlisp.lisp (REMOVE-FLUIDS): Move to lisp-backend.boot.
+	Rename to removeFluids.
+	(SIMPLE-ARGLIST): Move to lisp-backend.boot.  Rename to
+	simpleParameterList?.
+
 2012-05-01  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
 	* interp/vmlisp.lisp (COMP370): Move to c-util.boot
diff --git a/src/interp/lisp-backend.boot b/src/interp/lisp-backend.boot
index 69c30700..79677e07 100644
--- a/src/interp/lisp-backend.boot
+++ b/src/interp/lisp-backend.boot
@@ -760,3 +760,24 @@ eval x ==
 compileLispDefinition(name,def) ==
   _*COMP370_-APPLY_* ~= nil => apply(_*COMP370_-APPLY_*,name,def,nil)
   nil
+
+++ Return true if `parms' is the empty list
+++ of is a proper list of identifiers.
+simpleParameterList? parms ==
+  parms = nil => true
+  parms is [.,:.] and lastNode parms is [.] and (and/[ident? p for p in parms])
+
+removeFluids args ==
+  args = nil => args
+  ident? args =>
+    $Vars := [args,:$Vars]
+    args
+  args isnt [.,:.] =>
+    args := GENTEMP()
+    $Vars := [args,:$Vars]
+    args
+  args is ['FLUID,v] and ident? v =>
+    $Decls := [v,:$Decls]
+    $Vars := [v,:$Vars]
+    v
+  [removeFluids first args,:removeFluids rest args]
diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp
index c871dc8c..a4d5e01f 100644
--- a/src/interp/vmlisp.lisp
+++ b/src/interp/vmlisp.lisp
@@ -350,24 +350,25 @@
          (fname (car fn))
          (lamda (cadr fn))
          (ltype (car lamda))
-         *vars* *decl* args
+         |$Vars| |$Decls| args
          (body (cddr lamda)))
-    (declare (special *vars* *decl*))
+    (declare (special |$Vars| |$Decls|))
     (if (eq ltype 'LAM)
         (let ((*lam-name* (intern (concat fname "\,LAM"))))
           (setq lamda (eval lamda) ltype (car lamda) body (cddr lamda))))
     (let ((dectest (car body)))
       (if (and (eqcar dectest 'declare) (eqcar (cadr dectest) 'special))
-          (setq *decl* (cdr (cadr dectest)) body (cdr body))))
-    (setq args (remove-fluids (cadr lamda)))
-    (cond ((and (eq ltype 'lambda) (simple-arglist args)) (setq nargs args))
+          (setq |$Decls| (cdr (cadr dectest)) body (cdr body))))
+    (setq args (|removeFluids| (cadr lamda)))
+    (cond ((and (eq ltype 'lambda) (|simpleParameterList?| args))
+	   (setq nargs args))
           (t (setq nargs (gensym))
              (setq body `((dsetq ,args  ,nargs) ,@body))
-             (cond ((eq ltype 'lambda) (setq nargs `(&rest ,nargs &aux ,@*vars*)))
+             (cond ((eq ltype 'lambda) (setq nargs `(&rest ,nargs &aux ,@ |$Vars|)))
                    ((eq ltype 'mlambda)
-                    (setq nargs `(&whole ,nargs &rest ,(gensym) &aux ,@*vars*)))
+                    (setq nargs `(&whole ,nargs &rest ,(gensym) &aux ,@ |$Vars|)))
                    (t (error "bad function type")))))
-    (cond (*decl* (setq body (cons `(declare (special ,@ *decl*)) body))))
+    (cond (|$Decls| (setq body (cons `(declare (special ,@ |$Decls|)) body))))
     (setq body
           (cond ((eq ltype 'lambda) `(defun ,fname ,nargs . ,body))
                 ((eq ltype 'mlambda) `(defmacro ,fname ,nargs . ,body))))
@@ -375,29 +376,6 @@
 
     body))
 
-(defun simple-arglist (arglist)
-  (or (null arglist)
-      (and (consp arglist) (null (cdr (last arglist)))
-           (every #'symbolp arglist))))
-
-(defun remove-fluids (arglist &aux f v) ;updates specials *decl* and *vars*
-  (declare (special *decl* *vars*))
-   (cond ((null arglist) arglist)
-         ((symbolp arglist) (push arglist *vars*) arglist)
-                ;if atom but not symbol, ignore value
-         ((atom arglist) (push (setq arglist (gentemp)) *vars*) arglist)
-         ((and (setq f (car arglist))
-               (eq f 'fluid)
-               (listp (cdr arglist))
-               (setq v (cadr arglist))
-               (|ident?| v)
-               (null (cddr arglist)))
-          (push v *decl*)
-          (push v *vars*)
-          v)
-         (t (cons (remove-fluids (car arglist))
-                  (remove-fluids (cdr arglist))))))
-
 ; 9.4 Vectors and Bpis
 
 (defun IVECP (x) (and (vectorp x) (subtypep (array-element-type x) 'integer)))
-- 
cgit v1.2.3