aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/ChangeLog7
-rw-r--r--src/interp/lisp-backend.boot21
-rw-r--r--src/interp/vmlisp.lisp40
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,5 +1,12 @@
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
(compileLispDefinition): Move to lisp-backend.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)))