From 84610ed8a8859530ae8799201c6c5e1f0910c1e3 Mon Sep 17 00:00:00 2001
From: Lars Brinkhoff <lars@nocrew.org>
Date: Fri, 23 Mar 2018 11:59:28 +0100
Subject: [PATCH] New Scheme interpreter.

---
 Makefile                 |   2 +-
 build/build.tcl          |   8 +
 src/nschem/-read-.-this- |   2 +
 src/nschem/scheme.(init) |  13 +
 src/nschem/schint.lsp    | 672 +++++++++++++++++++++++++++++++++++++++
 src/nschem/schmac.lsp    | 509 +++++++++++++++++++++++++++++
 src/nschem/schuuo.lsp    | 196 ++++++++++++
 7 files changed, 1401 insertions(+), 1 deletion(-)
 create mode 100755 src/nschem/-read-.-this-
 create mode 100755 src/nschem/scheme.(init)
 create mode 100755 src/nschem/schint.lsp
 create mode 100755 src/nschem/schmac.lsp
 create mode 100755 src/nschem/schuuo.lsp

diff --git a/Makefile b/Makefile
index 2fbc2395..97504701 100644
--- a/Makefile
+++ b/Makefile
@@ -9,7 +9,7 @@ SRC = system syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa	\
       inquir acount gz sys decsys ecc alan sail kcc kcc_sy c games archy dcp \
       spcwar rwg libmax rat z emaxim rz maxtul aljabr cffk das ell ellen \
       jim jm jpg macrak maxdoc maxsrc mrg munfas paulw reh rlb rlb% share \
-      tensor transl wgd zz graphs lmlib pratt
+      tensor transl wgd zz graphs lmlib pratt nschem
 DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc chprog
 BIN = sys2 emacs _teco_ lisp liblsp alan inquir sail comlap c decsys moon graphs
 
diff --git a/build/build.tcl b/build/build.tcl
index ccb19793..38747600 100644
--- a/build/build.tcl
+++ b/build/build.tcl
@@ -2018,6 +2018,14 @@ respond "*" ":link lisp;defns mid,l;defns >\r"
 respond "*" ":midas liblsp;_libdoc;fft\r"
 respond "*" ":midas liblsp;_libdoc;phase\r"
 
+# New Scheme interpreter
+respond "*" "complr\013"
+respond "_" "nschem;scheme interp_schint lsp\r"
+respond "_" "nschem;scheme macros_schmac lsp\r"
+respond "_" "nschem;scheme uuohan_schuuo lsp\r"
+respond "_" "\032"
+type ":kill\r"
+
 bootable_tapes
 
 # make output.tape
diff --git a/src/nschem/-read-.-this- b/src/nschem/-read-.-this-
new file mode 100755
index 00000000..2b23c2be
--- /dev/null
+++ b/src/nschem/-read-.-this-
@@ -0,0 +1,2 @@
+Maeda created this directory on 5/26/89.
+It holds yet another version of GLS's MacLisp Scheme Interpreter.
\ No newline at end of file
diff --git a/src/nschem/scheme.(init) b/src/nschem/scheme.(init)
new file mode 100755
index 00000000..aca9bdbd
--- /dev/null
+++ b/src/nschem/scheme.(init)
@@ -0,0 +1,13 @@
+;; This was quux;scheme (init)
+;; I moved it to nschem;   -maeda 5/26/89
+
+(comment list 60000. symbols 4000.)
+
+(progn (setq pure 1)
+       (fasload scheme interp dsk nschem)
+	(fasload scheme macros dsk nschem)
+	(fasload scheme uuohan dsk nschem)
+       (setq alarmclock nil)
+       (setq *displace-save-sw* nil)
+
+       (scheme t '|SCHEME: Top Level|))
diff --git a/src/nschem/schint.lsp b/src/nschem/schint.lsp
new file mode 100755
index 00000000..48f3770d
--- /dev/null
+++ b/src/nschem/schint.lsp
@@ -0,0 +1,672 @@
+
+;for compiler, speedup hacks.
+
+(declare (mapex t)
+         (special **exp** **beta** **vals** **unevlis** **evlis** **pc** **clink**
+                  **fun** **val** **tem** **fluid!vars** **fluid!vals**
+                  **queue** **tick** **quantum** **process** **procnum**
+                  **jpcr** version lispversion))
+
+(defun version macro (x)
+       (cond (compiler-state
+	      (list 'quote
+		    (cond ((status feature newio) (list (namestring (truename infile))))
+			  (t (status uread)))))
+	     (t (rplaca x 'quote)
+		(rplacd x (list version))
+		(list 'quote version))))
+
+(declare (read))
+
+(setq version ((lambda (compiler-state) (version)) t))
+
+(defun fastcall (atsym)
+       (cond ((eq (car (cdr atsym)) 'subr)
+	      (subrcall nil (cadr (cdr atsym))))
+	     (t ((lambda (subr)
+			 (cond ((and subr
+				     (null (get atsym 'expr)))	;don't screw TRACE
+				(remprop atsym 'subr)
+				(putprop atsym subr 'subr)
+				(subrcall nil subr))
+			       (t (apply atsym nil))))
+		 (get atsym 'subr)))))
+
+;control stack stuff
+
+(defun push macro (l) (list 'setq '**clink** (push1 (cdr l))))
+
+(declare (eval (read)))
+
+(defun push1 (x)
+       (cond ((null x) '**clink**)
+             (t (list 'cons (car x) (push1 (cdr x))))))
+
+(defun top macro (l)
+   (list 
+     (list 'lambda '(ltem)
+       (cons 'setq
+             (mapcan '(lambda (x)
+                        (list x '(car ltem)  'ltem '(cdr ltem) ))
+                     (cdr l))))
+     '**clink**))
+
+(defun pop macro (l)
+ (list 'setq '**clink**
+   (list 
+     (list 'lambda '(ltem)
+       (cons 'setq
+             (mapcan '(lambda (x)
+                        (list x '(car ltem)  'ltem '(cdr ltem) ))
+                     (cdr l))))
+     '**clink**)))
+
+(defun 1st macro (l) (list 'car '**clink**))
+(defun 2nd macro (l) (list 'cadr '**clink**))
+(defun 3rd macro (l) (list 'caddr '**clink**))
+
+
+;environment manipulation
+
+(defun betacons (lamb obeta ovals name)
+       (cons 'beta
+             (cons (reverse (cadr lamb))
+                   (cons (cons obeta ovals)
+                         (cons (caddr lamb) name)))))
+
+(defun bind (newvars newvals name)
+       (setq **beta** (cons name
+                            (cons newvars
+                                  (cons (cons **beta** **vals**)
+                                        nil)))
+             **vals** newvals))
+
+(defun vars macro (l) (list 'cadr (cadr l)))
+
+(defun obeta macro (l) (list 'caaddr (cadr l)))
+
+(defun ovals macro (l) (list 'cdaddr (cadr l)))
+
+(defun body macro (l) (list 'cadddr (cadr l)))
+
+(defun name macro (l) (list 'cddddr (cadr l)))
+
+(defun lookup (identifier beta vals)
+       (prog (vars)
+        nextbeta
+           (setq vars (vars beta))
+        nextvar
+           (cond ((null vars)
+                  (setq vals (ovals beta))
+                  (cond ((setq beta (obeta beta)) (go nextbeta))
+                        (t (return nil))))
+                 ((eq identifier (car vars)) (return vals))
+                 (t (setq vars (cdr vars)
+                          vals (cdr vals))
+                    (go nextvar)))))
+
+(defun locin macro (l) (list 'car (cadr l)))
+
+
+;Enclose is the user level operator for making lambda expressions into closures.
+;  The first argument is the lambda expression, the second is an arbitrary name to
+;  be printed out by WHERE.
+
+(defun enclose nargs
+       (betacons (arg 1)
+		 nil
+		 nil
+		 (cond ((> nargs 1) (arg 2))
+		       (t '*anonymous-closure*))))
+
+(defprop moonphase (phase fasl dsk liblsp) autoload)
+(defprop phaseprinc (phsprt fasl dsk liblsp) autoload)
+(defprop datimprinc (phsprt fasl dsk liblsp) autoload)
+(defprop sunposprinc (phsprt fasl dsk liblsp) autoload)
+
+;basic interpreter -- initialization, main-loop, time slicing.
+
+(defun scheme (garbagep prompt)
+       (cond (garbagep
+	      (setq version (version)  lispversion (status lispversion))
+	      (terpri)
+	      (princ '|This is SCHEME |)
+	      (princ version)
+	      (princ '| running in LISP |)
+	      (princ lispversion)
+	      (princ '|.|)
+	      (terpri)
+	      (princ '|   |)
+	      (phaseprinc (moonphase))
+	      (terpri)
+	      (princ '|   |)
+	      (sunposprinc)
+	      (terpri)
+	      (princ '|   |)
+	      (datimprinc 'hack)))
+       (setq **beta** nil  **vals** nil  **fluid!vars** nil  **fluid!vals** nil
+	     **queue** nil
+             **process** (create!process (list '**top** (list 'quote prompt) ''|==> |)))
+       (swapinprocess)
+       (alarmclock 'runtime **quantum**)
+       (mloop))
+
+(defun mloop ()			;The "machine".
+       (do ((**tick** nil))  (nil)
+	  (and **jpcr** (inc-jpcr))
+          (and **tick** (allow) (schedule))
+          (fastcall **pc**)))
+
+(defun inc-jpcr ()
+       (cond ((eq (car **jpcr**) **beta**))
+	     (t (setq **jpcr** (cddr **jpcr**))
+		(rplaca **jpcr** **beta**)
+		(rplaca (cdr **jpcr**) **vals**))))
+
+(defun set-jpcr (n)
+       (setq **jpcr** nil)
+       (do i n (- i 1) (= i 0)
+	   (setq **jpcr** (nconc (list nil nil) **jpcr**)) )
+       (nconc **jpcr** **jpcr**))
+
+(setq **jpcr** nil)
+
+(defun allow ()
+  ((lambda (vcell)
+       (cond (vcell (car vcell))
+             (t t)))
+   (lookup '*allow* **beta** **vals**)))
+
+(defun schedule ()
+       (cond (**queue**
+	      (swapoutprocess)
+	      (nconc **queue** (list **process**))
+	      (setq **process** (car **queue**)
+		    **queue** (cdr **queue**))
+	      (swapinprocess)))
+       (setq **tick** nil)
+       (alarmclock 'runtime **quantum**))
+
+(defun swapoutprocess ()
+       (putprop **process**
+                (list **exp** **beta** **vals** **evlis** **unevlis** **pc** **clink**
+		      **fun** **fluid!vars** **fluid!vals** **val** **tem**)
+                '**process**))
+
+(defun swapinprocess () 
+       (mapc 'set
+             '(**exp** **beta** **vals** **evlis** **unevlis** **pc** **clink**
+	       **fun** **fluid!vars** **fluid!vals** **val** **tem**)
+             (get **process** '**process**) ))
+
+(defun settick (x) (setq **tick** t))
+(setq **quantum** 1000000. alarmclock 'settick)
+
+;central evaluator functions.
+
+(defun symbol-value (symbol beta vals)
+       (cond ((setq **tem** (lookup symbol beta vals))
+	      (locin **tem**))
+	     ((getl symbol '(subr expr lsubr)))
+	     ((boundp symbol) (symeval symbol))
+	     (t (symbol-value (error '|Unbound Symbol| symbol 'unbnd-vrbl) beta vals))))
+
+(defun dispatch ()
+       (cond ((atom **exp**)
+              (cond ((numberp **exp**) (setq **val** **exp**))
+		    (t (setq **val** (symbol-value **exp** **beta** **vals**)))))
+	     ((eq (car **exp**) 'lambda)
+	      (setq **val** (betacons **exp** **beta** **vals** **exp**)))
+	     (t (dispatch1))))
+
+(defun dispatch1 ()			;This winning bum is due to Charlie Rich.
+       (cond ((atom (car **exp**))
+              (cond ((setq **tem** (get (car **exp**) 'aint))
+                     (fastcall **tem**))
+		    (t (setq **fun** (symbol-value (car **exp**) **beta** **vals**))
+		       (setq **unevlis** (cdr **exp**)  **evlis** nil)
+		       (evlis-nopush))))
+	     ((eq (caar **exp**) 'lambda)
+	      (setq **fun** (betacons (car **exp**) **beta** **vals** (car **exp**)))
+	      (setq **unevlis** (cdr **exp**)  **evlis** nil)
+	      (evlis-nopush))
+	     ((null (cdr **exp**))
+	      (push **pc**)
+	      (setq **exp** (car **exp**)  **pc** 'nargs)
+	      (dispatch1))
+             (t (push **exp** **beta** **vals** **pc**)
+                (setq **exp** (car **exp**)  **pc** 'gotfun)
+                (dispatch1))))
+
+(defun evlis-nopush ()
+       (cond ((null **unevlis**)
+	      (setq **unevlis** **pc**  **pc** 'tapply))
+	     ((atom (car **unevlis**))
+	      (setq **evlis**
+		    (cons (cond ((numberp (car **unevlis**))
+				 (car **unevlis**))
+				(t (symbol-value (car **unevlis**) **beta** **vals**)))
+			  **evlis**)
+		    **unevlis** (cdr **unevlis**))
+	      (evlis-nopush))
+	     ((eq (caar **unevlis**) 'lambda)
+	      (setq **evlis**
+		    (cons (betacons (car **unevlis**) **beta** **vals** (car **unevlis**))
+			  **evlis**)
+		    **unevlis** (cdr **unevlis**))
+	      (evlis-nopush))
+	     ((null (cdr **unevlis**))
+	      (push **evlis** **fun** **pc**)
+	      (setq **exp** (car **unevlis**)  **pc** 'evlast)
+	      (dispatch1))
+	     (t (push **evlis** **unevlis** **fun** **beta** **vals** **pc**)
+		(setq **exp** (car **unevlis**)  **pc** 'evlis1)
+		(dispatch1))))
+
+(defun tapply () (setq **pc** **unevlis**) (sapply))
+
+(defun gotfun ()
+       (pop **exp**)
+       (push **val**)			;stack = fun,beta,vals,pc.
+       (setq **unevlis** (cdr **exp**)  **evlis** nil)
+       (evlis))
+
+(defun evlis ()
+       (cond ((null **unevlis**)
+              (pop **fun** **beta** **vals** **pc**)
+	      (sapply))
+	     ((atom (car **unevlis**))
+	      (setq **evlis**
+		    (cons (cond ((numberp (car **unevlis**))
+				 (car **unevlis**))
+				(t (symbol-value (car **unevlis**) (2nd) (3rd))))
+			  **evlis**)
+		    **unevlis** (cdr **unevlis**))
+	      (evlis))
+	     ((eq (caar **unevlis**) 'lambda)
+	      (setq **evlis**
+		    (cons (betacons (car **unevlis**) (2nd) (3rd) (car **unevlis**))
+			  **evlis**)
+		    **unevlis** (cdr **unevlis**))
+	      (evlis))
+	     ((null (cdr **unevlis**))
+	      (pop **fun** **beta** **vals**)
+	      (push **evlis** **fun**)
+	      (setq **exp** (car **unevlis**)  **pc** 'evlast)
+	      (dispatch1))
+             (t (top **fun** **beta** **vals**)
+                (push **evlis** **unevlis**) 
+                (setq **exp** (car **unevlis**) **pc** 'evlis1)
+                (dispatch1))))
+
+(defun evlis1 ()
+      (pop **evlis** **unevlis**)
+      (setq **evlis** (cons **val** **evlis**)  **unevlis** (cdr **unevlis**))
+      (evlis))
+
+(defun evlast ()
+       (pop **evlis** **fun** **pc**)
+       (setq **evlis** (cons **val** **evlis**))
+       (sapply))
+
+(defun nargs ()
+       (pop **pc**)
+       (setq **evlis** nil  **fun** **val**)
+       (sapply))
+
+(defun sapply ()
+       (cond ((eq (car **fun**) 'subr)
+	      (setq **val** (revsubrapply **fun** **evlis**)))
+	     ((eq (car **fun**) 'lsubr)
+	      (setq **val** (revlsubrapply **fun** **evlis**)))
+	     ((eq (car **fun**) 'beta)
+	      (setq **exp** (body **fun**) **beta** **fun** **vals** **evlis**)
+	      (dispatch))
+	     ((eq (car **fun**) 'expr)
+	      (setq **val** (revapply (cadr **fun**) **evlis**)))
+	     ((eq (car **fun**) 'cbeta)
+	      (compiled-beta-entry))		;See SCHUUO
+	     ((eq (car **fun**) 'delta)
+	      (setq **clink** (cadr **fun**))
+	      (pop **beta** **vals** **fluid!vars** **fluid!vals** **pc**)
+	      (setq **val** (car **evlis**)))
+	     (t (error '|Bad Function - Evlis| **fun** 'fail-act))))
+
+(defun revapply (fn vals)
+       (prog (a b c d e)
+	     (or vals (return (funcall fn)))
+	     (setq a (car vals) vals (cdr vals))
+	     (or vals (return (funcall fn a)))
+	     (setq b (car vals) vals (cdr vals))
+	     (or vals (return (funcall fn b a)))
+	     (setq c (car vals) vals (cdr vals))
+	     (or vals (return (funcall fn c b a)))
+	     (setq d (car vals) vals (cdr vals))
+	     (or vals (return (funcall fn d c b a)))
+	     (setq e (car vals) vals (cdr vals))
+	     (or vals (return (funcall fn e d c b a)))
+	     (return (apply fn (reverse vals)))))
+
+(defun revsubrapply (fn vals)
+       (prog (a b c d e)
+	     (or vals (return (subrcall nil (cadr fn))))
+	     (setq a (car vals) vals (cdr vals))
+	     (or vals (return (subrcall nil (cadr fn) a)))
+	     (setq b (car vals) vals (cdr vals))
+	     (or vals (return (subrcall nil (cadr fn) b a)))
+	     (setq c (car vals) vals (cdr vals))
+	     (or vals (return (subrcall nil (cadr fn) c b a)))
+	     (setq d (car vals) vals (cdr vals))
+	     (or vals (return (subrcall nil (cadr fn) d c b a)))
+	     (setq e (car vals) vals (cdr vals))
+	     (or vals (return (subrcall nil (cadr fn) e d c b a)))
+	     (error '|Too Many Arguments to a Subr| (cons fn vals) 'wrng-no-args)))
+
+(defun revlsubrapply (fn vals)
+       (prog (a b c d e temp)
+	     (setq temp vals)
+	     (or temp (return (lsubrcall nil (cadr fn))))
+	     (setq a (car temp) temp (cdr temp))
+	     (or temp (return (lsubrcall nil (cadr fn) a)))
+	     (setq b (car temp) temp (cdr temp))
+	     (or temp (return (lsubrcall nil (cadr fn) b a)))
+	     (setq c (car temp) temp (cdr temp))
+	     (or temp (return (lsubrcall nil (cadr fn) c b a)))
+	     (setq d (car temp) temp (cdr temp))
+	     (or temp (return (lsubrcall nil (cadr fn) d c b a)))
+	     (setq e (car temp) temp (cdr temp))
+	     (or temp (return (lsubrcall nil (cadr fn) e d c b a)))
+	     (setplist 'the-lsubr-apply-atom fn)
+	     (return (apply 'the-lsubr-apply-atom (reverse vals)))))
+
+;Basic AINTs.
+
+(defprop evaluate aeval aint)
+
+(defun aeval ()
+       (push **beta** **vals** **pc**)
+       (setq **exp** (cadr **exp**)  **pc** 'aeval1)
+       (dispatch))
+
+(defun aeval1 ()
+       (pop **beta** **vals** **pc**)
+       (setq **exp** **val**)
+       (dispatch))
+
+
+(defprop if aif aint)
+
+(defun aif ()
+       (push **exp** **beta** **vals** **pc**)
+       (setq **exp** (cadr **exp**)  **pc** 'if1)
+       (dispatch))
+
+(defun if1 ()
+       (pop **exp** **beta** **vals** **pc**)
+       (setq **exp** (cond (**val** (caddr **exp**)) (t (cadddr **exp**))))
+       (dispatch))
+
+
+(defprop block ablock aint)
+
+
+(defun ablock ()
+       (push **beta** **vals** **pc**)
+       (setq **unevlis**
+	     (or (cdr **exp**)
+		 (error '|Strange Block -- Ablock| **exp** 'fail-act)))
+       (ablock1))
+
+(defun ablock1 ()
+       (cond ((cdr **unevlis**)
+	      (top **beta** **vals**)
+	      (push **unevlis**)
+	      (setq **pc** 'ablock2))
+	     (t (pop **beta** **vals** **pc**)))
+       (setq **exp** (car **unevlis**))
+       (dispatch))
+
+(defun ablock2 ()
+       (pop **unevlis**)
+       (setq **unevlis** (cdr **unevlis**))
+       (ablock1))
+
+(defprop quote aquote aint)
+
+(defun aquote () (setq **val** (cadr **exp**)))
+
+
+(defprop labels alabels aint)
+
+(defun alabels ()
+       (bind (mapcar 'car (cadr **exp**))
+             (mapcar 'car (cadr **exp**))
+             'labels)
+       (map '(lambda (defl vall)
+		     (rplaca vall
+			     (betacons (cadar defl)
+				       **beta**
+				       **vals**
+				       (caar defl))))
+	    (cadr **exp**)
+	    **vals**)
+       (setq **exp** (caddr **exp**))
+       (dispatch))
+
+
+;Amacros for SCHEME syntax extension.
+
+(defun amacro ()
+       (setq **tem** (getl (car **exp**) '(amacro macro)))
+       (setq **exp** (funcall (cadr **tem**) **exp**))
+       (dispatch))
+
+
+;Side effects.
+
+(defprop define adefine aint)
+
+(defun adefine () (setq **val** (eval **exp**)))
+
+(defun define fexpr (l)
+       (setq **tem** (cond ((cdr l) (putprop (car l) (cadr l) 'scheme!function))
+                           ((get (car l) 'scheme!function))
+                           (t (error '|Bad Definition - Define| l 'fail-act))))
+       (set (car l) (betacons **tem** nil nil (car l)))
+       (car l))
+
+(defprop aset aaset aint)
+
+(defun aaset ()
+       (push **exp** **beta** **vals** **pc**)
+       (setq **exp** (cadr **exp**)  **pc** 'aset1)
+       (dispatch))
+
+(defun aset1 ()
+       (pop **exp**)
+       (top **beta** **vals**)
+       (setq **exp** (caddr **exp**)  **pc** 'aset2)
+       (push **val**)
+       (dispatch))
+
+(defun aset2 ()
+       (pop **tem** **beta** **vals** **pc**)	; tem is the identifier to be clobbered.
+       ((lambda (vc)
+                (cond (vc (rplaca vc **val**))
+                      (t (set **tem** **val**))))
+        (lookup **tem** **beta** **vals**)))
+
+;Fluid variable stuff.
+
+(defprop fluid!bind afluidbind aint)
+
+(defun afluidbind ()
+       (push **beta** **vals** **exp** **fluid!vars** **fluid!vals** **pc**)
+       (setq **evlis** **fluid!vals**  **unevlis** (cadr **exp**))
+       (afluidbind1))
+
+(defun afluidbind1 ()
+       (cond ((null **unevlis**)
+	      (pop **beta** **vals** **exp**)
+	      (setq **fluid!vars** (nconc (reverse (cadr **exp**)) **fluid!vars**))
+	      (setq **fluid!vals** **evlis**)
+	      (setq **exp** (caddr **exp**))
+	      (setq **pc** 'unbind)
+	      (dispatch))
+	     (t (top **beta** **vals**)
+		(setq **exp** (cadar **unevlis**))
+		(setq **pc** 'afluidbind2)
+		(push **evlis** **unevlis**)
+		(dispatch))))
+
+(defun afluidbind2 ()
+       (pop **evlis** **unevlis**)
+       (setq **evlis** (cons **val** **evlis**)  **unevlis** (cdr **unevlis**))
+       (setq **pc** 'afluidbind1))
+
+(defun unbind () (pop **fluid!vars** **fluid!vals** **pc**))
+
+(defprop fluid!value afluidval aint)
+
+(defun afluidval ()
+       (setq **val**
+	     ((lambda (vc)
+		      (cond (vc (car vc))
+			    ((boundp (cadr **exp**)) (symeval (cadr **exp**)))
+			    (t (error '|Unbound Fluid Variable| (cadr **exp**) 'fail-act))))
+	      (fluid!lookup (cadr **exp**) **fluid!vars** **fluid!vals**))))
+
+(defun fluid!set (var val)
+       ((lambda (vc)
+                (cond (vc (rplaca (cdr vc) val))
+                      (t (set var val))))
+        (fluid!lookup var **fluid!vars** **fluid!vals**)))
+
+(defun fluid!lookup (id vars vals)
+       (prog ()
+         lp (cond ((null vars) (return nil))
+                  ((eq id (car vars))
+                   (cond ((null vals) (error '|Vals too short -- fluid!lookup| id 'fail-act)))
+                   (return vals))
+                  ((null vals) (error '|Too few vals - fluid!lookup| id 'fail-act)))
+            (setq vars (cdr vars)  vals (cdr vals))
+            (go lp)))
+
+;Hairy control structure.
+
+(setq **procnum** 0)
+
+(defun genprocname ()
+       ((lambda (base *nopoint)
+		(implode (append '(p r o c e s s)
+				  (exploden (setq **procnum** (1+ **procnum**))))))
+	10. t))
+
+(defun create!process (exp)
+       ((lambda (**process** **beta** **vals** **evlis** **unevlis** **pc** **clink**
+		 **fun** **exp** **fluid!vars** **fluid!vals** **val** **tem**)
+                (dispatch)
+                (swapoutprocess)
+                **process**)
+        (genprocname) **beta** **vals** nil nil 'terminate nil nil
+        exp **fluid!vars** **fluid!vals** nil nil))
+
+(defun start!process (p)
+       (cond ((or (not (atom p)) (not (get p '**process**)))
+	      (error '|Bad Process - START!PROCESS| p 'fail-act)))
+       (or (eq p **process**) (memq p **queue**)
+	   (setq **queue** (nconc **queue** (list p))))
+       p)
+
+(defun stop!process (p)
+       (cond ((memq p **queue**)
+	      (setq **queue** (delete p **queue**))
+	      p)
+	     ((eq p **process**)
+	      (setq **val** p)
+	      (terminate))))
+
+(defun terminate ()
+       (swapoutprocess)
+       (cond ((null **queue**)
+	      (setq **beta** nil  **vals** nil  **fluid!vars** nil  **fluid!vals** nil)
+	      (setq **process**
+		    (create!process '(**top** '|SCHEME: Queue Ran Out| '|==> |))))
+	     (t (setq **process** (car **queue**)
+		      **queue** (cdr **queue**))))
+       (swapinprocess)
+       **val**)
+
+
+(defprop evaluate!uninterruptibly evun aint)
+
+(defun evun ()
+       (bind (list '*allow*) (list nil) 'evaluate!unterruptibly)
+       (setq **exp** (cadr **exp**))
+       (dispatch))
+
+
+(defprop catch acatch aint)
+
+(defun acatch ()
+       (bind (list (cadr **exp**))
+             (list (list 'delta
+                         ((lambda (**clink**)
+                           (push **beta** **vals** **fluid!vars** **fluid!vals** **pc**)
+                           **clink**)
+                          **clink**)
+			 (cadr **exp**)))
+             'catch)
+       (setq **exp** (caddr **exp**))
+       (dispatch))
+
+(defun punt ()
+       (and **queue**
+	    (progn (swapoutprocess)
+		   (setq **queue** (nconc **queue** (list **process**))
+			 **process** (car **queue**)
+			 **queue** (cdr **queue**))
+		   (swapinprocess)
+		   **val**)))
+
+
+;The read-eval-print loop.
+
+(define **top**
+	(lambda (**message** **prompt**)
+		(labels ((**top1**
+                          (lambda (**ignore0** **ignore1** **ignore2** **ignore3**
+					       **ignore4** **ignore5** **ignore6**
+					       **ignore7** **ignore8**)
+                             (**top1** (labels ((**puntloop**
+						 (lambda (**ignore8**)
+							 (if **queue**
+							     (**puntloop** (punt))))))
+					       (**puntloop** nil))
+				       (terpri)
+				       (princ **prompt**)
+				       (set '++ --)
+				       (set '-- (read))
+				       (set '** (evaluate --))
+				       (if (not ^q) (terpri)
+					   (if (> (charpos (symeval 'tyo)) 10.)
+					       ((lambda (x) (princ '|    |)) (terpri))))
+                                       (schprin1 **)
+				       (princ '| |)))))
+                    (**top1** (set '-- nil) (terpri) (princ **message**) nil
+			      nil nil nil))))
+
+(defun schprin1 (x)
+       (cond (prin1 (funcall prin1 x))
+	     (t (prin1 x))))
+
+(defun where ()
+       (do ((prinlevel 3) (prinlength 6)
+            (b **beta** (obeta b)))
+           ((null b) nil)
+          (cond ((eq (car b) 'beta) (print (name b)))
+                (t (print (car b))))))
+
+(defun schval fexpr (l)
+       (locin (lookup (car l) **beta** **vals**)))
+
diff --git a/src/nschem/schmac.lsp b/src/nschem/schmac.lsp
new file mode 100755
index 00000000..51b0c756
--- /dev/null
+++ b/src/nschem/schmac.lsp
@@ -0,0 +1,509 @@
+
+(defun schemestart nargs
+       (sstatus toplevel '(schemestart1))
+       (nointerrupt nil)
+       (^g))
+
+(defun schemestart1 ()
+       (sstatus toplevel nil)
+       (cursorpos 'c)
+       (cond ((not (= tty 5)) (scheme nil '|Quit|))
+	     (t (scheme t '|SCHEME: Top Level|))))
+
+(cond ((status feature newio)
+       (sstatus ttyint '/ 'schemestart))
+      (t (sstatus interrupt 16. 'schemestart)))
+
+(declare (read))
+(sstatus macro /% '(lambda ()()))
+(declare (sstatus macro /% '(lambda () ((lambda (/%) (eval /%) /%) (read)))) )
+
+(declare (mapex t) (macros t))
+
+;first, some useful macros.
+
+(declare (special *displace-sw* *displace-save-sw* *displace-list* *displace-count*))
+%
+(defun displace (x y)
+   (cond ((atom y) y)
+	 (*displace-sw*
+	  (cond (*displace-save-sw*
+		 (setq *displace-count* (1+ *displace-count*))
+		 (setq *displace-list*
+		       (cons (cons (cons (car x) (cdr x))
+				   x)
+			     *displace-list*))))
+	  (rplaca x (car y))
+	  (rplacd x (cdr y))
+	  x)
+	 (t y)) )
+%
+(or (boundp '*displace-sw*)
+    (setq *displace-sw* t))
+%
+(or (boundp '*displace-save-sw*)
+    (setq *displace-save-sw* t))
+%
+(or (boundp '*displace-list*)
+    (setq *displace-list* nil))
+%
+(or (boundp '*displace-count*)
+    (setq *displace-count* 0))
+%
+(defun replace ()
+       ((lambda (n)
+		(declare (fixnum n))
+		(cond ((not (= n *displace-count*))
+		       (terpri) (princ '|Someone's been hacking my *displace-list*!!!|)
+		       (terpri) (princ '|Do it again and I won't speak to you anymore.|)
+		       (break replace-lossage t)))
+		(mapc '(lambda (z)
+			(rplaca (cdr z) (caar z))
+			(rplacd (cdr z) (cdar z)))
+		      *displace-list*)
+		(setq *displace-count* 0)
+		(setq *displace-list* nil))
+	(length *displace-list*)))
+%
+(defun qexpander (m)
+       (prog (x y)
+	     (cond ((atom m) (return (list 'quote m)))
+		   ((eq (car m) '/,) (return (cdr m)))
+		   ((and (not (atom (car m)))
+			 (eq (caar m) '/@))
+		    (return (list 'append (cdar m) (qexpander (cdr m))))))
+	     (setq x (qexpander (car m))
+		   y (qexpander (cdr m)))
+	     (and (not (atom x))
+		  (not (atom y))
+		  (eq (car x) 'quote)
+		  (eq (car y) 'quote)
+		  (eq (cadr x) (car m))
+		  (eq (cadr y) (cdr m))
+		  (return (list 'quote m)))
+	     (return (list 'cons x y))))
+
+%(defun qmac () (qexpander (read)))
+%(defun cmac () (cons '/, (read)))
+%(defun amac () (cons '/@ (read)))
+
+%(sstatus macro /" 'qmac)
+%(sstatus macro /, 'cmac)
+%(sstatus macro /@ 'amac))
+
+(defprop let amacro aint)
+
+(defun let macro (x)
+   (displace x
+	     "((lambda ,(mapcar 'car (cadr x)) ,(blockify (cddr x)))
+	       @(mapcar 'cadr (cadr x)))))
+
+(defun if macro (x)
+       (displace x
+		 "(cond (,(cadr x) ,(caddr x))
+			(t ,(cadddr x)))))
+
+(putprop 'if (prog2 nil (get 'if 'aint) (remprop 'if 'aint)) 'aint)
+
+(declare (special **doname** **dobody**))
+
+(defprop do ado amacro) (defprop do amacro aint)
+
+(defun ado (x)
+   (displace x
+      "(labels ((,**doname**
+                  (lambda (,**dobody** @(mapcar 'car (cadr x)))
+                          (if ,(caaddr x) ,(blockify (cdaddr x))
+                              (,**doname** ,(blockify (cdddr x))
+                                       @(mapcar '(lambda (y)
+							 (cond ((and (cdr y) (cddr y))
+								(caddr y))
+							       (t (car y))))
+						(cadr x)))))))
+          (,**doname** nil @(mapcar '(lambda (y) (and (cdr y) (cadr y))) (cadr x))))))
+
+(setq **doname** (maknam (explodec '*doloop*)))
+(setq **dobody** (maknam (explodec '*dobody*)))
+
+(defprop cond acond amacro) (defprop cond amacro aint)
+
+(defun acond (x)
+       (cond ((null (cdr x)) (error '|Peculiar Cond| x 'fail-act))
+	     (t (displace x (acond1 (cdr x))))))
+
+(defun acond1 (x)
+      (cond ((null x) nil)
+            ((eq (caar x) 't) (blockify (cdar x)))
+	    ((null (cdar x))
+	     "(test ,(caar x)
+		    (lambda (x) x)
+		    ,(acond1 (cdr x))))
+	    ((eq (cadar x) '=>)
+	     "(test ,(caar x) ,(caddar x)
+		     ,(acond1 (cdr x))))
+            (t "(if ,(caar x) ,(blockify (cdar x))
+                    ,(acond1 (cdr x))))))
+
+(defprop test atest amacro) (defprop test amacro aint)
+
+(defun atest (x)
+       (displace x
+		 "((lambda (a b c)
+			   (if a (b a) (c)))
+		   ,(cadr x)
+		   ,(caddr x)
+		   (lambda () ,(cadddr x)))))
+
+;(defprop block ablock amacro) (defprop block amacro aint)
+
+;(defun ablock (x)
+;       (cond ((or (null (cdr x))
+;                  (null (cddr x)))
+;              (error '|Peculiar Block| x 'fail-act))
+;	     ((null (cdddr x))
+;	      (cond ((eq (cadadr x) '/:=)
+;		     (displace x
+;			 "((lambda ,(cond ((atom (caadr x))
+;					   (list (caadr x)))
+;					  (t (caadr x)))
+;				   ,(caddr x))
+;			   @(cddadr x))))
+;		    (t (displace x
+;			   "((lambda (a b) (b)) ,(cadr x) (lambda () ,(caddr x)))))))
+;	     (t (displace x
+;		    "(block ,(cadr x) (block @(cddr x)))))))
+
+(defun blockify (x)
+       (cond ((null x) nil)
+             ((null (cdr x)) (car x))
+             (t "(block @x))))
+
+(defprop and aand amacro) (defprop and amacro aint)
+
+(defun aand (x)
+       (displace x (cond ((or (null (cdr x))
+			      (null (cddr x)))
+			  (error '|Peculiar And| x 'wrng-no-args))
+			 (t (aand1 (cdr x))))))
+
+(defun aand1 (x)
+       (cond ((null (cdr x)) (car x))
+	     (t "(if ,(car x) ,(aand1 (cdr x)) nil))))
+
+(defprop or aor amacro) (defprop or amacro aint)
+
+(defun aor (x)
+       (displace x (cond ((or (null (cdr x))
+			      (null (cddr x)))
+			  (error '|Peculiar Or| x 'wrng-no-args))
+			 (t (aor1 (cdr x))))))
+
+(defun aor1 (x)
+       (cond ((null (cdr x)) (car x))
+	     (t "(test ,(car x)
+		       (lambda (x) x)
+		       ,(aor1 (cdr x))))))
+
+(defun orify (x)
+       (cond ((null x) nil)
+	     ((null (cdr x)) (car x))
+	     (t (cons 'or x))))
+
+(defprop amapcar amapcar1 amacro) (defprop amapcar amacro aint)
+
+(defun amapcar1 (x)
+       (cond ((null (cddr x))
+	      (error '|Peculiar Amapcar| x 'wrng-no-args))
+	     (t ((lambda (names)
+		     (displace x
+			 "(do ((,(car names)
+				nil
+				(cons (,(cadr x) @(mapcar '(lambda (y) "(car ,y))
+							   (cdr names)))
+				      ,(car names)))
+			       @(mapcar '(lambda (y n) "(,n ,y (cdr ,n)))
+					 (cddr x)
+					 (cdr names)))
+			      (,(orify (mapcar '(lambda (n) "(null ,n)) (cdr names)))
+			       (nreverse ,(car names))))))
+		 (do ((z (cdr x) (cdr z))
+		      (n nil (cons (gensym) n)))
+		     ((null z) n))))))
+
+(defprop amapc amapc1 amacro) (defprop amapc amacro aint)
+
+(defun amapc1 (x)
+       (cond ((null (cddr x))
+	      (error '|Peculiar Amapc| x 'wrng-no-args))
+	     (t ((lambda (names)
+		     (displace x
+			 "(do ,(mapcar '(lambda (y n) "(,n ,y (cdr ,n)))
+					 (cddr x)
+					 names)
+			      (,(orify (mapcar '(lambda (n) "(null ,n)) names))
+			       nil)
+			      (,(cadr x)
+			       @(mapcar '(lambda (y) "(car ,y))
+					names)))))
+		 (do ((z (cddr x) (cdr z))
+		      (n nil (cons (gensym) n)))
+		     ((null z) n))))))
+
+(defprop amaplist amaplist1 amacro) (defprop amaplist amacro aint)
+
+(defun amaplist1 (x)
+       (cond ((null (cddr x))
+	      (error '|Peculiar Amaplist| x 'wrng-no-args))
+	     (t ((lambda (names)
+		     (displace x
+			 "(do ((,(car names)
+				nil
+				(cons (,(cadr x) @(cdr names)) ,(car names)))
+			       @(mapcar '(lambda (y n) "(,n ,y (cdr ,n)))
+					 (cddr x)
+					 (cdr names)))
+			      (,(orify (mapcar '(lambda (n) "(null ,n)) (cdr names)))
+			       (nreverse ,(car names))))))
+		 (do ((z (cdr x) (cdr z))
+		      (n nil (cons (gensym) n)))
+		     ((null z) n))))))
+
+(defprop arraycall aarraycall amacro) (defprop arraycall amacro aint)
+
+(defun aarraycall (x)
+       (displace x
+		 "(funcall @(cddr x))))
+
+(defprop uread afsubr amacro) (defprop uread amacro aint)
+(defprop uwrite afsubr amacro) (defprop uwrite amacro aint)
+(defprop ufile afsubr amacro) (defprop ufile amacro aint)
+(defprop grindef afsubr amacro) (defprop grindef amacro aint)
+(defprop fasload afsubr amacro) (defprop fasload amacro aint)
+(defprop edit afsubr amacro) (defprop edit amacro aint)
+(defprop status afsubr amacro) (defprop status amacro aint)
+(defprop sstatus afsubr amacro) (defprop sstatus amacro aint)
+(defprop setq afsubr amacro) (defprop setq amacro aint)
+(defprop defprop afsubr amacro) (defprop defprop amacro aint)
+(defprop break afsubr amacro) (defprop break amacro aint)
+(defprop defun afsubr amacro) (defprop defun amacro aint)
+(defprop trace afsubr amacro) (defprop trace amacro aint)
+(defprop untrace afsubr amacro) (defprop untrace amacro aint)
+(defprop grindef afsubr amacro) (defprop grindef amacro aint)
+(defprop comment afsubr amacro) (defprop comment amacro aint)
+(defprop declare afsubr amacro) (defprop declare amacro aint)
+(defprop proclaim afsubr amacro) (defprop proclaim amacro aint)
+(defprop include afsubr amacro) (defprop include amacro aint)
+
+(defun afsubr (x) "(eval ',x))
+
+(defun proclaim fexpr (x) 'proclamation)
+
+(declare (special **genprogtag**))
+
+(defun genprogtag ()
+       ((lambda (base *nopoint)
+		(implode (append '(T A G)
+				 (explodec (setq **genprogtag**
+						 (1+ **genprogtag**))))))
+	10.
+	t))
+
+(setq **genprogtag** 0)
+
+(defprop go ago amacro) (defprop go amacro aint)
+
+(defun ago (x) (error '|Illegal GO| x 'unseen-go-tag))
+
+(defprop return areturn amacro) (defprop return amacro aint)
+
+(defun areturn (x) (error '|Illegal RETURN| x 'unseen-go-tag))
+
+(defprop prog aprog amacro) (defprop prog amacro aint)
+
+(defun aprog (x)
+       (displace x (aprog1 (cdr x) nil nil)))
+
+(defun aprog1 (x rnl ret)
+       "((lambda ,(car x) ,(aprog2 (cdr x) rnl ret))
+	 @(mapcar '(lambda (x) nil) (car x))))
+
+(defun aprog2 (body rnl ret)
+       ((lambda (stuff)
+		"(labels ,(maplist '(lambda (z)
+					"(,(caar z)
+					  (lambda ()
+					      ,(aprogx (cadar z)
+						       (cond ((cdr z) (caadr z))
+							     (t ret))
+						       (cdr stuff)
+						       ret))))
+				    (car stuff))
+			  (,(caaar stuff))))
+	(aprog3 body rnl ret)))
+
+(defun aprog3 (body rnl ret)
+       (do ((b body (cdr b))
+	    (r rnl)
+	    (tags nil
+		  (and (atom (car b)) (cons (car b) tags)))
+	    (x nil
+	       (cond ((atom (car b)) x)
+		     (t ((lambda (g)
+			     (setq r (do ((z tags (cdr z))
+					  (y r (cons (cons (putprop g (car z) 'gotag)
+							   g)
+						     y)))
+					 ((null z) y)))
+			     (cons (list g (car b)) x))
+			 (genprogtag))))))
+	   ((null b)
+	    (cons (nreverse x)
+		  (do ((z tags (cdr z))
+		       (y r (cons (cons (car z) ret) y)))
+		      ((null z) y))))))
+
+(defun aprogx (form next rnl ret)
+       (cond ((atom form)
+	      (cond (next "(,next))
+		    (t (error '|What The Hell? - PROG| form 'fail-act))))
+	     ((eq (car form) 'go)
+	      ((lambda (x)
+		   (cond ((null x)
+			  (error '|Illegal GO| form 'unseen-go-tag))
+			 (t "(,(cdr x)))))
+	       (assq (cadr form) rnl)))
+	     ((eq (car form) 'return)
+	      (cond (ret "(,ret))
+		    (t (cadr form))))
+	     ((eq (car form) 'if)
+	      "(if ,(cadr form)
+		   ,(aprogx (caddr form) next rnl ret)
+		   ,(aprogx (cadddr form) next rnl ret)))
+	     ((eq (car form) 'lambda)
+	      "(lambda ,(cadr form) ,(aprogx (caddr form) next rnl ret)))
+	     ((eq (car form) 'labels)
+	      "(labels @(mapcar '(lambda (x) "(,(car x)
+					       ,(aprogx (cadr x) next rnl ret)))
+				(cadr form))
+		       ,(aprogx (caddr form) next rnl ret)))
+	     ((eq (car form) 'prog)
+	      (aprog1 (cdr form) rnl next))
+	     ((and (atom (car form))
+		   (get (car form) 'amacro))
+	      (aprogx (apply (get (car form) 'amacro) form)
+		      next rnl ret))
+	     (t ((lambda (fm)
+		     (cond (next "(block ,fm (,next)))
+			   (t fm)))
+		 (mapcar '(lambda (x)
+				      (cond ((atom x) x)
+					    ((eq (car x) 'lambda)
+					     (aprogx x next rnl ret))
+					    (t x)))
+				 form)))))
+
+(defprop thunk athunk amacro) (defprop thunk amacro aint)
+
+(defun athunk (x)
+       (displace x
+		 "(cons (lambda (,(cond ((eq (cadr x) 'newval)
+					 'the-newval)
+					(t 'newval)))
+				,(cond ((eq (typep (cadr x)) 'symbol)
+					"(aset' ,(cadr x)
+						 ,(cond ((eq (cadr x) 'newval)
+							 'the-newval)
+							(t 'newval))))
+				       (t "(error ',(implode (append
+							      (explodec '|cannot be assigned to the call-by-name parameter |)
+							      (explode (cadr x))))
+						  ,(cond ((eq (cadr x) 'newval)
+							  'the-newval)
+							 (t 'newval))
+						  'fail-act))))
+			(lambda () ,(cadr x)))))
+
+(defprop thunkget athunkget amacro) (defprop thunkget amacro aint)
+
+(defun athunkget (x)
+       (or (eq (typep (cadr x)) 'symbol)
+	   (error '|Bad thunk variable - THUNKGET| x 'wrng-type-arg))
+       (displace x
+		 "((cdr ,(cadr x)))))
+
+(defprop thunkset athunkset amacro) (defprop thunkset amacro aint)
+
+(defun athunkset (x)
+       (or (eq (typep (cadr x)) 'symbol)
+	   (error '|Bad thunk variable - THUNKSET| x 'wrng-type-arg))
+       (displace x
+		 "((car ,(cadr x)) ,(caddr x))))
+
+; Defmac's allow for variable lists of the form (a1 ,,, an)
+;  or alternatively, allow a dotted list construction (a1 ,,, an-1 . an)
+;  so that an will be bound to the remainder of the calling form.
+; In addition, the list of arguments will be bound to the given
+;  variable in LSUBR fashion if a variable (not a list) is supplied.
+
+(declare (defun /@define fexpr (x) nil)
+	 (/@define defmac |lisp macro|))
+
+(defprop defmac amacro aint)
+
+(defun defmac macro (x)			;define MacLISP macro
+       (displace x
+		 "(progn
+
+		   'compile
+
+		   (defprop ,(cadr x) amacro aint)
+
+		   (defun ,(cadr x) macro (*z*)
+			   (displace *z*
+				     ((lambda ,(do ((a (caddr x) (cdr a))
+						    (b nil (cons (car a) b)))
+						   ((or (null a) (eq (typep a) 'symbol))
+						    (cond ((null a) (nreverse b))
+							  (t (nreverse (cons a b))))))
+					       ,(cadddr x))
+				      @(do ((a (caddr x) (cdr a))
+					    (b '(cdr *z*) "(cdr ,b))
+					    (c nil (cons "(car ,b) c)))
+					   (nil)
+					   (cond ((null a) (return (nreverse c)))
+						 ((eq (typep a) 'symbol)
+						  (return
+						   (nreverse (cons b c))))))))))))
+
+;SCHMACs are for SCHEME what DEFMACs are for LISP, with similar syntax.
+
+(declare (/@define schmac |scheme macro|))
+
+(defprop schmac amacro aint)
+
+(defun schmac macro (x)			;define SCHEME macro
+       ((lambda (newname)
+		(displace x
+			  "(progn 'compile
+				  (defprop ,(cadr x) amacro aint)
+				  (defprop ,(cadr x) ,newname amacro)
+				  (defun ,newname (*z*)
+					 (displace *z*
+						   ((lambda ,(do ((a (caddr x) (cdr a))
+								  (b nil (cons (car a) b)))
+								 ((or (null a)
+								      (eq (typep a) 'symbol))
+								  (cond ((null a) (nreverse b))
+									(t (nreverse
+									    (cons a b))))))
+							    ,(cadddr x))
+						    @(do ((a (caddr x) (cdr a))
+							  (b '(cdr *z*) "(cdr ,b))
+							  (c nil (cons "(car ,b) c)))
+							 (nil)
+							 (cond ((null a) (return (nreverse c)))
+							       ((eq (typep a) 'symbol)
+								(return
+								 (nreverse (cons b c))))))))))))
+	(implode (append (explodec (cadr x)) '(- a m a c r o)))))
+
diff --git a/src/nschem/schuuo.lsp b/src/nschem/schuuo.lsp
new file mode 100755
index 00000000..4666d87e
--- /dev/null
+++ b/src/nschem/schuuo.lsp
@@ -0,0 +1,196 @@
+
+; SCHEME compiled code linker.
+
+(declare (special **exp** **beta** **vals** **clink** **fun** **pc** **val** **evlis**
+		  **fluid!vars** **fluid!vals** **cont** **env** **argument-registers** **nargs**
+	          **cont+arg-regs** **number-of-arg-regs**
+		  **one** **two** **three** **four** **five** **six** **seven** **eight**))
+
+
+
+(defun body macro (l) (list 'cadddr (cadr l)))
+
+;control stack stuff
+
+(defun push macro (l) (list 'setq '**clink** (push1 (cdr l))))
+
+(declare (eval (read)))
+
+(defun push1 (x)
+       (cond ((null x) '**clink**)
+             (t (list 'cons (car x) (push1 (cdr x))))))
+
+(defun pop macro (l)
+ (list 'setq '**clink**
+   (list 
+     (list 'lambda '(ltem)
+       (cons 'setq
+             (mapcan '(lambda (x)
+                        (list x '(car ltem)  'ltem '(cdr ltem) ))
+                     (cdr l))))
+     '**clink**)))
+
+(setq **argument-registers** '(**one** **two** **three** **four**
+			       **five** **six** **seven** **eight**))
+
+(setq **cont+arg-regs** (cons '**cont** **argument-registers**))
+
+(setq **env+cont+arg-regs** (cons '**env** **cont+arg-regs**))
+
+(setq **number-of-arg-regs** (length **argument-registers**))
+
+(defun compiled-beta-entry ()
+       (setq **env** (cddr **fun**))
+       (setq **cont**
+	     (list 'epsilon
+		   ((lambda (**clink**)
+			    (push **pc**)
+			    **clink**)
+		    **clink**)))
+       (spread-evlis **evlis**)
+       (setq **pc** 'jrsticate)
+       (subrcall nil (cadr **fun**)))
+
+(defun spread-evlis (evlis)
+       (cond ((> (length evlis) **number-of-arg-regs**)
+	      (setq **one** (reverse evlis)))
+	     (t (spread-evlis1 evlis))))
+
+(defun spread-evlis1 (evlis)
+       (cond (evlis
+	      ((lambda (tem)
+		       (set (car tem)
+			    (car evlis))
+		       (cdr tem))
+	       (spread-evlis1 (cdr evlis))))
+	     (t **argument-registers**)))
+
+(setq **jrst** nil)
+
+(defun cheapy-jpc ()
+	(mapcar '(lambda (x) (subr (cadr x))) **jrst**))
+
+(defun rabbit-jpc ()
+	(mapcar '(lambda (x) (list (get (subr (cadr x))
+					'user-function)
+				   (caddr x)))
+		**jrst**))
+
+(defun jrsticate ()
+       (cond ((eq (car **fun**) 'cbeta)
+	      (setq **env** (cddr **fun**))
+	      (and **jrst**
+		   (setq **jrst** (cons **fun** **jrst**)))
+	      (subrcall nil (cadr **fun**)))
+	     ((eq (car **fun**) 'subr)
+	      (setq **one** (spreadsubrcall))
+	      (setq **fun** **cont**)
+	      (jrsticate))
+	     ((eq (car **fun**) 'lsubr)
+	      (setq **one** (spreadlsubrcall))
+	      (setq **fun** **cont**)
+	      (jrsticate))
+	     ((eq (car **fun**) 'expr)
+	      (setq **one** (spreadexprcall))
+	      (setq **fun** **cont**)
+	      (jrsticate))
+	     ((eq (car **fun**) 'beta)
+	      (setq **vals** (gather-evlis))
+	      (cond ((eq (car **cont**) 'epsilon)
+		     (setq **clink** (cadr **cont**))
+		     (pop **pc**))
+		    (t (setq **clink** **cont**)
+		       (setq **pc** 'jrsticate1)))
+	      (setq **exp** (body **fun**))
+	      (setq **beta** **fun**)
+	      (dispatch))
+	     ((eq (car **fun**) 'epsilon)
+	      (setq **clink** (cadr **fun**))
+	      (pop **pc**)
+	      (setq **val** **one**))
+	     ((eq (car **fun**) 'delta)
+	      (setq **clink** (cadr **fun**))
+	      (pop **beta** **vals** **fluid!vars** **fluid!vals** **pc**)
+	      (setq **val** **one**))
+	     (t (error '|Bad Function - Jrsticate| **fun** 'fail-act))))
+
+(defun jrsticate1 ()
+       (setq **one** **val**)
+       (setq **fun** **clink**)
+       (setq **pc** 'jrsticate)				;must set up pc
+       (jrsticate))					;faster than going through MLOOP
+
+
+(defun gather-evlis ()
+       (cond ((> **nargs** 8.) (reverse **one**))
+	     (t (do ((n 0 (+ 1 n))
+		     (argl nil (cons (symeval (car regl)) argl))
+		     (regl **argument-registers** (cdr regl)))
+		    ((= n **nargs**)
+		     argl)))))
+
+(defun spreadsubrcall ()
+       (cond ((= **nargs** 0)
+	      (subrcall nil (cadr **fun**)))
+	     ((= **nargs** 1)
+	      (subrcall nil (cadr **fun**) **one**))
+	     ((= **nargs** 2)
+	      (subrcall nil (cadr **fun**) **one** **two**))
+	     ((= **nargs** 3)
+	      (subrcall nil (cadr **fun**) **one** **two** **three**))
+	     ((= **nargs** 4)
+	      (subrcall nil (cadr **fun**) **one** **two** **three** **four**))
+	     ((= **nargs** 5)
+	      (subrcall nil (cadr **fun**) **one** **two** **three** **four** **five**))
+	     (t (error '|Too many arguments to a SUBR -- SPREAD|
+		       (list **fun** **nargs**)
+		       'fail-act))))
+
+(defun spreadlsubrcall ()
+       (cond ((= **nargs** 0)
+	      (lsubrcall nil (cadr **fun**)))
+	     ((= **nargs** 1)
+	      (lsubrcall nil (cadr **fun**) **one**))
+	     ((= **nargs** 2)
+	      (lsubrcall nil (cadr **fun**) **one** **two**))
+	     ((= **nargs** 3)
+	      (lsubrcall nil (cadr **fun**) **one** **two** **three**))
+	     ((= **nargs** 4)
+	      (lsubrcall nil (cadr **fun**) **one** **two** **three** **four**))
+	     ((= **nargs** 5)
+	      (lsubrcall nil (cadr **fun**) **one** **two** **three** **four** **five**))
+	     ((= **nargs** 6)
+	      (lsubrcall nil (cadr **fun**) **one** **two** **three** **four**
+		                          **five** **six**))
+	     ((= **nargs** 7)
+	      (lsubrcall nil (cadr **fun**) **one** **two** **three** **four**
+		                          **five** **six** **seven**))
+	     ((= **nargs** 8.)
+	      (lsubrcall nil (cadr **fun**) **one** **two** **three** **four**
+		                          **five** **six** **seven** **eight**))
+	     (t (setplist 'the-lsubr-apply-atom **fun**)
+		(apply 'the-lsubr-apply-atom **one**))))
+
+(defun spreadexprcall ()
+       (cond ((= **nargs** 0)
+	      (funcall nil (cadr **fun**)))
+	     ((= **nargs** 1)
+	      (funcall nil (cadr **fun**) **one**))
+	     ((= **nargs** 2)
+	      (funcall nil (cadr **fun**) **one** **two**))
+	     ((= **nargs** 3)
+	      (funcall nil (cadr **fun**) **one** **two** **three**))
+	     ((= **nargs** 4)
+	      (funcall nil (cadr **fun**) **one** **two** **three** **four**))
+	     ((= **nargs** 5)
+	      (funcall nil (cadr **fun**) **one** **two** **three** **four** **five**))
+	     ((= **nargs** 6)
+	      (funcall nil (cadr **fun**) **one** **two** **three** **four**
+		                          **five** **six**))
+	     ((= **nargs** 7)
+	      (funcall nil (cadr **fun**) **one** **two** **three** **four**
+		                          **five** **six** **seven**))
+	     ((= **nargs** 8.)
+	      (funcall nil (cadr **fun**) **one** **two** **three** **four**
+		                          **five** **six** **seven** **eight**))
+	     (t (apply (cadr **fun**) **one**))))