diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index b3075bc..7fee5fe 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -10375,6 +10375,22 @@ An angry JHD - August 15th., 1984 \end{chunk} +\defun{compBoolean}{compBoolean} +\calls{compBoolean}{comp} +\calls{compBoolean}{getSuccessEnvironment} +\calls{compBoolean}{getInverseEnvironment} +\begin{chunk}{defun compBoolean} +(defun |compBoolean| (p mode env) + (let (tmp1 pp) + (when (setq tmp1 (OR (|comp| p mode env))) + (setq pp (car tmp1)) + (setq mode (cadr tmp1)) + (setq env (caddr tmp1)) + (list pp mode (|getSuccessEnvironment| p env) + (|getInverseEnvironment| p env))))) + +\end{chunk} + \defplist{import}{compImport plist} \begin{chunk}{postvars} (eval-when (eval load) @@ -11045,6 +11061,103 @@ An angry JHD - August 15th., 1984 \end{chunk} +\defun{setqMultiple}{setqMultiple} +\calls{setqMultiple}{nreverse0} +\calls{setqMultiple}{pairp} +\calls{setqMultiple}{qcar} +\calls{setqMultiple}{qcdr} +\calls{setqMultiple}{stackMessage} +\calls{setqMultiple}{setqMultipleExplicit} +\calls{setqMultiple}{genVariable} +\calls{setqMultiple}{addBinding} +\calls{setqMultiple}{compSetq1} +\calls{setqMultiple}{convert} +\calls{setqMultiple}{put} +\calls{setqMultiple}{genSomeVariable} +\calls{setqMultiple}{length} +\calls{setqMultiple}{mkprogn} +\refsdollar{setqMultiple}{EmptyMode} +\refsdollar{setqMultiple}{NoValueMode} +\refsdollar{setqMultiple}{noEnv} +\begin{chunk}{defun setqMultiple} +(defun |setqMultiple| (nameList val m env) + (labels ( + (decompose (tt len env) + (declare (ignore len)) + (let (tmp1 z) + (declare (special |$EmptyMode|)) + (cond + ((and (pairp tt) (eq (qcar tt) '|Record|) + (progn (setq z (qcdr tt)) t)) + (loop for item in z + collect (cons (second item) (third item)))) + ((progn + (setq tmp1 (|comp| tt |$EmptyMode| env)) + (and (pairp tmp1) (PAIRP (qcdr tmp1)) (PAIRP (qcar (qcdr tmp1))) + (eq (qcar (qcar (qcdr tmp1))) '|RecordCategory|) + (pairp (qcdr (qcdr tmp1))) (eq (qcdr (qcdr (qcdr tmp1))) nil))) + (loop for item in z + collect (cons (second item) (third item)))) + (t (|stackMessage| (list '|no multiple assigns to mode: | tt))))))) + (let (g m1 tt x mp selectorModePairs tmp2 assignList) + (declare (special |$noEnv| |$EmptyMode| |$NoValueMode|)) + (cond + ((and (pairp val) (eq (qcar val) 'cons) (equal m |$NoValueMode|)) + (|setqMultipleExplicit| nameList (|uncons| val) m env)) + ((and (pairp val) (eq (qcar val) '|@Tuple|) (equal m |$NoValueMode|)) + (|setqMultipleExplicit| nameList (qcdr val) m env)) + ; 1 create a gensym, %add to local environment, compile and assign rhs + (t + (setq g (|genVariable|)) + (setq env (|addBinding| g nil env)) + (setq tmp2 (|compSetq1| g val |$EmptyMode| env)) + (when tmp2 + (setq tt tmp2) + (setq m1 (cadr tmp2)) + (setq env (|put| g 'mode m1 env)) + (setq tmp2 (|convert| tt m)) +; 1.1 --exit if result is a list + (when tmp2 + (setq x (first tmp2)) + (setq mp (second tmp2)) + (setq env (third tmp2)) + (cond + ((and (pairp m1) (eq (qcar m1) '|List|) (pairp (qcdr m1)) + (eq (qcdr (qcdr m1)) nil)) + (loop for y in nameList do + (setq env + (|put| y '|value| (list (|genSomeVariable|) (second m1) |$noEnv|) + env))) + (|convert| (list (list 'progn x (list 'let nameList g) g) mp env) m)) + (t +; 2 --verify that the #nameList = number of parts of right-hand-side + (setq selectorModePairs + (decompose m1 (|#| nameList) env)) + (when selectorModePairs + (cond + ((nequal (|#| nameList) (|#| selectorModePairs)) + (|stackMessage| + (list val '| must decompose into | + (|#| nameList) '| components| ))) + (t +; 3 --generate code + (setq assignList + (loop for x in nameList + for item in selectorModePairs + collect (car + (progn + (setq tmp2 + (or (|compSetq1| x (list '|elt| g (first item)) + (rest item) env) + (return '|failed|))) + (setq env (third tmp2)) + tmp2)))) + (unless (eq assignList '|failed|) + (list (mkprogn (cons x (append assignList (list g)))) mp env)) + )))))))))))) + +\end{chunk} + \defun{setqSetelt}{setqSetelt} \calls{setqSetelt}{comp} \begin{chunk}{defun setqSetelt} @@ -11134,6 +11247,22 @@ An angry JHD - August 15th., 1984 \end{chunk} +\defun{assignError}{assignError} +\calls{assignError}{stackMessage} +\begin{chunk}{defun assignError} +(defun |assignError| (val mp form m) + (let (message) + (setq message + (if val + (list '|CANNOT ASSIGN: | val '|%l| + '| OF MODE: | mp '|%l| + '| TO: | form '|%l| '| OF MODE: | m) + (list '|CANNOT ASSIGN: | val '|%l| + '| TO: | form '|%l| '| OF MODE: | m))) + (|stackMessage| message))) + +\end{chunk} + \defun{outputComp}{outputComp} \calls{outputComp}{comp} \calls{outputComp}{pairp} @@ -11152,52 +11281,29 @@ An angry JHD - August 15th., 1984 ; [['coerceUn2E,x,v.mode],$Expression,e] ; [x,$Expression,e] -(DEFUN |outputComp| (|x| |e|) - (PROG (|u| |argl| |LETTMP#1| |v| |ISTMP#1| |l|) - (declare (special |$Expression|)) - (RETURN - (SEQ (COND - ((SPADLET |u| - (|comp| (CONS '|::| - (CONS |x| - (CONS |$Expression| NIL))) - |$Expression| |e|)) - |u|) - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|construct|) - (PROGN (SPADLET |argl| (QCDR |x|)) 'T)) - (CONS (CONS 'LIST - (PROG (G167017) - (SPADLET G167017 NIL) - (RETURN - (DO ((G167025 |argl| (CDR G167025)) - (|x| NIL)) - ((OR (ATOM G167025) - (PROGN - (SETQ |x| (CAR G167025)) - NIL)) - (NREVERSE0 G167017)) - (SEQ (EXIT - (SETQ G167017 - (CONS - (CAR - (PROGN - (SPADLET |LETTMP#1| - (|outputComp| |x| |e|)) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|)) - G167017)))))))) - (CONS |$Expression| (CONS |e| NIL)))) - ((AND (SPADLET |v| (|get| |x| '|value| |e|)) - (PROGN - (SPADLET |ISTMP#1| (CADR |v|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|Union|) - (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T)))) - (CONS (CONS '|coerceUn2E| - (CONS |x| (CONS (CADR |v|) NIL))) - (CONS |$Expression| (CONS |e| NIL)))) - ('T (CONS |x| (CONS |$Expression| (CONS |e| NIL))))))))) +(defun |outputComp| (x env) + (let (argl v) + (declare (special |$Expression|)) + (cond + ((|comp| (list '|::| x |$Expression|) |$Expression| env)) + ((and (pairp x) (eq (qcar x) '|construct|)) + (setq argl (qcdr x)) + (list (cons 'list + (let (result tmp1) + (loop for x in argl + do (setq result + (cons (car + (progn + (setq tmp1 (|outputComp| x env)) + (setq env (third tmp1)) + tmp1)) + result))) + (nreverse0 result))) + |$Expression| env)) + ((and (setq v (|get| x '|value| env)) + (pairp (cadr v)) (eq (qcar (cadr v)) '|Union|)) + (list (list '|coerceUn2E| x (cadr v)) |$Expression| env)) + (t (list x |$Expression| env))))) \end{chunk} @@ -17795,6 +17901,106 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} +\defun{getFormModemaps}{getFormModemaps} +\calls{getFormModemaps}{pairp} +\calls{getFormModemaps}{qcar} +\calls{getFormModemaps}{qcdr} +\calls{getFormModemaps}{getFormModemaps} +\calls{getFormModemaps}{nreverse0} +\calls{getFormModemaps}{get} +\calls{getFormModemaps}{nequal} +\calls{getFormModemaps}{eltModemapFilter} +\calls{getFormModemaps}{last} +\calls{getFormModemaps}{length} +\calls{getFormModemaps}{stackMessage} +\refsdollar{getFormModemaps}{insideCategoryPackageIfTrue} +\begin{chunk}{defun getFormModemaps} +(defun |getFormModemaps| (form env) + (let (op argl domain op1 modemapList nargs finalModemapList) + (declare (special |$insideCategoryPackageIfTrue|)) + (setq op (car form)) + (setq argl (cdr form)) + (cond + ((and (pairp op) (eq (qcar op) '|elt|) (PAIRP (qcdr op)) + (pairp (qcdr (qcdr op))) (eq (qcdr (qcdr (qcdr op))) nil)) + (setq op1 (third op)) + (setq domain (second op)) + (loop for x in (|getFormModemaps| (cons op1 argl) env) + when (and (pairp x) (pairp (qcar x)) (equal (qcar (qcar x)) domain)) + collect x)) + ((null (atom op)) nil) + (t + (setq modemapList (|get| op '|modemap| env)) + (when |$insideCategoryPackageIfTrue| + (setq modemapList + (loop for x in modemapList + when (and (pairp x) (pairp (qcar x)) (nequal (qcar (qcar x)) '$)) + collect x))))) + (cond + ((eq op '|elt|) + (setq modemapList (|eltModemapFilter| (|last| argl) modemapList env))) + ((eq op '|setelt|) + (setq modemapList (|seteltModemapFilter| (CADR argl) modemapList env)))) + (setq nargs (|#| argl)) + (setq finalModemapList + (loop for mm in modemapList + when (equal (|#| (cddar mm)) nargs) + collect mm)) + (when (and modemapList (null finalModemapList)) + (|stackMessage| + (list '|no modemap for| '|%b| op '|%d| '|with | nargs '| arguments|))) + finalModemapList)) + +\end{chunk} + +\defun{eltModemapFilter}{eltModemapFilter} +\calls{eltModemapFilter}{pairp} +\calls{eltModemapFilter}{qcar} +\calls{eltModemapFilter}{qcdr} +\calls{eltModemapFilter}{isConstantId} +\calls{eltModemapFilter}{stackMessage} +\begin{chunk}{defun eltModemapFilter} +(defun |eltModemapFilter| (name mmList env) + (let (z) + (if (|isConstantId| name env) + (cond + ((setq z + (loop for mm in mmList + when (and (pairp mm) (pairp (qcar mm)) (pairp (qcdr (qcar mm))) + (pairp (qcdr (qcdr (qcar mm)))) + (pairp (qcdr (qcdr (qcdr (qcar mm))))) + (equal (fourth (first mm)) name)) + collect mm)) + z) + (t + (|stackMessage| + (list '|selector variable: | name '| is undeclared and unbound|)) + nil)) + mmList))) + +\end{chunk} + +\defun{seteltModemapFilter}{seteltModemapFilter} +\calls{seteltModemapFilter}{isConstantId} +\calls{seteltModemapFilter}{stackMessage} +\begin{chunk}{defun seteltModemapFilter} +(defun |seteltModemapFilter| (name mmList env) + (let (z) + (if (|isConstantId| name env) + (cond + ((setq z + (loop for mm in mmList + when (equal (car (cdddar mm)) name) + collect mm)) + z) + (t + (|stackMessage| + (list '|selector variable: | name '| is undeclared and unbound|)) + nil)) + mmList))) + +\end{chunk} + \defun{compExpressionList}{compExpressionList} \calls{compExpressionList}{nreverse0} \calls{compExpressionList}{comp} @@ -17920,6 +18126,35 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} +\defun{compForm3}{compForm3} +\calls{compForm3}{compFormWithModemap} +\throws{compForm3}{compUniquely} +\refsdollar{compForm3}{compUniquelyIfTrue} +\begin{chunk}{defun compForm3} +(defun |compForm3| (form mode env modemapList) + (let (op argl mml tt) + (declare (special |$compUniquelyIfTrue|)) + (setq op (car form)) + (setq argl (cdr form)) + (setq tt + (let (result) + (maplist #'(lambda (mlst) + (setq result (or result + (|compFormWithModemap| form mode env (car (setq mml mlst)))))) + modemapList) + result)) + (when |$compUniquelyIfTrue| + (if (let (result) + (mapcar #'(lambda (mm) + (setq result (or result (|compFormWithModemap| form mode env mm)))) + (rest mml)) + result) + (throw '|compUniquely| nil) + tt)) + tt)) + +\end{chunk} + \defun{compFormPartiallyBottomUp}{compFormPartiallyBottomUp} \calls{compFormPartiallyBottomUp}{compForm3} \calls{compFormPartiallyBottomUp}{compFormMatch} @@ -18723,6 +18958,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun aplTran1} \getchunk{defun aplTranList} \getchunk{defun argsToSig} +\getchunk{defun assignError} \getchunk{defun augLisplibModemapsFromCategory} \getchunk{defun augmentLisplibModemapsFromFunctor} \getchunk{defun augModemapsFromCategory} @@ -18744,13 +18980,13 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun compArgumentsAndTryAgain} \getchunk{defun compAtom} \getchunk{defun compAtSign} +\getchunk{defun compBoolean} \getchunk{defun compCapsule} \getchunk{defun compCapsuleInner} \getchunk{defun compCase} \getchunk{defun compCase1} \getchunk{defun compCat} \getchunk{defun compCategory} -\getchunk{defun compDefineCategory1} \getchunk{defun compCoerce} \getchunk{defun compCoerce1} \getchunk{defun compColon} @@ -18763,6 +18999,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun compDefine1} \getchunk{defun compDefineAddSignature} \getchunk{defun compDefineCategory} +\getchunk{defun compDefineCategory1} \getchunk{defun compDefineCategory2} \getchunk{defun compDefineFunctor} \getchunk{defun compDefineFunctor1} @@ -18775,6 +19012,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun compForm} \getchunk{defun compForm1} \getchunk{defun compForm2} +\getchunk{defun compForm3} \getchunk{defun compFormMatch} \getchunk{defun compFormPartiallyBottomUp} \getchunk{defun compFunctorBody} @@ -18844,6 +19082,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun domainMember} \getchunk{defun drop} +\getchunk{defun eltModemapFilter} \getchunk{defun errhuh} \getchunk{defun escape-keywords} \getchunk{defun escaped} @@ -18863,6 +19102,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun getCategoryOpsAndAtts} \getchunk{defun getConstructorOpsAndAtts} \getchunk{defun getDomainsInScope} +\getchunk{defun getFormModemaps} \getchunk{defun getFunctorOpsAndAtts} \getchunk{defun getModemap} \getchunk{defun getModemapList} @@ -19165,6 +19405,8 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun rwriteLispForm} \getchunk{defun setDefOp} +\getchunk{defun seteltModemapFilter} +\getchunk{defun setqMultiple} \getchunk{defun signatureTran} \getchunk{defun skip-blanks} \getchunk{defun skip-ifblock} diff --git a/changelog b/changelog index 6d36c13..c322d9e 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20110807 tpd src/axiom-website/patches.html 20110807.01.tpd.patch +20110807 tpd src/interp/compiler.lisp treeshake compiler +20110807 tpd books/bookvol9 treeshake compiler 20110804 tpd src/axiom-website/patches.html 20110804.01.tpd.patch 20110804 tpd src/interp/compiler.lisp treeshake compiler 20110804 tpd books/bookvol9 treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 2d3e1f1..4e3099e 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3578,5 +3578,7 @@ src/interp/as.lisp removed
src/interp/ax.lisp removed aldor compiler hooks
20110804.01.tpd.patch books/bookvol9 treeshake compiler
+20110807.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/compiler.lisp.pamphlet b/src/interp/compiler.lisp.pamphlet index 3fdb0ac..e54586e 100644 --- a/src/interp/compiler.lisp.pamphlet +++ b/src/interp/compiler.lisp.pamphlet @@ -123,203 +123,6 @@ (|hasType,fn| (|get| |x| '|condition| |e|))) \end{chunk} -\subsection{compForm3} -\begin{chunk}{*} -;compForm3(form is [op,:argl],m,e,modemapList) == -; T:= -; or/ -; [compFormWithModemap(form,m,e,first (mml:= ml)) -; for ml in tails modemapList] -; $compUniquelyIfTrue => -; or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] => -; THROW("compUniquely",nil) -; T -; T - -(DEFUN |compForm3| (|form| |m| |e| |modemapList|) - (PROG (|op| |argl| |mml| T$) - (declare (special |$compUniquelyIfTrue|)) - (RETURN - (SEQ (PROGN - (SPADLET |op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (SPADLET T$ - (PROG (G167599) - (SPADLET G167599 NIL) - (RETURN - (DO ((G167605 NIL G167599) - (|ml| |modemapList| (CDR |ml|))) - ((OR G167605 (ATOM |ml|)) G167599) - (SEQ (EXIT (SETQ G167599 - (OR G167599 - (|compFormWithModemap| |form| - |m| |e| - (CAR (SPADLET |mml| |ml|))))))))))) - (COND - (|$compUniquelyIfTrue| - (COND - ((PROG (G167610) - (SPADLET G167610 NIL) - (RETURN - (DO ((G167616 NIL G167610) - (G167617 (CDR |mml|) (CDR G167617)) - (|mm| NIL)) - ((OR G167616 (ATOM G167617) - (PROGN - (SETQ |mm| (CAR G167617)) - NIL)) - G167610) - (SEQ (EXIT (SETQ G167610 - (OR G167610 - (|compFormWithModemap| |form| - |m| |e| |mm|)))))))) - (THROW '|compUniquely| NIL)) - ('T T$))) - ('T T$))))))) - -\end{chunk} -\subsection{getFormModemaps} -\begin{chunk}{*} -;getFormModemaps(form is [op,:argl],e) == -; op is ["elt",domain,op1] => -; [x for x in getFormModemaps([op1,:argl],e) | x is [[ =domain,:.],:.]] -; null atom op => nil -; modemapList:= get(op,"modemap",e) -; if $insideCategoryPackageIfTrue then -; modemapList := [x for x in modemapList | x is [[dom,:.],:.] and dom ^= '$] -; if op="elt" -; then modemapList:= eltModemapFilter(LAST argl,modemapList,e) or return nil -; else -; if op="setelt" then modemapList:= -; seteltModemapFilter(CADR argl,modemapList,e) or return nil -; nargs:= #argl -; finalModemapList:= [mm for (mm:= [[.,.,:sig],:.]) in modemapList | #sig=nargs] -; modemapList and null finalModemapList => -; stackMessage ["no modemap for","%b",op,"%d","with ",nargs," arguments"] -; finalModemapList - -(DEFUN |getFormModemaps| (|form| |e|) - (PROG (|op| |argl| |domain| |ISTMP#2| |op1| |ISTMP#1| |dom| - |modemapList| |nargs| |sig| |finalModemapList|) - (declare (special |$insideCategoryPackageIfTrue|)) - (RETURN - (SEQ (PROGN - (SPADLET |op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (COND - ((AND (PAIRP |op|) (EQ (QCAR |op|) '|elt|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |op|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |domain| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |op1| (QCAR |ISTMP#2|)) - 'T)))))) - (PROG (G167686) - (SPADLET G167686 NIL) - (RETURN - (DO ((G167692 - (|getFormModemaps| (CONS |op1| |argl|) - |e|) - (CDR G167692)) - (|x| NIL)) - ((OR (ATOM G167692) - (PROGN (SETQ |x| (CAR G167692)) NIL)) - (NREVERSE0 G167686)) - (SEQ (EXIT (COND - ((AND (PAIRP |x|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |x|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) - |domain|)))) - (SETQ G167686 - (CONS |x| G167686)))))))))) - ((NULL (ATOM |op|)) NIL) - ('T (SPADLET |modemapList| (|get| |op| '|modemap| |e|)) - (COND - (|$insideCategoryPackageIfTrue| - (SPADLET |modemapList| - (PROG (G167703) - (SPADLET G167703 NIL) - (RETURN - (DO - ((G167709 |modemapList| - (CDR G167709)) - (|x| NIL)) - ((OR (ATOM G167709) - (PROGN - (SETQ |x| (CAR G167709)) - NIL)) - (NREVERSE0 G167703)) - (SEQ - (EXIT - (COND - ((AND (PAIRP |x|) - (PROGN - (SPADLET |ISTMP#1| - (QCAR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |dom| - (QCAR |ISTMP#1|)) - 'T))) - (NEQUAL |dom| '$)) - (SETQ G167703 - (CONS |x| G167703)))))))))))) - (COND - ((BOOT-EQUAL |op| '|elt|) - (SPADLET |modemapList| - (OR (|eltModemapFilter| (|last| |argl|) - |modemapList| |e|) - (RETURN NIL)))) - ((BOOT-EQUAL |op| '|setelt|) - (SPADLET |modemapList| - (OR (|seteltModemapFilter| (CADR |argl|) - |modemapList| |e|) - (RETURN NIL)))) - ('T NIL)) - (SPADLET |nargs| (|#| |argl|)) - (SPADLET |finalModemapList| - (PROG (G167721) - (SPADLET G167721 NIL) - (RETURN - (DO ((G167728 |modemapList| - (CDR G167728)) - (|mm| NIL)) - ((OR (ATOM G167728) - (PROGN - (SETQ |mm| (CAR G167728)) - NIL) - (PROGN - (PROGN - (SPADLET |sig| (CDDAR |mm|)) - |mm|) - NIL)) - (NREVERSE0 G167721)) - (SEQ (EXIT - (COND - ((BOOT-EQUAL (|#| |sig|) - |nargs|) - (SETQ G167721 - (CONS |mm| G167721)))))))))) - (COND - ((AND |modemapList| (NULL |finalModemapList|)) - (|stackMessage| - (CONS '|no modemap for| - (CONS '|%b| - (CONS |op| - (CONS '|%d| - (CONS '|with | - (CONS |nargs| - (CONS '| arguments| NIL))))))))) - ('T |finalModemapList|))))))))) - -\end{chunk} \subsection{getConstructorFormOfMode} \begin{chunk}{*} ;getConstructorFormOfMode(m,e) == @@ -445,122 +248,6 @@ (|member| |name| '(|Record| |Vector| |List|)))))) \end{chunk} -\subsection{eltModemapFilter} -\begin{chunk}{*} -;eltModemapFilter(name,mmList,e) == -; isConstantId(name,e) => -; l:= [mm for mm in mmList | mm is [[.,.,.,sel,:.],:.] and sel=name] => l -; --there are elts with extra parameters -; stackMessage ["selector variable: ",name," is undeclared and unbound"] -; nil -; mmList - -(DEFUN |eltModemapFilter| (|name| |mmList| |e|) - (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |ISTMP#4| |sel| |l|) - (RETURN - (SEQ (COND - ((|isConstantId| |name| |e|) - (COND - ((SPADLET |l| - (PROG (G167882) - (SPADLET G167882 NIL) - (RETURN - (DO ((G167888 |mmList| (CDR G167888)) - (|mm| NIL)) - ((OR (ATOM G167888) - (PROGN - (SETQ |mm| (CAR G167888)) - NIL)) - (NREVERSE0 G167882)) - (SEQ (EXIT - (COND - ((AND (PAIRP |mm|) - (PROGN - (SPADLET |ISTMP#1| - (QCAR |mm|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND - (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |sel| - (QCAR - |ISTMP#4|)) - 'T))))))))) - (BOOT-EQUAL |sel| |name|)) - (SETQ G167882 - (CONS |mm| G167882)))))))))) - |l|) - ('T - (|stackMessage| - (CONS '|selector variable: | - (CONS |name| - (CONS '| is undeclared and unbound| - NIL)))) - NIL))) - ('T |mmList|)))))) - -\end{chunk} -\subsection{seteltModemapFilter} -\begin{chunk}{*} -;seteltModemapFilter(name,mmList,e) == -; isConstantId(name,e) => -; l:= [mm for (mm:= [[.,.,.,sel,:.],:.]) in mmList | sel=name] => l -; --there are setelts with extra parameters -; stackMessage ["selector variable: ",name," is undeclared and unbound"] -; nil -; mmList - -(DEFUN |seteltModemapFilter| (|name| |mmList| |e|) - (PROG (|sel| |l|) - (RETURN - (SEQ (COND - ((|isConstantId| |name| |e|) - (COND - ((SPADLET |l| - (PROG (G167914) - (SPADLET G167914 NIL) - (RETURN - (DO ((G167921 |mmList| (CDR G167921)) - (|mm| NIL)) - ((OR (ATOM G167921) - (PROGN - (SETQ |mm| (CAR G167921)) - NIL) - (PROGN - (PROGN - (SPADLET |sel| - (CAR (CDDDAR |mm|))) - |mm|) - NIL)) - (NREVERSE0 G167914)) - (SEQ (EXIT - (COND - ((BOOT-EQUAL |sel| |name|) - (SETQ G167914 - (CONS |mm| G167914)))))))))) - |l|) - ('T - (|stackMessage| - (CONS '|selector variable: | - (CONS |name| - (CONS '| is undeclared and unbound| - NIL)))) - NIL))) - ('T |mmList|)))))) - -\end{chunk} \subsection{substituteIntoFunctorModemap} \begin{chunk}{*} ;substituteIntoFunctorModemap(argl,modemap is [[dc,:sig],:.],e) == @@ -645,271 +332,6 @@ \end{chunk} -\subsection{assignError} -\begin{chunk}{*} -;assignError(val,m',form,m) == -; message:= -; val => -; ["CANNOT ASSIGN: ",val,"%l"," OF MODE: ",m',"%l"," TO: ",form,"%l", -; " OF MODE: ",m] -; ["CANNOT ASSIGN: ",val,"%l"," TO: ",form,"%l"," OF MODE: ",m] -; stackMessage message - -(DEFUN |assignError| (|val| |m'| |form| |m|) - (PROG (|message|) - (RETURN - (PROGN - (SPADLET |message| - (COND - (|val| (CONS '|CANNOT ASSIGN: | - (CONS |val| - (CONS '|%l| - (CONS '| OF MODE: | - (CONS |m'| - (CONS '|%l| - (CONS '| TO: | - (CONS |form| - (CONS '|%l| - (CONS '| OF MODE: | - (CONS |m| NIL)))))))))))) - ('T - (CONS '|CANNOT ASSIGN: | - (CONS |val| - (CONS '|%l| - (CONS '| TO: | - (CONS |form| - (CONS '|%l| - (CONS '| OF MODE: | - (CONS |m| NIL))))))))))) - (|stackMessage| |message|))))) - -\end{chunk} -\subsection{setqMultiple} -\begin{chunk}{*} -;setqMultiple(nameList,val,m,e) == -; val is ["CONS",:.] and m=$NoValueMode => -; setqMultipleExplicit(nameList,uncons val,m,e) -; val is ["Tuple",:l] and m=$NoValueMode => setqMultipleExplicit(nameList,l,m,e) -; 1 --create a gensym, %add to local environment, compile and assign rhs -; g:= genVariable() -; e:= addBinding(g,nil,e) -; T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil -; e:= put(g,"mode",m1,e) -; [x,m',e]:= convert(T,m) or return nil -; 1.1 --exit if result is a list -; m1 is ["List",D] => -; for y in nameList repeat e:= put(y,"value",[genSomeVariable(),D,$noEnv],e) -; convert([["PROGN",x,["LET",nameList,g],g],m',e],m) -; 2 --verify that the #nameList = number of parts of right-hand-side -; selectorModePairs:= -; --list of modes -; decompose(m1,#nameList,e) or return nil where -; decompose(t,length,e) == -; t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l] -; comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] => -; [[name,:mode] for [":",name,mode] in l] -; stackMessage ["no multiple assigns to mode: ",t] -; #nameList^=#selectorModePairs => -; stackMessage [val," must decompose into ",#nameList," components"] -; 3 --generate code; return -; assignList:= -; [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr -; for x in nameList for [y,:z] in selectorModePairs] -; if assignList="failed" then NIL -; else [MKPROGN [x,:assignList,g],m',e] - -(DEFUN |setqMultiple,decompose| (|t| |length| |e|) - (declare (ignore |length|)) - (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |l| |ISTMP#4| |name| |mode|) - (declare (special |$EmptyMode|)) - (RETURN - (SEQ (IF (AND (PAIRP |t|) (EQ (QCAR |t|) '|Record|) - (PROGN (SPADLET |l| (QCDR |t|)) 'T)) - (EXIT (PROG (G168310) - (SPADLET G168310 NIL) - (RETURN - (DO ((G168316 |l| (CDR G168316)) - (G168272 NIL)) - ((OR (ATOM G168316) - (PROGN - (SETQ G168272 (CAR G168316)) - NIL) - (PROGN - (PROGN - (SPADLET |name| (CADR G168272)) - (SPADLET |mode| - (CADDR G168272)) - G168272) - NIL)) - (NREVERSE0 G168310)) - (SEQ (EXIT (SETQ G168310 - (CONS (CONS |name| |mode|) - G168310))))))))) - (IF (PROGN - (SPADLET |ISTMP#1| (|comp| |t| |$EmptyMode| |e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) - '|RecordCategory|) - (PROGN - (SPADLET |l| (QCDR |ISTMP#3|)) - 'T))) - (PROGN - (SPADLET |ISTMP#4| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL))))))) - (EXIT (PROG (G168328) - (SPADLET G168328 NIL) - (RETURN - (DO ((G168334 |l| (CDR G168334)) - (G168300 NIL)) - ((OR (ATOM G168334) - (PROGN - (SETQ G168300 (CAR G168334)) - NIL) - (PROGN - (PROGN - (SPADLET |name| (CADR G168300)) - (SPADLET |mode| - (CADDR G168300)) - G168300) - NIL)) - (NREVERSE0 G168328)) - (SEQ (EXIT (SETQ G168328 - (CONS (CONS |name| |mode|) - G168328))))))))) - (EXIT (|stackMessage| - (CONS '|no multiple assigns to mode: | - (CONS |t| NIL)))))))) - - -(DEFUN |setqMultiple| (|nameList| |val| |m| |e|) - (PROG (|l| |g| |m1| T$ |x| |m'| |ISTMP#1| D |selectorModePairs| |y| - |z| |LETTMP#1| |assignList|) - (declare (special |$noEnv| |$EmptyMode| |$NoValueMode|)) - (RETURN - (SEQ (COND - ((AND (PAIRP |val|) (EQ (QCAR |val|) 'CONS) - (BOOT-EQUAL |m| |$NoValueMode|)) - (|setqMultipleExplicit| |nameList| (|uncons| |val|) |m| - |e|)) - ((AND (PAIRP |val|) (EQ (QCAR |val|) '|@Tuple|) - (PROGN (SPADLET |l| (QCDR |val|)) 'T) - (BOOT-EQUAL |m| |$NoValueMode|)) - (|setqMultipleExplicit| |nameList| |l| |m| |e|)) - ('T (SPADLET |g| (|genVariable|)) - (SPADLET |e| (|addBinding| |g| NIL |e|)) - (SPADLET T$ - (PROGN - (SPADLET |LETTMP#1| - (OR (|compSetq1| |g| |val| - |$EmptyMode| |e|) - (RETURN NIL))) - (SPADLET |m1| (CADR |LETTMP#1|)) - |LETTMP#1|)) - (SPADLET |e| (|put| |g| '|mode| |m1| |e|)) - (SPADLET |LETTMP#1| (OR (|convert| T$ |m|) (RETURN NIL))) - (SPADLET |x| (CAR |LETTMP#1|)) - (SPADLET |m'| (CADR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (COND - ((AND (PAIRP |m1|) (EQ (QCAR |m1|) '|List|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |m1|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET D (QCAR |ISTMP#1|)) 'T)))) - (DO ((G168370 |nameList| (CDR G168370)) (|y| NIL)) - ((OR (ATOM G168370) - (PROGN (SETQ |y| (CAR G168370)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |e| - (|put| |y| '|value| - (CONS (|genSomeVariable|) - (CONS D (CONS |$noEnv| NIL))) - |e|))))) - (|convert| - (CONS (CONS 'PROGN - (CONS |x| - (CONS - (CONS 'LET - (CONS |nameList| - (CONS |g| NIL))) - (CONS |g| NIL)))) - (CONS |m'| (CONS |e| NIL))) - |m|)) - ('T - (SPADLET |selectorModePairs| - (OR (|setqMultiple,decompose| |m1| - (|#| |nameList|) |e|) - (RETURN NIL))) - (COND - ((NEQUAL (|#| |nameList|) (|#| |selectorModePairs|)) - (|stackMessage| - (CONS |val| - (CONS '| must decompose into | - (CONS (|#| |nameList|) - (CONS '| components| NIL)))))) - ('T - (SPADLET |assignList| - (PROG (G168385) - (SPADLET G168385 NIL) - (RETURN - (DO ((G168395 |nameList| - (CDR G168395)) - (|x| NIL) - (G168396 |selectorModePairs| - (CDR G168396)) - (G168362 NIL)) - ((OR (ATOM G168395) - (PROGN - (SETQ |x| (CAR G168395)) - NIL) - (ATOM G168396) - (PROGN - (SETQ G168362 - (CAR G168396)) - NIL) - (PROGN - (PROGN - (SPADLET |y| - (CAR G168362)) - (SPADLET |z| - (CDR G168362)) - G168362) - NIL)) - (NREVERSE0 G168385)) - (SEQ - (EXIT - (SETQ G168385 - (CONS - (CAR - (PROGN - (SPADLET |LETTMP#1| - (OR - (|compSetq1| |x| - (CONS '|elt| - (CONS |g| (CONS |y| NIL))) - |z| |e|) - (RETURN '|failed|))) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|)) - G168385)))))))) - (COND - ((BOOT-EQUAL |assignList| '|failed|) NIL) - ('T - (CONS (MKPROGN (CONS |x| - (APPEND |assignList| - (CONS |g| NIL)))) - (CONS |m'| (CONS |e| NIL))))))))))))))) - -\end{chunk} \subsection{setqMultipleExplicit} \begin{chunk}{*} ;setqMultipleExplicit(nameList,valList,m,e) == @@ -1503,26 +925,6 @@ ('T (|systemErrorHere| "canReturn"))))))) \end{chunk} -\subsection{compBoolean} -\begin{chunk}{*} -;compBoolean(p,m,E) == -; [p',m,E]:= comp(p,m,E) or return nil -; [p',m,getSuccessEnvironment(p,E),getInverseEnvironment(p,E)] - -(DEFUN |compBoolean| (|p| |m| E) - (PROG (|LETTMP#1| |p'|) - (RETURN - (PROGN - (SPADLET |LETTMP#1| (OR (|comp| |p| |m| E) (RETURN NIL))) - (SPADLET |p'| (CAR |LETTMP#1|)) - (SPADLET |m| (CADR |LETTMP#1|)) - (SPADLET E (CADDR |LETTMP#1|)) - (CONS |p'| - (CONS |m| - (CONS (|getSuccessEnvironment| |p| E) - (CONS (|getInverseEnvironment| |p| E) NIL)))))))) - -\end{chunk} \subsection{getSuccessEnvironment} \begin{chunk}{*} ;getSuccessEnvironment(a,e) ==