Artifact 16392cbc34871869fdcf151bea1b876b8e8f287a02ef6bcd63a8754db203ad88:
- Executable file
r38/lisp/csl/cslbase/unbyte.lsp
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 58438) [annotate] [blame] [check-ins using] [more...]
% RLISP to LISP converter. A C Norman 2004-2007 (linelength 72) (de lprim (x) (print x)) (de no!-side!-effectp (u) (cond ((atom u) (or (numberp u) (and (idp u) (not ( or (fluidp u) (globalp u)))))) (t (cond ((eq (car u) (quote quote)) t) (t ( cond ((flagp!*!* (car u) (quote nosideeffects)) (no!-side!-effect!-listp u)) (t nil))))))) (de no!-side!-effect!-listp (u) (or (null u) (and (no!-side!-effectp (car u)) (no!-side!-effect!-listp (cdr u))))) (flag (quote (car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr cons)) (quote nosideeffects)) (de structchk (u) (prog (v) (prog nil lab1000 (progn (setq v (copy u)) (setq u (structchk1 u))) (cond ((null (equal u v)) (go lab1000)))) (return u))) (de structchk1 (u) (prog (x) (cond ((or (atom u) (eq (car u) (quote quote))) (return u)) (t (cond ((and (atom (car u)) (setq x (get (car u) (quote structfn)))) (return (apply x (list u)))) (t (cond ((eq (car u) (quote lambda )) (return (list (quote lambda) (cadr u) (structchk1 (caddr u))))) (t (cond ( (eq (car u) (quote procedure)) (return (list (quote procedure) (cadr u) ( caddr u) (cadddr u) (car (cddddr u)) (structchk1 (cadr (cddddr u)))))) (t ( return (prog (var1002 var1003) (setq var1002 u) lab1001 (cond ((null var1002) (return (reversip var1003)))) (prog (x) (setq x (car var1002)) (setq var1003 (cons (structchk1 x) var1003))) (setq var1002 (cdr var1002)) (go lab1001)))) ))))))))) (put (quote cond) (quote structfn) (quote strcond)) (put (quote rblock) (quote structfn) (quote blockchk)) (put (quote prog) (quote structfn) (quote progchk)) (put (quote progn) (quote structfn) (quote prognchk)) (de strcond (u) (prog nil (setq u (prog (var1005 var1006) (setq var1005 (cdr u)) lab1004 (cond ((null var1005) (return (reversip var1006)))) (prog (x) ( setq x (car var1005)) (setq var1006 (cons (list (car x) (structchk1 (cadr x)) ) var1006))) (setq var1005 (cdr var1005)) (go lab1004))) (cond ((and (equal ( length u) 2) (eqcar (cadar u) (quote cond)) (equal (caadr u) (quote t))) ( setq u (cons (list (mknot (caar u)) (cadadr u)) (cdadar u))))) (return (cons (quote cond) u)))) (de mknot (u) (cond ((and (not (atom u)) (memq (car u) (quote (not null)))) ( cadr u)) (t (list (quote not) u)))) (fluid (quote (flg lablist))) (de addlbl (lbl) (cond ((atsoc lbl lablist) nil) (t (setq lablist (cons (list lbl nil) lablist))))) (de addblock (lst) (rplacd (cdr (atsoc (getlbl (caar lst)) lablist)) (cons ( cdar lst) (cdr lst)))) (de gochk (u) (cond ((or (atom u) (memq (car u) (quote (quote prog)))) nil) ( t (cond ((eq (car u) (quote go)) (updlbl (cadr u) u)) (t (progn (gochk (car u )) (gochk (cdr u)))))))) (de updlbl (lbl exp) (prog (x) (setq x (atsoc lbl lablist)) (cond (x (rplaca (cdr x) (cons exp (cadr x)))) (t (setq lablist (cons (list lbl (list exp)) lablist)))))) (de transferp (u) (cond ((or (atom u) (not (idp (car u)))) nil) (t (cond (( flagp (car u) (quote transfer)) (car u)) (t (cond ((eq (car u) (quote cond)) (condtranp (cdr u))) (t (cond ((memq (car u) (quote (prog2 progn))) ( transferp (car (reverse (cdr u))))) (t nil))))))))) (flag (quote (go return rederr error errach)) (quote transfer)) (de condtranp (u) (cond ((null u) nil) (t (cond ((and (null (cdr u)) (eq ( caar u) t)) (transferp (cadar u))) (t (and (transferp (cadar u)) (condtranp ( cdr u)))))))) (de progchk (u) (blockchk1 u (quote prog))) (de blockchk (u) (blockchk1 u (quote rblock))) (de blockchk1 (u v) (prog (flg lablist laststat vars top x z) (setq vars ( cadr u)) (setq u (cddr u)) (cond ((null u) (lprie "empty block"))) (setq x u) (prog nil lab1007 (cond ((null (cdr x)) (return nil))) (setq x (cdr x)) (go lab1007)) (prog nil lab1008 (cond ((null (and u (not (labelp (car u))))) ( return nil))) (progn (setq top (cons (car u) top)) (gochk (car u)) (setq u ( cdr u))) (go lab1008)) (cond ((null u) (progn (setq top (reversip top)) (go ret))) (t (cond ((or (null top) (not (transferp (car top)))) (progn (setq top (cons (list (quote go) (getlbl (car u))) top)) (gochk (car top))))))) (setq top (reversip top)) (setq top (cons (list nil) (cons nil (cons top (car ( reverse top)))))) (prog nil lab1010 (cond ((null u) (return nil))) (cond (( labelp (car u)) (progn (addlbl (getlbl (car u))) (cond ((or (null laststat) ( transferp laststat)) (progn (setq laststat nil) (setq x (list (car u))) (setq u (cdr u)) (prog nil lab1009 (cond ((null (and u (not (transferp laststat))) ) (return nil))) (progn (cond ((labelp (car u)) (setq u (cons (list (quote go ) (getlbl (car u))) u)))) (gochk (car u)) (setq laststat (car u)) (setq x ( cons (car u) x)) (setq u (cdr u))) (go lab1009)) (addblock (cons (reversip x) laststat)) (setq x nil)))))) (t (rederr (list "unreachable statement" (car u ))))) (go lab1010)) (setq lablist (reversip lablist)) a (setq flg nil) (prog (var1012) (setq var1012 (cons top lablist)) lab1011 (cond ((null var1012) ( return nil))) (prog (x) (setq x (car var1012)) (cond ((and (cdr x) (cddr x) ( eqcar (cdddr x) (quote go))) (condgochk (caddr x) (cdddr x))))) (setq var1012 (cdr var1012)) (go lab1011)) (setq x nil) (prog nil lab1013 (cond ((null lablist) (return nil))) (progn (setq z (length (cadar lablist))) (cond ((or ( equal z 0) (and (equal z 1) (equal (cdddar lablist) (caadar lablist)))) ( lprim (list "unreferenced block at label" (caar lablist)))) (t (cond ((equal z 1) (progn (setq flg t) (lprim (list "label" (caar lablist) "removed")) ( rplacw (caadar lablist) (prognchk1 (caddar lablist))))) (t (setq x (cons (car lablist) x)))))) (setq lablist (cdr lablist))) (go lab1013)) (setq lablist ( reversip x)) (prog (var1015) (setq var1015 lablist) lab1014 (cond ((null var1015) (return nil))) (prog (z) (setq z (car var1015)) (cond ((and (equal ( cdddr z) (caadr z)) (eqcar (caaddr z) (quote cond)) (null (cddr (caaddr z))) (transferp (cadadr (caaddr z))) (notranp (cdaddr z))) (progn (setq flg t) ( rplaca (cdr z) (!&deleq (cdddr z) (cadr z))) (rplaca (cddr z) (list (whilechk (mknull (caadr (caaddr z))) (cdr (reverse (cdaddr z)))) (cadadr (caaddr z))) ) (rplacd (cddr z) nil))))) (setq var1015 (cdr var1015)) (go lab1014)) (cond (flg (prog (var1018) (setq var1018 (cons top lablist)) lab1017 (cond ((null var1018) (return nil))) (prog (y) (setq y (car var1018)) (progn (setq z ( caddr y)) (prog nil lab1016 (cond ((null z) (return nil))) (cond ((eqcar (car z) (quote progn)) (rplacw z (nconc (cdar z) (cdr z)))) (t (setq z (cdr z)))) (go lab1016)) (cond ((and (cdr y) (cddr y) (eqcar (cdddr y) (quote progn))) (rplacd (cddr y) (car (reverse (cdddr y)))))))) (setq var1018 (cdr var1018)) (go lab1017)))) (cond (flg (go a))) (setq top (caddr top)) (setq x top) (prog nil lab1020 (cond ((null x) (return nil))) (progn (prog nil lab1019 (cond (( null (cdr x)) (return nil))) (setq x (cdr x)) (go lab1019)) (cond ((and ( eqcar (car x) (quote go)) (setq z (atsoc (cadar x) lablist))) (progn (rplacw x (cond ((cdadr z) (cons (mklbl (car z)) (caddr z))) (t (progn (lprim (list "label" (caar lablist) "removed")) (caddr z))))) (setq lablist (delete z lablist)))) (t (cond (lablist (progn (rplacd x (cons (mklbl (caar lablist)) ( caddar lablist))) (setq lablist (cdr lablist)))) (t (setq x (cdr x))))))) (go lab1020)) ret (setq top (miscchk (structchk1 top))) (cond ((and (null vars) (eqcar (car top) (quote return))) (return (cadar top))) (t (return (cons v ( cons vars top))))))) (de miscchk (u) (prog (v w) (setq v u) (prog nil lab1021 (cond ((null v) ( return nil))) (cond ((and (eqcar (car v) (quote setq)) (neq (setq w (setqchk (car v) (cdr v))) v)) (rplacw v w)) (t (cond ((and (cdr v) (eqcar (car v) ( quote cond)) (null (cddar v)) (eqcar (cadr (cadar v)) (quote return)) (eqcar (cadr v) (quote return))) (rplacw v (cons (list (quote return) (list (quote cond) (list (caadar v) (cadr (cadr (cadar v)))) (list (quote t) (cadr (cadr v ))))) (cddr v)))) (t (setq v (cdr v)))))) (go lab1021)) (return u))) (de setqchk (u v) (prog (x y z) (setq x (cadr u)) (setq y (caddr u)) (cond (( not (no!-side!-effectp y)) (return (cons u v)))) a (cond ((null v) (return ( cons u (reversip z)))) (t (cond ((and (eqcar (car v) (quote return)) ( used!-oncep x (cadar v))) (progn (lprim (list "assignment for" x "removed")) (return (nconc (reversip z) (cons (substq x y (car v)) (cdr v)))))) (t (cond ((not (smemq x (car v))) (progn (setq z (cons (car v) z)) (setq v (cdr v)) ( go a))) (t (return (cons u (nconc (reversip z) v))))))))))) (de used!-oncep (u v) (cond ((atom v) t) (t (cond ((eq (car v) (quote quote)) t) (t (cond ((eq u (car v)) (not (smemq u (cdr v)))) (t (used!-oncep u (cdr v))))))))) (de substq (u v w) (cond ((atom w) (cond ((eq u w) v) (t w))) (t (cond ((eq ( car w) (quote quote)) w) (t (cond ((eq u (car w)) (cons v (cdr w))) (t (cond ((not (atom (car w))) (cons (substq u v (car w)) (substq u v (cdr w)))) (t ( cons (car w) (substq u v (cdr w)))))))))))) (de labelp (u) (or (atom u) (eq (car u) (quote !*label)))) (de getlbl (u) (cond ((atom u) u) (t (cadr u)))) (de mklbl (u) (list (quote !*label) u)) (de notranp (u) (null (smemqlp (quote (go return)) (cdr (reverse u))))) (de !&deleq (u v) (cond ((null v) nil) (t (cond ((eq u (car v)) (cdr v)) (t ( cons (car v) (!&deleq u (cdr v)))))))) (de prognchk (u) (prognchk1 (cdr u))) (de prognchk1 (u) (cond ((or (null (cdr u)) (null (cdr (setq u (miscchk u)))) ) (car u)) (t (cons (quote progn) u)))) (de mknull (u) (cond ((and (not (atom u)) (memq (car u) (quote (null not)))) (cadr u)) (t (list (quote null) u)))) (de condgochk (u v) (cond ((null u) nil) (t (progn (condgochk (cdr u) v) ( cond ((eqcar (car u) (quote cond)) (cgchk1 (cdar u) u v))))))) (de cgchk1 (u v w) (cond ((null u) nil) (t (cond ((not (transferp (cadar u))) nil) (t (prog (x y z) (cgchk1 (cdr u) v w) (setq x (cadar u)) (cond ((or ( equal x w) (and (eqcar x (quote progn)) (equal (setq x (car (reverse x))) w) (setq y (reverse (cdr (reverse (cdadar u))))))) (progn (setq flg t) (setq z ( atsoc (cadr w) lablist)) (rplaca (cdr z) (!&deleq x (cadr z))) (rplaca (car u ) (mknull (caar u))) (setq z (reverse (cdr (reverse (cdr v))))) (cond ((cdr u ) (progn (setq z (cons (cons (quote cond) (cdr u)) z)) (rplacd u nil)))) ( cond (y (rplacd u (list (list t (prognchk1 y)))))) (rplaca (cdar u) ( prognchk1 z)) (rplacd v (list w)))) (t nil)))))))) (de mapox (u) (mapsox u (quote on) (quote do))) (de mapcox (u) (mapsox u (quote in) (quote do))) (de maplistox (u) (mapsox u (quote on) (quote collect))) (de mapcarox (u) (mapsox u (quote in) (quote collect))) (de mapconox (u) (mapsox u (quote on) (quote conc))) (de mapcanox (u) (mapsox u (quote in) (quote conc))) (de mapsox (u v w) (prog (x y z) (setq x (cadr u)) (setq y (caddr u)) (cond ( (not (eqcar y (quote function))) (rederr (list "syntax error in map expression" u)))) (setq y (cadr y)) (cond ((atom y) ( progn (setq z (quote x)) (setq y (list y z)))) (t (cond ((or (not (eq (car y) (quote lambda))) (null (cadr y)) (cdadr y)) (rederr (list "syntax error in map expression" u))) (t (progn (setq z (caadr y)) (setq y ( caddr y))))))) (return (list (quote foreach) z v x w y)))) (put (quote map) (quote structfn) (quote mapox)) (put (quote mapc) (quote structfn) (quote mapcox)) (put (quote maplist) (quote structfn) (quote maplistox)) (put (quote mapcar) (quote structfn) (quote mapcarox)) (put (quote mapcan) (quote structfn) (quote mapcanox)) (put (quote mapcon) (quote structfn) (quote mapconox)) (de whilechk (u v) (prog (w) (return (cond ((and (idp u) (equal (car v) (list (quote setq) u (list (quote cdr) u))) (not (eq (setq w (caronly u (cdr v) ( quote j))) (quote !*failed!*)))) (list (quote progn) (list (quote foreach) ( quote j) (quote in) u (quote do) (prognchk1 (reversip w))) (list (quote setq) u nil))) (t (list (quote while) u (prognchk1 (reversip v)))))))) (de caronly (u v w) (prog (x) (return (cond ((not (smemq u v)) v) (t (cond (( atom v) (cond ((eq u v) (quote !*failed!*)) (t v))) (t (cond ((or (not (idp ( car v))) (not (and (eqcar (cdr v) u) (cdr v) (null (cddr v)) (setq x (get ( car v) (quote carfn)))))) (cmerge (caronly u (car v) w) (caronly u (cdr v) w) )) (t (cond ((eq (car v) (quote car)) w) (t (list x w)))))))))))) (deflist (quote ((car t) (caar car) (cdar cdr) (caaar caar) (cadar cadr) ( cdaar cdar) (cddar cddr) (caaaar caaar) (caadar caadr) (cadaar cadar) (caddar caddr) (cdaaar cdaar) (cdadar cdadr) (cddaar cddar) (cdddar cdddr))) (quote carfn)) (de cmerge (u v) (cond ((or (eq u (quote !*failed!*)) (eq v (quote !*failed!* ))) (quote !*failed!*)) (t (cons u v)))) (fluid (quote (all_jumps))) (fluid (quote (!@a !@b !@w !@stack !@catch))) (global (quote (opnames))) (de unbyte (name) (prog (pc code len env byte r entry_stack w w1 w2 args nargs stack deepest locals all_jumps !@a !@b !@w !@stack !@catch) (setq !@a ( gensym)) (setq !@b (gensym)) (setq !@w (gensym)) (setq !@stack (gensym)) ( setq code (symbol!-env name)) (setq nargs (symbol!-argcount name)) (cond ((or (atom code) (not (bpsp (car code)))) (return nil))) (setq env (cdr code)) ( setq code (car code)) (setq len (bps!-upbv code)) (cond ((fixp nargs) (progn (setq entry_stack nargs) (cond ((lessp nargs 4) (setq pc 0)) (t (setq pc 1))) )) (t (progn (setq entry_stack (cadr nargs)) (cond ((neq (logand (caddr nargs ) 2) 0) (setq entry_stack (plus entry_stack 1)))) (setq pc 2)))) (setq r nil) (setq all_jumps (list nil pc)) (prog nil lab1022 (cond ((null (leq pc len)) (return nil))) (progn (setq byte (bps!-getv code pc)) (setq w (funcall (getv opnames byte) (plus pc 1) code env)) (cond (r (setq w1 (caddr (car r)))) (t ( setq w1 nil))) (cond ((eqcar w1 (quote if)) (setq r (cons (cons pc (cons ( cadr (cadddr w1)) (cdr w))) r))) (t (setq r (cons (cons pc (cons nil (cdr w)) ) r)))) (setq pc (plus pc (car w)))) (go lab1022)) (prog nil lab1023 (cond (( null all_jumps) (return nil))) (progn (setq w (assoc (cadr all_jumps) r)) ( cond ((null w) (error 1 "Branch destination not found"))) (cond ((null (cadr w)) (rplaca (cdr w) (gensym)))) (rplaca (cdr all_jumps) (cadr w)) (setq w ( car all_jumps)) (rplaca all_jumps (quote go)) (setq all_jumps w)) (go lab1023 )) (setq w nil) (prog nil lab1026 (cond ((null r) (return nil))) (progn (setq w1 (cddar r)) (setq w2 w1) (prog nil lab1024 (cond ((null (cdr w2)) (return nil))) (setq w2 (cdr w2)) (go lab1024)) (setq w2 (car w2)) (cond ((and w (not (or (eqcar w2 (quote if)) (eqcar w2 (quote go)) (eqcar w2 (quote return)) ( eqcar w2 (quote throw))))) (progn (setq w1 (append w1 (list (list (quote go) (caar w)))))))) (prog nil lab1025 (cond ((null (null (cadar r))) (return nil) )) (progn (setq r (cdr r)) (setq w1 (append (cddar r) w1))) (go lab1025)) ( setq w (cons (cons (cadar r) (cons nil w1)) w)) (setq r (cdr r))) (go lab1026 )) (rplaca (cdar w) (list nil)) (setq r (list (caar w))) (prog nil lab1029 ( cond ((null r) (return nil))) (prog (n) (setq w1 (assoc (car r) w)) (setq r ( cdr r)) (setq n (caadr w1)) (prog (var1028) (setq var1028 (cddr w1)) lab1027 (cond ((null var1028) (return nil))) (prog (z) (setq z (car var1028)) (progn (cond ((eqcar z (quote freebind)) (setq n (cons (cadr z) n))) (t (cond (( eqcar z (quote freerstr)) (progn (rplaca (cdr z) (car n)) (setq n (cdr n)))) (t (cond ((eqcar z (quote if)) (progn (setq r (set_bind (assoc (cadr (caddr z )) w) r n)) (setq r (set_bind (assoc (cadr (cadddr z)) w) r n)))) (t (cond (( eqcar z (quote go)) (setq r (set_bind (assoc (cadr z) w) r n)))))))))))) ( setq var1028 (cdr var1028)) (go lab1027))) (go lab1029)) (prog (var1031) ( setq var1031 w) lab1030 (cond ((null var1031) (return nil))) (prog (z) (setq z (car var1031)) (rplaca (cdr z) nil)) (setq var1031 (cdr var1031)) (go lab1030)) (rplaca (cdar w) entry_stack) (setq deepest entry_stack) (setq r ( list (caar w))) (prog nil lab1034 (cond ((null r) (return nil))) (prog (n) ( setq w1 (assoc (car r) w)) (cond ((null w1) (progn (prin (car r)) (princ " not found in ") (print w) (error 1 r)))) (setq r (cdr r)) (setq n (cadr w1) ) (cond ((greaterp n deepest) (setq deepest n))) (prog (var1033) (setq var1033 (cddr w1)) lab1032 (cond ((null var1033) (return nil))) (prog (z) ( setq z (car var1033)) (progn (cond ((equal z (quote push)) (setq n (plus n 1) )) (t (cond ((equal z (quote lose)) (setq n (difference n 1))) (t (cond (( eqcar z (quote freebind)) (setq n (plus n 2 (length (cadr z))))) (t (cond (( equal z (quote pvbind)) (setq n (plus n 2))) (t (cond ((eqcar z (quote freerstr)) (setq n (difference (difference n 2) (length (cadr z))))) (t (cond ((equal z (quote pvrestore)) (setq n (difference n 2))) (t (cond ((or (equal z (quote uncatch)) (equal z (quote unprotect))) (setq n (difference n 3))) ( t (cond ((eqcar z (quote if)) (progn (cond ((eqcar (cadr z) !@catch) (progn ( setq n (plus n 3)) (rplaca z (quote ifcatch))))) (setq r (set_stack (assoc ( cadr (caddr z)) w) r n)) (setq r (set_stack (assoc (cadr (cadddr z)) w) r n)) )) (t (cond ((eqcar z (quote go)) (setq r (set_stack (assoc (cadr z) w) r n)) )))))))))))))))))) (cond ((lessp n entry_stack) (error 1 "Too many POPs in the codestream")) (t (cond ((greaterp n deepest) (setq deepest n))))))) (setq var1033 (cdr var1033)) (go lab1032))) (go lab1034)) ( setq args (setq stack (setq locals nil))) (cond ((fixp nargs) (progn (prog (i ) (setq i 1) lab1035 (cond ((minusp (times 1 (difference nargs i))) (return nil))) (setq stack (cons (gensym) stack)) (setq i (plus i 1)) (go lab1035)) ( setq args (reverse stack)))) (t (progn (prog (i) (setq i 1) lab1036 (cond (( minusp (times 1 (difference (car nargs) i))) (return nil))) (setq stack (cons (gensym) stack)) (setq i (plus i 1)) (go lab1036)) (setq args stack) (cond ( (not (equal (cadr nargs) (car nargs))) (progn (setq args (cons (quote !&optional) args)) (prog (i) (setq i (plus (car nargs) 1)) lab1037 (cond (( minusp (times 1 (difference (cadr nargs) i))) (return nil))) (progn (setq w1 (gensym)) (setq stack (cons w1 stack)) (cond ((equal (logand (caddr nargs) 1) 0) (setq args (cons w1 args))) (t (setq args (cons (list w1 (quote (quote !*spid!*))) args))))) (setq i (plus i 1)) (go lab1037)) (cond ((neq (logand ( caddr nargs) 2) 0) (progn (setq w1 (gensym)) (setq stack (cons w1 stack)) ( setq args (cons w1 (cons (quote !&rest) args))))))))) (setq args (reverse args))))) (setq locals (list !@a !@b !@w)) (prog (i) (setq i (plus 1 (length stack))) lab1038 (cond ((minusp (times 1 (difference deepest i))) (return nil ))) (setq locals (cons (gensym) locals)) (setq i (plus i 1)) (go lab1038)) ( prog (var1042) (setq var1042 w) lab1041 (cond ((null var1042) (return nil))) (prog (b) (setq b (car var1042)) (prog (m z1) (setq m (cadr b)) (cond ((not ( fixp m)) (error 1 "Unreferenced code block"))) (prog (var1040) (setq var1040 (cddr b)) lab1039 (cond ((null var1040) (return nil))) (prog (z) (setq z (car var1040)) (progn (cond ((equal z (quote push)) (setq m (plus m 1))) (t (cond ((equal z (quote lose)) (setq m (difference m 1))) (t (cond ((eqcar z (quote freebind)) (setq m (plus m 2 (length (cadr z))))) (t (cond ((equal z (quote pvbind)) (setq m (plus m 2))) (t (cond ((eqcar z (quote freerstr)) (setq m ( difference (difference m 2) (length (cadr z))))) (t (cond ((equal z (quote pvrestore)) (setq m (difference m 2))) (t (cond ((or (equal z (quote uncatch) ) (equal z (quote unprotect))) (setq m (difference m 3))) (t (progn (setq z1 (stackref z m stack locals entry_stack)) (rplaca z (car z1)) (rplacd z (cdr z1))))))))))))))))))) (setq var1040 (cdr var1040)) (go lab1039)))) (setq var1042 (cdr var1042)) (go lab1041)) (setq w (fix_free_bindings w)) (setq w ( optimise_blocks w stack locals)) (setq r (cons (quote prog) (cons locals ( flowgraph_to_lisp w)))) (terpri) (princ "=> ") (prettyprint r) (setq w ( errorset (list (quote structchk) (mkquote r)) t t)) (cond ((not (atom w)) ( setq r (car w)))) (setq r (list (quote de) name args r)) (terpri) (princ "Finally: ") (prettyprint r) (return nil))) (de flowgraph_to_lisp (w) (prog (r) (prog (var1046) (setq var1046 w) lab1045 (cond ((null var1046) (return nil))) (prog (i) (setq i (car var1046)) (progn (setq r (cons (car i) r)) (prog (var1044) (setq var1044 (cddr i)) lab1043 ( cond ((null var1044) (return nil))) (prog (j) (setq j (car var1044)) (progn ( cond ((eqcar j (quote prog)) (setq r (cons (cons (quote prog) (cons (cadr j) (flowgraph_to_lisp (cddr j)))) r))) (t (cond ((eqcar j (quote if)) (setq r ( cons (list (quote cond) (list (cadr j) (caddr j)) (list (quote t) (cadddr j)) ) r))) (t (cond ((or (eqcar j (quote freerstr)) (eqcar j (quote progexits))) nil) (t (cond ((not (member j (quote (push lose)))) (setq r (cons j r)))))))) )))) (setq var1044 (cdr var1044)) (go lab1043)))) (setq var1046 (cdr var1046) ) (go lab1045)) (return (reversip r)))) (de set_stack (block r n) (cond ((null (cadr block)) (progn (rplaca (cdr block) n) (cons (car block) r))) (t (cond ((not (equal (cadr block) n)) ( progn (printc "++++ Stack confusion") (prin n) (princ " vs. ") (print block) r)) (t r))))) (de set_bind (block r n) (cond ((null (cadr block)) (progn (rplaca (cdr block ) (list n)) (cons (car block) r))) (t (cond ((not (equal (caadr block) n)) ( progn (printc "++++ Binding confusion") (prin n) (princ " vs. ") (print block ) r)) (t r))))) (de stackref (u m stack locals entry_stack) (cond ((or (atom u) (eqcar u ( quote quote))) u) (t (cond ((eqcar u !@stack) (prog (n x) (setq n (cadr u)) ( setq x (plus (difference n m) entry_stack)) (cond ((geq x 0) (progn (cond (( geq x entry_stack) (error 1 "Reference outside stack-frame"))) (prog (i) ( setq i 1) lab1047 (cond ((minusp (times 1 (difference x i))) (return nil))) ( setq stack (cdr stack)) (setq i (plus i 1)) (go lab1047)) (return (car stack) ))) (t (progn (prog (i) (setq i 1) lab1048 (cond ((minusp (times 1 ( difference (minus (plus x 1)) i))) (return nil))) (setq locals (cdr locals)) (setq i (plus i 1)) (go lab1048)) (return (car locals))))))) (t (prog ( var1050 var1051) (setq var1050 u) lab1049 (cond ((null var1050) (return ( reversip var1051)))) (prog (x) (setq x (car var1050)) (setq var1051 (cons ( stackref x m stack locals entry_stack) var1051))) (setq var1050 (cdr var1050) ) (go lab1049))))))) (setq opnames (mkvect 255)) (setq s!:opcodelist (quote (LOADLOC LOADLOC0 LOADLOC1 LOADLOC2 LOADLOC3 LOADLOC4 LOADLOC5 LOADLOC6 LOADLOC7 LOADLOC8 LOADLOC9 LOADLOC10 LOADLOC11 LOC0LOC1 LOC1LOC2 LOC2LOC3 LOC1LOC0 LOC2LOC1 LOC3LOC2 VNIL LOADLIT LOADLIT1 LOADLIT2 LOADLIT3 LOADLIT4 LOADLIT5 LOADLIT6 LOADLIT7 LOADFREE LOADFREE1 LOADFREE2 LOADFREE3 LOADFREE4 STORELOC STORELOC0 STORELOC1 STORELOC2 STORELOC3 STORELOC4 STORELOC5 STORELOC6 STORELOC7 STOREFREE STOREFREE1 STOREFREE2 STOREFREE3 LOADLEX STORELEX CLOSURE CARLOC0 CARLOC1 CARLOC2 CARLOC3 CARLOC4 CARLOC5 CARLOC6 CARLOC7 CARLOC8 CARLOC9 CARLOC10 CARLOC11 CDRLOC0 CDRLOC1 CDRLOC2 CDRLOC3 CDRLOC4 CDRLOC5 CAARLOC0 CAARLOC1 CAARLOC2 CAARLOC3 CALL0 CALL1 CALL2 CALL2R CALL3 CALLN CALL0_0 CALL0_1 CALL0_2 CALL0_3 CALL1_0 CALL1_1 CALL1_2 CALL1_3 CALL1_4 CALL1_5 CALL2_0 CALL2_1 CALL2_2 CALL2_3 CALL2_4 BUILTIN0 BUILTIN1 BUILTIN2 BUILTIN2R BUILTIN3 APPLY1 APPLY2 APPLY3 APPLY4 JCALL JCALLN JUMP JUMP_B JUMP_L JUMP_BL JUMPNIL JUMPNIL_B JUMPNIL_L JUMPNIL_BL JUMPT JUMPT_B JUMPT_L JUMPT_BL JUMPATOM JUMPATOM_B JUMPATOM_L JUMPATOM_BL JUMPNATOM JUMPNATOM_B JUMPNATOM_L JUMPNATOM_BL JUMPEQ JUMPEQ_B JUMPEQ_L JUMPEQ_BL JUMPNE JUMPNE_B JUMPNE_L JUMPNE_BL JUMPEQUAL JUMPEQUAL_B JUMPEQUAL_L JUMPEQUAL_BL JUMPNEQUAL JUMPNEQUAL_B JUMPNEQUAL_L JUMPNEQUAL_BL JUMPL0NIL JUMPL0T JUMPL1NIL JUMPL1T JUMPL2NIL JUMPL2T JUMPL3NIL JUMPL3T JUMPL4NIL JUMPL4T JUMPST0NIL JUMPST0T JUMPST1NIL JUMPST1T JUMPST2NIL JUMPST2T JUMPL0ATOM JUMPL0NATOM JUMPL1ATOM JUMPL1NATOM JUMPL2ATOM JUMPL2NATOM JUMPL3ATOM JUMPL3NATOM JUMPFREE1NIL JUMPFREE1T JUMPFREE2NIL JUMPFREE2T JUMPFREE3NIL JUMPFREE3T JUMPFREE4NIL JUMPFREE4T JUMPFREENIL JUMPFREET JUMPLIT1EQ JUMPLIT1NE JUMPLIT2EQ JUMPLIT2NE JUMPLIT3EQ JUMPLIT3NE JUMPLIT4EQ JUMPLIT4NE JUMPLITEQ JUMPLITNE JUMPB1NIL JUMPB1T JUMPB2NIL JUMPB2T JUMPFLAGP JUMPNFLAGP JUMPEQCAR JUMPNEQCAR CATCH CATCH_B CATCH_L CATCH_BL UNCATCH THROW PROTECT UNPROTECT PVBIND PVRESTORE FREEBIND FREERSTR EXIT NILEXIT LOC0EXIT LOC1EXIT LOC2EXIT PUSH PUSHNIL PUSHNIL2 PUSHNIL3 PUSHNILS POP LOSE LOSE2 LOSE3 LOSES SWOP EQ EQCAR EQUAL NUMBERP CAR CDR CAAR CADR CDAR CDDR CONS NCONS XCONS ACONS LENGTH LIST2 LIST2STAR LIST3 PLUS2 ADD1 DIFFERENCE SUB1 TIMES2 GREATERP LESSP FLAGP GET LITGET GETV QGETV QGETVN BIGSTACK BIGCALL ICASE FASTGET SPARE1 SPARE2))) (cond ((demo!-mode) (progn (setq p s!:opcodelist) (prog (j) (setq j 0) lab1053 (cond ((minusp (times 1 (difference 254 j))) (return nil))) (progn ( setq n (random!-number (difference 256 j))) (setq q p) (prog (k) (setq k 1) lab1052 (cond ((minusp (times 1 (difference n k))) (return nil))) (setq q ( cdr q)) (setq k (plus k 1)) (go lab1052)) (setq w (car p)) (rplaca p (car q)) (rplaca q w) (setq p (cdr p))) (setq j (plus j 1)) (go lab1053))))) (prog (w) (setq w s!:opcodelist) (prog (i) (setq i 0) lab1054 (cond ((minusp (times 1 (difference 255 i))) (return nil))) (progn (putv opnames i (compress (cons (quote h) (cons (quote !!) (cons (quote !:) (explode (car w))))))) ( setq w (cdr w))) (setq i (plus i 1)) (go lab1054))) (global (quote (builtin0 builtin1 builtin2 builtin3))) (setq builtin0 (mkvect 255)) (setq builtin1 (mkvect 255)) (setq builtin2 (mkvect 255)) (setq builtin3 (mkvect 255)) (prog (var1056) (setq var1056 (oblist)) lab1055 (cond ((null var1056) (return nil))) (prog (x) (setq x (car var1056)) (prog (w) (cond ((setq w (get x ( quote s!:builtin0))) (putv builtin0 w x)) (t (cond ((setq w (get x (quote s!:builtin1))) (putv builtin1 w x)) (t (cond ((setq w (get x (quote s!:builtin2))) (putv builtin2 w x)) (t (cond ((setq w (get x (quote s!:builtin3))) (putv builtin3 w x))))))))))) (setq var1056 (cdr var1056)) (go lab1055)) (off echo) (de byte1 nil (bps!-getv code pc)) (de byte2 nil (bps!-getv code (plus pc 1))) (de twobytes nil (plus (times 256 (byte1)) (byte2))) (de makeif (why loc) (list (quote if) why loc (list (quote go) (gensym)))) (de jumpto (x) (setq all_jumps (list all_jumps x))) (de jumpop (why) (list 2 (makeif why (jumpto (plus pc (byte1) 1))))) (de jumpopb (why) (list 2 (makeif why (jumpto (plus (difference pc (byte1)) 1 ))))) (de jumpopl (why) (list 3 (makeif why (jumpto (plus pc (twobytes) 1))))) (de jumpopbl (why) (list 3 (makeif why (jumpto (plus (difference pc (twobytes )) 1))))) (progn (de h!:LOADLOC (pc code env) (list 2 (list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack (byte1))))) (de h!:LOADLOC0 (pc code env) ( list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 0)))) (de h!:LOADLOC1 (pc code env) (list 1 (list (quote setq) !@b !@a) (list ( quote setq) !@a (list !@stack 1)))) (de h!:LOADLOC2 (pc code env) (list 1 ( list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 2)))) (de h!:LOADLOC3 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 3)))) (de h!:LOADLOC4 (pc code env) (list 1 (list ( quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 4)))) (de h!:LOADLOC5 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 5)))) (de h!:LOADLOC6 (pc code env) (list 1 (list ( quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 6)))) (de h!:LOADLOC7 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 7)))) (de h!:LOADLOC8 (pc code env) (list 1 (list ( quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 8)))) (de h!:LOADLOC9 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 9)))) (de h!:LOADLOC10 (pc code env) (list 1 (list ( quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 10)))) (de h!:LOADLOC11 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 11)))) (de h!:LOC0LOC1 (pc code env) (list 1 (list ( quote setq) !@b (list !@stack 0)) (list (quote setq) !@a (list !@stack 1)))) (de h!:LOC1LOC2 (pc code env) (list 1 (list (quote setq) !@b (list !@stack 1) ) (list (quote setq) !@a (list !@stack 2)))) (de h!:LOC2LOC3 (pc code env) ( list 1 (list (quote setq) !@b (list !@stack 2)) (list (quote setq) !@a (list !@stack 3)))) (de h!:LOC1LOC0 (pc code env) (list 1 (list (quote setq) !@b ( list !@stack 1)) (list (quote setq) !@a (list !@stack 1)))) (de h!:LOC2LOC1 ( pc code env) (list 1 (list (quote setq) !@b (list !@stack 2)) (list (quote setq) !@a (list !@stack 1)))) (de h!:LOC3LOC2 (pc code env) (list 1 (list ( quote setq) !@b (list !@stack 3)) (list (quote setq) !@a (list !@stack 2)))) (de h!:VNIL (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a nil))) (de freeref (env n) (cond ((or (lessp n 0) (greaterp n (upbv env))) (error 1 "free variable (etc) reference failure")) (t (getv env n)))) (de litref (env n) (cond ((or (lessp n 0) (greaterp n (upbv env))) (error 1 "literal reference failure")) (t (mkquote (getv env n))))) (de h!:LOADLIT (pc code env) (list 2 (list (quote setq) !@b !@a) (list (quote setq) !@a (litref env (byte1))))) (de h!:LOADLIT1 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (litref env 1)))) (de h!:LOADLIT2 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (litref env 2)))) (de h!:LOADLIT3 (pc code env) (list 1 (list (quote setq) !@b !@a) (list ( quote setq) !@a (litref env 3)))) (de h!:LOADLIT4 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (litref env 4)))) (de h!:LOADLIT5 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (litref env 5)))) (de h!:LOADLIT6 (pc code env) (list 1 (list ( quote setq) !@b !@a) (list (quote setq) !@a (litref env 6)))) (de h!:LOADLIT7 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a ( litref env 7)))) (de h!:LOADFREE (pc code env) (list 2 (list (quote setq) !@b !@a) (list (quote setq) !@a (freeref env (byte1))))) (de h!:LOADFREE1 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (freeref env 1)))) (de h!:LOADFREE2 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (freeref env 2)))) (de h!:LOADFREE3 (pc code env) ( list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (freeref env 3)))) (de h!:LOADFREE4 (pc code env) (list 1 (list (quote setq) !@b !@a) (list ( quote setq) !@a (freeref env 4)))) (de h!:STORELOC (pc code env) (list 2 ( list (quote setq) (list !@stack (byte1)) !@a))) (de h!:STORELOC0 (pc code env ) (list 1 (list (quote setq) (list !@stack 0) !@a))) (de h!:STORELOC1 (pc code env) (list 1 (list (quote setq) (list !@stack 1) !@a))) (de h!:STORELOC2 (pc code env) (list 1 (list (quote setq) (list !@stack 2) !@a))) (de h!:STORELOC3 (pc code env) (list 1 (list (quote setq) (list !@stack 3) !@a))) (de h!:STORELOC4 (pc code env) (list 1 (list (quote setq) (list !@stack 4) !@a))) (de h!:STORELOC5 (pc code env) (list 1 (list (quote setq) (list !@stack 5) !@a))) (de h!:STORELOC6 (pc code env) (list 1 (list (quote setq) ( list !@stack 6) !@a))) (de h!:STORELOC7 (pc code env) (list 1 (list (quote setq) (list !@stack 7) !@a))) (de h!:STOREFREE (pc code env) (list 2 (list ( quote setq) (freeref env (byte1)) !@a))) (de h!:STOREFREE1 (pc code env) ( list 1 (list (quote setq) (freeref env 1) !@a))) (de h!:STOREFREE2 (pc code env) (list 1 (list (quote setq) (freeref env 2) !@a))) (de h!:STOREFREE3 (pc code env) (list 1 (list (quote setq) (freeref env 3) !@a))) (de h!:LOADLEX ( pc code env) (prog nil (error 1 "loadlex") (return (list 3 (quote loadlex)))) ) (de h!:STORELEX (pc code env) (prog nil (error 1 "storelex") (return (list 3 (quote storelex))))) (de h!:CLOSURE (pc code env) (prog nil (error 1 "closure") (return (list 2 (quote closure))))) (de h!:CARLOC0 (pc code env) ( list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) ( list !@stack 0))))) (de h!:CARLOC1 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 1))))) (de h!:CARLOC2 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 2))))) (de h!:CARLOC3 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 3))))) (de h!:CARLOC4 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 4))))) (de h!:CARLOC5 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 5))))) (de h!:CARLOC6 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 6))))) (de h!:CARLOC7 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 7))))) (de h!:CARLOC8 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 8))))) (de h!:CARLOC9 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 9))))) (de h!:CARLOC10 (pc code env) (list 1 (list (quote setq ) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 10))))) (de h!:CARLOC11 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 11))))) (de h!:CDRLOC0 (pc code env ) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote cdr ) (list !@stack 0))))) (de h!:CDRLOC1 (pc code env) (list 1 (list (quote setq ) !@b !@a) (list (quote setq) !@a (list (quote cdr) (list !@stack 1))))) (de h!:CDRLOC2 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote cdr) (list !@stack 2))))) (de h!:CDRLOC3 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote cdr) (list !@stack 3))))) (de h!:CDRLOC4 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote cdr) (list !@stack 4))))) (de h!:CDRLOC5 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote cdr) (list !@stack 5))))) (de h!:CAARLOC0 (pc code env ) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote caar) (list !@stack 0))))) (de h!:CAARLOC1 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote caar) (list !@stack 1)))) ) (de h!:CAARLOC2 (pc code env) (list 1 (list (quote setq) !@b !@a) (list ( quote setq) !@a (list (quote caar) (list !@stack 2))))) (de h!:CAARLOC3 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list ( quote car) (list !@stack 3))))) (de h!:CALL0 (pc code env) (list 2 (list ( quote setq) !@b !@a) (list (quote setq) !@a (list (freeref env (byte1)))))) ( de h!:CALL1 (pc code env) (list 2 (list (quote setq) !@a (list (freeref env ( byte1)) !@a)))) (de h!:CALL2 (pc code env) (list 2 (list (quote setq) !@a ( list (freeref env (byte1)) !@b !@a)))) (de h!:CALL2R (pc code env) (list 2 ( list (quote setq) !@a (list (freeref env (byte1)) !@a !@b)))) (de h!:CALL3 ( pc code env) (list 2 (list (quote setq) !@a (expand_call 3 (freeref env ( byte1)))) (quote lose))) (de h!:CALLN (pc code env) (prog (n w) (setq n ( byte1)) (prog (i) (setq i 1) lab1057 (cond ((minusp (times 1 (difference ( difference n 2) i))) (return nil))) (setq w (cons (quote lose) w)) (setq i ( plus i 1)) (go lab1057)) (return (list!* 3 (list (quote setq) !@a ( expand_call n (freeref env (byte2)))) w)))) (de h!:CALL0_0 (pc code env) ( list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (freeref env 0))))) (de h!:CALL0_1 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (freeref env 1))))) (de h!:CALL0_2 (pc code env) ( list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (freeref env 2))))) (de h!:CALL0_3 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (freeref env 3))))) (de h!:CALL1_0 (pc code env) ( list 1 (list (quote setq) !@a (list (freeref env 0) !@a)))) (de h!:CALL1_1 ( pc code env) (list 1 (list (quote setq) !@a (list (freeref env 1) !@a)))) (de h!:CALL1_2 (pc code env) (list 1 (list (quote setq) !@a (list (freeref env 2 ) !@a)))) (de h!:CALL1_3 (pc code env) (list 1 (list (quote setq) !@a (list ( freeref env 3) !@a)))) (de h!:CALL1_4 (pc code env) (list 1 (list (quote setq ) !@a (list (freeref env 4) !@a)))) (de h!:CALL1_5 (pc code env) (list 1 ( list (quote setq) !@a (list (freeref env 5) !@a)))) (de h!:CALL2_0 (pc code env) (list 1 (list (quote setq) !@a (list (freeref env 0) !@b !@a)))) (de h!:CALL2_1 (pc code env) (list 1 (list (quote setq) !@a (list (freeref env 1) !@b !@a)))) (de h!:CALL2_2 (pc code env) (list 1 (list (quote setq) !@a ( list (freeref env 2) !@b !@a)))) (de h!:CALL2_3 (pc code env) (list 1 (list ( quote setq) !@a (list (freeref env 3) !@b !@a)))) (de h!:CALL2_4 (pc code env ) (list 1 (list (quote setq) !@a (list (freeref env 4) !@b !@a)))) (de h!:BUILTIN0 (pc code env) (prog (w) (setq w (getv builtin0 (byte1))) (cond (( null w) (error 1 "Invalid builtin-function specifier"))) (return (list 2 ( list (quote setq) !@a (list w)))))) (de h!:BUILTIN1 (pc code env) (prog (w) ( setq w (getv builtin1 (byte1))) (cond ((null w) (error 1 "Invalid builtin-function specifier"))) (return (list 2 (list (quote setq) !@a (list w !@a)))))) (de h!:BUILTIN2 (pc code env) (prog (w) (setq w (getv builtin2 (byte1))) (cond ((null w) (error 1 "Invalid builtin-function specifier"))) (return (list 2 (list (quote setq) !@a (list w !@b !@a)))))) (de h!:BUILTIN2R (pc code env) (prog (w) (setq w ( getv builtin2 (byte1))) (cond ((null w) (error 1 "Invalid builtin-function specifier"))) (return (list 2 (list (quote setq) !@a (list w !@a !@b)))))) (de h!:BUILTIN3 (pc code env) (prog (w) (setq w ( getv builtin3 (byte1))) (cond ((null w) (error 1 "Invalid builtin-function specifier"))) (return (list 2 (list (quote setq) !@a (expand_call 3 w)) (quote lose))))) (de h!:APPLY1 (pc code env) (list 1 ( list (quote setq) !@a (list (quote apply) !@b !@a)))) (de h!:APPLY2 (pc code env) (list 1 (list (quote setq) !@a (list (quote apply) (list !@stack 0) !@b !@a)) (quote lose))) (de h!:APPLY3 (pc code env) (list 1 (list (quote setq) !@a (list (quote apply) (list !@stack 0) (list !@stack 1) !@b !@a)) (quote lose) (quote lose))) (de h!:APPLY4 (pc code env) (list 1 (list (quote setq) !@a (list (quote apply) (list !@stack 0) (list !@stack 1) (list !@stack 2) !@b !@a)) (quote lose) (quote lose) (quote lose))) (de h!:JCALL (pc code env) (prog (nargs dest) (setq nargs (byte1)) (setq dest (freeref env (logand nargs 31))) (setq nargs (irightshift nargs 5)) (return (list 2 (expand_jcall nargs dest))))) (de h!:JCALLN (pc code env) (list 3 (expand_jcall (byte2) ( freeref env (byte1))))) (de expand_jcall (nargs dest) (list (quote return) ( expand_call nargs dest))) (de expand_call (nargs dest) (cond ((equal nargs 0) (list dest)) (t (cond ((equal nargs 1) (list dest !@a)) (t (cond ((equal nargs 2) (list dest !@b !@a)) (t (prog (w) (setq w (list !@b !@a)) (prog (i) (setq i 1) lab1058 (cond ((minusp (times 1 (difference (difference nargs 2) i ))) (return nil))) (setq w (cons (list !@stack i) w)) (setq i (plus i 1)) (go lab1058)) (return (cons dest w)))))))))) (de h!:JUMP (pc code env) (list 2 ( jumpto (plus pc (byte1) 1)))) (de h!:JUMP_B (pc code env) (list 2 (jumpto ( plus (difference pc (byte1)) 1)))) (de h!:JUMP_L (pc code env) (list 3 ( jumpto (plus pc (twobytes) 1)))) (de h!:JUMP_BL (pc code env) (list 3 (jumpto (plus (difference pc (twobytes)) 1)))) (de h!:JUMPNIL (pc code env) (jumpop (list (quote null) !@a))) (de h!:JUMPNIL_B (pc code env) (jumpopb (list ( quote null) !@a))) (de h!:JUMPNIL_L (pc code env) (jumpopl (list (quote null) !@a))) (de h!:JUMPNIL_BL (pc code env) (jumpopbl (list (quote null) !@a))) ( de h!:JUMPT (pc code env) (jumpop !@a)) (de h!:JUMPT_B (pc code env) (jumpopb !@a)) (de h!:JUMPT_L (pc code env) (jumpopl !@a)) (de h!:JUMPT_BL (pc code env) (jumpopbl !@a)) (de h!:JUMPATOM (pc code env) (jumpop (list (quote atom) !@a))) (de h!:JUMPATOM_B (pc code env) (jumpopb (list (quote atom) !@a))) ( de h!:JUMPATOM_L (pc code env) (jumpopl (list (quote atom) !@a))) (de h!:JUMPATOM_BL (pc code env) (jumpopbl (list (quote atom) !@a))) (de h!:JUMPNATOM (pc code env) (jumpop (list (quote not) (list (quote atom) !@a)) )) (de h!:JUMPNATOM_B (pc code env) (jumpopb (list (quote not) (list (quote atom) !@a)))) (de h!:JUMPNATOM_L (pc code env) (jumpopl (list (quote not) ( list (quote atom) !@a)))) (de h!:JUMPNATOM_BL (pc code env) (jumpopbl (list ( quote not) (list (quote atom) !@a)))) (de h!:JUMPEQ (pc code env) (jumpop ( list (quote eq) !@b !@a))) (de h!:JUMPEQ_B (pc code env) (jumpopb (list ( quote eq) !@b !@a))) (de h!:JUMPEQ_L (pc code env) (jumpopl (list (quote eq) !@b !@a))) (de h!:JUMPEQ_BL (pc code env) (jumpopbl (list (quote eq) !@b !@a) )) (de h!:JUMPNE (pc code env) (jumpop (list (quote not) (list (quote eq) !@b !@a)))) (de h!:JUMPNE_B (pc code env) (jumpopb (list (quote not) (list ( quote eq) !@b !@a)))) (de h!:JUMPNE_L (pc code env) (jumpopl (list (quote not ) (list (quote eq) !@b !@a)))) (de h!:JUMPNE_BL (pc code env) (jumpopbl (list (quote not) (list (quote eq) !@b !@a)))) (de h!:JUMPEQUAL (pc code env) ( jumpop (list (quote equal) !@b !@a))) (de h!:JUMPEQUAL_B (pc code env) ( jumpopb (list (quote equal) !@b !@a))) (de h!:JUMPEQUAL_L (pc code env) ( jumpopl (list (quote equal) !@b !@a))) (de h!:JUMPEQUAL_BL (pc code env) ( jumpopbl (list (quote equal) !@b !@a))) (de h!:JUMPNEQUAL (pc code env) ( jumpop (list (quote not) (list (quote equal) !@b !@a)))) (de h!:JUMPNEQUAL_B (pc code env) (jumpopb (list (quote not) (list (quote equal) !@b !@a)))) (de h!:JUMPNEQUAL_L (pc code env) (jumpopl (list (quote not) (list (quote equal) !@b !@a)))) (de h!:JUMPNEQUAL_BL (pc code env) (jumpopbl (list (quote not) ( list (quote equal) !@b !@a)))) (de h!:JUMPL0NIL (pc code env) (jumpop (list ( quote null) (list !@stack 0)))) (de h!:JUMPL0T (pc code env) (jumpop (list !@stack 0))) (de h!:JUMPL1NIL (pc code env) (jumpop (list (quote null) (list !@stack 1)))) (de h!:JUMPL1T (pc code env) (jumpop (list !@stack 1))) (de h!:JUMPL2NIL (pc code env) (jumpop (list (quote null) (list !@stack 2)))) (de h!:JUMPL2T (pc code env) (jumpop (list !@stack 2))) (de h!:JUMPL3NIL (pc code env) (jumpop (list (quote null) (list !@stack 3)))) (de h!:JUMPL3T (pc code env) (jumpop (list !@stack 3))) (de h!:JUMPL4NIL (pc code env) (jumpop ( list (quote null) (list !@stack 4)))) (de h!:JUMPL4T (pc code env) (jumpop ( list !@stack 4))) (de h!:JUMPST0NIL (pc code env) (jumpop (list (quote null) (list (quote setq) (list !@stack 0) !@a)))) (de h!:JUMPST0T (pc code env) ( jumpop (list (quote setq) (list !@stack 0) !@a))) (de h!:JUMPST1NIL (pc code env) (jumpop (list (quote null) (list (quote setq) (list !@stack 1) !@a)))) ( de h!:JUMPST1T (pc code env) (jumpop (list (quote setq) (list !@stack 1) !@a) )) (de h!:JUMPST2NIL (pc code env) (jumpop (list (quote null) (list (quote setq) (list !@stack 2) !@a)))) (de h!:JUMPST2T (pc code env) (jumpop (list ( quote setq) (list !@stack 2) !@a))) (de h!:JUMPL0ATOM (pc code env) (jumpop ( list (quote atom) (list !@stack 0)))) (de h!:JUMPL0NATOM (pc code env) ( jumpop (list (quote not) (list (quote atom) (list !@stack 0))))) (de h!:JUMPL1ATOM (pc code env) (jumpop (list (quote atom) (list !@stack 1)))) ( de h!:JUMPL1NATOM (pc code env) (jumpop (list (quote not) (list (quote atom) (list !@stack 1))))) (de h!:JUMPL2ATOM (pc code env) (jumpop (list (quote atom) (list !@stack 2)))) (de h!:JUMPL2NATOM (pc code env) (jumpop (list ( quote not) (list (quote atom) (list !@stack 2))))) (de h!:JUMPL3ATOM (pc code env) (jumpop (list (quote atom) (list !@stack 3)))) (de h!:JUMPL3NATOM (pc code env) (jumpop (list (quote not) (list (quote atom) (list !@stack 3))))) ( de h!:JUMPFREE1NIL (pc code env) (jumpop (list (quote null) (freeref env 1))) ) (de h!:JUMPFREE1T (pc code env) (jumpop (freeref env 1))) (de h!:JUMPFREE2NIL (pc code env) (jumpop (list (quote null) (freeref env 2)))) ( de h!:JUMPFREE2T (pc code env) (jumpop (freeref env 2))) (de h!:JUMPFREE3NIL (pc code env) (jumpop (list (quote null) (freeref env 3)))) (de h!:JUMPFREE3T (pc code env) (jumpop (freeref env 3))) (de h!:JUMPFREE4NIL (pc code env) ( jumpop (list (quote null) (freeref env 4)))) (de h!:JUMPFREE4T (pc code env) (jumpop (freeref env 4))) (de h!:JUMPFREENIL (pc code env) (list 3 (makeif ( list (quote null) (freeref env (byte1))) (jumpto (plus pc (byte2) 2))))) (de h!:JUMPFREET (pc code env) (list 3 (makeif (freeref env (byte1)) (jumpto ( plus pc (byte2) 2))))) (de h!:JUMPLIT1EQ (pc code env) (jumpop (list (quote eq) !@a (litref env 1)))) (de h!:JUMPLIT1NE (pc code env) (jumpop (list ( quote not) (list (quote eq) !@a (litref env 1))))) (de h!:JUMPLIT2EQ (pc code env) (jumpop (list (quote eq) !@a (litref env 2)))) (de h!:JUMPLIT2NE (pc code env) (jumpop (list (quote not) (list (quote eq) !@a (litref env 1))))) ( de h!:JUMPLIT3EQ (pc code env) (jumpop (list (quote eq) !@a (litref env 3)))) (de h!:JUMPLIT3NE (pc code env) (jumpop (list (quote not) (list (quote eq) !@a (litref env 1))))) (de h!:JUMPLIT4EQ (pc code env) (jumpop (list (quote eq) !@a (litref env 4)))) (de h!:JUMPLIT4NE (pc code env) (jumpop (list ( quote not) (list (quote eq) !@a (litref env 1))))) (de h!:JUMPLITEQ (pc code env) (list 3 (makeif (list (quote eq) !@a (litref env (byte1))) (jumpto (plus pc (byte2) 2))))) (de h!:JUMPLITNE (pc code env) (list 3 (makeif (list ( quote not) (list (quote eq) !@a (litref env (byte1)))) (jumpto (plus pc ( byte2) 2))))) (de h!:JUMPB1NIL (pc code env) (prog (w) (setq w (elt builtin1 (byte1))) (cond ((null w) (error 1 "Bad in JUMPB1NIL"))) (return (list 3 ( makeif (list (quote null) (list w !@a)) (jumpto (plus pc (byte2) 2))))))) (de h!:JUMPB1T (pc code env) (prog (w) (setq w (elt builtin1 (byte1))) (cond (( null w) (error 1 "Bad in JUMPB1T"))) (return (list 3 (makeif (list w !@a) ( jumpto (plus pc (byte2) 2))))))) (de h!:JUMPB2NIL (pc code env) (prog (w) ( setq w (elt builtin2 (byte1))) (cond ((null w) (error 1 "Bad in JUMPB2NIL"))) (return (list 3 (makeif (list (quote null) (list w !@b !@a)) (jumpto (plus pc (byte2) 2))))))) (de h!:JUMPB2T (pc code env) (prog (w) (setq w (elt builtin2 (byte1))) (cond ((null w) (error 1 "Bad in JUMPB2T"))) (return (list 3 (makeif (list w !@b !@a) (jumpto (plus pc (byte2) 2))))))) (de h!:JUMPFLAGP (pc code env) (jumpop (list (quote flagp) !@b !@a))) (de h!:JUMPNFLAGP (pc code env) (jumpop (list (quote not) (list (quote flagp) !@b !@a)))) (de h!:JUMPEQCAR (pc code env) (list 3 (makeif (list (quote eqcar) !@a (litref env (byte1))) (jumpto (plus pc (byte2) 2))))) (de h!:JUMPNEQCAR ( pc code env) (list 3 (makeif (list (quote not) (list (quote eqcar) !@a ( litref env (byte1)))) (jumpto (plus pc (byte2) 2))))) (de h!:CATCH (pc code env) (jumpop (list !@catch !@a))) (de h!:CATCH_B (pc code env) (jumpopb (list !@catch !@a))) (de h!:CATCH_L (pc code env) (jumpopl (list !@catch !@a))) ( de h!:CATCH_BL (pc code env) (jumpopbl (list !@catch !@a))) (de h!:UNCATCH ( pc code env) (list 1 (quote uncatch) (jumpto pc))) (de h!:THROW (pc code env) (quote (1 throw))) (de h!:PROTECT (pc code env) (list 1 (quote protect) ( jumpto pc))) (de h!:UNPROTECT (pc code env) (list 1 (quote unprotect) (jumpto pc))) (de h!:PVBIND (pc code env) (list 1 (quote pvbind) (jumpto pc))) (de h!:PVRESTORE (pc code env) (list 1 (quote pvrestore) (jumpto pc))) (de vector_to_list (v) (cond ((not (vectorp v)) (error 1 "Error in binding fluid variables")) (t (prog (r) (prog (i) (setq i 0) lab1059 (cond ((minusp (times 1 (difference (upbv v) i))) (return nil))) ( setq r (cons (getv v i) r)) (setq i (plus i 1)) (go lab1059)) (return ( reversip r)))))) (de h!:FREEBIND (pc code env) (list 2 (list (quote freebind) (vector_to_list (freeref env (byte1)))) (jumpto (plus pc 1)))) (de h!:FREERSTR (pc code env) (list 1 (quote (freerstr !*)) (jumpto pc))) (de h!:EXIT (pc code env) (list 1 (list (quote return) !@a))) (de h!:NILEXIT (pc code env) (list 1 (list (quote return) nil))) (de h!:LOC0EXIT (pc code env) ( list 1 (list (quote return) (list !@stack 0)))) (de h!:LOC1EXIT (pc code env) (list 1 (list (quote return) (list !@stack 1)))) (de h!:LOC2EXIT (pc code env) (list 1 (list (quote return) (list !@stack 2)))) (de h!:PUSH (pc code env) (list 1 (quote push) (list (quote setq) (list !@stack 0) !@a))) (de h!:PUSHNIL (pc code env) (list 1 (quote push) (list (quote setq) (list !@stack 0) nil))) (de h!:PUSHNIL2 (pc code env) (list 1 (quote push) (list ( quote setq) (list !@stack 0) nil) (quote push) (list (quote setq) (list !@stack 0) nil))) (de h!:PUSHNIL3 (pc code env) (list 1 (quote push) (list ( quote setq) (list !@stack 0) nil) (quote push) (list (quote setq) (list !@stack 0) nil) (quote push) (list (quote setq) (list !@stack 0) nil))) (de h!:PUSHNILS (pc code env) (prog (n w) (setq n (byte1)) (prog (i) (setq i 1) lab1060 (cond ((minusp (times 1 (difference n i))) (return nil))) (setq w ( cons (quote push) (cons (list (quote setq) (list !@stack 0) nil) w))) (setq i (plus i 1)) (go lab1060)) (return (cons 2 w)))) (de h!:POP (pc code env) ( list 1 (list (quote setq) (list (quote !@stack) 0)) (quote lose))) (de h!:LOSE (pc code env) (quote (1 lose))) (de h!:LOSE2 (pc code env) (quote (1 lose lose))) (de h!:LOSE3 (pc code env) (quote (1 lose lose lose))) (de h!:LOSES (pc code env) (prog (n w) (setq n (byte1)) (prog (i) (setq i 1) lab1061 (cond ((minusp (times 1 (difference n i))) (return nil))) (setq w ( cons (quote lose) w)) (setq i (plus i 1)) (go lab1061)) (return (cons 2 w)))) (de h!:SWOP (pc code env) (list 1 (list (quote setq) !@w !@a) (list (quote setq) !@a !@b) (list (quote setq) !@b !@w))) (de h!:EQ (pc code env) (list 1 (list (quote setq) !@a (list (quote eq) !@b !@a)))) (de h!:EQCAR (pc code env ) (list 1 (list (quote setq) !@a (list (quote eqcar) !@b !@a)))) (de h!:EQUAL (pc code env) (list 1 (list (quote setq) !@a (list (quote equal) !@b !@a)))) (de h!:NUMBERP (pc code env) (list 1 (list (quote setq) !@a (list (quote numberp) !@a)))) (de h!:CAR (pc code env) (list 1 (list (quote setq) !@a ( list (quote car) !@a)))) (de h!:CDR (pc code env) (list 1 (list (quote setq) !@a (list (quote cdr) !@a)))) (de h!:CAAR (pc code env) (list 1 (list (quote setq) !@a (list (quote caar) !@a)))) (de h!:CADR (pc code env) (list 1 (list (quote setq) !@a (list (quote cadr) !@a)))) (de h!:CDAR (pc code env) (list 1 (list (quote setq) !@a (list (quote cdar) !@a)))) (de h!:CDDR (pc code env) (list 1 (list (quote setq) !@a (list (quote cddr) !@a)))) (de h!:CONS (pc code env) (list 1 (list (quote setq) !@a (list (quote cons) !@b !@a)))) (de h!:NCONS (pc code env) (list 1 (list (quote setq) !@a (list (quote ncons) !@a )))) (de h!:XCONS (pc code env) (list 1 (list (quote setq) !@a (list (quote cons) !@a !@b)))) (de h!:ACONS (pc code env) (list 1 (list (quote setq) !@a ( list (quote acons) !@b !@a (list !@stack 0))) (quote lose))) (de h!:LENGTH ( pc code env) (list 1 (list (quote setq) !@a (list (quote length) !@a)))) (de h!:LIST2 (pc code env) (list 1 (list (quote setq) !@a (list (quote list) !@b !@a)))) (de h!:LIST2STAR (pc code env) (list 1 (list (quote setq) !@a (list ( quote list!*) !@b !@a (list !@stack 0))) (quote lose))) (de h!:LIST3 (pc code env) (list 1 (list (quote setq) !@a (list (quote list) !@b !@a (list !@stack 0))) (quote lose))) (de h!:PLUS2 (pc code env) (list 1 (list (quote setq) !@a (list (quote plus) !@b !@a)))) (de h!:ADD1 (pc code env) (list 1 (list ( quote setq) !@a (list (quote add1) !@a)))) (de h!:DIFFERENCE (pc code env) ( list 1 (list (quote setq) !@a (list (quote difference) !@b !@a)))) (de h!:SUB1 (pc code env) (list 1 (list (quote setq) !@a (list (quote sub1) !@a)) )) (de h!:TIMES2 (pc code env) (list 1 (list (quote setq) !@a (list (quote times) !@b !@a)))) (de h!:GREATERP (pc code env) (list 1 (list (quote setq) !@a (list (quote greaterp) !@b !@a)))) (de h!:LESSP (pc code env) (list 1 ( list (quote setq) !@a (list (quote lessp) !@b !@a)))) (de h!:FLAGP (pc code env) (list 1 (list (quote setq) !@a (list (quote flagp) !@b !@a)))) (de h!:GET (pc code env) (list 1 (list (quote setq) !@a (list (quote get) !@b !@a )))) (de h!:LITGET (pc code env) (list 2 (list (quote setq) !@a (list (quote get) !@a (litref env (byte1)))))) (de h!:GETV (pc code env) (list 1 (list ( quote setq) !@a (list (quote getv) !@b !@a)))) (de h!:QGETV (pc code env) ( list 1 (list (quote setq) !@a (list (quote qgetv) !@b !@a)))) (de h!:QGETVN ( pc code env) (list 2 (list (quote setq) !@a (list (quote qgetv) !@a (byte1))) )) (de h!:BIGSTACK (pc code env) (prog nil (error 1 "bigstack") (return (list 3 (quote bigstack))))) (de h!:BIGCALL (pc code env) (prog nil (error 1 "bigcall") (return (list 3 (quote bigcall))))) (de h!:ICASE (pc code env) ( prog nil (error 1 "ICASE opcode found") (return (list (plus 4 (times 2 (byte1 ))) (quote icase))))) (de h!:FASTGET (pc code env) (prog nil (error 1 "fastget") (return (list 2 (quote fastget))))) (de h!:SPARE1 (pc code env) ( error 1 "Invalid (spare) opcode found in byte-stream")) (de h!:SPARE2 (pc code env) (error 1 "Invalid (spare) opcode found in byte-stream")) "All helper functions present") (de find_freebind (x) (cond ((null x) nil) (t (cond ((eqcar (car x) (quote freebind)) x) (t (find_freebind (cdr x))))))) (de find_freerstr (x) (cond ((null x) nil) (t (cond ((eqcar (car x) (quote freerstr)) x) (t (find_freerstr (cdr x))))))) (de mark_restores (w lab) (prog (b) (setq b (assoc lab w)) (cond ((null b) ( error 1 "block not found"))) (cond ((cadr b) (return nil))) (rplaca (cdr b) t ) (cond ((find_freerstr (cddr b)) (return nil)) (t (cond ((find_freebind ( cddr b)) (return t))))) (prog nil lab1062 (cond ((null (not (atom (cdr b)))) (return nil))) (setq b (cdr b)) (go lab1062)) (setq b (car b)) (cond ((eqcar b (quote go)) (return (mark_restores w (cadr b)))) (t (cond ((eqcar b (quote if)) (progn (cond ((mark_restores w (cadr (caddr b))) (return t)) (t (return (mark_restores w (cadr (cadddr b)))))))) (t (cond ((eqcar b (quote progexits) ) (return (mark_several_restores w (cdr b)))) (t (return nil))))))))) (de mark_several_restores (w l) (cond ((null l) nil) (t (cond ((mark_restores w (car l)) t) (t (mark_several_restores w (cdr l))))))) (de lift_free_binding (w fb) (prog (r1 r2 w1) (prog nil lab1063 (cond ((null w) (return nil))) (progn (setq w1 (cdr w)) (cond ((cadar w) (progn (rplaca ( cdar w) nil) (rplacd w r1) (setq r1 w))) (t (progn (rplacd w r2) (setq r2 w)) )) (setq w w1)) (go lab1063)) (setq r1 (reversip r1)) (rplaca fb (cons (quote prog) (cons (cadar fb) r1))) (rplacd fb (list (cons (quote progexits) ( free_exits r1)))) (return (reversip r2)))) (de free_exits (b) (prog (r r1) (prog (var1066) (setq var1066 b) lab1065 ( cond ((null var1066) (return nil))) (prog (i) (setq i (car var1066)) (progn ( prog nil lab1064 (cond ((null (not (atom (cdr i)))) (return nil))) (setq i ( cdr i)) (go lab1064)) (setq i (car i)) (cond ((eqcar i (quote go)) (setq r ( union (cdr i) r))) (t (cond ((eqcar i (quote if)) (setq r (union (cdr (caddr i)) (union (cdr (cadddr i)) r)))) (t (cond ((eqcar i (quote progexits)) (setq r (union (cdr i) r)))))))))) (setq var1066 (cdr var1066)) (go lab1065)) ( prog (var1068) (setq var1068 r) lab1067 (cond ((null var1068) (return nil))) (prog (i) (setq i (car var1068)) (cond ((null (assoc i b)) (setq r1 (cons i r1))))) (setq var1068 (cdr var1068)) (go lab1067)) (return r1))) (de fix_free_bindings (w) (prog (changed aborted p fb) (setq changed t) (prog nil lab1072 (cond ((null changed) (return nil))) (progn (setq changed nil) ( prog (var1070) (setq var1070 w) lab1069 (cond ((null var1070) (return nil))) (prog (z) (setq z (car var1070)) (rplaca (cdr z) nil)) (setq var1070 (cdr var1070)) (go lab1069)) (cond (aborted (setq p (cdr p))) (t (setq p w))) ( setq aborted nil) (prog nil lab1071 (cond ((null (and p (not (setq fb ( find_freebind (cddar p)))))) (return nil))) (setq p (cdr p)) (go lab1071)) ( cond (p (progn (setq changed t) (cond ((mark_restores w (cadr (cadr fb))) ( setq aborted t)) (t (setq w (lift_free_binding w fb)))))))) (go lab1072)) ( return w))) (de optimise_blocks (w args locals) (prog (vars changed avail) (setq vars ( append args locals)) (prog (var1074) (setq var1074 w) lab1073 (cond ((null var1074) (return nil))) (prog (z) (setq z (car var1074)) (rplaca (cdr z) ( quote unknown))) (setq var1074 (cdr var1074)) (go lab1073)) (rplaca (cdar w) nil) (setq changed t) (prog nil lab1079 (cond ((null changed) (return nil))) (progn (setq changed nil) (prog (var1078) (setq var1078 w) lab1077 (cond (( null var1078) (return nil))) (prog (z) (setq z (car var1078)) (progn (setq avail (cadr z)) (prog (var1076) (setq var1076 (cddr z)) lab1075 (cond ((null var1076) (return nil))) (prog (q) (setq q (car var1076)) (progn nil)) (setq var1076 (cdr var1076)) (go lab1075)))) (setq var1078 (cdr var1078)) (go lab1077))) (go lab1079)) (return w))) (setq !*echo (setq !*plap t)) (de simple (x) (cond ((atom x) x) (t (cond ((null (cdr x)) (car x)) (t ( simple (cdr x))))))) (fluid (quote (x y))) (de mylast (x) (cond ((atom x) x) (t (cond ((null (cdr x)) (car x)) (t ( mylast (cdr x))))))) (de test (a) (prog (x) (setq x (plus a a a)) (setq x (prog (y) (setq y (times x x)) (print (list x y)) (return y))) (return (quotient x a)))) (unfluid (quote (x y))) (setq !*plap nil) (unbyte (quote simple)) (unbyte (quote mylast)) (unbyte (quote test)) % end of file