diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 18a32ec..f878a09 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -3950,12 +3950,16 @@ The READLOOP calls preparseReadLine which returns a pair of the form \seebook{preparse1}{strposl}{5} \calls{preparse1}{is-console} \catches{preparse1}{spad-reader} -\usesdollar{preparse1}{linelist} -\usesdollar{preparse1}{echolinestack} -\usesdollar{preparse1}{byConstructors} -\usesdollar{preparse1}{skipme} -\usesdollar{preparse1}{constructorsSeen} -\usesdollar{preparse1}{preparse-last-line} +\refsdollar{preparse1}{echolinestack} +\refsdollar{preparse1}{byConstructors} +\defsdollar{preparse1}{skipme} +\refsdollar{preparse1}{constructorsSeen} +\defsdollar{preparse1}{preparse-last-line} +\refsdollar{preparse1}{preparse-last-line} +\defsdollar{preparse1}{index} +\refsdollar{preparse1}{index} +\refsdollar{preparse1}{linelist} +\refsdollar{preparse1}{in-stream} \begin{chunk}{defun preparse1} (defun preparse1 (linelist) (labels ( @@ -3968,7 +3972,7 @@ The READLOOP calls preparseReadLine which returns a pair of the form instring pcount comsym strsym oparsym cparsym n ncomsym tmp1 (sloc -1) continue (parenlev 0) ncomblock lines locs nums functor) (declare (special $linelist $echolinestack |$byConstructors| $skipme - |$constructorsSeen| $preparse-last-line)) + |$constructorsSeen| $preparse-last-line $index in-stream)) READLOOP (setq tmp1 (preparseReadLine linelist)) (setq num (car tmp1)) @@ -6670,48 +6674,44 @@ constructMacro (form is [nam,[lam,vl,body]]) (setq vl (cadadr form)) (setq body (car (cddadr form))) (cond - ((contained (intern " " "BOOT") body) - (|sayBrightly| (cons " " (append (|bright| nam) (list " not compiled"))))) - (t - (cond - ((and (pairp vl) (progn (setq tmp1 (reverse vl)) t) - (pairp tmp1) - (progn - (setq e (qcar tmp1)) - (setq vlp (qcdr tmp1)) - t) - (progn (setq vlp (nreverse vlp)) t) - (pairp body) - (progn (setq namp (qcar body)) t) - (equal (qcdr body) vlp)) - (|LAM,EVALANDFILEACTQ| - (list 'put (mkq nam) (mkq '|SPADreplace|) (mkq namp))) - (|sayBrightly| - (cons " " (append (|bright| nam) - (cons "is replaced by" (|bright| namp)))))) - ((and (or (atom body) - (let ((result t)) - (loop for x in body - do (setq result (and result (atom x)))) - result)) - (pairp vl) - (progn (setq tmp1 (reverse vl)) t) - (pairp tmp1) - (progn - (setq e (qcar tmp1)) - (setq vlp (qcdr tmp1)) - t) - (progn (setq vlp (nreverse vlp)) t) - (null (contained e body))) - (setq macform (list 'xlam vlp body)) - (|LAM,EVALANDFILEACTQ| - (list 'put (mkq nam) (mkq '|SPADreplace|) (mkq macform))) - (|sayBrightly| (cons " " (append (|bright| nam) - (cons "is replaced by" (|bright| body)))))) - (t nil)) - (if |$insideCapsuleFunctionIfTrue| - (car (comp (list form))) - (|compileConstructor| form)))))) + ((and (pairp vl) (progn (setq tmp1 (reverse vl)) t) + (pairp tmp1) + (progn + (setq e (qcar tmp1)) + (setq vlp (qcdr tmp1)) + t) + (progn (setq vlp (nreverse vlp)) t) + (pairp body) + (progn (setq namp (qcar body)) t) + (equal (qcdr body) vlp)) + (|LAM,EVALANDFILEACTQ| + (list 'put (mkq nam) (mkq '|SPADreplace|) (mkq namp))) + (|sayBrightly| + (cons " " (append (|bright| nam) + (cons "is replaced by" (|bright| namp)))))) + ((and (or (atom body) + (let ((result t)) + (loop for x in body + do (setq result (and result (atom x)))) + result)) + (pairp vl) + (progn (setq tmp1 (reverse vl)) t) + (pairp tmp1) + (progn + (setq e (qcar tmp1)) + (setq vlp (qcdr tmp1)) + t) + (progn (setq vlp (nreverse vlp)) t) + (null (contained e body))) + (setq macform (list 'xlam vlp body)) + (|LAM,EVALANDFILEACTQ| + (list 'put (mkq nam) (mkq '|SPADreplace|) (mkq macform))) + (|sayBrightly| (cons " " (append (|bright| nam) + (cons "is replaced by" (|bright| body)))))) + (t nil)) + (if |$insideCapsuleFunctionIfTrue| + (car (comp (list form))) + (|compileConstructor| form)))) \end{chunk} @@ -8751,6 +8751,15 @@ where item has form \end{chunk} +\defun{AssocBarGensym}{AssocBarGensym} +\calls{AssocBarGensym}{EqualBarGensym} +\begin{chunk}{defun AssocBarGensym} +(defun |AssocBarGensym| (key z) + (loop for x in z + do (when (and (pairp x) (|EqualBarGensym| key (car x))) (return x)))) + +\end{chunk} + \defun{compDefWhereClause}{compDefWhereClause} \calls{compDefWhereClause}{pairp} \calls{compDefWhereClause}{qcar} @@ -9016,6 +9025,93 @@ where item has form \end{chunk} +\defun{optXLAMCond}{optXLAMCond} +\calls{optXLAMCond}{optCONDtail} +\calls{optXLAMCond}{optPredicateIfTrue} +\calls{optXLAMCond}{optXLAMCond} +\calls{optXLAMCond}{pairp} +\calls{optXLAMCond}{qcar} +\calls{optXLAMCond}{qcdr} +\calls{optXLAMCond}{rplac} +\begin{chunk}{defun optXLAMCond} +(defun |optXLAMCond| (x) + (cond + ((and (pairp x) (eq (qcar x) 'cond) (pairp (qcdr x)) + (pairp (qcar (qcdr x))) (pairp (qcdr (qcar (qcdr x)))) + (eq (qcdr (qcdr (qcar (qcdr x)))) nil)) + (if (|optPredicateIfTrue| (qcar (qcar (qcdr x)))) + (qcar (qcdr (qcar (qcdr x)))) + (cons 'cond (cons (qcar (qcdr x)) (|optCONDtail| (qcdr (qcdr x))))))) + ((atom x) x) + (t + (rplac (car x) (|optXLAMCond| (car x))) + (rplac (cdr x) (|optXLAMCond| (cdr x))) + x))) + +\end{chunk} + +\defun{optCONDtail}{optCONDtail} +\calls{optCONDtail}{optCONDtail} +\refsdollar{optCONDtail}{true} +\begin{chunk}{defun optCONDtail} +(defun |optCONDtail| (z) + (declare (special |$true|)) + (when z + (cond + ((|optPredicateIfTrue| (caar z)) (list (list |$true| (cadar z)))) + ((null (cdr z)) (list (car z) (list |$true| (list '|CondError|)))) + (t (cons (car z) (|optCONDtail| (cdr z))))))) + +\end{chunk} + +\defdollar{BasicPredicates} +If these predicates are found in an expression the code optimizer +routine optPredicateIfTrue then optXLAM will replace the call with +the argument. This is used for predicates that test the type of +their argument so that, for instance, a call to integerp on an integer +will be replaced by that integer if it is true. This represents a +simple kind of compile-time type evaluation. +\begin{chunk}{initvars} +(defvar |$BasicPredicates| '(integerp stringp floatp)) + +\end{chunk} + +\defun{optPredicateIfTrue}{optPredicateIfTrue} +\refsdollar{optPredicateIfTrue}{BasicPredicates} +\begin{chunk}{defun optPredicateIfTrue} +(defun |optPredicateIfTrue| (p) + (declare (special |$BasicPredicates|)) + (cond + ((and (pairp p) (eq (qcar p) 'quote)) T) + ((and (pairp p) (pairp (qcdr p)) (eq (qcdr (qcdr p)) nil) + (member (qcar p) |$BasicPredicates|) (funcall (qcar p) (qcar (qcdr p)))) + t) + (t nil))) + +\end{chunk} + +\defun{optIF2COND}{optIF2COND} +\calls{optIF2COND}{optIF2COND} +\refsdollar{optIF2COND}{true} +\begin{chunk}{defun optIF2COND} +(defun |optIF2COND| (arg) + (let (a b c) + (declare (special |$true|)) + (setq a (cadr arg)) + (setq b (caddr arg)) + (setq c (cadddr arg)) + (cond + ((eq b '|noBranch|) (list 'cond (list (list 'null a ) c))) + ((eq c '|noBranch|) (list 'cond (list a b))) + ((and (pairp c) (eq (qcar c) 'if)) + (cons 'cond (cons (list a b) (cdr (|optIF2COND| c))))) + ((and (pairp c) (eq (qcar c) 'cond)) + (cons 'cond (cons (list a b) (qcdr c)))) + (t + (list 'cond (list a b) (list |$true| c)))))) + +\end{chunk} + \defun{subrname}{subrname} \calls{subrname}{identp} \calls{subrname}{compiled-function-p} @@ -9032,7 +9128,37 @@ where item has form \subsection{Special case optimizers} Optimization functions are called through the OPTIMIZE property on the -symbol property list. +symbol property list. The current list is: +\begin{verbatim} + |call| optCall + seq optSEQ + eq optEQ + minus optMINUS + qsminus optQSMINUS + - opt- + lessp optLESSP + spadcall optSPADCALL + | optSuchthat + catch optCatch + cond optCond + |mkRecord| optMkRecord + recordelt optRECORDELT + setrecordelt optSETRECORDELT + recordcopy optRECORDCOPY +\end{verbatim} + +Be aware that there are case-sensitivity issues. When found in the +s-expression, each symbol in the left column will call a custom +optimization routine in the right column. The optimization routines +are below. Note that each routine has a special chunk in postvars +using eval-when to set the property list at load time. + +These optimizations are done destructively. That is, they modify the +function in-place using rplac. + +Not all of the optimization routines are called through the property +list. Some are called only from other optimization routines, e.g. +optPackageCall. \defplist{call}{optCall} \begin{chunk}{postvars} @@ -9041,6 +9167,204 @@ symbol property list. \end{chunk} +\defun{optCall}{Optimize ``call'' expressions} +\calls{optCall}{optimize} +\calls{optCall}{rplac} +\calls{optCall}{optPackageCall} +\calls{optCall}{optCallSpecially} +\calls{optCall}{systemErrorHere} +\refsdollar{optCall}{QuickCode} +\refsdollar{optCall}{bootStrapMode} +\begin{chunk}{defun optCall} +(defun |optCall| (x) + (let (u tmp1 fn a name q r n w) + (declare (special |$QuickCode| |$bootStrapMode|)) + (setq u (cdr x)) + (setq x (|optimize| (list u))) + (cond + ((atom (car x)) (car x)) + (t + (setq tmp1 (car x)) + (setq fn (car tmp1)) + (setq a (cdr tmp1)) + (cond + ((atom fn) (rplac (cdr x) a) (rplac (car x) fn)) + ((and (pairp fn) (eq (qcar fn) 'pac)) (|optPackageCall| x fn a)) + ((and (pairp fn) (eq (qcar fn) '|applyFun|) + (pairp (qcdr fn)) (eq (qcdr (qcdr fn)) nil)) + (setq name (qcar (qcdr fn))) + (rplac (car x) 'spadcall) + (rplac (cdr x) (append a (cons name nil))) + x) + ((and (pairp fn) (pairp (qcdr fn)) (pairp (qcdr (qcdr fn))) + (eq (qcdr (qcdr (qcdr fn))) nil) + (member (qcar fn) '(elt qrefelt const))) + (setq q (qcar fn)) + (setq r (qcar (qcdr fn))) + (setq n (qcar (qcdr (qcdr fn)))) + (cond + ((and (null |$bootStrapMode|) (setq w (|optCallSpecially| q x n r))) + w) + ((eq q 'const) + (list '|spadConstant| r n)) + (t + (rplac (car x) 'spadcall) + (when |$QuickCode| (rplaca fn 'qrefelt)) + (rplac (cdr x) (append a (list fn))) + x))) + (t (|systemErrorHere| "optCall"))))))) + +\end{chunk} + +\defun{optPackageCall}{optPackageCall} +\calls{optPackageCall}{rplaca} +\calls{optPackageCall}{rplacd} +\begin{chunk}{defun optPackageCall} +(defun |optPackageCall| (x arg2 arglist) + (let (packageVariableOrForm functionName) + (setq packageVariableOrForm (second arg2)) + (setq functionName (third arg2)) + (rplaca x functionName) + (rplacd x (append arglist (list packageVariableOrForm))) + x)) + +\end{chunk} + +\defun{optCallSpecially}{optCallSpecially} +\calls{optCallSpecially}{lassoc} +\calls{optCallSpecially}{kar} +\calls{optCallSpecially}{get} +\calls{optCallSpecially}{opOf} +\calls{optCallSpecially}{optSpecialCall} +\refsdollar{optCallSpecially}{specialCaseKeyList} +\refsdollar{optCallSpecially}{getDomainCode} +\refsdollar{optCallSpecially}{optimizableConstructorNames} +\refsdollar{optCallSpecially}{e} +\begin{chunk}{defun optCallSpecially} +(defun |optCallSpecially| (q x n r) + (declare (ignore q)) + (labels ( + (lookup (a z) + (let (zp) + (when z + (setq zp (car z)) + (setq z (cdr x)) + (if (and (pairp zp) (eq (qcar zp) 'let) (pairp (qcdr zp)) + (equal (qcar (qcdr zp)) a) (pairp (qcdr (qcdr zp)))) + (qcar (qcdr (qcdr zp))) + (lookup a z)))))) + (let (tmp1 op y prop yy) + (declare (special |$specialCaseKeyList| |$getDomainCode| |$e| + |$optimizableConstructorNames|)) + (cond + ((setq y (lassoc r |$specialCaseKeyList|)) + (|optSpecialCall| x y n)) + ((member (kar r) |$optimizableConstructorNames|) + (|optSpecialCall| x r n)) + ((and (setq y (|get| r '|value| |$e|)) + (member (|opOf| (car y)) |$optimizableConstructorNames|)) + (|optSpecialCall| x (car y) n)) + ((and (setq y (lookup r |$getDomainCode|)) + (progn + (setq tmp1 y) + (setq op (first tmp1)) + (setq y (second tmp1)) + (setq prop (third tmp1)) + tmp1) + (setq yy (lassoc y |$specialCaseKeyList|))) + (|optSpecialCall| x (list op yy prop) n)) + (t nil))))) + +\end{chunk} + +\defun{optSpecialCall}{optSpecialCall} +\calls{optSpecialCall}{optCallEval} +\calls{optSpecialCall}{function} +\calls{optSpecialCall}{keyedSystemError} +\calls{optSpecialCall}{mkq} +\calls{optSpecialCall}{getl} +\calls{optSpecialCall}{compileTimeBindingOf} +\calls{optSpecialCall}{rplac} +\calls{optSpecialCall}{optimize} +\calls{optSpecialCall}{rplacw} +\calls{optSpecialCall}{rplaca} +\refsdollar{optSpecialCall}{QuickCode} +\refsdollar{optSpecialCall}{Undef} +\begin{chunk}{defun optSpecialCall} +(defun |optSpecialCall| (x y n) + (let (yval args tmp1 fn a) + (declare (special |$QuickCode| |Undef|)) + (setq yval (|optCallEval| y)) + (cond + ((eq (caaar x) 'const) + (cond + ((equal (kar (elt yval n)) (|function| |Undef|)) + (|keyedSystemError| 'S2GE0016 + (list "optSpecialCall" "invalid constant"))) + (t (mkq (elt yval n))))) + ((setq fn (getl (|compileTimeBindingOf| (car (elt yval n))) '|SPADreplace|)) + (|rplac| (cdr x) (cdar x)) + (|rplac| (car x) fn) + (when (and (pairp fn) (eq (qcar fn) 'xlam)) + (setq x (car (|optimize| (list x))))) + (if (and (pairp x) (eq (qcar x) 'equal) (progn (setq args (qcdr x)) t)) + (rplacw x (def-equal args)) + x)) + (t + (setq tmp1 (car x)) + (setq fn (car tmp1)) + (setq a (cdr tmp1)) + (rplac (car x) 'spadcall) + (when |$QuickCode| (rplaca fn 'qrefelt)) + (rplac (cdr x) (append a (list fn))) + x)))) + +\end{chunk} + +\defun{compileTimeBindingOf}{compileTimeBindingOf} +\calls{compileTimeBindingOf}{bpiname} +\calls{compileTimeBindingOf}{keyedSystemError} +\calls{compileTimeBindingOf}{moan} +\begin{chunk}{defun compileTimeBindingOf} +(defun |compileTimeBindingOf| (u) + (let (name) + (cond + ((null (setq name (bpiname u))) + (|keyedSystemError| 'S2OO0001 (list u))) + ((eq name '|Undef|) + (moan "optimiser found unknown function")) + (t name)))) + +\end{chunk} + +\defun{optCallEval}{optCallEval} +\calls{optCallEval}{pairp} +\calls{optCallEval}{qcar} +\calls{optCallEval}{List} +\calls{optCallEval}{Integer} +\calls{optCallEval}{Vector} +\calls{optCallEval}{PrimititveArray} +\calls{optCallEval}{FactoredForm} +\calls{optCallEval}{Matrix} +\calls{optCallEval}{eval} +\begin{chunk}{defun optCallEval} +(defun |optCallEval| (u) + (cond + ((and (pairp u) (eq (qcar u) '|List|)) + (|List| (|Integer|))) + ((and (pairp u) (eq (qcar u) '|Vector|)) + (|Vector| (|Integer|))) + ((and (pairp u) (eq (qcar u) '|PrimitiveArray|)) + (|PrimitiveArray| (|Integer|))) + ((and (pairp u) (eq (qcar u) '|FactoredForm|)) + (|FactoredForm| (|Integer|))) + ((and (pairp u) (eq (qcar u) '|Matrix|)) + (|Matrix| (|Integer|))) + (t + (|eval| u)))) + +\end{chunk} + \defplist{seq}{optSEQ} \begin{chunk}{postvars} (eval-when (eval load) @@ -9048,6 +9372,63 @@ symbol property list. \end{chunk} +\defun{optSEQ}{optSEQ} +\begin{chunk}{defun optSEQ} +(defun |optSEQ| (arg) + (labels ( + (tryToRemoveSEQ (z) + (if (and (pairp z) (eq (qcar z) 'seq) (pairp (qcdr z)) + (eq (qcdr (qcdr z)) nil) (pairp (qcar (qcdr z))) + (pairp (qcdr (qcar (qcdr z)))) + (eq (qcdr (qcdr (qcar (qcdr z)))) nil) + (member (qcar (qcar (qcdr z))) '(exit return throw))) + (qcar (qcdr (qcar (qcdr z)))) + z)) + (SEQToCOND (z) + (let (transform before aft) + (setq transform + (loop for x in z + while + (and (pairp x) (eq (qcar x) 'cond) (pairp (qcdr x)) + (eq (qcdr (qcdr x)) nil) (pairp (qcar (qcdr x))) + (pairp (qcdr (qcar (qcdr x)))) + (eq (qcdr (qcdr (qcar (qcdr x)))) nil) + (pairp (qcar (qcdr (qcar (qcdr x))))) + (eq (qcar (qcar (qcdr (qcar (qcdr x))))) 'exit) + (pairp (qcdr (qcar (qcdr (qcar (qcdr x)))))) + (eq (qcdr (qcdr (qcar (qcdr (qcar (qcdr x)))))) nil)) + collect + (list (qcar (qcar (qcdr x))) + (qcar (qcdr (qcar (qcdr (qcar (qcdr x))))))))) + (setq before (take (|#| transform) z)) + (setq aft (|after| z before)) + (cond + ((null before) (cons 'seq aft)) + ((null aft) + (cons 'cond (append transform (list '(t (|conderr|)))))) + (t + (cons 'cond (append transform + (list (list ''t (|optSEQ| (cons 'seq aft)))))))))) + (getRidOfTemps (z) + (let (g x r) + (cond + ((null z) nil) + ((and (pairp z) (pairp (qcar z)) (eq (qcar (qcar z)) 'let) + (pairp (qcdr (qcar z))) (pairp (qcdr (qcdr (qcar z)))) + (gensymp (qcar (qcdr (qcar z)))) + (> 2 (|numOfOccurencesOf| (qcar (qcdr (qcar z))) (qcdr z)))) + (setq g (qcar (qcdr (qcar z)))) + (setq x (qcar (qcdr (qcdr (qcar z))))) + (setq r (qcdr z)) + (getRidOfTemps (msubst x g r))) + ((eq (car z) '|/throwAway|) + (getRidOfTemps (cdr z))) + (t + (cons (car z) (getRidOfTemps (cdr z)))))))) + (tryToRemoveSEQ (SEQToCOND (getRidOfTemps (cdr arg)))))) + +\end{chunk} + \defplist{eq}{optEQ} \begin{chunk}{postvars} (eval-when (eval load) @@ -9055,6 +9436,23 @@ symbol property list. \end{chunk} +\defun{optEQ}{optEQ} +\begin{chunk}{defun optEQ} +(defun |optEQ| (u) + (let (z r) + (cond + ((and (pairp u) (eq (qcar u) 'eq) (pairp (qcdr u)) + (pairp (qcdr (qcdr u))) (eq (qcdr (qcdr (qcdr u))) nil)) + (setq z (qcar (qcdr u))) + (setq r (qcar (qcdr (qcdr u)))) +; That undoes some weird work in Boolean to do with the definition of true + (if (and (numberp z) (numberp r)) + (list 'quote (eq z r)) + u)) + (t u)))) + +\end{chunk} + \defplist{minus}{optMINUS} \begin{chunk}{postvars} (eval-when (eval load) @@ -9062,6 +9460,19 @@ symbol property list. \end{chunk} +\defun{optMINUS}{optMINUS} +\begin{chunk}{defun optMINUS} +(defun |optMINUS| (u) + (let (v) + (cond + ((and (pairp u) (eq (qcar u) 'minus) (pairp (qcdr u)) + (eq (qcdr (qcdr u)) nil)) + (setq v (qcar (qcdr u))) + (cond ((numberp v) (- v)) (t u))) + (t u)))) + +\end{chunk} + \defplist{qsminus}{optQSMINUS} \begin{chunk}{postvars} (eval-when (eval load) @@ -9069,6 +9480,19 @@ symbol property list. \end{chunk} +\defun{optQSMINUS}{optQSMINUS} +\begin{chunk}{defun optQSMINUS} +(defun |optQSMINUS| (u) + (let (v) + (cond + ((and (pairp u) (eq (qcar u) 'qsminus) (pairp (qcdr u)) + (eq (qcdr (qcdr u)) nil)) + (setq v (qcar (qcdr u))) + (cond ((numberp v) (- v)) (t u))) + (t u)))) + +\end{chunk} + \defplist{-}{opt-} \begin{chunk}{postvars} (eval-when (eval load) @@ -9076,6 +9500,19 @@ symbol property list. \end{chunk} +\defun{opt-}{opt-} +\begin{chunk}{defun opt-} +(defun |opt-| (u) + (let (v) + (cond + ((and (pairp u) (eq (qcar u) '-) (pairp (qcdr u)) + (eq (qcdr (qcdr u)) NIL)) + (setq v (qcar (qcdr u))) + (cond ((numberp v) (- v)) (t u))) + (t u)))) + +\end{chunk} + \defplist{lessp}{optLESSP} \begin{chunk}{postvars} (eval-when (eval load) @@ -9083,6 +9520,23 @@ symbol property list. \end{chunk} +\defun{optLESSP}{optLESSP} +\begin{chunk}{defun optLESSP} +(defun |optLESSP| (u) + (let (a b) + (cond + ((and (pairp u) (eq (qcar u) 'lessp) (pairp (qcdr u)) + (pairp (qcdr (qcdr u))) + (eq (qcdr (qcdr (qcdr u))) nil)) + (setq a (qcar (qcdr u))) + (setq b (qcar (qcdr (qcdr u)))) + (if (eql b 0) + (list 'minusp a) + (list '> b a))) + (t u)))) + +\end{chunk} + \defplist{spadcall}{optSPADCALL} \begin{chunk}{postvars} (eval-when (eval load) @@ -9090,13 +9544,55 @@ symbol property list. \end{chunk} -\defplist{\vert{}}{optSuchthat} +\defun{optSPADCALL}{optSPADCALL} +\calls{optSPADCALL}{optCall} +\refsdollar{optSPADCALL}{InteractiveMode} +\begin{chunk}{defun optSPADCALL} +(defun |optSPADCALL| (form) + (let (fun argl tmp1 dom slot) + (declare (special |$InteractiveMode|)) + (setq argl (cdr form)) + (cond + ; last arg is function/env, but may be a form + ((null |$InteractiveMode|) form) + ((and (pairp argl) + (progn (setq tmp1 (reverse argl)) t) + (pairp tmp1)) + (setq fun (qcar tmp1)) + (setq argl (qcdr tmp1)) + (setq argl (nreverse argl)) + (cond + ((and (pairp fun) + (or (eq (qcar fun) 'elt) (eq (qcar fun) 'lispelt)) + (progn + (and (pairp (qcdr fun)) + (progn + (setq dom (qcar (qcdr fun))) + (and (pairp (qcdr (qcdr fun))) + (eq (qcdr (qcdr (qcdr fun))) nil) + (progn + (setq slot (qcar (qcdr (qcdr fun)))) + t)))))) + (|optCall| (cons '|call| (cons (list 'elt dom slot) argl)))) + (t form))) + (t form)))) + +\end{chunk} + +\defplist{|}{optSuchthat} \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|\|| 'optimize) '|optSuchthat|)) \end{chunk} +\defun{optSuchthat}{optSuchthat} +\begin{chunk}{defun optSuchthat} +(defun |optSuchthat| (arg) + (cons 'suchthat (cdr arg))) + +\end{chunk} + \defplist{catch}{optCatch} \begin{chunk}{postvars} (eval-when (eval load) @@ -9104,6 +9600,85 @@ symbol property list. \end{chunk} +\defun{optCatch}{optCatch} +\calls{optCatch}{pairp} +\calls{optCatch}{qcar} +\calls{optCatch}{qcdr} +\calls{optCatch}{rplac} +\calls{optCatch}{optimize} +\refsdollar{optCatch}{InteractiveMode} +\begin{chunk}{defun optCatch} +(defun |optCatch| (x) + (labels ( + (changeThrowToExit (s g) + (cond + ((or (atom s) (member (car s) '(quote seq repeat collect))) nil) + ((and (pairp s) (eq (qcar s) 'throw) (pairp (qcdr s)) + (equal (qcar (qcdr s)) g)) + (|rplac| (car s) 'exit) + (|rplac| (cdr s) (qcdr (qcdr s)))) + (t + (changeThrowToExit (car s) g) + (changeThrowToExit (cdr s) g)))) + (hasNoThrows (a g) + (cond + ((and (pairp a) (eq (qcar a) 'throw) (pairp (qcdr a)) + (equal (qcar (qcdr a)) g)) + nil) + ((atom a) t) + (t + (and (hasNoThrows (car a) g) + (hasNoThrows (cdr a) g))))) + (changeThrowToGo (s g) + (let (u) + (cond + ((or (atom s) (eq (car s) 'quote)) nil) + ((and (pairp s) (eq (qcar s) 'throw) (pairp (qcdr s)) + (equal (qcar (qcdr s)) g) (pairp (qcdr (qcdr s))) + (eq (qcdr (qcdr (qcdr s))) nil)) + (setq u (qcar (qcdr (qcdr s)))) + (changeThrowToGo u g) + (|rplac| (car s) 'progn) + (|rplac| (cdr s) (list (list 'let (cadr g) u) (list 'go (cadr g))))) + (t + (changeThrowToGo (car s) g) + (changeThrowToGo (cdr s) g)))))) + (let (g tmp2 u s tmp6 a) + (declare (special |$InteractiveMode|)) + (setq g (cadr x)) + (setq a (caddr x)) + (cond + (|$InteractiveMode| x) + ((atom a) a) + (t + (cond + ((and (pairp a) (eq (qcar a) 'seq) (pairp (qcdr a)) + (progn (setq tmp2 (reverse (qcdr a))) t) + (pairp tmp2) (pairp (qcar tmp2)) (eq (qcar (qcar tmp2)) 'throw) + (pairp (qcdr (qcar tmp2))) + (equal (qcar (qcdr (qcar tmp2))) g) + (pairp (qcdr (qcdr (qcar tmp2)))) + (eq (qcdr (qcdr (qcdr (qcar tmp2)))) nil)) + (setq u (qcar (qcdr (qcdr (qcar tmp2))))) + (setq s (qcdr tmp2)) + (setq s (nreverse s)) + (changeThrowToExit s g) + (|rplac| (cdr a) (append s (list (list 'exit u)))) + (setq tmp6 (|optimize| x)) + (setq a (caddr tmp6)))) + (cond + ((hasNoThrows a g) + (|rplac| (car x) (car a)) + (|rplac| (cdr x) (cdr a))) + (t + (changeThrowToGo a g) + (|rplac| (car x) 'seq) + (|rplac| (cdr x) + (list (list 'exit a) (cadr g) (list 'exit (cadr g)))))) + x))))) + +\end{chunk} + \defplist{cond}{optCond} \begin{chunk}{postvars} (eval-when (eval load) @@ -9111,6 +9686,116 @@ symbol property list. \end{chunk} +\defun{optCond}{optCond} +\calls{optCond}{pairp} +\calls{optCond}{qcar} +\calls{optCond}{qcdr} +\calls{optCond}{rplacd} +\calls{optCond}{TruthP} +\calls{optCond}{EqualBarGensym} +\calls{optCond}{rplac} +\begin{chunk}{defun optCond} +(defun |optCond| (x) + (let (z p1 p2 c3 c1 c2 a result) + (setq z (cdr x)) + (when + (and (pairp z) (pairp (qcdr z)) (eq (qcdr (qcdr z)) nil) + (pairp (qcar (qcdr z))) (pairp (qcdr (qcar (qcdr z)))) + (eq (qcdr (qcdr (qcar (qcdr z)))) nil) + (|TruthP| (qcar (qcar (qcdr z)))) + (pairp (qcar (qcdr (qcar (qcdr z))))) + (eq (qcar (qcar (qcdr (qcar (qcdr z))))) 'cond)) + (rplacd (cdr x) (qcdr (qcar (qcdr (qcar (qcdr z))))))) + (cond + ((and (pairp z) (pairp (qcar z)) (pairp (qcdr z)) (pairp (qcar (qcdr z)))) + (setq p1 (qcar (qcar z))) + (setq c1 (qcdr (qcar z))) + (setq p2 (qcar (qcar (qcdr z)))) + (setq c2 (qcdr (qcar (qcdr z)))) + (when + (or (and (pairp p1) (eq (qcar p1) 'null) (pairp (qcdr p1)) + (eq (qcdr (qcdr p1)) nil) + (equal (qcar (qcdr p1)) p2)) + (and (pairp p2) (eq (qcar p2) 'null) (pairp (qcdr p2)) + (eq (qcdr (qcdr p2)) nil) + (equal (qcar (qcdr p2)) p1))) + (setq z (list (cons p1 c1) (cons ''t c2))) + (rplacd x z)) + (when + (and (pairp c1) (eq (qcdr c1) nil) (equal (qcar c1) 'nil) + (equal p2 ''t) (equal (car c2) ''t)) + (if (and (pairp p1) (eq (qcar p1) 'null) (pairp (qcdr p1)) + (eq (qcdr (qcdr p1)) nil)) + (setq result (qcar (qcdr p1))) + (setq result (list 'null p1)))))) + (if result + result + (cond + ((and (pairp z) (pairp (qcar z)) (pairp (qcdr z)) (pairp (qcar (qcdr z))) + (pairp (qcdr (qcdr z))) (eq (qcdr (qcdr (qcdr z))) nil) + (pairp (qcar (qcdr (qcdr z)))) + (|TruthP| (qcar (qcar (qcdr (qcdr z)))))) + (setq p1 (qcar (qcar z))) + (setq c1 (qcdr (qcar z))) + (setq p2 (qcar (qcar (qcdr z)))) + (setq c2 (qcdr (qcar (qcdr z)))) + (setq c3 (qcdr (qcar (qcdr (qcdr z))))) + (cond + ((|EqualBarGensym| c1 c3) + (list 'cond + (cons (list 'or p1 (list 'null p2)) c1) (cons (list 'quote t) c2))) + ((|EqualBarGensym| c1 c2) + (list 'cond (cons (list 'or p1 p2) c1) (cons (list 'quote t) c3))) + (t x))) + (t + (do ((y z (cdr y))) + ((atom y) nil) + (do () + ((null (and (pairp y) (pairp (qcar y)) (pairp (qcdr (qcar y))) + (eq (qcdr (qcdr (qcar y))) nil) (pairp (qcdr y)) + (pairp (qcar (qcdr y))) (pairp (qcdr (qcar (qcdr y)))) + (eq (qcdr (qcdr (qcar (qcdr y)))) nil) + (|EqualBarGensym| (qcar (qcdr (qcar y))) + (qcar (qcdr (qcar (qcdr y))))))) + nil) + (setq a (list 'or (qcar (qcar y)) (qcar (qcar (qcdr y))))) + (rplac (car (car y)) a) + (rplac (cdr y) (qcdr (qcdr y))))) + x))))) + +\end{chunk} + +\defun{EqualBarGensym}{EqualBarGensym} +\calls{EqualBarGensym}{gensymp} +\refsdollar{EqualBarGensym}{GensymAssoc} +\defsdollar{EqualBarGensym}{GensymAssoc} +\begin{chunk}{defun EqualBarGensym} +(defun |EqualBarGensym| (x y) + (labels ( + (fn (x y) + (let (z) + (declare (special |$GensymAssoc|)) + (cond + ((equal x y) t) + ((and (gensymp x) (gensymp y)) + (if (setq z (|assoc| x |$GensymAssoc|)) + (if (equal y (cdr z)) t nil) + (progn + (setq |$GensymAssoc| (cons (cons x y) |$GensymAssoc|)) + t))) + ((null x) (and (pairp y) (eq (qcdr y) nil) (gensymp (qcar y)))) + ((null y) (and (pairp x) (eq (qcdr x) nil) (gensymp (qcar x)))) + ((or (atom x) (atom y)) nil) + (t + (and (fn (car x) (car y)) + (fn (cdr x) (cdr y)))))))) + (let (|$GensymAssoc|) + (declare (special |$GensymAssoc|)) + (setq |$GensymAssoc| NIL) + (fn x y)))) + +\end{chunk} + \defplist{mkRecord}{optMkRecord} \begin{chunk}{postvars} (eval-when (eval load) @@ -9118,6 +9803,19 @@ symbol property list. \end{chunk} +\defun{optMkRecord}{optMkRecord} +\calls{optMkRecord}{length} +\begin{chunk}{defun optMkRecord} +(defun |optMkRecord| (arg) + (let (u) + (setq u (cdr arg)) + (cond + ((and (pairp u) (eq (qcdr u) nil)) (list 'list (qcar u))) + ((eql (|#| u) 2) (cons 'cons u)) + (t (cons 'vector u))))) + +\end{chunk} + \defplist{recordelt}{optRECORDELT} \begin{chunk}{postvars} (eval-when (eval load) @@ -9125,6 +9823,28 @@ symbol property list. \end{chunk} +\defun{optRECORDELT}{optRECORDELT} +\calls{optRECORDELT}{keyedSystemError} +\begin{chunk}{defun optRECORDELT} +(defun |optRECORDELT| (arg) + (let (name ind len) + (setq name (cadr arg)) + (setq ind (caddr arg)) + (setq len (cadddr arg)) + (cond + ((eql len 1) + (cond + ((eql ind 0) (list 'qcar name)) + (t (|keyedSystemError| 'S2OO0002 (list ind))))) + ((eql len 2) + (cond + ((eql ind 0) (list 'qcar name)) + ((eql ind 1) (list 'qcdr name)) + (t (|keyedSystemError| 'S2OO0002 (list ind))))) + (t (list 'qvelt name ind))))) + +\end{chunk} + \defplist{setrecordelt}{optSETRECORDELT} \begin{chunk}{postvars} (eval-when (eval load) @@ -9132,6 +9852,32 @@ symbol property list. \end{chunk} +\defun{optSETRECORDELT}{optSETRECORDELT} +\calls{optSETRECORDELT}{keyedSystemError} +\begin{chunk}{defun optSETRECORDELT} +(defun |optSETRECORDELT| (arg) + (let (name ind len expr) + (setq name (cadr arg)) + (setq ind (caddr arg)) + (setq len (cadddr arg)) + (setq expr (car (cddddr arg))) + (cond + ((eql len 1) + (if (eql ind 0) + (list 'progn (list 'rplaca name expr) (list 'qcar name)) + (|keyedSystemError| 'S2OO0002 (list ind)))) + ((eql len 2) + (cond + ((eql ind 0) + (list 'progn (list 'rplaca name expr) (list 'qcar name))) + ((eql ind 1) + (list 'progn (list 'rplacd name expr) (list 'qcdr name))) + (t (|keyedSystemError| 'S2OO0002 (list ind))))) + (t + (list 'qsetvelt name ind expr))))) + +\end{chunk} + \defplist{recordcopy}{optRECORDCOPY} \begin{chunk}{postvars} (eval-when (eval load) @@ -9139,6 +9885,19 @@ symbol property list. \end{chunk} +\defun{optRECORDCOPY}{optRECORDCOPY} +\begin{chunk}{defun optRECORDCOPY} +(defun |optRECORDCOPY| (arg) + (let (name len) + (setq name (cadr arg)) + (setq len (caddr arg)) + (cond + ((eql len 1) (list 'list (list 'car name))) + ((eql len 2) (list 'cons (list 'car name) (list 'cdr name))) + (t (list 'replace (list 'make-array len) name))))) + +\end{chunk} + \section{Functions to manipulate modemaps} \defun{addDomain}{addDomain} @@ -9865,15 +10624,6 @@ add flag identifiers as literals in the environment \refsdollar{addModemap}{CapsuleModemapFrame} \defsdollar{addModemap}{CapsuleModemapFrame} \begin{chunk}{defun addModemap} -;addModemap(op,mc,sig,pred,fn,$e) == -; $InteractiveMode => $e -; if knownInfo pred then pred:=true -; $insideCapsuleFunctionIfTrue=true => -; $CapsuleModemapFrame := -; addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame) -; $e -; addModemap0(op,mc,sig,pred,fn,$e) - (defun |addModemap| (op mc sig pred fn |$e|) (declare (special |$e| |$CapsuleModemapFrame| |$InteractiveMode| |$insideCapsuleFunctionIfTrue|)) @@ -10173,10 +10923,6 @@ Since we can't be sure we take the least disruptive course of action. \end{chunk} -;compSingleCapsuleItem(item,$predl,$e) == -; doIt(macroExpandInPlace(item,$e),$predl) -; $e - \defun{compSingleCapsuleItem}{compSingleCapsuleItem} \calls{compSingleCapsuleItem}{doit} \refsdollar{compSingleCapsuleItem}{pred} @@ -10390,6 +11136,20 @@ Since we can't be sure we take the least disruptive course of action. \end{chunk} \defun{doItIf}{doItIf} +\calls{doItIf}{comp} +\calls{doItIf}{userError} +\calls{doItIf}{compSingleCapsuleItem} +\calls{doItIf}{getSuccessEnvironment} +\calls{doItIf}{localExtras} +\calls{doItIf}{rplaca} +\calls{doItIf}{rplacd} +\defsdollar{doItIf}{e} +\defsdollar{doItIf}{functorLocalParameters} +\refsdollar{doItIf}{predl} +\refsdollar{doItIf}{e} +\refsdollar{doItIf}{functorLocalParameters} +\refsdollar{doItIf}{getDomainCode} +\refsdollar{doItIf}{Boolean} \begin{chunk}{defun doItIf} (defun |doItIf| (item |$predl| |$e|) (declare (special |$predl| |$e|)) @@ -10427,7 +11187,7 @@ Since we can't be sure we take the least disruptive course of action. (setq |$functorLocalParameters| (append oldFLP (nreverse nils))) (nreverse ans))))) (let (p x y olde tmp1 pp xp oldFLP yp) - (declare (special |$functorLocalParameters|)) + (declare (special |$functorLocalParameters| |$Boolean|)) (setq p (second item)) (setq x (third item)) (setq y (fourth item)) @@ -10751,9 +11511,6 @@ An angry JHD - August 15th., 1984 \end{chunk} -;mustInstantiate D == -; D is [fn,:.] and ^(member(fn,$DummyFunctorNames) or GET(fn,"makeFunctionList")) - \defun{mustInstantiate}{mustInstantiate} \calls{mustInstantiate}{pairp} \calls{mustInstantiate}{qcar} @@ -10783,37 +11540,6 @@ An angry JHD - August 15th., 1984 \end{chunk} \defun{compColon}{compColon} -\begin{verbatim} -;compColon([":",f,t],m,e) == -; $insideExpressionIfTrue=true => compColonInside(f,m,e,t) -; --if inside an expression, ":" means to convert to m "on faith" -; $lhsOfColon: local:= f -; t:= -; atom t and (t':= ASSOC(t,getDomainsInScope e)) => t' -; isDomainForm(t,e) and not $insideCategoryIfTrue => -; (if not MEMBER(t,getDomainsInScope e) then e:= addDomain(t,e); t) -; isDomainForm(t,e) or isCategoryForm(t,e) => t -; t is ["Mapping",m',:r] => t -; unknownTypeError t -; t -; f is ["LISTOF",:l] => -; (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T) -; e:= -; f is [op,:argl] and not (t is ["Mapping",:.]) => -; --for MPOLY--replace parameters by formal arguments: RDJ 3/83 -; newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList), -; [(x is [":",a,m] => a; x) for x in argl],t) -; signature:= -; ["Mapping",newTarget,: -; [(x is [":",a,m] => m; -; getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]] -; put(op,"mode",signature,e) -; put(f,"mode",t,e) -; if not $bootStrapMode and $insideFunctorIfTrue and -; makeCategoryForm(t,e) is [catform,e] then -; e:= put(f,"value",[genSomeVariable(),t,$noEnv],e) -; ["/throwAway",getmode(f,e),e] -\end{verbatim} \calls{compColon}{compColonInside} \calls{compColon}{assoc} \calls{compColon}{getDomainsInScope} @@ -11500,9 +12226,7 @@ An angry JHD - August 15th., 1984 (|sayBrightly| (cons " compiling " (cons localOrExported (append (|bright| |$op|) (cons ": " formattedSig))))) - (setq tt - (or (catch '|compCapsuleBody| (|compOrCroak| body rettype e)) - (list (intern " " "BOOT") rettype e))) + (setq tt (catch '|compCapsuleBody| (|compOrCroak| body rettype e))) (|NRTassignCapsuleFunctionSlot| |$op| signaturep) ; A THROW to the above CATCH occurs if too many semantic errors occur ; see stackSemanticError @@ -11748,7 +12472,7 @@ is still more than one complain else return the only signature. \calls{getSignature}{printSignature} \calls{getSignature}{SourceLevelSubsume} \calls{getSignature}{stackSemanticError} -\refsdollar{getSignature{e} +\refsdollar{getSignature}{e} \begin{chunk}{defun getSignature} (defun |getSignature| (op argModeList |$e|) (declare (special |$e|)) @@ -13403,14 +14127,6 @@ is still more than one complain else return the only signature. \calls{outputComp}{get} \refsdollar{outputComp}{Expression} \begin{chunk}{defun outputComp} -;outputComp(x,e) == -; u:=comp(['_:_:,x,$Expression],$Expression,e) => u -; x is ['construct,:argl] => -; [['LIST,:[([.,.,e]:=outputComp(x,e)).expr for x in argl]],$Expression,e] -; (v:= get(x,"value",e)) and (v.mode is ['Union,:l]) => -; [['coerceUn2E,x,v.mode],$Expression,e] -; [x,$Expression,e] - (defun |outputComp| (x env) (let (argl v) (declare (special |$Expression|)) @@ -16843,9 +17559,10 @@ IteratorTail: ('repeat' ! / Iterator*) ; \calls{PARSE-Primary1}{PARSE-Expr} \calls{PARSE-Primary1}{PARSE-Sequence} \calls{PARSE-Primary1}{PARSE-Enclosure} -\usesdollar{PARSE-Primary1}{boot} +\refsdollar{PARSE-Primary1}{boot} \begin{chunk}{defun PARSE-Primary1} (defun |PARSE-Primary1| () + (declare (special $boot)) (or (and (|PARSE-VarForm|) (optional (and nonblank (eq (current-symbol) '|(|) @@ -17977,6 +18694,7 @@ equivalent to. \subsection{Floating Point Support} \defun{floatexpid}{floatexpid} +\tpdhere{The use of and in spadreduce is undefined. rewrite this to loop} \seebook{floatexpid}{identp}{5} \seebook{floatexpid}{pname}{5} \calls{floatexpid}{spadreduce} @@ -18143,12 +18861,13 @@ Stack of results of reduced productions. \calls{displayPreCompilationErrors}{sayBrightly} \calls{displayPreCompilationErrors}{nequal} \calls{displayPreCompilationErrors}{sayMath} -\usesdollar{displayPreCompilationErrors}{postStack} -\usesdollar{displayPreCompilationErrors}{topOp} +\refsdollar{displayPreCompilationErrors}{postStack} +\refsdollar{displayPreCompilationErrors}{topOp} +\refsdollar{displayPreCompilationErrors}{InteractiveMode} \begin{chunk}{defun displayPreCompilationErrors} (defun |displayPreCompilationErrors| () (let (n errors heading) - (declare (special |$postStack| |$topOp|)) + (declare (special |$postStack| |$topOp| |$InteractiveMode|)) (setq n (|#| (setq |$postStack| (remdup (nreverse |$postStack|))))) (unless (eql n 0) (setq errors (cond ((> n 1) "errors") (t "error"))) @@ -18189,14 +18908,6 @@ Stack of results of reduced productions. \end{chunk} \defun{parseTranCheckForRecord}{parseTranCheckForRecord} -\begin{verbatim} -;parseTranCheckForRecord(x,op) == -; (x:= parseTran x) is ['Record,:l] => -; or/[y for y in l | y isnt [":",.,.]] => -; postError ['" Constructor",:bright x,'"has missing label"] -; x -; x -\end{verbatim} \calls{parseTranCheckForRecord}{qcar} \calls{parseTranCheckForRecord}{qcdr} \calls{parseTranCheckForRecord}{postError} @@ -18344,8 +19055,10 @@ Stack of results of reduced productions. \end{chunk} \defun{print-package}{print-package} +\refsdollar{print-package}{out-stream} \begin{chunk}{defun print-package} (defun print-package (package) + (declare (special out-stream)) (format out-stream "~&~%(IN-PACKAGE ~S )~%~%" package)) \end{chunk} @@ -20055,27 +20768,6 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} \defun{comp3}{comp3} -\begin{verbatim} -;comp3(x,m,$e) == -; --returns a Triple or %else nil to signalcan't do' -; $e:= addDomain(m,$e) -; e:= $e --for debugging purposes -; m is ["Mapping",:.] => compWithMappingMode(x,m,e) -; m is ["QUOTE",a] => (x=a => [x,m,$e]; nil) -; STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) -; ^x or atom x => compAtom(x,m,e) -; op:= first x -; getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u -; op is ["KAPPA",sig,varlist,body] => compApply(sig,varlist,body,rest x,m,e) -; op=":" => compColon(x,m,e) -; op="::" => compCoerce(x,m,e) -; not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) => -; compTypeOf(x,m,e) -; t:= compExpression(x,m,e) -; t is [x',m',e'] and not MEMBER(m',getDomainsInScope e') => -; [x',m',addDomain(m',e')] -; t -\end{verbatim} \calls{comp3}{addDomain} \calls{comp3}{compWithMappingMode} \calls{comp3}{compAtom} @@ -20224,22 +20916,6 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} \defun{compAtom}{compAtom} -\begin{verbatim} -;compAtom(x,m,e) == -; T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => T -; x="nil" => -; T:= -; modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e) -; modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e) -; T => convert(T,m) -; t:= -; isSymbol x => -; compSymbol(x,m,e) or return nil -; m = $Expression and primitiveType x => [x,m,e] -; STRINGP x => [x,x,e] -; [x,primitiveType x or return nil,e] -; convert(t,m) -\end{verbatim} \calls{compAtom}{compAtomWithModemap} \calls{compAtom}{get} \calls{compAtom}{modeIsAggregateOf} @@ -20386,13 +21062,6 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} \defun{compList}{compList} -\begin{verbatim} -;compList(l,m is ["List",mUnder],e) == -; null l => [NIL,m,e] -; Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] -; Tl="failed" => nil -; T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e] -\end{verbatim} \calls{compList}{comp} \begin{chunk}{defun compList} (defun |compList| (form mode env) @@ -20877,116 +21546,6 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} \defun{compWithMappingMode1}{compWithMappingMode1} -\begin{verbatim} -;compWithMappingMode1(x,m is ["Mapping",m',:sl],oldE,$formalArgList) == -; $killOptimizeIfTrue: local:= true -; e:= oldE -; isFunctor x => -; if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and -; (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl] -; ) and extendsCategoryForm("$",target,m') then return [x,m,e] -; if STRINGP x then x:= INTERN x -; ress:=nil -; old_style:=true -; if x is ["+->",vl,nx] then -; old_style:=false -; vl is [":",:.] => -; ress:=compLambda(x,m,oldE) -; ress -; vl:= -; vl is ["Tuple",:vl1] => vl1 -; vl -; vl:= -; SYMBOLP(vl) => [vl] -; LISTP(vl) and (and/[SYMBOLP(v) for v in vl]) => vl -; stackAndThrow ["bad +-> arguments:",vl] -; $formatArgList:=[:vl,:$formalArgList] -; x:=nx -; else -; vl:=take(#sl,$FormalMapVariableList) -; ress => ress -; for m in sl for v in vl repeat -; [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) -; old_style and not null vl and not hasFormalMapVariable(x, vl) => return -; [u,.,.] := comp([x,:vl],m',e) or return nil -; extractCodeAndConstructTriple(u, m, oldE) -; null vl and (t := comp([x], m', e)) => return -; [u,.,.] := t -; extractCodeAndConstructTriple(u, m, oldE) -; [u,.,.]:= comp(x,m',e) or return nil -; uu:=optimizeFunctionDef [nil,['LAMBDA,vl,u]] -; -- At this point, we have a function that we would like to pass. -; -- Unfortunately, it makes various free variable references outside -; -- itself. So we build a mini-vector that contains them all, and -; -- pass this as the environment to our inner function. -; $FUNNAME :local := nil -; $FUNNAME__TAIL :local := [nil] -; expandedFunction:=COMP_-TRAN CADR uu -; frees:=freelist(expandedFunction,vl,nil,e) -; where freelist(u,bound,free,e) == -; atom u => -; not IDENTP u => free -; MEMQ(u,bound) => free -; v:=ASSQ(u,free) => -; RPLACD(v,1+CDR v) -; free -; not getmode(u, e) => free -; [[u,:1],:free] -; op:=CAR u -; MEMQ(op, '(QUOTE GO function)) => free -; EQ(op,'LAMBDA) => -; bound:=UNIONQ(bound,CADR u) -; for v in CDDR u repeat -; free:=freelist(v,bound,free,e) -; free -; EQ(op,'PROG) => -; bound:=UNIONQ(bound,CADR u) -; for v in CDDR u | NOT ATOM v repeat -; free:=freelist(v,bound,free,e) -; free -; EQ(op,'SEQ) => -; for v in CDR u | NOT ATOM v repeat -; free:=freelist(v,bound,free,e) -; free -; EQ(op,'COND) => -; for v in CDR u repeat -; for vv in v repeat -; free:=freelist(vv,bound,free,e) -; free -; if ATOM op then u:=CDR u --Atomic functions aren't descended -; for v in u repeat -; free:=freelist(v,bound,free,e) -; free -; expandedFunction := -; --One free can go by itself, more than one needs a vector -; --An A-list name . number of times used -; #frees = 0 => ['LAMBDA,[:vl,"$$"], :CDDR expandedFunction] -; #frees = 1 => -; vec:=first first frees -; ['LAMBDA,[:vl,vec], :CDDR expandedFunction] -; scode:=nil -; vec:=nil -; locals:=nil -; i:=-1 -; for v in frees repeat -; i:=i+1 -; vec:=[first v,:vec] -; scode:=[['SETQ,first v,[($QuickCode => 'QREFELT;'ELT),"$$",i]],:scode] -; locals:=[first v,:locals] -; body:=CDDR expandedFunction -; if locals then -; if body is [['DECLARE,:.],:.] then -; body:=[CAR body,['PROG,locals,:scode,['RETURN,['PROGN,:CDR body]]]] -; else body:=[['PROG,locals,:scode,['RETURN,['PROGN,:body]]]] -; vec:=['VECTOR,:NREVERSE vec] -; ['LAMBDA,[:vl,"$$"],:body] -; fname:=['CLOSEDFN,expandedFunction] -; --Like QUOTE, but gets compiled -; uu:= -; frees => ['CONS,fname,vec] -; ['LIST,fname] -; [uu,m,oldE] -\end{verbatim} \calls{compWithMappingMode1}{isFunctor} \calls{compWithMappingMode1}{get} \calls{compWithMappingMode1}{qcar} @@ -21717,9 +22276,10 @@ The current input line. \defun{next-line}{next-line} \refsdollar{next-line}{in-stream} +\refsdollar{next-line}{line-handler} \begin{chunk}{defun next-line} (defun next-line (&optional (in-stream t)) - (declare (special in-stream)) + (declare (special in-stream line-handler)) (funcall Line-Handler in-stream)) \end{chunk} @@ -21824,6 +22384,7 @@ The current input line. \getchunk{defun aplTranList} \getchunk{defun argsToSig} \getchunk{defun assignError} +\getchunk{defun AssocBarGensym} \getchunk{defun augLisplibModemapsFromCategory} \getchunk{defun augmentLisplibModemapsFromFunctor} \getchunk{defun augModemapsFromCategory} @@ -21914,6 +22475,7 @@ The current input line. \getchunk{defun compilerDoitWithScreenedLisplib} \getchunk{defun compileSpad2Cmd} \getchunk{defun compileSpadLispCmd} +\getchunk{defun compileTimeBindingOf} \getchunk{defun compImport} \getchunk{defun compInternalFunction} \getchunk{defun compIs} @@ -21980,6 +22542,7 @@ The current input line. \getchunk{defun eltModemapFilter} \getchunk{defun encodeItem} \getchunk{defun encodeFunctionName} +\getchunk{defun EqualBarGensym} \getchunk{defun errhuh} \getchunk{defun escape-keywords} \getchunk{defun escaped} @@ -22115,9 +22678,32 @@ The current input line. \getchunk{defun new2OldLisp} \getchunk{defun nonblankloc} +\getchunk{defun optCall} +\getchunk{defun optCallEval} +\getchunk{defun optCallSpecially} +\getchunk{defun optCatch} +\getchunk{defun optCond} +\getchunk{defun optCONDtail} +\getchunk{defun optEQ} +\getchunk{defun optIF2COND} \getchunk{defun optimize} \getchunk{defun optimizeFunctionDef} \getchunk{defun optional} +\getchunk{defun optLESSP} +\getchunk{defun optMINUS} +\getchunk{defun optMkRecord} +\getchunk{defun optPackageCall} +\getchunk{defun optPredicateIfTrue} +\getchunk{defun optQSMINUS} +\getchunk{defun optRECORDCOPY} +\getchunk{defun optRECORDELT} +\getchunk{defun optSETRECORDELT} +\getchunk{defun optSEQ} +\getchunk{defun optSPADCALL} +\getchunk{defun optSpecialCall} +\getchunk{defun optSuchthat} +\getchunk{defun optXLAMCond} +\getchunk{defun opt-} \getchunk{defun orderByDependency} \getchunk{defun orderPredicateItems} \getchunk{defun orderPredTran} diff --git a/changelog b/changelog index 5506f5a..6f8a1e8 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,8 @@ +20110905 jxc src/axiom-website/patches.html 20110905.02.tpd.patch +20110905 tpd src/interp/Makefile remove g-opt.lisp +20110905 tpd src/interp/g-opt.lisp removed +20110905 tpd src/interp/vmlisp.lisp treeshake compiler +20110905 tpd books/bookvol9 treeshake compiler 20110905 jxc src/axiom-website/patches.html 20110905.01.jxc.patch 20110905 jxc src/axiom-website/download.html add Gentoo notes by James Cloos 20110905 jxc books/bookvol5 add James Cloos to credits diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 8d8ff77..2ba6237 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3608,5 +3608,7 @@ books/bookvol9 treeshake compiler
books/bookvolbib add Kendall Ken99a, Ken99b
20110905.01.jxc.patch src/axiom-website/download.html add Gentoo notes by James Cloos
+20110905.02.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 493e99a..31bfbb0 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -145,7 +145,7 @@ OBJS= ${OUT}/vmlisp.${O} \ ${OUT}/compress.${O} \ ${OUT}/format.${O} \ ${OUT}/g-boot.${O} ${OUT}/g-cndata.${O} \ - ${OUT}/g-error.${O} ${OUT}/g-opt.${O} \ + ${OUT}/g-error.${O} \ ${OUT}/g-timer.${O} ${OUT}/g-util.${O} \ ${OUT}/http.${O} \ ${OUT}/hypertex.${O} ${OUT}/i-analy.${O} \ @@ -1792,30 +1792,6 @@ ${MID}/g-error.lisp: ${IN}/g-error.lisp.pamphlet @ -\subsection{g-opt.lisp} -<>= -${OUT}/g-opt.${O}: ${MID}/g-opt.lisp - @ echo 136 making ${OUT}/g-opt.${O} from ${MID}/g-opt.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/g-opt.lisp"' \ - ':output-file "${OUT}/g-opt.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/g-opt.lisp"' \ - ':output-file "${OUT}/g-opt.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/g-opt.lisp: ${IN}/g-opt.lisp.pamphlet - @ echo 137 making ${MID}/g-opt.lisp from ${IN}/g-opt.lisp.pamphlet - @ (cd ${MID} ; \ - echo '(tangle "${IN}/g-opt.lisp.pamphlet" "*" "g-opt.lisp")' \ - | ${OBJ}/${SYS}/bin/lisp ) - -@ - \subsection{g-timer.lisp} <>= ${OUT}/g-timer.${O}: ${MID}/g-timer.lisp @@ -3173,9 +3149,6 @@ clean: <> <> -<> -<> - <> <> diff --git a/src/interp/g-opt.lisp.pamphlet b/src/interp/g-opt.lisp.pamphlet deleted file mode 100644 index ce3dc60..0000000 --- a/src/interp/g-opt.lisp.pamphlet +++ /dev/null @@ -1,1369 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp g-opt.lisp} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{chunk}{*} - -(IN-PACKAGE "BOOT" ) - -;--% OPTIMIZER -; -; -;optCatch (x is ["CATCH",g,a]) == -; $InteractiveMode => x -; atom a => a -; if a is ["SEQ",:s,["THROW", =g,u]] then -; changeThrowToExit(s,g) where -; changeThrowToExit(s,g) == -; atom s or MEMQ(first s,'(QUOTE SEQ REPEAT COLLECT)) => nil -; s is ["THROW", =g,:u] => (rplac(first s,"EXIT"); rplac(rest s,u)) -; changeThrowToExit(first s,g) -; changeThrowToExit(rest s,g) -; rplac(rest a,[:s,["EXIT",u]]) -; ["CATCH",y,a]:= optimize x -; if hasNoThrows(a,g) -; then (rplac(first x,first a); rplac(rest x,rest a)) where -; hasNoThrows(a,g) == -; a is ["THROW", =g,:.] => false -; atom a => true -; hasNoThrows(first a,g) and hasNoThrows(rest a,g) -; else -; changeThrowToGo(a,g) where -; changeThrowToGo(s,g) == -; atom s or first s='QUOTE => nil -; s is ["THROW", =g,u] => -; changeThrowToGo(u,g) -; rplac(first s,"PROGN") -; rplac(rest s,[["LET",CADR g,u],["GO",CADR g]]) -; changeThrowToGo(first s,g) -; changeThrowToGo(rest s,g) -; rplac(first x,"SEQ") -; rplac(rest x,[["EXIT",a],CADR g,["EXIT",CADR g]]) -; x - -(DEFUN |optCatch,changeThrowToExit| (|s| |g|) - (PROG (|ISTMP#1| |u|) - (RETURN - (SEQ (IF (OR (ATOM |s|) - (member (CAR |s|) '(QUOTE SEQ REPEAT COLLECT))) - (EXIT NIL)) - (IF (AND (PAIRP |s|) (EQ (QCAR |s|) 'THROW) - (PROGN - (SPADLET |ISTMP#1| (QCDR |s|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |g|) - (PROGN (SPADLET |u| (QCDR |ISTMP#1|)) 'T)))) - (EXIT (SEQ (|rplac| (CAR |s|) 'EXIT) - (EXIT (|rplac| (CDR |s|) |u|))))) - (|optCatch,changeThrowToExit| (CAR |s|) |g|) - (EXIT (|optCatch,changeThrowToExit| (CDR |s|) |g|)))))) - -(DEFUN |optCatch,hasNoThrows| (|a| |g|) - (PROG (|ISTMP#1|) - (RETURN - (SEQ (IF (AND (PAIRP |a|) (EQ (QCAR |a|) 'THROW) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |g|)))) - (EXIT NIL)) - (IF (ATOM |a|) (EXIT 'T)) - (EXIT (AND (|optCatch,hasNoThrows| (CAR |a|) |g|) - (|optCatch,hasNoThrows| (CDR |a|) |g|))))))) - -(DEFUN |optCatch,changeThrowToGo| (|s| |g|) - (PROG (|ISTMP#1| |ISTMP#2| |u|) - (RETURN - (SEQ (IF (OR (ATOM |s|) (BOOT-EQUAL (CAR |s|) 'QUOTE)) - (EXIT NIL)) - (IF (AND (PAIRP |s|) (EQ (QCAR |s|) 'THROW) - (PROGN - (SPADLET |ISTMP#1| (QCDR |s|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |g|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |u| (QCAR |ISTMP#2|)) - 'T)))))) - (EXIT (SEQ (|optCatch,changeThrowToGo| |u| |g|) - (|rplac| (CAR |s|) 'PROGN) - (EXIT (|rplac| (CDR |s|) - (CONS - (CONS 'LET - (CONS (CADR |g|) - (CONS |u| NIL))) - (CONS - (CONS 'GO - (CONS (CADR |g|) NIL)) - NIL))))))) - (|optCatch,changeThrowToGo| (CAR |s|) |g|) - (EXIT (|optCatch,changeThrowToGo| (CDR |s|) |g|)))))) - -(DEFUN |optCatch| (|x|) - (PROG (|g| |ISTMP#1| |ISTMP#2| |ISTMP#3| |ISTMP#4| |ISTMP#5| |u| |s| - |LETTMP#1| |y| |a|) - (DECLARE (SPECIAL |$InteractiveMode|)) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR |x|) 'CATCH) (CAR |x|))) - (SPADLET |g| (CADR |x|)) - (SPADLET |a| (CADDR |x|)) - (COND - (|$InteractiveMode| |x|) - ((ATOM |a|) |a|) - ('T - (COND - ((AND (PAIRP |a|) (EQ (QCAR |a|) 'SEQ) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (REVERSE |ISTMP#1|)) - 'T) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) 'THROW) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQUAL (QCAR |ISTMP#4|) |g|) - (PROGN - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |u| - (QCAR |ISTMP#5|)) - 'T))))))) - (PROGN - (SPADLET |s| (QCDR |ISTMP#2|)) - 'T) - (PROGN (SPADLET |s| (NREVERSE |s|)) 'T)))) - (|optCatch,changeThrowToExit| |s| |g|) - (|rplac| (CDR |a|) - (APPEND |s| - (CONS (CONS 'EXIT (CONS |u| NIL)) - NIL))) - (SPADLET |LETTMP#1| (|optimize| |x|)) - (COND - ((EQ (CAR |LETTMP#1|) 'CATCH) (CAR |LETTMP#1|))) - (SPADLET |y| (CADR |LETTMP#1|)) - (SPADLET |a| (CADDR |LETTMP#1|)) |LETTMP#1|)) - (COND - ((|optCatch,hasNoThrows| |a| |g|) - (|rplac| (CAR |x|) (CAR |a|)) - (|rplac| (CDR |x|) (CDR |a|))) - ('T (|optCatch,changeThrowToGo| |a| |g|) - (|rplac| (CAR |x|) 'SEQ) - (|rplac| (CDR |x|) - (CONS (CONS 'EXIT (CONS |a| NIL)) - (CONS (CADR |g|) - (CONS - (CONS 'EXIT - (CONS (CADR |g|) NIL)) - NIL)))))) - |x|))))))) - -;optSPADCALL(form is ['SPADCALL,:argl]) == -; null $InteractiveMode => form -; -- last arg is function/env, but may be a form -; argl is [:argl,fun] => -; fun is ['ELT,dom,slot] or fun is ['LISPELT,dom,slot] => -; optCall ['call,['ELT,dom,slot],:argl] -; form -; form - -(DEFUN |optSPADCALL| (|form|) - (PROG (|fun| |argl| |ISTMP#1| |dom| |ISTMP#2| |slot|) - (DECLARE (SPECIAL |$InteractiveMode|)) - (RETURN - (PROGN - (SPADLET |argl| (CDR |form|)) - (COND - ((NULL |$InteractiveMode|) |form|) - ((AND (PAIRP |argl|) - (PROGN (SPADLET |ISTMP#1| (REVERSE |argl|)) 'T) - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |fun| (QCAR |ISTMP#1|)) - (SPADLET |argl| (QCDR |ISTMP#1|)) - 'T) - (PROGN (SPADLET |argl| (NREVERSE |argl|)) 'T)) - (COND - ((OR (AND (PAIRP |fun|) (EQ (QCAR |fun|) 'ELT) - (PROGN - (SPADLET |ISTMP#1| (QCDR |fun|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |dom| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |slot| - (QCAR |ISTMP#2|)) - 'T)))))) - (AND (PAIRP |fun|) (EQ (QCAR |fun|) 'LISPELT) - (PROGN - (SPADLET |ISTMP#1| (QCDR |fun|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |dom| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |slot| - (QCAR |ISTMP#2|)) - 'T))))))) - (|optCall| - (CONS '|call| - (CONS (CONS 'ELT - (CONS |dom| (CONS |slot| NIL))) - |argl|)))) - ('T |form|))) - ('T |form|)))))) - -;optCall (x is ["call",:u]) == -; -- destructively optimizes this new x -; x:= optimize [u] -; -- next should happen only as result of macro expansion -; atom first x => first x -; [fn,:a]:= first x -; atom fn => (RPLAC(rest x,a); RPLAC(first x,fn)) -; fn is ["PAC",:.] => optPackageCall(x,fn,a) -; fn is ["applyFun",name] => -; (RPLAC(first x,"SPADCALL"); RPLAC(rest x,[:a,name]); x) -; fn is [q,R,n] and MEMQ(q,'(ELT QREFELT CONST)) => -; not $bootStrapMode and (w:= optCallSpecially(q,x,n,R)) => w -; q="CONST" => -;--+ -; ["spadConstant",R,n] -; --putInLocalDomainReferences will change this to ELT or QREFELT -; RPLAC(first x,"SPADCALL") -; if $QuickCode then RPLACA(fn,"QREFELT") -; RPLAC(rest x,[:a,fn]) -; x -; systemErrorHere '"optCall" - -(DEFUN |optCall| (|x|) - (PROG (|u| |LETTMP#1| |fn| |a| |name| |q| |ISTMP#1| R |ISTMP#2| |n| - |w|) - (DECLARE (SPECIAL |$QuickCode| |$bootStrapMode|)) - (RETURN - (PROGN - (COND ((EQ (CAR |x|) '|call|) (CAR |x|))) - (SPADLET |u| (CDR |x|)) - (SPADLET |x| (|optimize| (CONS |u| NIL))) - (COND - ((ATOM (CAR |x|)) (CAR |x|)) - ('T (SPADLET |LETTMP#1| (CAR |x|)) - (SPADLET |fn| (CAR |LETTMP#1|)) - (SPADLET |a| (CDR |LETTMP#1|)) - (COND - ((ATOM |fn|) (RPLAC (CDR |x|) |a|) (RPLAC (CAR |x|) |fn|)) - ((AND (PAIRP |fn|) (EQ (QCAR |fn|) 'PAC)) - (|optPackageCall| |x| |fn| |a|)) - ((AND (PAIRP |fn|) (EQ (QCAR |fn|) '|applyFun|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |fn|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |name| (QCAR |ISTMP#1|)) 'T)))) - (RPLAC (CAR |x|) 'SPADCALL) - (RPLAC (CDR |x|) (APPEND |a| (CONS |name| NIL))) |x|) - ((AND (PAIRP |fn|) - (PROGN - (SPADLET |q| (QCAR |fn|)) - (SPADLET |ISTMP#1| (QCDR |fn|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET R (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |n| (QCAR |ISTMP#2|)) - 'T))))) - (member |q| '(ELT QREFELT CONST))) - (COND - ((AND (NULL |$bootStrapMode|) - (SPADLET |w| (|optCallSpecially| |q| |x| |n| R))) - |w|) - ((BOOT-EQUAL |q| 'CONST) - (CONS '|spadConstant| (CONS R (CONS |n| NIL)))) - ('T (RPLAC (CAR |x|) 'SPADCALL) - (COND (|$QuickCode| (RPLACA |fn| 'QREFELT))) - (RPLAC (CDR |x|) (APPEND |a| (CONS |fn| NIL))) |x|))) - ('T (|systemErrorHere| "optCall"))))))))) - -;optPackageCall(x,["PAC",packageVariableOrForm,functionName],arglist) == -; RPLACA(x,functionName) -; RPLACD(x,[:arglist,packageVariableOrForm]) -; x - -(DEFUN |optPackageCall| (|x| G166589 |arglist|) - (PROG (|packageVariableOrForm| |functionName|) - (RETURN - (PROGN - (COND ((EQ (CAR G166589) 'PAC) (CAR G166589))) - (SPADLET |packageVariableOrForm| (CADR G166589)) - (SPADLET |functionName| (CADDR G166589)) - (RPLACA |x| |functionName|) - (RPLACD |x| - (APPEND |arglist| (CONS |packageVariableOrForm| NIL))) - |x|)))) - -;optCallSpecially(q,x,n,R) == -; y:= LASSOC(R,$specialCaseKeyList) => optSpecialCall(x,y,n) -; MEMQ(KAR R,$optimizableConstructorNames) => optSpecialCall(x,R,n) -; (y:= get(R,"value",$e)) and -; MEMQ(opOf y.expr,$optimizableConstructorNames) => -; optSpecialCall(x,y.expr,n) -; ( -; (y:= lookup(R,$getDomainCode)) and ([op,y,prop]:= y) and -; (yy:= LASSOC(y,$specialCaseKeyList)) => -; optSpecialCall(x,[op,yy,prop],n)) where -; lookup(a,l) == -; null l => nil -; [l',:l]:= l -; l' is ["LET", =a,l',:.] => l' -; lookup(a,l) -; nil - -(DEFUN |optCallSpecially,lookup| (|a| |l|) - (PROG (|LETTMP#1| |ISTMP#1| |ISTMP#2| |l'|) - (RETURN - (SEQ (IF (NULL |l|) (EXIT NIL)) - (PROGN - (SPADLET |LETTMP#1| |l|) - (SPADLET |l'| (CAR |LETTMP#1|)) - (SPADLET |l| (CDR |LETTMP#1|)) - |LETTMP#1|) - (IF (AND (PAIRP |l'|) (EQ (QCAR |l'|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |l'|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |a|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |l'| (QCAR |ISTMP#2|)) - 'T)))))) - (EXIT |l'|)) - (EXIT (|optCallSpecially,lookup| |a| |l|)))))) - -(DEFUN |optCallSpecially| (|q| |x| |n| R) - (declare (ignore |q|)) - (PROG (|LETTMP#1| |op| |y| |prop| |yy|) - (DECLARE (SPECIAL |$specialCaseKeyList| |$getDomainCode| |$e| - |$optimizableConstructorNames|)) - (RETURN - (COND - ((SPADLET |y| (LASSOC R |$specialCaseKeyList|)) - (|optSpecialCall| |x| |y| |n|)) - ((member (KAR R) |$optimizableConstructorNames|) - (|optSpecialCall| |x| R |n|)) - ((AND (SPADLET |y| (|get| R '|value| |$e|)) - (member (|opOf| (CAR |y|)) |$optimizableConstructorNames|)) - (|optSpecialCall| |x| (CAR |y|) |n|)) - ((AND (SPADLET |y| - (|optCallSpecially,lookup| R |$getDomainCode|)) - (PROGN - (SPADLET |LETTMP#1| |y|) - (SPADLET |op| (CAR |LETTMP#1|)) - (SPADLET |y| (CADR |LETTMP#1|)) - (SPADLET |prop| (CADDR |LETTMP#1|)) - |LETTMP#1|) - (SPADLET |yy| (LASSOC |y| |$specialCaseKeyList|))) - (|optSpecialCall| |x| - (CONS |op| (CONS |yy| (CONS |prop| NIL))) |n|)) - ('T NIL))))) - -;optCallEval u == -; u is ["List",:.] => List Integer() -; u is ["Vector",:.] => Vector Integer() -; u is ["PrimitiveArray",:.] => PrimitiveArray Integer() -; u is ["FactoredForm",:.] => FactoredForm Integer() -; u is ["Matrix",:.] => Matrix Integer() -; eval u - -(DEFUN |optCallEval| (|u|) - (COND - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|List|)) (|List| (|Integer|))) - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|Vector|)) - (|Vector| (|Integer|))) - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|PrimitiveArray|)) - (|PrimitiveArray| (|Integer|))) - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|FactoredForm|)) - (|FactoredForm| (|Integer|))) - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|Matrix|)) - (|Matrix| (|Integer|))) - ('T (|eval| |u|)))) - -;optCons (x is ["CONS",a,b]) == -; a="NIL" => -; b='NIL => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:'NIL]); x) -; b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:c]); x) -; x -; a is ['QUOTE,a'] => -; b='NIL => (rplac(first x,'QUOTE); rplac(rest x,[a',:'NIL]); x) -; b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,[a',:c]); x) -; x -; x - -(DEFUN |optCons| (|x|) - (PROG (|a| |b| |ISTMP#1| |a'| |c|) - (RETURN - (PROGN - (COND ((EQ (CAR |x|) 'CONS) (CAR |x|))) - (SPADLET |a| (CADR |x|)) - (SPADLET |b| (CADDR |x|)) - (COND - ((BOOT-EQUAL |a| 'NIL) - (COND - ((BOOT-EQUAL |b| 'NIL) (|rplac| (CAR |x|) 'QUOTE) - (|rplac| (CDR |x|) (CONS 'NIL 'NIL)) |x|) - ((AND (PAIRP |b|) (EQ (QCAR |b|) 'QUOTE) - (PROGN (SPADLET |c| (QCDR |b|)) 'T)) - (|rplac| (CAR |x|) 'QUOTE) - (|rplac| (CDR |x|) (CONS 'NIL |c|)) |x|) - ('T |x|))) - ((AND (PAIRP |a|) (EQ (QCAR |a|) 'QUOTE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a'| (QCAR |ISTMP#1|)) 'T)))) - (COND - ((BOOT-EQUAL |b| 'NIL) (|rplac| (CAR |x|) 'QUOTE) - (|rplac| (CDR |x|) (CONS |a'| 'NIL)) |x|) - ((AND (PAIRP |b|) (EQ (QCAR |b|) 'QUOTE) - (PROGN (SPADLET |c| (QCDR |b|)) 'T)) - (|rplac| (CAR |x|) 'QUOTE) - (|rplac| (CDR |x|) (CONS |a'| |c|)) |x|) - ('T |x|))) - ('T |x|)))))) - -;optSpecialCall(x,y,n) == -; yval := optCallEval y -; CAAAR x="CONST" => -; KAR yval.n = function Undef => -; keyedSystemError("S2GE0016",['"optSpecialCall", -; '"invalid constant"]) -; MKQ yval.n -; fn := GET(compileTimeBindingOf first yval.n,'SPADreplace) => -; rplac(rest x,CDAR x) -; rplac(first x,fn) -; if fn is ["XLAM",:.] then x:=first optimize [x] -; x is ["EQUAL",:args] => RPLACW(x,DEF_-EQUAL args) -; --DEF-EQUAL is really an optimiser -; x -; [fn,:a]:= first x -; RPLAC(first x,"SPADCALL") -; if $QuickCode then RPLACA(fn,"QREFELT") -; RPLAC(rest x,[:a,fn]) -; x - -(DEFUN |optSpecialCall| (|x| |y| |n|) - (PROG (|yval| |args| |LETTMP#1| |fn| |a|) - (DECLARE (SPECIAL |$QuickCode|)) - (RETURN - (PROGN - (SPADLET |yval| (|optCallEval| |y|)) - (COND - ((BOOT-EQUAL (CAAAR |x|) 'CONST) - (COND - ((BOOT-EQUAL (KAR (ELT |yval| |n|)) (|function| |Undef|)) - (|keyedSystemError| 'S2GE0016 - (CONS "optSpecialCall" (CONS "invalid constant" NIL)))) - ('T (MKQ (ELT |yval| |n|))))) - ((SPADLET |fn| - (GETL (|compileTimeBindingOf| - (CAR (ELT |yval| |n|))) - '|SPADreplace|)) - (|rplac| (CDR |x|) (CDAR |x|)) (|rplac| (CAR |x|) |fn|) - (COND - ((AND (PAIRP |fn|) (EQ (QCAR |fn|) 'XLAM)) - (SPADLET |x| (CAR (|optimize| (CONS |x| NIL)))))) - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'EQUAL) - (PROGN (SPADLET |args| (QCDR |x|)) 'T)) - (RPLACW |x| (DEF-EQUAL |args|))) - ('T |x|))) - ('T (SPADLET |LETTMP#1| (CAR |x|)) - (SPADLET |fn| (CAR |LETTMP#1|)) - (SPADLET |a| (CDR |LETTMP#1|)) (RPLAC (CAR |x|) 'SPADCALL) - (COND (|$QuickCode| (RPLACA |fn| 'QREFELT))) - (RPLAC (CDR |x|) (APPEND |a| (CONS |fn| NIL))) |x|)))))) - -;compileTimeBindingOf u == -; NULL(name:= BPINAME u) => keyedSystemError("S2OO0001",[u]) -; name="Undef" => MOAN "optimiser found unknown function" -; name - -(DEFUN |compileTimeBindingOf| (|u|) - (PROG (|name|) - (RETURN - (COND - ((NULL (SPADLET |name| (BPINAME |u|))) - (|keyedSystemError| 'S2OO0001 (CONS |u| NIL))) - ((BOOT-EQUAL |name| '|Undef|) - (MOAN "optimiser found unknown function")) - ('T |name|))))) - -;optMkRecord ["mkRecord",:u] == -; u is [x] => ["LIST",x] -; #u=2 => ["CONS",:u] -; ["VECTOR",:u] - -(DEFUN |optMkRecord| (G166580) - (PROG (|u| |x|) - (RETURN - (PROGN - (COND ((EQ (CAR G166580) '|mkRecord|) (CAR G166580))) - (SPADLET |u| (CDR G166580)) - (COND - ((AND (PAIRP |u|) (EQ (QCDR |u|) NIL) - (PROGN (SPADLET |x| (QCAR |u|)) 'T)) - (CONS 'LIST (CONS |x| NIL))) - ((EQL (|#| |u|) 2) (CONS 'CONS |u|)) - ('T (CONS 'VECTOR |u|))))))) - -;optCond (x is ['COND,:l]) == -; if l is [a,[aa,b]] and TruthP aa and b is ["COND",:c] then -; RPLACD(rest x,c) -; if l is [[p1,:c1],[p2,:c2],:.] then -; if (p1 is ['NULL,p1'] and p1' = p2) or (p2 is ['NULL,p2'] and p2' = p1) then -; l:=[[p1,:c1],['(QUOTE T),:c2]] -; RPLACD( x,l) -; c1 is ['NIL] and p2 = '(QUOTE T) and first c2 = '(QUOTE T) => -; p1 is ['NULL,p1']=> return p1' -; return ['NULL,p1] -; l is [[p1,:c1],[p2,:c2],[p3,:c3]] and TruthP p3 => -; EqualBarGensym(c1,c3) => -; ["COND",[["OR",p1,["NULL",p2]],:c1],[['QUOTE,true],:c2]] -; EqualBarGensym(c1,c2) => ["COND",[["OR",p1,p2],:c1],[['QUOTE,true],:c3]] -; x -; for y in tails l repeat -; while y is [[a1,c1],[a2,c2],:y'] and EqualBarGensym(c1,c2) repeat -; a:=['OR,a1,a2] -; RPLAC(first first y,a) -; RPLAC(rest y,y') -; x - -(DEFUN |optCond| (|x|) - (PROG (|aa| |b| |c| |p2'| |l| |p1'| |p1| |p2| |p3| |c3| |ISTMP#1| - |a1| |ISTMP#2| |c1| |ISTMP#3| |ISTMP#4| |a2| |ISTMP#5| - |c2| |y'| |a|) - (RETURN - (SEQ (PROGN - (SPADLET |l| (CDR |x|)) - (COND - ((AND (PAIRP |l|) - (PROGN - (SPADLET |a| (QCAR |l|)) - (SPADLET |ISTMP#1| (QCDR |l|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |aa| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#3|)) - 'T))))))) - (|TruthP| |aa|) (PAIRP |b|) (EQ (QCAR |b|) 'COND) - (PROGN (SPADLET |c| (QCDR |b|)) 'T)) - (RPLACD (CDR |x|) |c|))) - (COND - ((AND (PAIRP |l|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |l|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |p1| (QCAR |ISTMP#1|)) - (SPADLET |c1| (QCDR |ISTMP#1|)) - 'T))) - (PROGN - (SPADLET |ISTMP#2| (QCDR |l|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |p2| (QCAR |ISTMP#3|)) - (SPADLET |c2| (QCDR |ISTMP#3|)) - 'T)))))) - (COND - ((OR (AND (PAIRP |p1|) (EQ (QCAR |p1|) 'NULL) - (PROGN - (SPADLET |ISTMP#1| (QCDR |p1|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |p1'| (QCAR |ISTMP#1|)) - 'T))) - (BOOT-EQUAL |p1'| |p2|)) - (AND (PAIRP |p2|) (EQ (QCAR |p2|) 'NULL) - (PROGN - (SPADLET |ISTMP#1| (QCDR |p2|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |p2'| (QCAR |ISTMP#1|)) - 'T))) - (BOOT-EQUAL |p2'| |p1|))) - (SPADLET |l| - (CONS (CONS |p1| |c1|) - (CONS (CONS ''T |c2|) NIL))) - (RPLACD |x| |l|))) - (COND - ((AND (PAIRP |c1|) (EQ (QCDR |c1|) NIL) - (EQUAL (QCAR |c1|) 'NIL) (BOOT-EQUAL |p2| ''T) - (BOOT-EQUAL (CAR |c2|) ''T)) - (COND - ((AND (PAIRP |p1|) (EQ (QCAR |p1|) 'NULL) - (PROGN - (SPADLET |ISTMP#1| (QCDR |p1|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |p1'| (QCAR |ISTMP#1|)) - 'T)))) - (RETURN |p1'|)) - ('T (RETURN (CONS 'NULL (CONS |p1| NIL))))))))) - (COND - ((AND (PAIRP |l|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |l|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |p1| (QCAR |ISTMP#1|)) - (SPADLET |c1| (QCDR |ISTMP#1|)) - 'T))) - (PROGN - (SPADLET |ISTMP#2| (QCDR |l|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |p2| (QCAR |ISTMP#3|)) - (SPADLET |c2| (QCDR |ISTMP#3|)) - 'T))) - (PROGN - (SPADLET |ISTMP#4| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) - (PROGN - (SPADLET |ISTMP#5| - (QCAR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (PROGN - (SPADLET |p3| (QCAR |ISTMP#5|)) - (SPADLET |c3| (QCDR |ISTMP#5|)) - 'T))))))) - (|TruthP| |p3|)) - (COND - ((|EqualBarGensym| |c1| |c3|) - (CONS 'COND - (CONS (CONS (CONS 'OR - (CONS |p1| - (CONS - (CONS 'NULL (CONS |p2| NIL)) - NIL))) - |c1|) - (CONS (CONS (CONS 'QUOTE (CONS 'T NIL)) - |c2|) - NIL)))) - ((|EqualBarGensym| |c1| |c2|) - (CONS 'COND - (CONS (CONS (CONS 'OR - (CONS |p1| (CONS |p2| NIL))) - |c1|) - (CONS (CONS (CONS 'QUOTE (CONS 'T NIL)) - |c3|) - NIL)))) - ('T |x|))) - ('T - (DO ((|y| |l| (CDR |y|))) ((ATOM |y|) NIL) - (SEQ (EXIT (DO () - ((NULL (AND (PAIRP |y|) - (PROGN - (SPADLET |ISTMP#1| - (QCAR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a1| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (SPADLET |c1| - (QCAR |ISTMP#2|)) - 'T))))) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |y|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCAR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |a2| - (QCAR |ISTMP#4|)) - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) - NIL) - (PROGN - (SPADLET |c2| - (QCAR |ISTMP#5|)) - 'T))))) - (PROGN - (SPADLET |y'| - (QCDR |ISTMP#3|)) - 'T))) - (|EqualBarGensym| |c1| |c2|))) - NIL) - (SEQ (EXIT - (PROGN - (SPADLET |a| - (CONS 'OR - (CONS |a1| (CONS |a2| NIL)))) - (RPLAC (CAR (CAR |y|)) |a|) - (RPLAC (CDR |y|) |y'|)))))))) - |x|))))))) - -;AssocBarGensym(key,l) == -; for x in l repeat -; PAIRP x => -; EqualBarGensym(key,CAR x) => return x - -(DEFUN |AssocBarGensym| (|key| |l|) - (PROG () - (RETURN - (SEQ (DO ((G166925 |l| (CDR G166925)) (|x| NIL)) - ((OR (ATOM G166925) - (PROGN (SETQ |x| (CAR G166925)) NIL)) - NIL) - (SEQ (EXIT (COND - ((PAIRP |x|) - (EXIT (COND - ((|EqualBarGensym| |key| (CAR |x|)) - (EXIT (RETURN |x|)))))))))))))) - -;EqualBarGensym(x,y) == -; $GensymAssoc: nil -; fn(x,y) where -; fn(x,y) == -; x=y => true -; GENSYMP x and GENSYMP y => -; z:= ASSOC(x,$GensymAssoc) => (y=rest z => true; false) -; $GensymAssoc:= [[x,:y],:$GensymAssoc] -; true -; null x => y is [g] and GENSYMP g -; null y => x is [g] and GENSYMP g -; atom x or atom y => false -; fn(first x,first y) and fn(rest x,rest y) - -(DEFUN |EqualBarGensym,fn| (|x| |y|) - (PROG (|z| |g|) - (DECLARE (SPECIAL |$GensymAssoc|)) - (RETURN - (SEQ (IF (BOOT-EQUAL |x| |y|) (EXIT 'T)) - (IF (AND (GENSYMP |x|) (GENSYMP |y|)) - (EXIT (SEQ (IF (SPADLET |z| - (|assoc| |x| |$GensymAssoc|)) - (EXIT (SEQ - (IF (BOOT-EQUAL |y| (CDR |z|)) - (EXIT 'T)) - (EXIT NIL)))) - (SPADLET |$GensymAssoc| - (CONS (CONS |x| |y|) |$GensymAssoc|)) - (EXIT 'T)))) - (IF (NULL |x|) - (EXIT (AND (AND (PAIRP |y|) (EQ (QCDR |y|) NIL) - (PROGN (SPADLET |g| (QCAR |y|)) 'T)) - (GENSYMP |g|)))) - (IF (NULL |y|) - (EXIT (AND (AND (PAIRP |x|) (EQ (QCDR |x|) NIL) - (PROGN (SPADLET |g| (QCAR |x|)) 'T)) - (GENSYMP |g|)))) - (IF (OR (ATOM |x|) (ATOM |y|)) (EXIT NIL)) - (EXIT (AND (|EqualBarGensym,fn| (CAR |x|) (CAR |y|)) - (|EqualBarGensym,fn| (CDR |x|) (CDR |y|)))))))) - -(DEFUN |EqualBarGensym| (|x| |y|) - (PROG (|$GensymAssoc|) - (DECLARE (SPECIAL |$GensymAssoc|)) - (RETURN - (PROGN - (SPADLET |$GensymAssoc| NIL) - (|EqualBarGensym,fn| |x| |y|))))) - -;--Called early, to change IF to COND -; -;optIF2COND ["IF",a,b,c] == -; b is "noBranch" => ["COND",[["NULL",a],c]] -; c is "noBranch" => ["COND",[a,b]] -; c is ["IF",:.] => ["COND",[a,b],:rest optIF2COND c] -; c is ["COND",:p] => ["COND",[a,b],:p] -; ["COND",[a,b],[$true,c]] - -(DEFUN |optIF2COND| (G166953) - (PROG (|a| |b| |c| |p|) - (DECLARE (SPECIAL |$true|)) - (RETURN - (PROGN - (COND ((EQ (CAR G166953) 'IF) (CAR G166953))) - (SPADLET |a| (CADR G166953)) - (SPADLET |b| (CADDR G166953)) - (SPADLET |c| (CADDDR G166953)) - (COND - ((EQ |b| '|noBranch|) - (CONS 'COND - (CONS (CONS (CONS 'NULL (CONS |a| NIL)) - (CONS |c| NIL)) - NIL))) - ((EQ |c| '|noBranch|) - (CONS 'COND (CONS (CONS |a| (CONS |b| NIL)) NIL))) - ((AND (PAIRP |c|) (EQ (QCAR |c|) 'IF)) - (CONS 'COND - (CONS (CONS |a| (CONS |b| NIL)) - (CDR (|optIF2COND| |c|))))) - ((AND (PAIRP |c|) (EQ (QCAR |c|) 'COND) - (PROGN (SPADLET |p| (QCDR |c|)) 'T)) - (CONS 'COND (CONS (CONS |a| (CONS |b| NIL)) |p|))) - ('T - (CONS 'COND - (CONS (CONS |a| (CONS |b| NIL)) - (CONS (CONS |$true| (CONS |c| NIL)) NIL))))))))) - -;optXLAMCond x == -; x is ["COND",u:= [p,c],:l] => -; (optPredicateIfTrue p => c; ["COND",u,:optCONDtail l]) -; atom x => x -; RPLAC(first x,optXLAMCond first x) -; RPLAC(rest x,optXLAMCond rest x) -; x - -(DEFUN |optXLAMCond| (|x|) - (PROG (|ISTMP#1| |ISTMP#2| |p| |ISTMP#3| |c| |u| |l|) - (RETURN - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'COND) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |p| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |c| (QCAR |ISTMP#3|)) - 'T))))) - (PROGN (SPADLET |u| (QCAR |ISTMP#1|)) 'T) - (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T)))) - (COND - ((|optPredicateIfTrue| |p|) |c|) - ('T (CONS 'COND (CONS |u| (|optCONDtail| |l|)))))) - ((ATOM |x|) |x|) - ('T (RPLAC (CAR |x|) (|optXLAMCond| (CAR |x|))) - (RPLAC (CDR |x|) (|optXLAMCond| (CDR |x|))) |x|))))) - -;optPredicateIfTrue p == -; p is ['QUOTE,:.] => true -; p is [fn,x] and MEMQ(fn,$BasicPredicates) and FUNCALL(fn,x) => true -; nil - -(DEFUN |optPredicateIfTrue| (|p|) - (PROG (|fn| |ISTMP#1| |x|) - (DECLARE (SPECIAL |$BasicPredicates|)) - (RETURN - (COND - ((AND (PAIRP |p|) (EQ (QCAR |p|) 'QUOTE)) 'T) - ((AND (PAIRP |p|) - (PROGN - (SPADLET |fn| (QCAR |p|)) - (SPADLET |ISTMP#1| (QCDR |p|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |x| (QCAR |ISTMP#1|)) 'T))) - (member |fn| |$BasicPredicates|) (FUNCALL |fn| |x|)) - 'T) - ('T NIL))))) - -;optCONDtail l == -; null l => nil -; [frst:= [p,c],:l']:= l -; optPredicateIfTrue p => [[$true,c]] -; null rest l => [frst,[$true,["CondError"]]] -; [frst,:optCONDtail l'] - -(DEFUN |optCONDtail| (|l|) - (PROG (|frst| |p| |c| |l'|) - (DECLARE (SPECIAL |$true|)) - (RETURN - (COND - ((NULL |l|) NIL) - ('T (SPADLET |frst| (CAR |l|)) (SPADLET |p| (CAAR |l|)) - (SPADLET |c| (CADAR |l|)) (SPADLET |l'| (CDR |l|)) - (COND - ((|optPredicateIfTrue| |p|) - (CONS (CONS |$true| (CONS |c| NIL)) NIL)) - ((NULL (CDR |l|)) - (CONS |frst| - (CONS (CONS |$true| - (CONS (CONS '|CondError| NIL) NIL)) - NIL))) - ('T (CONS |frst| (|optCONDtail| |l'|))))))))) - -;optSEQ ["SEQ",:l] == -; tryToRemoveSEQ SEQToCOND getRidOfTemps l where -; getRidOfTemps l == -; null l => nil -; l is [["LET",g,x,:.],:r] and GENSYMP g and 2>numOfOccurencesOf(g,r) => -; getRidOfTemps substitute(x,g,r) -; first l="/throwAway" => getRidOfTemps rest l -; --this gets rid of unwanted labels generated by declarations in SEQs -; [first l,:getRidOfTemps rest l] -; SEQToCOND l == -; transform:= [[a,b] for x in l while (x is ["COND",[a,["EXIT",b]]])] -; before:= take(#transform,l) -; aft:= after(l,before) -; null before => ["SEQ",:aft] -; null aft => ["COND",:transform,'((QUOTE T) (conderr))] -; true => ["COND",:transform,['(QUOTE T),optSEQ ["SEQ",:aft]]] -; tryToRemoveSEQ l == -; l is ["SEQ",[op,a]] and MEMQ(op,'(EXIT RETURN THROW)) => a -; l - -(DEFUN |optSEQ,tryToRemoveSEQ| (|l|) - (PROG (|ISTMP#1| |ISTMP#2| |op| |ISTMP#3| |a|) - (RETURN - (SEQ (IF (AND (AND (PAIRP |l|) (EQ (QCAR |l|) 'SEQ) - (PROGN - (SPADLET |ISTMP#1| (QCDR |l|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |op| - (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |a| - (QCAR |ISTMP#3|)) - 'T)))))))) - (member |op| '(EXIT RETURN THROW))) - (EXIT |a|)) - (EXIT |l|))))) - -(DEFUN |optSEQ,SEQToCOND| (|l|) - (PROG (|ISTMP#1| |ISTMP#2| |a| |ISTMP#3| |ISTMP#4| |ISTMP#5| |b| - |transform| |before| |aft|) - (RETURN - (SEQ (SPADLET |transform| - (PROG (G167164) - (SPADLET G167164 NIL) - (RETURN - (DO ((G167170 |l| (CDR G167170)) (|x| NIL)) - ((OR (ATOM G167170) - (PROGN - (SETQ |x| (CAR G167170)) - NIL) - (NULL (AND (PAIRP |x|) - (EQ (QCAR |x|) 'COND) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| - (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |a| - (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) - NIL) - (PROGN - (SPADLET |ISTMP#4| - (QCAR |ISTMP#3|)) - (AND - (PAIRP |ISTMP#4|) - (EQ - (QCAR |ISTMP#4|) - 'EXIT) - (PROGN - (SPADLET - |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND - (PAIRP - |ISTMP#5|) - (EQ - (QCDR - |ISTMP#5|) - NIL) - (PROGN - (SPADLET |b| - (QCAR - |ISTMP#5|)) - 'T)))))))))))))) - (NREVERSE0 G167164)) - (SEQ (EXIT (SETQ G167164 - (CONS (CONS |a| (CONS |b| NIL)) - G167164)))))))) - (SPADLET |before| (TAKE (|#| |transform|) |l|)) - (SPADLET |aft| (|after| |l| |before|)) - (IF (NULL |before|) (EXIT (CONS 'SEQ |aft|))) - (IF (NULL |aft|) - (EXIT (CONS 'COND - (APPEND |transform| - (CONS '('T (|conderr|)) NIL))))) - (EXIT (IF 'T - (EXIT (CONS 'COND - (APPEND |transform| - (CONS - (CONS ''T - (CONS - (|optSEQ| - (CONS 'SEQ |aft|)) - NIL)) - NIL)))))))))) - -(DEFUN |optSEQ,getRidOfTemps| (|l|) - (PROG (|ISTMP#1| |ISTMP#2| |g| |ISTMP#3| |x| |r|) - (RETURN - (SEQ (IF (NULL |l|) (EXIT NIL)) - (IF (AND (AND (AND (PAIRP |l|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |l|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) 'LET) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |g| - (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |x| - (QCAR |ISTMP#3|)) - 'T))))))) - (PROGN (SPADLET |r| (QCDR |l|)) 'T)) - (GENSYMP |g|)) - (> 2 (|numOfOccurencesOf| |g| |r|))) - (EXIT (|optSEQ,getRidOfTemps| (MSUBST |x| |g| |r|)))) - (IF (BOOT-EQUAL (CAR |l|) '|/throwAway|) - (EXIT (|optSEQ,getRidOfTemps| (CDR |l|)))) - (EXIT (CONS (CAR |l|) (|optSEQ,getRidOfTemps| (CDR |l|)))))))) - -(DEFUN |optSEQ| (G167201) - (PROG (|l|) - (RETURN - (PROGN - (COND ((EQ (CAR G167201) 'SEQ) (CAR G167201))) - (SPADLET |l| (CDR G167201)) - (|optSEQ,tryToRemoveSEQ| - (|optSEQ,SEQToCOND| (|optSEQ,getRidOfTemps| |l|))))))) - -;optRECORDELT ["RECORDELT",name,ind,len] == -; len=1 => -; ind=0 => ["QCAR",name] -; keyedSystemError("S2OO0002",[ind]) -; len=2 => -; ind=0 => ["QCAR",name] -; ind=1 => ["QCDR",name] -; keyedSystemError("S2OO0002",[ind]) -; ["QVELT",name,ind] - -(DEFUN |optRECORDELT| (G167217) - (PROG (|name| |ind| |len|) - (RETURN - (PROGN - (COND ((EQ (CAR G167217) 'RECORDELT) (CAR G167217))) - (SPADLET |name| (CADR G167217)) - (SPADLET |ind| (CADDR G167217)) - (SPADLET |len| (CADDDR G167217)) - (COND - ((EQL |len| 1) - (COND - ((EQL |ind| 0) (CONS 'QCAR (CONS |name| NIL))) - ('T (|keyedSystemError| 'S2OO0002 (CONS |ind| NIL))))) - ((EQL |len| 2) - (COND - ((EQL |ind| 0) (CONS 'QCAR (CONS |name| NIL))) - ((EQL |ind| 1) (CONS 'QCDR (CONS |name| NIL))) - ('T (|keyedSystemError| 'S2OO0002 (CONS |ind| NIL))))) - ('T (CONS 'QVELT (CONS |name| (CONS |ind| NIL))))))))) - -;optSETRECORDELT ["SETRECORDELT",name,ind,len,expr] == -; len=1 => -; ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] -; keyedSystemError("S2OO0002",[ind]) -; len=2 => -; ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] -; ind=1 => ["PROGN",["RPLACD",name,expr],["QCDR",name]] -; keyedSystemError("S2OO0002",[ind]) -; ["QSETVELT",name,ind,expr] - -(DEFUN |optSETRECORDELT| (G167239) - (PROG (|name| |ind| |len| |expr|) - (RETURN - (PROGN - (COND ((EQ (CAR G167239) 'SETRECORDELT) (CAR G167239))) - (SPADLET |name| (CADR G167239)) - (SPADLET |ind| (CADDR G167239)) - (SPADLET |len| (CADDDR G167239)) - (SPADLET |expr| (CAR (CDDDDR G167239))) - (COND - ((EQL |len| 1) - (COND - ((EQL |ind| 0) - (CONS 'PROGN - (CONS (CONS 'RPLACA - (CONS |name| (CONS |expr| NIL))) - (CONS (CONS 'QCAR (CONS |name| NIL)) NIL)))) - ('T (|keyedSystemError| 'S2OO0002 (CONS |ind| NIL))))) - ((EQL |len| 2) - (COND - ((EQL |ind| 0) - (CONS 'PROGN - (CONS (CONS 'RPLACA - (CONS |name| (CONS |expr| NIL))) - (CONS (CONS 'QCAR (CONS |name| NIL)) NIL)))) - ((EQL |ind| 1) - (CONS 'PROGN - (CONS (CONS 'RPLACD - (CONS |name| (CONS |expr| NIL))) - (CONS (CONS 'QCDR (CONS |name| NIL)) NIL)))) - ('T (|keyedSystemError| 'S2OO0002 (CONS |ind| NIL))))) - ('T - (CONS 'QSETVELT - (CONS |name| (CONS |ind| (CONS |expr| NIL)))))))))) - -;optRECORDCOPY ["RECORDCOPY",name,len] == -; len=1 => ["LIST",["CAR",name]] -; len=2 => ["CONS",["CAR",name],["CDR",name]] -; ["MOVEVEC",["MAKE_-ARRAY",len],name] - -(DEFUN |optRECORDCOPY| (G167262) - (PROG (|name| |len|) - (RETURN - (PROGN - (COND ((EQ (CAR G167262) 'RECORDCOPY) (CAR G167262))) - (SPADLET |name| (CADR G167262)) - (SPADLET |len| (CADDR G167262)) - (COND - ((EQL |len| 1) - (CONS 'LIST (CONS (CONS 'CAR (CONS |name| NIL)) NIL))) - ((EQL |len| 2) - (CONS 'CONS - (CONS (CONS 'CAR (CONS |name| NIL)) - (CONS (CONS 'CDR (CONS |name| NIL)) NIL)))) - ('T - (CONS 'replace - (CONS (CONS 'make-array (CONS |len| NIL)) - (CONS |name| NIL))))))))) - -;--mkRecordAccessFunction(ind,len) == -;-- stringOfDs:= $EmptyString -;-- for i in 0..(ind-1) do stringOfDs:= STRCONC(stringOfDs,PNAME "D") -;-- prefix:= if ind=len-1 then PNAME "C" else PNAME "CA" -;-- if $QuickCode then prefix:=STRCONC("Q",prefix) -;-- INTERN(STRCONC(prefix,stringOfDs,PNAME "R")) -; -;optSuchthat [.,:u] == ["SUCHTHAT",:u] - -(DEFUN |optSuchthat| (G167278) - (PROG (|u|) - (RETURN - (PROGN (SPADLET |u| (CDR G167278)) (CONS 'SUCHTHAT |u|))))) - -;optMINUS u == -; u is ['MINUS,v] => -; NUMBERP v => -v -; u -; u - -(DEFUN |optMINUS| (|u|) - (PROG (|ISTMP#1| |v|) - (RETURN - (COND - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'MINUS) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |v| (QCAR |ISTMP#1|)) 'T)))) - (COND ((NUMBERP |v|) (SPADDIFFERENCE |v|)) ('T |u|))) - ('T |u|))))) - -;optQSMINUS u == -; u is ['QSMINUS,v] => -; NUMBERP v => -v -; u -; u - -(DEFUN |optQSMINUS| (|u|) - (PROG (|ISTMP#1| |v|) - (RETURN - (COND - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'QSMINUS) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |v| (QCAR |ISTMP#1|)) 'T)))) - (COND ((NUMBERP |v|) (SPADDIFFERENCE |v|)) ('T |u|))) - ('T |u|))))) - -;opt_- u == -; u is ['_-,v] => -; NUMBERP v => -v -; u -; u - -(DEFUN |opt-| (|u|) - (PROG (|ISTMP#1| |v|) - (RETURN - (COND - ((AND (PAIRP |u|) (EQ (QCAR |u|) '-) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |v| (QCAR |ISTMP#1|)) 'T)))) - (COND ((NUMBERP |v|) (SPADDIFFERENCE |v|)) ('T |u|))) - ('T |u|))))) - -;optLESSP u == -; u is ['LESSP,a,b] => -; b = 0 => ['MINUSP,a] -; ['GREATERP,b,a] -; u - -(DEFUN |optLESSP| (|u|) - (PROG (|ISTMP#1| |a| |ISTMP#2| |b|) - (RETURN - (COND - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'LESSP) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) 'T)))))) - (COND - ((EQL |b| 0) (CONS 'MINUSP (CONS |a| NIL))) - ('T (CONS '> (CONS |b| (CONS |a| NIL)))))) - ('T |u|))))) - -;optEQ u == -; u is ['EQ,l,r] => -; NUMBERP l and NUMBERP r => ['QUOTE,EQ(l,r)] -; -- That undoes some weird work in Boolean to do with the definition of true -; u -; u - -(DEFUN |optEQ| (|u|) - (PROG (|ISTMP#1| |l| |ISTMP#2| |r|) - (RETURN - (COND - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'EQ) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |l| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |r| (QCAR |ISTMP#2|)) 'T)))))) - (COND - ((AND (NUMBERP |l|) (NUMBERP |r|)) - (CONS 'QUOTE (CONS (EQ |l| |r|) NIL))) - ('T |u|))) - ('T |u|))))) - -;EVALANDFILEACTQ -; ( -; for x in '( (call optCall) _ -; (SEQ optSEQ)_ -; (EQ optEQ) -; (MINUS optMINUS)_ -; (QSMINUS optQSMINUS)_ -; (_- opt_-)_ -; (LESSP optLESSP)_ -; (SPADCALL optSPADCALL)_ -; (_| optSuchthat)_ -; (CATCH optCatch)_ -; (COND optCond)_ -; (mkRecord optMkRecord)_ -; (RECORDELT optRECORDELT)_ -; (SETRECORDELT optSETRECORDELT)_ -; (RECORDCOPY optRECORDCOPY)) _ -; repeat MAKEPROP(CAR x,'OPTIMIZE,CREATE_-SBC CADR x) -; --much quicker to call functions if they have an SBC -; ) -; - -;(EVALANDFILEACTQ -; (REPEAT (IN |x| -; '((|call| |optCall|) (SEQ |optSEQ|) (EQ |optEQ|) -; (MINUS |optMINUS|) (QSMINUS |optQSMINUS|) (- |opt-|) -; (LESSP |optLESSP|) (SPADCALL |optSPADCALL|) -; (|\|| |optSuchthat|) (CATCH |optCatch|) -; (COND |optCond|) (|mkRecord| |optMkRecord|) -; (RECORDELT |optRECORDELT|) -; (SETRECORDELT |optSETRECORDELT|) -; (RECORDCOPY |optRECORDCOPY|))) -; (MAKEPROP (CAR |x|) 'OPTIMIZE (CADR |x|)))) - -\end{chunk} -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index 9e85239..33b815b 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -2127,8 +2127,6 @@ do the compile, and then rename the result back to code.o. (def-boot-val |$BasicDomains| '(|Integer| |Float| |Symbol| |Boolean| |String|) "???") -(def-boot-val |$BasicPredicates| - '(INTEGERP STRINGP FLOATP) "???") (def-boot-val |$BFtag| '-BF- "big float marker") (def-boot-val |$BigFloat| '(|Float|) "???") (def-boot-val |$BigFloatOpt| '(|BigFloat| . OPT) "???") @@ -5813,7 +5811,6 @@ now the function is defined but does nothing. (SETQ |$true| ''T) (SETQ |$false| NIL) (SETQ |$suffix| NIL) -(SETQ |$BasicPredicates| '(INTEGERP STRINGP FLOATP)) (SETQ |$coerceIntByMapCounter| 0) (SETQ |$reportCoerce| NIL) (SETQ |$reportCompilation| NIL)