diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index ff6db87..8d31e9b 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -33082,6 +33082,463 @@ o )history \end{chunk} \footnote{\fnref{history}} +\section{Evaluation} +Some Antique Comments About the Interpreter + +EVAL BOOT contains the top level interface to the Scratchhpad-II +interpreter. The Entry point into the interpreter from the parser is +processInteractive. + +The type analysis algorithm is contained in the file BOTMUP BOOT, +and MODSEL boot, +the map handling routines are in MAP BOOT and NEWMAP BOOT, and +the interactive coerce routines are in COERCE BOOT and COERCEFN BOOT. + +{\bf Conventions:} +All spad values in the interpreter are passed around in triples. +These are lists of three items: +\begin{verbatim} + [value,mode,environment] +\end{verbatim} +The value +may be wrapped (this is a pair whose CAR is the atom WRAPPED and +whose CDR is the value), which indicates that it is a real value, +or unwrapped in which case it needs to be EVALed to produce the +proper value. The mode is the type of value, and should always be +completely specified (not contain \verb|$EmptyMode|). The environment +is always empty, and is included for historical reasons. + +{\bf Modemaps:} +Modemaps are descriptions of compiled Spad function which the +interpreter uses to perform type analysis. They consist of patterns +of types for the arguments, and conditions the types must satisfy +for the function to apply. For each function name there is a list +of modemaps in file modemap DATABASE for each distinct function with +that name. The following is the list of the modemaps for ``*'' +(multiplication. The first modemap (the one with the labels) is for +module mltiplication which is multiplication of an element of a +module by a member of its scalar domain. + +This is the signature pattern for the modemap, it is of the form: +\begin{verbatim} + (DomainOfComputation TargetType ) + | + | This is the predicate that needs to be + | satisfied for the modemap to apply + | | + V | + /-----------/ | + ( ( (*1 *1 *2 *1) V + /-----------------------------------------------------------/ + ( (AND (ofCategory *1 (Module *2)) (ofCategory *2 (SimpleRing))) ) + . CATDEF) <-- This is the file where the function was defined + ( (*1 *1 *2 *1) + ( (AND (isDomain *2 (Integer)) (ofCategory *1 (AbelianGroup))) ) + . CATDEF) + ( (*1 *1 *2 *1) + ( (AND + (isDomain *2 (NonNegativeInteger)) + (ofCategory *1 (AbelianMonoid))) ) + . CATDEF) + ((*1 *1 *1 *1) ((ofCategory *1 (SemiGroup)) ) . CATDEF) + ) +\end{verbatim} +{\bf Environments:} +Environments associate properties with atoms. + +Some common properties are: +\begin{itemize} +\item {\bf modeSet:} +During interpretation we build a modeSet property for each node in +the expression. This is (in theory) a list of all the types +possible for the node. In the current implementation these +modeSets always contain a single type. +\item {\bf value:} +Value properties are always triples. This is where the values of +variables are stored. We also build value properties for internal +nodes during the bottom up phase. +\item {\bf mode:} +This is the declared type of an identifier. +\end{itemize} + +There are several different environments used in the interpreter: +\begin{itemize} +\item {\bf \verb|$InteractiveFrame|:} this is the environment where the user +values are stored. Any side effects of evaluation of a top-level +expression are stored in this environment. It is always used as +the starting environment for interpretation. +\item {\bf \$e:} +This is the name used for \verb|$InteractiveFrame| while interpreting. +\item {\bf \verb|$env|:} This is local environment used by the interpreter. +Only temporary information (such as types of local variables is +stored in \verb|$env|. +It is thrown away after evaluation of each expression. +\end{itemize} + +Frequently used global variables: +\begin{itemize} +\item {\bf \verb|$genValue|}: if true then evaluate generated code, +otherwise leave code unevaluated. If \verb|$genValue| is false then +we are compiling. +\item {\bf \verb|$op|}: name of the top level operator +(unused except in map printing) +\item {\bf \verb|$mapList|}: list of maps being type analyzed, used in +recursive map type anlysis. +\item {\bf \verb|$compilingMap|}: true when compiling a map, used to +detect where to THROW when interpret-only is invoked +\item {\bf \verb|$compilingLoop|}: true when compiling a loop body, +used to control nesting level of interp-only loop CATCH points +\item {\bf \verb|$interpOnly|}: true when in interpret only mode, used +to call alternate forms of COLLECT and REPEAT. +\item {\bf \verb|$inCOLLECT|}: true when compiling a COLLECT, used +only for hacked stream compiler. +\item {\bf \verb|$StreamFrame|}: used in printing streams, it is the +environment where local stream variables are stored +\item {\bf \verb|$declaredMode|}: Weak type propagation for symbols, +set in upCOERCE and upLET. This variable is used to determine the +alternate polynomial types of Symbols. +\item {\bf \verb|$localVars|}: list of local variables in a map body +\item {\bf \verb|$MapArgumentTypeList|}: hack for stream compilation +\end{itemize} + +\defun{evalDomain}{evalDomain} +\calls{evalDomain}{sayMSG} +\calls{evalDomain}{concat} +\calls{evalDomain}{prefix2String} +\calls{evalDomain}{startTimingProcess} +\calls{evalDomain}{newType?} +\calls{evalDomain}{eval} +\calls{evalDomain}{mkEvalable} +\calls{evalDomain}{stopTimingProcess} +\refsdollar{evalDomain}{evalDomain} +\begin{chunk}{defun evalDomain} +(defun |evalDomain| (form) + (let (result) + (declare (special |$evalDomain|)) + (when |$evalDomain| + (|sayMSG| + (|concat| " instantiating" '|%b| (|prefix2String| form) '|%d|))) + (|startTimingProcess| '|instantiation|) + (cond + ((|newType?| form) form) + ('t + (setq result (|eval| (|mkEvalable| form))) + (|stopTimingProcess| '|instantiation|) + result)))) + +\end{chunk} + +\defun{mkEvalable}{mkEvalable} +\calls{mkEvalable}{pairp} +\calls{mkEvalable}{qcar} +\calls{mkEvalable}{qcdr} +\calls{mkEvalable}{mkEvalable} +\calls{mkEvalable}{devaluate} +\calls{mkEvalable}{mkEvalableRecord} +\calls{mkEvalable}{mkEvalableUnion} +\calls{mkEvalable}{mkEvalableMapping} +\calls{mkEvalable}{loadIfNecessary} +\calls{mkEvalable}{getdatabase} +\calls{mkEvalable}{mkq} +\calls{mkEvalable}{constructor?} +\calls{mkEvalable}{fbpip} +\calls{mkEvalable}{bpiname} +\refsdollar{mkEvalable}{Integer} +\refsdollar{mkEvalable}{EmptyMode} +\begin{chunk}{defun mkEvalable} +(defun |mkEvalable| (form) + (let (op argl kind cosig tmp1 y) + (declare (special |$Integer| |$EmptyMode|)) + (cond + ((pairp form) + (setq op (qcar form)) + (setq argl (qcdr form)) + (cond + ((eq op 'quote) form) + ((eq op 'wrapped) (|mkEvalable| (|devaluate| argl))) + ((eq op '|Record|) (|mkEvalableRecord| form)) + ((eq op '|Union|) (|mkEvalableUnion| form)) + ((eq op '|Mapping|) (|mkEvalableMapping| form)) + ((eq op '|Enumeration|) form) + (t + (|loadIfNecessary| op) + (setq kind (getdatabase op 'constructorkind)) + (cond + ((setq cosig (getdatabase op 'cosig)) + (cons op + (loop for x in argl for typeFlag in (rest cosig) + collect + (cond + (typeFlag + (cond + ((eq kind '|category|) (mkq x)) + ((vecp x) (mkq x)) + (t + (|loadIfNecessary| x) + (|mkEvalable| x)))) + ((and (pairp x) (eq (qcar x) 'quote)) x) + ((and (pairp x) (eq (qcar x) '|#|) (pairp (qcdr x)) + (eq (qcdr (qcdr x)) nil)) + (list 'size (mkq (qcar (qcdr x))))) + (t (mkq x)))))) + (t + (cons op + (loop for x in argl + collect (|mkEvalable| x)))))))) + ((equal form |$EmptyMode|) |$Integer|) + ((and (identp form) (|constructor?| form)) (list form)) + ((fbpip form) (bpiname form)) + (t form)))) + +\end{chunk} + +\defun{mkEvalableUnion}{mkEvalableUnion} +\calls{mkEvalableUnion}{mkEvalable} +\begin{chunk}{defun mkEvalableUnion} +(defun |mkEvalableUnion| (form) + (cond + ((|isTaggedUnion| form) + (cons + (car form) + (loop for item in (rest form) + collect (list '|:| (second item) (|mkEvalable| (third item)))))) + (t + (cons (car form) + (loop for d in (rest form) + collect (|mkEvalable| d)))))) + +\end{chunk} + +\defun{mkEvalableRecord}{mkEvalableRecord} +\calls{mkEvalableRecord}{mkEvalable} +\begin{chunk}{defun mkEvalableRecord} +(defun |mkEvalableRecord| (form) + (let (n d) + (cons + (car form) + (loop for item in (rest form) + collect (list (quote |:|) (second item) (|mkEvalable| (third item))))))) + +\end{chunk} + +\defun{mkEvalableMapping}{mkEvalableMapping} +\calls{mkEvalableMapping}{mkEvalable} +\begin{chunk}{defun mkEvalableMapping} +(defun |mkEvalableMapping| (form) + (cons + (car form) + (loop for d in (rest form) + collect (|mkEvalable| d)))) + +\end{chunk} + +\defun{evaluateType}{evaluateType} +Takes a parsed, unabbreviated type and evaluates it, replacing +type valued variables with their values, and calling bottomUp +on non-type valued arguemnts to the constructor +and finally checking to see whether the type satisfies the +conditions of its modemap +\calls{evaluateType}{isDomainValuedVariable} +\calls{evaluateType}{pairp} +\calls{evaluateType}{qcar} +\calls{evaluateType}{qcdr} +\calls{evaluateType}{mkAtree} +\calls{evaluateType}{bottomUp} +\calls{evaluateType}{objVal} +\calls{evaluateType}{getValue} +\calls{evaluateType}{evaluateSignature} +\calls{evaluateType}{member} +\calls{evaluateType}{evaluateType} +\calls{evaluateType}{constructor?} +\calls{evaluateType}{throwEvalTypeMsg} +\refsdollar{evaluateType}{EmptyMode} +\defsdollar{evaluateType}{expandSegments} +\begin{chunk}{defun evaluateType} +(defun |evaluateType| (form) + (let (|$expandSegments| domain formp op argl) + (declare (special |$expandSegments| |$EmptyMode|)) + (cond + ((setq domain (|isDomainValuedVariable| form)) domain) + ((equal form |$EmptyMode|) form) + ((eq form '?) |$EmptyMode|) + ((stringp form) form) + ((eq form '$) form) + (t + (setq |$expandSegments| nil) + (cond + ((and (pairp form) (eq (qcar form) '|typeOf|) (pairp (qcdr form)) + (eq (qcdr (qcdr form)) nil)) + (setq formp (|mkAtree| form)) + (|bottomUp| formp) + (|objVal| (|getValue| formp))) + ((pairp form) + (setq op (qcar form)) + (setq argl (qcdr form)) + (cond + ((eq op 'category) + (cond + ((pairp argl) + (cons op + (cons (qcar argl) + (loop for s in (qcdr argl) + collect (|evaluateSignature| s))))) + (t form))) + ((|member| op '(|Join| |Mapping|)) + (cons op + (loop for arg in argl + collect (|evaluateType| arg)))) + ((eq op '|Union|) + (cond + ((and argl (pairp (car argl)) (pairp (qcdr (car argl))) + (pairp (qcdr (qcdr (car argl)))) + (eq (qcdr (qcdr (qcdr (car argl)))) nil) + (|member| (qcar (car argl)) '(|:| |Declare|))) + (cons op + (loop for item in argl + collect + (list '|:| (second item) (|evaluateType| (third item)))))) + (t + (cons op + (loop for arg in argl + collect (|evaluateType| arg)))))) + ((eq op '|Record|) + (cons op + (loop for item in argl + collect + (list '|:| (second item) (|evaluateType| (third item)))))) + ((eq op '|Enumeration|) form) + (t (|evaluateType1| form)))) + ((|constructor?| form) + (if (atom form) + (|evaluateType| (list form)) + (|throwEvalTypeMsg| 'S2IE0003 (list form form)))) + (t (|throwEvalTypeMsg| 'S2IE0004 (list form)))))))) + +\end{chunk} + +\defun{evaluateType1}{Eval args passed to a constructor} +Evaluates the arguments passed to a constructor +\calls{evaluateType1}{constructor?} +\calls{evaluateType1}{getConstructorSignature} +\calls{evaluateType1}{throwEvalTypeMsg} +\calls{evaluateType1}{replaceSharps} +\calls{evaluateType1}{nequal} +\calls{evaluateType1}{categoryForm?} +\calls{evaluateType1}{evaluateType} +\calls{evaluateType1}{evalCategory} +\calls{evaluateType1}{getdatabase} +\calls{evaluateType1}{mkAtree} +\calls{evaluateType1}{putTarget} +\calls{evaluateType1}{bottumUp} +\calls{evaluateType1}{pairp} +\calls{evaluateType1}{qcar} +\calls{evaluateType1}{qcdr} +\calls{evaluateType1}{getAndEvalConstructorArguments} +\calls{evaluateType1}{coerceOrRetract} +\calls{evaluateType1}{objValUnwrap} +\calls{evaluateType1}{throwKeyedMsgCannotCoerceWithValue} +\calls{evaluateType1}{makeOrdinal} +\refsdollar{evaluateType1}{quadSymbol} +\refsdollar{evaluateType1}{EmptyMode} +\begin{chunk}{defun evaluateType1} +(defun |evaluateType1| (form) + (let (op argl sig ml xp tree tmp1 m1 z1 zt zv v typeList (argnum 0)) + (declare (special |$quadSymbol| |$EmptyMode|)) + (setq op (car form)) + (setq argl (cdr form)) + (cond + ((|constructor?| op) + (cond + ((null (setq sig (|getConstructorSignature| form))) + (|throwEvalTypeMsg| 'S2IE0005 (list form))) + (t + (setq ml (cdr sig)) + (setq ml (|replaceSharps| ml form)) + (cond + ((nequal (|#| argl) (|#| ml)) + (|throwEvalTypeMsg| 'S2IE0003 (list form form))) + (t + (loop for x in argl for m in ml + do + (setq typeList + (cons + (cond + ((|categoryForm?| m) + (setq m (|evaluateType| (msubstq x '$ m))) + (if (|evalCategory| (setq xp (|evaluateType| x)) m) + xp + (|throwEvalTypeMsg| 'S2IE0004 (list form)))) + (t + (setq m (|evaluateType| m)) + (cond + ((and (eq (getdatabase (|opOf| m) 'constructorkind) '|domain|) + (setq tree (|mkAtree| x)) + (|putTarget| tree m) + (progn + (setq tmp1 (|bottomUp| tree)) + (and (pairp tmp1) + (eq (qcdr tmp1) nil)))) + (setq m1 (qcar tmp1)) + (setq z1 (|getAndEvalConstructorArgument| tree)) + (setq zt (car z1)) + (setq zv (cdr z1)) + (if (setq v (|coerceOrRetract| z1 m)) + (|objValUnwrap| v) + (|throwKeyedMsgCannotCoerceWithValue| zv zt m))) + (t + (when (equal x |$EmptyMode|) (setq x |$quadSymbol|)) + (|throwEvalTypeMsg| 'S2IE0006 + (list (|makeOrdinal| (incf argnum)) m form)))))) + typeList))) + (cons op (nreverse typeList))))))) + (t (|throwEvalTypeMsg| 'S2IE0007 (list op)))))) + +\end{chunk} + +\defdollar{noEvalTypeMsg} +\begin{chunk}{initvars} +(defvar |$noEvalTypeMsg| nil) + +\end{chunk} + +\defun{throwEvalTypeMsg}{throwEvalTypeMsg} +\calls{throwEvalTypeMsg}{spadThrow} +\calls{throwEvalTypeMsg}{throwKeyedMsg} +\refsdollar{throwEvalTypeMsg}{noEvalTypeMsg} +\begin{chunk}{defun throwEvalTypeMsg} +(defun |throwEvalTypeMsg| (msg args) + (declare (special |$noEvalTypeMsg|)) + (if |$noEvalTypeMsg| + (|spadThrow|) + (|throwKeyedMsg| msg args))) + +\end{chunk} + +\defun{makeOrdinal}{makeOrdinal} +\begin{chunk}{defun makeOrdinal} +(defun |makeOrdinal| (i) + (elt '(|first| |second| |third| |fourth| |fifth| |sixth| |seventh| + |eighth| |ninth| |tenth|) + (1- i))) + +\end{chunk} + +\defun{evaluateSignature}{evaluateSignature} +Calls evaluateType on a signature +\calls{evaluateSignature}{evaluateType} +\begin{chunk}{defun evaluateSignature} +(defun |evaluateSignature| (sig) + (cond + ((and (pairp sig) (eq (qcar sig) 'signature) (pairp (qcdr sig)) + (pairp (qcdr (qcdr sig))) (eq (qcdr (qcdr (qcdr sig))) nil)) + (cons 'signature (cons (qcar (qcdr sig)) + (list + (loop for z in (qcar (qcdr (qcdr sig))) + collect (if (eq z '$) z (|evaluateType| z))))))) + (t sig))) + +\end{chunk} + \section{Data Structures} \verb|$frameRecord = [delta1, delta2,... ]| where delta(i) contains changes in the ``backwards'' direction. @@ -40445,6 +40902,10 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun erMsgCompare} \getchunk{defun erMsgSep} \getchunk{defun erMsgSort} +\getchunk{defun evalDomain} +\getchunk{defun evaluateSignature} +\getchunk{defun evaluateType} +\getchunk{defun evaluateType1} \getchunk{defun ExecuteInterpSystemCommand} \getchunk{defun executeQuietCommand} @@ -40652,6 +41113,7 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun make-instream} \getchunk{defun makeLeaderMsg} \getchunk{defun makeMsgFromLine} +\getchunk{defun makeOrdinal} \getchunk{defun make-outstream} \getchunk{defun makePathname} \getchunk{defun makeStream} @@ -40660,6 +41122,10 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun messageprint} \getchunk{defun messageprint-1} \getchunk{defun messageprint-2} +\getchunk{defun mkEvalable} +\getchunk{defun mkEvalableMapping} +\getchunk{defun mkEvalableRecord} +\getchunk{defun mkEvalableUnion} \getchunk{defun mkLineList} \getchunk{defun mkprompt} \getchunk{defun msgCreate} @@ -41330,6 +41796,7 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun tersyscommand} \getchunk{defun thisPosIsEqual} \getchunk{defun thisPosIsLess} +\getchunk{defun throwEvalTypeMsg} \getchunk{defun toFile?} \getchunk{defun tokConstruct} \getchunk{defun token-stack-show} diff --git a/changelog b/changelog index f8582f2..7b4b04d 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20110909 tpd src/axiom-website/patches.html 20110909.01.tpd.patch +20110909 tpd src/interp/i-eval.lisp treeshake interpreter +20110909 tpd books/bookvol5 treeshake interpreter 20110905 tpd src/axiom-website/patches.html 20110905.03.tpd.patch 20110905 tpd src/scripts/tex/axiom.sty fix defplist 20110905 tpd src/doc/axiom.sty fix defplist diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 49ce52e..c7c20a6 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3612,5 +3612,7 @@ src/axiom-website/download.html add Gentoo notes by James Cloos
books/bookvol9 treeshake compiler
20110905.03.tpd.patch src/scripts/tex/axiom.sty fix defplist
+20110909.01.tpd.patch +books/bookvol5 treeshake interpreter
diff --git a/src/interp/i-eval.lisp.pamphlet b/src/interp/i-eval.lisp.pamphlet index 8edb61d..0e6e219 100644 --- a/src/interp/i-eval.lisp.pamphlet +++ b/src/interp/i-eval.lisp.pamphlet @@ -9,338 +9,9 @@ \eject \tableofcontents \eject -Some Antique Comments About the Interpreter - -EVAL BOOT contains the top level interface to the Scratchhpad-II -interpreter. The Entry point into the interpreter from the parser is -processInteractive. - -The type analysis algorithm is contained in the file BOTMUP BOOT, -and MODSEL boot, -the map handling routines are in MAP BOOT and NEWMAP BOOT, and -the interactive coerce routines are in COERCE BOOT and COERCEFN BOOT. - -{\bf Conventions:} -All spad values in the interpreter are passed around in triples. -These are lists of three items: -\begin{verbatim} -[value,mode,environment] -\end{verbatim} -The value -may be wrapped (this is a pair whose CAR is the atom WRAPPED and -whose CDR is the value), which indicates that it is a real value, -or unwrapped in which case it needs to be EVALed to produce the -proper value. The mode is the type of value, and should always be -completely specified (not contain \$EmptyMode). The environment -is always empty, and is included for historical reasons. - -{\bf Modemaps:} -Modemaps are descriptions of compiled Spad function which the -interpreter uses to perform type analysis. They consist of patterns -of types for the arguments, and conditions the types must satisfy -for the function to apply. For each function name there is a list -of modemaps in file modemap DATABASE for each distinct function with -that name. The following is the list of the modemaps for ``*'' -(multiplication. The first modemap (the one with the labels) is for -module mltiplication which is multiplication of an element of a -module by a member of its scalar domain. - -This is the signature pattern for the modemap, it is of the form: -\begin{verbatim} - (DomainOfComputation TargetType ) - | - | This is the predicate that needs to be - | satisfied for the modemap to apply - | | - V | - /-----------/ | - ( ( (*1 *1 *2 *1) V - /-----------------------------------------------------------/ - ( (AND (ofCategory *1 (Module *2)) (ofCategory *2 (SimpleRing))) ) - . CATDEF) <-- This is the file where the function was defined - ( (*1 *1 *2 *1) - ( (AND (isDomain *2 (Integer)) (ofCategory *1 (AbelianGroup))) ) - . CATDEF) - ( (*1 *1 *2 *1) - ( (AND - (isDomain *2 (NonNegativeInteger)) - (ofCategory *1 (AbelianMonoid))) ) - . CATDEF) - ((*1 *1 *1 *1) ((ofCategory *1 (SemiGroup)) ) . CATDEF) - ) -\end{verbatim} -{\bf Environments:} -Environments associate properties with atoms. -(see CUTIL BOOT for the exact structure of environments). -Some common properties are: -\begin{itemize} -\item {\bf modeSet:} -During interpretation we build a modeSet property for each node in -the expression. This is (in theory) a list of all the types -possible for the node. In the current implementation these -modeSets always contain a single type. -\item {\bf value:} -Value properties are always triples. This is where the values of -variables are stored. We also build value properties for internal -nodes during the bottom up phase. -\item {\bf mode:} -This is the declared type of an identifier. -\end{itemize} - -There are several different environments used in the interpreter: -\begin{itemize} -\item {\bf \$InteractiveFrame:} this is the environment where the user -values are stored. Any side effects of evaluation of a top-level -expression are stored in this environment. It is always used as -the starting environment for interpretation. -\item {\bf \$e:} -This is the name used for \$InteractiveFrame while interpreting. -\item {\bf \$env:} This is local environment used by the interpreter. -Only temporary information (such as types of local variables is -stored in \$env. -It is thrown away after evaluation of each expression. -\end{itemize} - -Frequently used global variables: -\begin{itemize} -\item {\bf \$genValue}: if true then evaluate generated code, otherwise leave -code unevaluated. If \$genValue is false then we are compiling. -\item {\bf \$op}: name of the top level operator -(unused except in map printing) -\item {\bf \$mapList}: list of maps being type analyzed, used in recursive -map type anlysis. -\item {\bf \$compilingMap}: true when compiling a map, used to detect where to -THROW when interpret-only is invoked -\item {\bf \$compilingLoop}: true when compiling a loop body, used to control -nesting level of interp-only loop CATCH points -\item {\bf \$interpOnly}: true when in interpret only mode, used to call -alternate forms of COLLECT and REPEAT. -\item {\bf \$inCOLLECT}: true when compiling a COLLECT, used only for hacked -stream compiler. -\item {\bf \$StreamFrame}: used in printing streams, it is the environment -where local stream variables are stored -\item {\bf \$declaredMode}: Weak type propagation for symbols, set in upCOERCE -and upLET. This variable is used to determine -the alternate polynomial types of Symbols. -\item {\bf \$localVars}: list of local variables in a map body -\item {\bf \$MapArgumentTypeList}: hack for stream compilation -\end{itemize} \begin{chunk}{*} (IN-PACKAGE "BOOT" ) -;--% Constructor Evaluation -;$noEvalTypeMsg := nil - -(SPADLET |$noEvalTypeMsg| NIL) - -;evalDomain form == -; if $evalDomain then -; sayMSG concat('" instantiating","%b",prefix2String form,"%d") -; startTimingProcess 'instantiation -; newType? form => form -; result := eval mkEvalable form -; stopTimingProcess 'instantiation -; result - -(DEFUN |evalDomain| (|form|) - (PROG (|result|) - (declare (special |$evalDomain|)) - (RETURN - (PROGN - (COND - (|$evalDomain| - (|sayMSG| - (|concat| " instantiating" - (QUOTE |%b|) (|prefix2String| |form|) (QUOTE |%d|))))) - (|startTimingProcess| (QUOTE |instantiation|)) - (COND - ((|newType?| |form|) |form|) - ((QUOTE T) - (SPADLET |result| (|eval| (|mkEvalable| |form|))) - (|stopTimingProcess| (QUOTE |instantiation|)) - |result|)))))) - -;mkEvalable form == -; form is [op,:argl] => -; op="QUOTE" => form -; op="WRAPPED" => mkEvalable devaluate argl -; op="Record" => mkEvalableRecord form -; op="Union" => mkEvalableUnion form -; op="Mapping"=> mkEvalableMapping form -; op="Enumeration" => form -; loadIfNecessary op -; kind:= GETDATABASE(op,'CONSTRUCTORKIND) -; cosig := GETDATABASE(op, 'COSIG) => -; [op,:[val for x in argl for typeFlag in rest cosig]] where val == -; typeFlag => -; kind = 'category => MKQ x -; VECP x => MKQ x -; loadIfNecessary x -; mkEvalable x -; x is ['QUOTE,:.] => x -; x is ['_#,y] => ['SIZE,MKQ y] -; MKQ x -; [op,:[mkEvalable x for x in argl]] -; form=$EmptyMode => $Integer -; IDENTP form and constructor?(form) => [form] -; FBPIP form => BPINAME form -; form - -(DEFUN |mkEvalable| (|form|) - (PROG (|op| |argl| |kind| |cosig| |ISTMP#1| |y|) - (declare (special |$Integer| |$EmptyMode|)) - (RETURN - (SEQ - (COND - ((AND (PAIRP |form|) - (PROGN - (SPADLET |op| (QCAR |form|)) - (SPADLET |argl| (QCDR |form|)) - (QUOTE T))) - (COND - ((BOOT-EQUAL |op| (QUOTE QUOTE)) |form|) - ((BOOT-EQUAL |op| (QUOTE WRAPPED)) (|mkEvalable| (|devaluate| |argl|))) - ((BOOT-EQUAL |op| (QUOTE |Record|)) (|mkEvalableRecord| |form|)) - ((BOOT-EQUAL |op| (QUOTE |Union|)) (|mkEvalableUnion| |form|)) - ((BOOT-EQUAL |op| (QUOTE |Mapping|)) (|mkEvalableMapping| |form|)) - ((BOOT-EQUAL |op| (QUOTE |Enumeration|)) |form|) - ((QUOTE T) - (|loadIfNecessary| |op|) - (SPADLET |kind| (GETDATABASE |op| (QUOTE CONSTRUCTORKIND))) - (COND - ((SPADLET |cosig| (GETDATABASE |op| (QUOTE COSIG))) - (CONS |op| - (PROG (#0=#:G166087) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166097 |argl| (CDR #1#)) - (|x| NIL) - (#2=#:G166098 (CDR |cosig|) (CDR #2#)) - (|typeFlag| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |x| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |typeFlag| (CAR #2#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# - (CONS - (COND - (|typeFlag| - (COND - ((BOOT-EQUAL |kind| (QUOTE |category|)) (MKQ |x|)) - ((VECP |x|) (MKQ |x|)) - ((QUOTE T) (|loadIfNecessary| |x|) (|mkEvalable| |x|)))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE QUOTE))) |x|) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |#|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) (QUOTE T))))) - (CONS (QUOTE SIZE) (CONS (MKQ |y|) NIL))) - ((QUOTE T) (MKQ |x|))) #0#))))))))) - ((QUOTE T) - (CONS |op| - (PROG (#3=#:G166111) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G166116 |argl| (CDR #4#)) (|x| NIL)) - ((OR (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) - (NREVERSE0 #3#)) - (SEQ (EXIT (SETQ #3# (CONS (|mkEvalable| |x|) #3#))))))))))))) - ((BOOT-EQUAL |form| |$EmptyMode|) |$Integer|) - ((AND (IDENTP |form|) (|constructor?| |form|)) (CONS |form| NIL)) - ((FBPIP |form|) (BPINAME |form|)) - ((QUOTE T) |form|)))))) - -;mkEvalableMapping form == -; [first form,:[mkEvalable d for d in rest form]] - -(DEFUN |mkEvalableMapping| (|form|) - (PROG NIL - (RETURN - (SEQ - (CONS - (CAR |form|) - (PROG (#0=#:G166137) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166142 (CDR |form|) (CDR #1#)) (|d| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |d| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (|mkEvalable| |d|) #0#)))))))))))) - -;mkEvalableRecord form == -; [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]] - -(DEFUN |mkEvalableRecord| (|form|) - (PROG (|n| |d|) - (RETURN - (SEQ - (CONS - (CAR |form|) - (PROG (#0=#:G166161) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166167 (CDR |form|) (CDR #1#)) (#2=#:G166152 NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ #2# (CAR #1#)) NIL) - (PROGN - (PROGN (SPADLET |n| (CADR #2#)) (SPADLET |d| (CADDR #2#)) #2#) - NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# - (CONS - (CONS (QUOTE |:|) (CONS |n| (CONS (|mkEvalable| |d|) NIL))) - #0#)))))))))))) - -;mkEvalableUnion form == -; isTaggedUnion form => -; [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]] -; [first form,:[mkEvalable d for d in rest form]] - -(DEFUN |mkEvalableUnion| (|form|) - (PROG (|n| |d|) - (RETURN - (SEQ - (COND - ((|isTaggedUnion| |form|) - (CONS - (CAR |form|) - (PROG (#0=#:G166190) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166196 (CDR |form|) (CDR #1#)) (#2=#:G166180 NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ #2# (CAR #1#)) NIL) - (PROGN - (PROGN - (SPADLET |n| (CADR #2#)) - (SPADLET |d| (CADDR #2#)) - #2#) - NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# - (CONS - (CONS (QUOTE |:|) (CONS |n| (CONS (|mkEvalable| |d|) NIL))) - #0#))))))))) - ((QUOTE T) - (CONS - (CAR |form|) - (PROG (#3=#:G166207) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G166212 (CDR |form|) (CDR #4#)) (|d| NIL)) - ((OR (ATOM #4#) (PROGN (SETQ |d| (CAR #4#)) NIL)) (NREVERSE0 #3#)) - (SEQ (EXIT (SETQ #3# (CONS (|mkEvalable| |d|) #3#)))))))))))))) - ;evaluateType0 form == ; -- Takes a parsed, unabbreviated type and evaluates it, replacing ; -- type valued variables with their values, and calling bottomUp @@ -517,355 +188,6 @@ the alternate polynomial types of Symbols. (|throwEvalTypeMsg| 'S2IE0003 (CONS |form| (CONS |form| NIL))))))))))))) -;evaluateType form == -; -- Takes a parsed, unabbreviated type and evaluates it, replacing -; -- type valued variables with their values, and calling bottomUp -; -- on non-type valued arguemnts to the constructor -; -- and finally checking to see whether the type satisfies the -; -- conditions of its modemap -; domain:= isDomainValuedVariable form => domain -; form = $EmptyMode => form -; form = "?" => $EmptyMode -; STRINGP form => form -; form = "$" => form -; $expandSegments : local := nil -; form is ['typeOf,.] => -; form' := mkAtree form -; bottomUp form' -; objVal getValue(form') -; form is [op,:argl] => -; op='CATEGORY => -; argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]] -; form -; op in '(Join Mapping) => -; [op,:[evaluateType arg for arg in argl]] -; op='Union => -; argl and first argl is [x,.,.] and member(x,'(_: Declare)) => -; [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] -; [op,:[evaluateType arg for arg in argl]] -; op='Record => -; [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] -; op='Enumeration => form -; evaluateType1 form -; constructor? form => -; ATOM form => evaluateType [form] -; throwEvalTypeMsg("S2IE0003",[form,form]) -; throwEvalTypeMsg("S2IE0004",[form]) - -(DEFUN |evaluateType| (|form|) - (PROG (|$expandSegments| |domain| |form'| |op| |argl| |sigs| |ISTMP#1| - |x| |ISTMP#2| |ISTMP#3| |sel| |type|) - (DECLARE (SPECIAL |$expandSegments| |$EmptyMode|)) - (RETURN - (SEQ - (COND - ((SPADLET |domain| (|isDomainValuedVariable| |form|)) |domain|) - ((BOOT-EQUAL |form| |$EmptyMode|) |form|) - ((BOOT-EQUAL |form| (QUOTE ?)) |$EmptyMode|) - ((STRINGP |form|) |form|) - ((BOOT-EQUAL |form| (QUOTE $)) |form|) - ((QUOTE T) - (SPADLET |$expandSegments| NIL) - (COND - ((AND (PAIRP |form|) - (EQ (QCAR |form|) (QUOTE |typeOf|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) - (SPADLET |form'| (|mkAtree| |form|)) - (|bottomUp| |form'|) - (|objVal| (|getValue| |form'|))) - ((AND (PAIRP |form|) - (PROGN - (SPADLET |op| (QCAR |form|)) - (SPADLET |argl| (QCDR |form|)) - (QUOTE T))) - (COND - ((BOOT-EQUAL |op| (QUOTE CATEGORY)) - (COND - ((AND (PAIRP |argl|) - (PROGN - (SPADLET |x| (QCAR |argl|)) - (SPADLET |sigs| (QCDR |argl|)) - (QUOTE T))) - (CONS |op| - (CONS |x| - (PROG (#0=#:G166416) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166421 |sigs| (CDR #1#)) (|s| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |s| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# (CONS (|evaluateSignature| |s|) #0#)))))))))) - ((QUOTE T) |form|))) - ((|member| |op| (QUOTE (|Join| |Mapping|))) - (CONS |op| - (PROG (#2=#:G166431) - (SPADLET #2# NIL) - (RETURN - (DO ((#3=#:G166436 |argl| (CDR #3#)) (|arg| NIL)) - ((OR (ATOM #3#) (PROGN (SETQ |arg| (CAR #3#)) NIL)) - (NREVERSE0 #2#)) - (SEQ (EXIT (SETQ #2# (CONS (|evaluateType| |arg|) #2#))))))))) - ((BOOT-EQUAL |op| (QUOTE |Union|)) - (COND - ((AND - |argl| - (PROGN - (SPADLET |ISTMP#1| (CAR |argl|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) (EQ (QCDR |ISTMP#3|) NIL))))))) - (|member| |x| (QUOTE (|:| |Declare|)))) - (CONS |op| - (PROG (#4=#:G166447) - (SPADLET #4# NIL) - (RETURN - (DO ((#5=#:G166453 |argl| (CDR #5#)) (#6=#:G166400 NIL)) - ((OR (ATOM #5#) - (PROGN (SETQ #6# (CAR #5#)) NIL) - (PROGN - (PROGN - (SPADLET |sel| (CADR #6#)) - (SPADLET |type| (CADDR #6#)) - #6#) - NIL)) - (NREVERSE0 #4#)) - (SEQ - (EXIT - (SETQ #4# - (CONS - (CONS - (QUOTE |:|) - (CONS |sel| (CONS (|evaluateType| |type|) NIL))) - #4#))))))))) - ((QUOTE T) - (CONS |op| - (PROG (#7=#:G166464) - (SPADLET #7# NIL) - (RETURN - (DO ((#8=#:G166469 |argl| (CDR #8#)) (|arg| NIL)) - ((OR (ATOM #8#) (PROGN (SETQ |arg| (CAR #8#)) NIL)) - (NREVERSE0 #7#)) - (SEQ - (EXIT - (SETQ #7# (CONS (|evaluateType| |arg|) #7#))))))))))) - ((BOOT-EQUAL |op| (QUOTE |Record|)) - (CONS |op| - (PROG (#9=#:G166480) - (SPADLET #9# NIL) - (RETURN - (DO ((#10=#:G166486 |argl| (CDR #10#)) (#11=#:G166405 NIL)) - ((OR (ATOM #10#) - (PROGN (SETQ #11# (CAR #10#)) NIL) - (PROGN - (PROGN - (SPADLET |sel| (CADR #11#)) - (SPADLET |type| (CADDR #11#)) - #11#) - NIL)) - (NREVERSE0 #9#)) - (SEQ - (EXIT - (SETQ #9# - (CONS - (CONS - (QUOTE |:|) - (CONS |sel| (CONS (|evaluateType| |type|) NIL))) - #9#))))))))) - ((BOOT-EQUAL |op| (QUOTE |Enumeration|)) |form|) - ((QUOTE T) (|evaluateType1| |form|)))) - ((|constructor?| |form|) - (COND - ((ATOM |form|) (|evaluateType| (CONS |form| NIL))) - ((QUOTE T) - (|throwEvalTypeMsg| - (QUOTE S2IE0003) - (CONS |form| (CONS |form| NIL)))))) - ((QUOTE T) - (|throwEvalTypeMsg| (QUOTE S2IE0004) (CONS |form| NIL)))))))))) - -;evaluateType1 form == -; --evaluates the arguments passed to a constructor -; [op,:argl]:= form -; constructor? op => -; null (sig := getConstructorSignature form) => -; throwEvalTypeMsg("S2IE0005",[form]) -; [.,:ml] := sig -; ml := replaceSharps(ml,form) -; # argl ^= #ml => throwEvalTypeMsg("S2IE0003",[form,form]) -; for x in argl for m in ml for argnum in 1.. repeat -; typeList := [v,:typeList] where v == -; categoryForm?(m) => -; m := evaluateType MSUBSTQ(x,'_$,m) -; evalCategory(x' := (evaluateType x), m) => x' -; throwEvalTypeMsg("S2IE0004",[form]) -; m := evaluateType m -; GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'domain and -; (tree := mkAtree x) and -; putTarget(tree,m) and ((bottomUp tree) is [m1]) => -; [zt,:zv]:= z1:= getAndEvalConstructorArgument tree -; (v:= coerceOrRetract(z1,m)) => objValUnwrap v -; throwKeyedMsgCannotCoerceWithValue(zv,zt,m) -; if x = $EmptyMode then x := $quadSymbol -; throwEvalTypeMsg("S2IE0006",[makeOrdinal argnum,m,form]) -; [op,:NREVERSE typeList] -; throwEvalTypeMsg("S2IE0007",[op]) - -(DEFUN |evaluateType1| (|form|) - (PROG (|op| |argl| |sig| |ml| |x'| |tree| |ISTMP#1| |m1| |z1| |zt| |zv| - |v| |typeList|) - (declare (special |$quadSymbol| |$EmptyMode|)) - (RETURN - (SEQ - (PROGN - (SPADLET |op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (COND - ((|constructor?| |op|) - (COND - ((NULL (SPADLET |sig| (|getConstructorSignature| |form|))) - (|throwEvalTypeMsg| (QUOTE S2IE0005) (CONS |form| NIL))) - ((QUOTE T) - (SPADLET |ml| (CDR |sig|)) - (SPADLET |ml| (|replaceSharps| |ml| |form|)) - (COND - ((NEQUAL (|#| |argl|) (|#| |ml|)) - (|throwEvalTypeMsg| - (QUOTE S2IE0003) - (CONS |form| (CONS |form| NIL)))) - ((QUOTE T) - (DO ((#0=#:G166558 |argl| (CDR #0#)) - (|x| NIL) - (#1=#:G166559 |ml| (CDR #1#)) - (|m| NIL) - (|argnum| 1 (QSADD1 |argnum|))) - ((OR (ATOM #0#) - (PROGN (SETQ |x| (CAR #0#)) NIL) - (ATOM #1#) - (PROGN (SETQ |m| (CAR #1#)) NIL)) - NIL) - (SEQ - (EXIT - (SPADLET |typeList| - (CONS - (COND - ((|categoryForm?| |m|) - (SPADLET |m| (|evaluateType| (MSUBSTQ |x| (QUOTE $) |m|))) - (COND - ((|evalCategory| (SPADLET |x'| (|evaluateType| |x|)) |m|) - |x'|) - ((QUOTE T) - (|throwEvalTypeMsg| (QUOTE S2IE0004) (CONS |form| NIL))))) - ((QUOTE T) - (SPADLET |m| (|evaluateType| |m|)) - (COND - ((AND - (BOOT-EQUAL - (GETDATABASE (|opOf| |m|) (QUOTE CONSTRUCTORKIND)) - (QUOTE |domain|)) - (SPADLET |tree| (|mkAtree| |x|)) - (|putTarget| |tree| |m|) - (PROGN - (SPADLET |ISTMP#1| (|bottomUp| |tree|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |m1| (QCAR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |z1| (|getAndEvalConstructorArgument| |tree|)) - (SPADLET |zt| (CAR |z1|)) - (SPADLET |zv| (CDR |z1|)) - (COND - ((SPADLET |v| (|coerceOrRetract| |z1| |m|)) - (|objValUnwrap| |v|)) - ((QUOTE T) - (|throwKeyedMsgCannotCoerceWithValue| |zv| |zt| |m|)))) - ((QUOTE T) - (COND - ((BOOT-EQUAL |x| |$EmptyMode|) - (SPADLET |x| |$quadSymbol|))) - (|throwEvalTypeMsg| - (QUOTE S2IE0006) - (CONS - (|makeOrdinal| |argnum|) - (CONS |m| (CONS |form| NIL)))))))) - |typeList|))))) - (CONS |op| (NREVERSE |typeList|))))))) - ((QUOTE T) (|throwEvalTypeMsg| (QUOTE S2IE0007) (CONS |op| NIL))))))))) - -;throwEvalTypeMsg(msg, args) == -; $noEvalTypeMsg => spadThrow() -; throwKeyedMsg(msg, args) - -(DEFUN |throwEvalTypeMsg| (|msg| |args|) - (declare (special |$noEvalTypeMsg|)) - (COND - (|$noEvalTypeMsg| (|spadThrow|)) - ((QUOTE T) (|throwKeyedMsg| |msg| |args|)))) - -;makeOrdinal i == -; ('(first second third fourth fifth sixth seventh eighth ninth tenth)).(i-1) - -(DEFUN |makeOrdinal| (|i|) - (ELT - (QUOTE (|first| |second| |third| |fourth| |fifth| |sixth| |seventh| - |eighth| |ninth| |tenth|)) - (SPADDIFFERENCE |i| 1))) - -;evaluateSignature sig == -; -- calls evaluateType on a signature -; sig is [ ='SIGNATURE,fun,sigl] => -; ['SIGNATURE,fun, -; [(t = '_$ => t; evaluateType(t)) for t in sigl]] -; sig - -(DEFUN |evaluateSignature| (|sig|) - (PROG (|ISTMP#1| |fun| |ISTMP#2| |sigl|) - (RETURN - (SEQ - (COND - ((AND (PAIRP |sig|) - (EQUAL (QCAR |sig|) (QUOTE SIGNATURE)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |sig|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |fun| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |sigl| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (CONS - (QUOTE SIGNATURE) - (CONS |fun| - (CONS - (PROG (#0=#:G166617) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166622 |sigl| (CDR #1#)) (|t| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |t| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# - (CONS - (COND - ((BOOT-EQUAL |t| (QUOTE $)) |t|) - ((QUOTE T) (|evaluateType| |t|))) - #0#))))))) - NIL)))) - ((QUOTE T) |sig|)))))) - ;--% Code Evaluation ;-- This code generates, then evaluates code during the bottom up phase ;-- of interpretation