diff options
| -rw-r--r-- | src/ChangeLog | 7 | ||||
| -rw-r--r-- | src/interp/lisp-backend.boot | 21 | ||||
| -rw-r--r-- | 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,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))) |