diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index 91054a1..07b1e91 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -23130,7 +23130,8 @@ o )history \end{chunk} \defun{/read}{/read} -\calls{/read}{} +\seebook{/read}{/rf}{9} +\seebook{/read}{/rq}{9} \uses{/read}{/editfile} \begin{chunk}{defun /read} (defun /read (l q) @@ -35562,27 +35563,6 @@ Returns the value of form if form is a variable with a type value \end{chunk} -\defun{/rq}{/rq} -\seebook{/rq}{/rf-1}{9} -\uses{/rq}{echo-meta} -\begin{chunk}{defun /rq} -(defun /RQ (&rest foo &aux (echo-meta nil)) - (declare (special Echo-Meta) (ignore foo)) - (/rf-1 nil)) - -\end{chunk} - -\defun{/rf}{/rf} -Compile with noisy output -\seebook{/rf}{/rf-1}{9} -\uses{/rf}{echo-meta} -\begin{chunk}{defun /rf} -(defun /rf (&rest foo &aux (echo-meta t)) - (declare (special echo-meta) (ignore foo)) - (/rf-1 nil)) - -\end{chunk} - \defvar{boot-line-stack} \begin{chunk}{initvars} (defvar boot-line-stack nil "List of lines returned from preparse") @@ -44790,8 +44770,6 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun restart0} \getchunk{defun restoreHistory} \getchunk{defun retract} -\getchunk{defun /rf} -\getchunk{defun /rq} \getchunk{defun rread} \getchunk{defun ruleLhsTran} \getchunk{defun rulePredicateTran} diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 83aad5a..f3e9b07 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -4927,8 +4927,6 @@ of the symbol being parsed. The original list read: \end{chunk} \defun{transIs1}{transIs1} -\calls{transIs1}{qcar} -\calls{transIs1}{qcdr} \calls{transIs1}{nreverse0} \calls{transIs1}{transIs} \calls{transIs1}{transIs1} @@ -5132,8 +5130,6 @@ of the symbol being parsed. The original list read: \defun{parseHas}{parseHas} \calls{parseHas}{unabbrevAndLoad} -\calls{parseHas}{qcar} -\calls{parseHas}{qcdr} \calls{parseHas}{getdatabase} \calls{parseHas}{opOf} \calls{parseHas}{makeNonAtomic} @@ -5201,8 +5197,6 @@ of the symbol being parsed. The original list read: \defun{parseHasRhs}{parseHasRhs} \calls{parseHasRhs}{get} -\calls{parseHasRhs}{qcar} -\calls{parseHasRhs}{qcdr} \calls{parseHasRhs}{member} \calls{parseHasRhs}{abbreviation?} \calls{parseHasRhs}{loadIfNecessary} @@ -5923,80 +5917,303 @@ of the symbol being parsed. The original list read: \end{chunk} \chapter{Compile Transformers} - -\defdollar{NoValueMode} -\begin{chunk}{initvars} -(defvar |$NoValueMode| '|NoValueMode|) +With some specific exceptions most compile transformers are invoked +through the property list item ``{\tt special}''. When a specific +keyword is encountered in a list form the {\tt compExpression} function +looks up the keyword on the property list and funcalls the handler +function, passing the form, the mode, and the environment. + +\label{handlers} +If a handler for the keyword is not found then the {\tt compForm} function +is called to attempt to compile the form. +\defun{compExpression}{compExpression} +\calls{compExpression}{getl} +\calls{compExpression}{compForm} +\usesdollar{compExpression}{insideExpressionIfTrue} +\begin{chunk}{defun compExpression} +(defun |compExpression| (form mode env) + (let (|$insideExpressionIfTrue| fn) + (declare (special |$insideExpressionIfTrue|)) + (setq |$insideExpressionIfTrue| t) + (if (and (atom (car form)) (setq fn (getl (car form) 'special))) + (funcall fn form mode env) + (|compForm| form mode env)))) \end{chunk} +The functions in this section are called through the symbol-plist +of the symbol being parsed. In general, each of these functions +takes 3 arguments +\begin{enumerate} +\item the {\bf form} which is specific to the function +\item the {\bf mode} a |Join|, which is a set of categories and domains +\item the {\bf env} which is a list of functions and their modemaps +\end{enumerate} +and the functions return modified versions of the three arguments +suitable for further processing. +\begin{tabular}{ll} +\verb|DEF| & \refto{compDefine}\\ +\verb|add| & \refto{compAdd}\\ +\verb|@| & \refto{compAtSign}\\ +\verb|CAPSULE| & \refto{compCapsule}\\ +\verb|case| & \refto{compCase}\\ +\verb|Mapping| & \refto{compCat}\\ +\verb|Record| & \refto{compCat}\\ +\verb|Union| & \refto{compCat}\\ +\verb|CATEGORY| & \refto{compCategory}\\ +\verb|::| & \refto{compCoerce}\\ +\verb|:| & \refto{compColon}\\ +\verb|CONS| & \refto{compCons}\\ +\verb|construct| & \refto{compConstruct}\\ +\verb|ListCategory| & \refto{compConstructorCategory}\\ +\verb|RecordCategory| & \refto{compConstructorCategory}\\ +\verb|UnionCategory| & \refto{compConstructorCategory}\\ +\verb|VectorCategory| & \refto{compConstructorCategory}\\ +\verb|elt| & \refto{compElt}\\ +\verb|exit| & \refto{compExit}\\ +\verb|has| & \refto{compHas}(pred mode \verb|$e|)\\ +\verb|IF| & \refto{compIf}\\ +\verb|import| & \refto{compImport}\\ +\verb|is| & \refto{compIs}\\ +\verb|Join| & \refto{compJoin}\\ +\verb|+->| & \refto{compLambda}\\ +\verb|leave| & \refto{compLeave}\\ +\verb|MDEF| & \refto{compMacro}\\ +\verb|pretend| & \refto{compPretend}\\ +\verb|QUOTE| & \refto{compQuote}\\ +\verb|REDUCE| & \refto{compReduce}\\ +\verb|COLLECT| & \refto{compRepeatOrCollect}\\ +\verb|REPEAT| & \refto{compRepeatOrCollect}\\ +\verb|return| & \refto{compReturn}\\ +\verb|SEQ| & \refto{compSeq}\\ +\verb|LET| & \refto{compSetq}\\ +\verb|SETQ| & \refto{compSetq}\\ +\verb|String| & \refto{compString}\\ +\verb|SubDomain| & \refto{compSubDomain}\\ +\verb|SubsetCategory| & \refto{compSubsetCategory}\\ +\verb?|? & \refto{compSuchthat}\\ +\verb|VECTOR| & \refto{compVector}\\ +\verb|where| & \refto{compWhere} +\end{tabular} -\defdollar{EmptyMode} -\verb|$EmptyMode| is a contant whose value is \verb|$EmptyMode|. -It is used by isPartialMode to -decide if a modemap is partially constructed. If the \verb|$EmptyMode| -constant occurs anywhere in the modemap structure at any depth -then the modemap is still incomplete. To find this constant the -isPartialMode function calls CONTAINED \verb|$EmptyMode| $Y$ -which will walk the structure $Y$ looking for this constant. -\begin{chunk}{initvars} -(defvar |$EmptyMode| '|EmptyMode|) +\section{Handline Category DEF forms} +This is the graph of the functions used for compDefine. +The syntax is a graphviz dot file. +To generate this graph as a JPEG file, type: +\begin{verbatim} +tangle v9compDefine.dot bookvol9.pamphlet >v9compdefine.dot +dot -Tjpg v9compdefine.dot >v9compdefine.jpg +\end{verbatim} +\begin{chunk}{v9compDefine.dot} +digraph pic { + fontsize=10; + bgcolor="#ECEA81"; + node [shape=box, color=white, style=filled]; -\end{chunk} +"compArgumentConditions" [color="#ECEA81"] +"compDefWhereClause" [color="#ECEA81"] +"compDefine" [color="#ECEA81"] +"compDefine1" [color="#ECEA81"] +"compDefineAddSignature" [color="#ECEA81"] +"compDefineCapsuleFunction" [color="#ECEA81"] +"compDefineCategory" [color="#ECEA81"] +"compDefineCategory1" [color="#ECEA81"] +"compDefineCategory2" [color="#ECEA81"] +"compDefineFunctor" [color="#ECEA81"] +"compDefineFunctor1" [color="#ECEA81"] +"compDefineLisplib" [color="#ECEA81"] +"compInternalFunction" [color="#ECEA81"] +"compMakeDeclaration" [color="#FFFFFF"] +"compFunctorBody" [color="#ECEA81"] +"compOrCroak" [color="#FFFFFF"] +"compile" [color="#ECEA81"] +"compileCases" [color="#ECEA81"] +"compileDocumentation" [color="#ECEA81"] + +"compDefine" -> "compDefine1" +"compDefine1" -> "compDefineCapsuleFunction" +"compDefine1" -> "compDefWhereClause" +"compDefine1" -> "compDefineAddSignature" +"compDefine1" -> "compDefineCategory" +"compDefine1" -> "compDefineFunctor" +"compDefine1" -> "compInternalFunction" +"compDefineCapsuleFunction" -> "compArgumentConditions" +"compDefineCapsuleFunction" -> "compOrCroak" +"compDefineCapsuleFunction" -> "compileCases" +"compDefineCategory" -> "compDefineCategory1" +"compDefineCategory" -> "compDefineLisplib" +"compDefineCategory1" -> "compDefine1" +"compDefineCategory1" -> "compDefineCategory2" +"compDefineCategory2" -> "compMakeDeclaration" +"compDefineCategory2" -> "compOrCroak" +"compDefineCategory2" -> "compile" +"compDefineFunctor" -> "compDefineFunctor1" +"compDefineFunctor" -> "compDefineLisplib" +"compDefineFunctor1" -> "compMakeDeclaration" +"compDefineFunctor1" -> "compFunctorBody" +"compDefineFunctor1" -> "compile" +"compDefineLisplib" -> "compileDocumentation" +"compileCases" -> "compile" -\section{Routines for handling forms} -The functions in this section are called through the symbol-plist -of the symbol being parsed. +} + +\end{chunk} +\includegraphics[scale=0.5]{ps/v9compdefine.eps} +A Category is represented by a DEF form with 4 parts: \begin{itemize} -\item \verb|add| \refto{compAdd}(form mode env) $\rightarrow$ (form mode env) -\item \verb|@| \refto{compAtSign}(form mode env) $\rightarrow$ -\item \verb|CAPSULE| \refto{compCapsule}(form mode env) $\rightarrow$ -\item \verb|case| \refto{compCase}(form mode env) $\rightarrow$ -\item \verb|Mapping| \refto{compCat}(form mode env) $\rightarrow$ -\item \verb|Record| \refto{compCat}(form mode env) $\rightarrow$ -\item \verb|Union| \refto{compCat}(form mode env) $\rightarrow$ -\item \verb|CATEGORY| \refto{compCategory}(form mode env) $\rightarrow$ -\item \verb|::| \refto{compCoerce}(form mode env) $\rightarrow$ -\item \verb|:| \refto{compColon}(form mode env) $\rightarrow$ -\item \verb|CONS| \refto{compCons}(form mode env) $\rightarrow$ -\item \verb|construct| \refto{compConstruct}(form mode env) $\rightarrow$ -\item \verb|ListCategory| \refto{compConstructorCategory}(form mode env) -$\rightarrow$ -\item \verb|RecordCategory| \refto{compConstructorCategory}(form mode env) -$\rightarrow$ -\item \verb|UnionCategory| \refto{compConstructorCategory}(form mode env) -$\rightarrow$ -\item \verb|VectorCategory| \refto{compConstructorCategory}(form mode env) -$\rightarrow$ -\item \verb|DEF| \refto{compDefine}(form mode env) $\rightarrow$ -\item \verb|elt| \refto{compElt}(form mode env) $\rightarrow$ -\item \verb|exit| \refto{compExit}(form mode env) $\rightarrow$ -\item \verb|has| \refto{compHas}(pred mode \verb|$e|) $\rightarrow$ -\item \verb|IF| \refto{compIf}(form mode env) $\rightarrow$ -\item \verb|import| \refto{compImport}(form mode env) $\rightarrow$ -\item \verb|is| \refto{compIs}(form mode env) $\rightarrow$ -\item \verb|Join| \refto{compJoin}(form mode env) $\rightarrow$ -\item \verb|+->| \refto{compLambda}(form mode env) $\rightarrow$ -\item \verb|leave| \refto{compLeave}(form mode env) $\rightarrow$ -\item \verb|MDEF| \refto{compMacro}(form mode env) $\rightarrow$ -\item \verb|pretend| \refto{compPretend} $\rightarrow$ -\item \verb|QUOTE| \refto{compQuote}(form mode env) $\rightarrow$ -\item \verb|REDUCE| \refto{compReduce}(form mode env) $\rightarrow$ -\item \verb|COLLECT| \refto{compRepeatOrCollect}(form mode env) $\rightarrow$ -\item \verb|REPEAT| \refto{compRepeatOrCollect}(form mode env) $\rightarrow$ -\item \verb|return| \refto{compReturn}(form mode env) $\rightarrow$ -\item \verb|SEQ| \refto{compSeq}(form mode env) $\rightarrow$ -\item \verb|LET| \refto{compSetq}(form mode env) $\rightarrow$ -\item \verb|SETQ| \refto{compSetq}(form mode env) $\rightarrow$ -\item \verb|String| \refto{compString}(form mode env) $\rightarrow$ -\item \verb|SubDomain| \refto{compSubDomain}(form mode env) $\rightarrow$ -\item \verb|SubsetCategory| \refto{compSubsetCategory}(form mode env) -$\rightarrow$ -\item \verb?|? \refto{compSuchthat}(form mode env) $\rightarrow$ -\item \verb|VECTOR| \refto{compVector}(form mode env) $\rightarrow$ -\item \verb|where| \refto{compWhere}(form mode eInit) $\rightarrow$ +\item a name +\item a distnature +\item an SC +\item a body \end{itemize} +For example, the BasicType category is written as +\begin{verbatim} +BasicType(): Category == with + "=": (%,%) -> Boolean ++ x=y tests if x and y are equal. + "~=": (%,%) -> Boolean ++ x~=y tests if x and y are not equal. + add + _~_=(x:%,y:%) : Boolean == not(x=y) +\end{verbatim} +Which compiles to the DEF form: +\begin{verbatim} + (DEF + (|BasicType|) + ((|Category|)) + (NIL) + (|add| + (CATEGORY |domain| + (SIGNATURE = ((|Boolean|) $ $)) + (SIGNATURE ~= ((|Boolean|) $ $))) + (CAPSULE + (DEF + (~= |x| |y|) + ((|Boolean|) $ $) + (NIL NIL NIL) + (IF (= |x| |y|) |false| |true|))))) +\end{verbatim} + +\defplist{def}{compDefine plist} +We set up the {\tt compDefine} function to handle the DEF keyword +by setting the {\tt special} keyword on the DEF symbol property list. +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'def 'special) '|compDefine|)) + +\end{chunk} + +\defun{compDefine}{compDefine} +The compDefine function expects three arguments: +\begin{enumerate} +\item the {\bf form} which is an def specifying the domain to define. +\item the {\bf mode} a |Join|, which is a set of categories and domains +\item the {\bf env} which is a list of functions and their modemaps +\end{enumerate} +\calls{compDefine}{compDefine1} +\defsdollar{compDefine}{tripleCache} +\defsdollar{compDefine}{tripleHits} +\defsdollar{compDefine}{macroIfTrue} +\defsdollar{compDefine}{packagesUsed} +\begin{chunk}{defun compDefine} +(defun |compDefine| (form mode env) + (let (|$tripleCache| |$tripleHits| |$macroIfTrue| |$packagesUsed|) + (declare (special |$tripleCache| |$tripleHits| |$macroIfTrue| + |$packagesUsed|)) + (setq |$tripleCache| nil) + (setq |$tripleHits| 0) + (setq |$macroIfTrue| nil) + (setq |$packagesUsed| nil) + (|compDefine1| form mode env))) + +\end{chunk} + +\defun{compDefine1}{compDefine1} +\calls{compDefine1}{macroExpand} +\calls{compDefine1}{isMacro} +\calls{compDefine1}{getSignatureFromMode} +\calls{compDefine1}{compDefine1} +\calls{compDefine1}{compInternalFunction} +\calls{compDefine1}{compDefineAddSignature} +\calls{compDefine1}{compDefWhereClause} +\calls{compDefine1}{compDefineCategory} +\calls{compDefine1}{isDomainForm} +\calls{compDefine1}{getTargetFromRhs} +\calls{compDefine1}{giveFormalParametersValues} +\calls{compDefine1}{addEmptyCapsuleIfNecessary} +\calls{compDefine1}{compDefineFunctor} +\calls{compDefine1}{stackAndThrow} +\calls{compDefine1}{strconc} +\calls{compDefine1}{getAbbreviation} +\calls{compDefine1}{length} +\calls{compDefine1}{compDefineCapsuleFunction} +\usesdollar{compDefine1}{insideExpressionIfTrue} +\usesdollar{compDefine1}{formalArgList} +\usesdollar{compDefine1}{form} +\usesdollar{compDefine1}{op} +\usesdollar{compDefine1}{prefix} +\usesdollar{compDefine1}{insideFunctorIfTrue} +\usesdollar{compDefine1}{Category} +\usesdollar{compDefine1}{insideCategoryIfTrue} +\usesdollar{compDefine1}{insideCapsuleFunctionIfTrue} +\usesdollar{compDefine1}{ConstructorNames} +\usesdollar{compDefine1}{NoValueMode} +\usesdollar{compDefine1}{EmptyMode} +\usesdollar{compDefine1}{insideWhereIfTrue} +\usesdollar{compDefine1}{insideExpressionIfTrue} +\begin{chunk}{defun compDefine1} +(defun |compDefine1| (form mode env) + (let (|$insideExpressionIfTrue| lhs specialCases sig signature rhs newPrefix + (tmp1 t)) + (declare (special |$insideExpressionIfTrue| |$formalArgList| |$form| + |$op| |$prefix| |$insideFunctorIfTrue| |$Category| + |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| + |$ConstructorNames| |$NoValueMode| |$EmptyMode| + |$insideWhereIfTrue| |$insideExpressionIfTrue|)) + (setq |$insideExpressionIfTrue| nil) + (setq form (|macroExpand| form env)) + (setq lhs (second form)) + (setq signature (third form)) + (setq specialCases (fourth form)) + (setq rhs (fifth form)) + (cond + ((and |$insideWhereIfTrue| + (|isMacro| form env) + (or (equal mode |$EmptyMode|) (equal mode |$NoValueMode|))) + (list lhs mode (|put| (car lhs) '|macro| rhs env))) + ((and (null (car signature)) (consp rhs) + (null (member (qfirst rhs) |$ConstructorNames|)) + (setq sig (|getSignatureFromMode| lhs env))) + (|compDefine1| + (list 'def lhs (cons (car sig) (cdr signature)) specialCases rhs) + mode env)) + (|$insideCapsuleFunctionIfTrue| (|compInternalFunction| form mode env)) + (t + (when (equal (car signature) |$Category|) (setq |$insideCategoryIfTrue| t)) + (setq env (|compDefineAddSignature| lhs signature env)) + (cond + ((null (dolist (x (rest signature) tmp1) (setq tmp1 (and tmp1 (null x))))) + (|compDefWhereClause| form mode env)) + ((equal (car signature) |$Category|) + (|compDefineCategory| form mode env nil |$formalArgList|)) + ((and (|isDomainForm| rhs env) (null |$insideFunctorIfTrue|)) + (when (null (car signature)) + (setq signature + (cons (|getTargetFromRhs| lhs rhs + (|giveFormalParametersValues| (cdr lhs) env)) + (cdr signature)))) + (setq rhs (|addEmptyCapsuleIfNecessary| (car signature) rhs)) + (|compDefineFunctor| + (list 'def lhs signature specialCases rhs) + mode env NIL |$formalArgList|)) + ((null |$form|) + (|stackAndThrow| (list "bad == form " form))) + (t + (setq newPrefix + (if |$prefix| + (intern (strconc (|encodeItem| |$prefix|) "," (|encodeItem| |$op|))) + (|getAbbreviation| |$op| (|#| (cdr |$form|))))) + (|compDefineCapsuleFunction| + form mode env newPrefix |$formalArgList|))))))) -\section{Functions which handle == statements} +\end{chunk} \defun{compDefineAddSignature}{compDefineAddSignature} \calls{compDefineAddSignature}{hasFullSignature} @@ -6026,6751 +6243,6654 @@ $\rightarrow$ \end{chunk} -\defun{hasFullSignature}{hasFullSignature} -\tpdhere{test with BASTYPE} -\calls{hasFullSignature}{get} -\begin{chunk}{defun hasFullSignature} -(defun |hasFullSignature| (argl signature env) - (let (target ml u) - (setq target (first signature)) - (setq ml (rest signature)) - (when target - (setq u - (loop for x in argl for m in ml - collect (or m (|get| x '|mode| env) (return 'failed)))) - (unless (eq u 'failed) (cons target u))))) - -\end{chunk} - -\defun{addEmptyCapsuleIfNecessary}{addEmptyCapsuleIfNecessary} -\calls{addEmptyCapsuleIfNecessary}{kar} -\usesdollar{addEmptyCapsuleIfNecessary}{SpecialDomainNames} -\begin{chunk}{defun addEmptyCapsuleIfNecessary} -(defun |addEmptyCapsuleIfNecessary| (target rhs) - (declare (special |$SpecialDomainNames|) (ignore target)) - (if (member (kar rhs) |$SpecialDomainNames|) - rhs - (list '|add| rhs (list 'capsule)))) - -\end{chunk} - -\defun{getTargetFromRhs}{getTargetFromRhs} -\calls{getTargetFromRhs}{stackSemanticError} -\calls{getTargetFromRhs}{getTargetFromRhs} -\calls{getTargetFromRhs}{compOrCroak} -\begin{chunk}{defun getTargetFromRhs} -(defun |getTargetFromRhs| (lhs rhs env) - (declare (special |$EmptyMode|)) - (cond - ((and (consp rhs) (eq (qfirst rhs) 'capsule)) - (|stackSemanticError| - (list "target category of " lhs - " cannot be determined from definition") - nil)) - ((and (consp rhs) (eq (qfirst rhs) '|SubDomain|) (consp (qrest rhs))) - (|getTargetFromRhs| lhs (second rhs) env)) - ((and (consp rhs) (eq (qfirst rhs) '|add|) - (consp (qrest rhs)) (consp (qcddr rhs)) - (eq (qcdddr rhs) nil) - (consp (qthird rhs)) - (eq (qcaaddr rhs) 'capsule)) - (|getTargetFromRhs| lhs (second rhs) env)) - ((and (consp rhs) (eq (qfirst rhs) '|Record|)) - (cons '|RecordCategory| (rest rhs))) - ((and (consp rhs) (eq (qfirst rhs) '|Union|)) - (cons '|UnionCategory| (rest rhs))) - ((and (consp rhs) (eq (qfirst rhs) '|List|)) - (cons '|ListCategory| (rest rhs))) - ((and (consp rhs) (eq (qfirst rhs) '|Vector|)) - (cons '|VectorCategory| (rest rhs))) - (t - (second (|compOrCroak| rhs |$EmptyMode| env))))) - -\end{chunk} - -\defun{giveFormalParametersValues}{giveFormalParametersValues} -\calls{giveFormalParametersValues}{put} -\calls{giveFormalParametersValues}{get} -\begin{chunk}{defun giveFormalParametersValues} -(defun |giveFormalParametersValues| (argl env) - (dolist (x argl) - (setq env - (|put| x '|value| - (list (|genSomeVariable|) (|get| x '|mode| env) nil) env))) - env) +\defun{compDefineFunctor}{compDefineFunctor} +\calls{compDefineFunctor}{compDefineLisplib} +\calls{compDefineFunctor}{compDefineFunctor1} +\usesdollar{compDefineFunctor}{domainShell} +\usesdollar{compDefineFunctor}{profileCompiler} +\usesdollar{compDefineFunctor}{lisplib} +\usesdollar{compDefineFunctor}{profileAlist} +\begin{chunk}{defun compDefineFunctor} +(defun |compDefineFunctor| (df mode env prefix fal) + (let (|$domainShell| |$profileCompiler| |$profileAlist|) + (declare (special |$domainShell| |$profileCompiler| $lisplib |$profileAlist|)) + (setq |$domainShell| nil) + (setq |$profileCompiler| t) + (setq |$profileAlist| nil) + (if $lisplib + (|compDefineLisplib| df mode env prefix fal '|compDefineFunctor1|) + (|compDefineFunctor1| df mode env prefix fal)))) \end{chunk} -\defun{macroExpandInPlace}{macroExpandInPlace} -\calls{macroExpandInPlace}{macroExpand} -\begin{chunk}{defun macroExpandInPlace} -(defun |macroExpandInPlace| (form env) - (let (y) - (setq y (|macroExpand| form env)) - (if (or (atom form) (atom y)) - y - (progn - (rplaca form (car y)) - (rplacd form (cdr y)) - form - )))) - -\end{chunk} - -\defun{macroExpand}{macroExpand} -\calls{macroExpand}{macroExpand} -\calls{macroExpand}{macroExpandList} -\begin{chunk}{defun macroExpand} -(defun |macroExpand| (form env) - (let (u) - (cond - ((atom form) - (if (setq u (|get| form '|macro| env)) - (|macroExpand| u env) - form)) - ((and (consp form) (eq (qfirst form) 'def) - (consp (qrest form)) - (consp (qcddr form)) - (consp (qcdddr form)) - (consp (qcddddr form)) - (eq (qrest (qcddddr form)) nil)) - (list 'def (|macroExpand| (second form) env) - (|macroExpandList| (third form) env) - (|macroExpandList| (fourth form) env) - (|macroExpand| (fifth form) env))) - (t (|macroExpandList| form env))))) - -\end{chunk} - -\defun{macroExpandList}{macroExpandList} -\calls{macroExpandList}{macroExpand} -\calls{macroExpandList}{getdatabase} -\begin{chunk}{defun macroExpandList} -(defun |macroExpandList| (lst env) - (let (tmp) - (if (and (consp lst) (eq (qrest lst) nil) - (identp (qfirst lst)) (getdatabase (qfirst lst) 'niladic) - (setq tmp (|get| (qfirst lst) '|macro| env))) - (|macroExpand| tmp env) - (loop for x in lst collect (|macroExpand| x env))))) - -\end{chunk} - -\defun{compDefineCategory1}{compDefineCategory1} -\calls{compDefineCategory1}{compDefineCategory2} -\calls{compDefineCategory1}{makeCategoryPredicates} -\calls{compDefineCategory1}{compDefine1} -\calls{compDefineCategory1}{mkCategoryPackage} -\usesdollar{compDefineCategory1}{insideCategoryPackageIfTrue} -\usesdollar{compDefineCategory1}{EmptyMode} -\usesdollar{compDefineCategory1}{categoryPredicateList} -\usesdollar{compDefineCategory1}{lisplibCategory} -\usesdollar{compDefineCategory1}{bootStrapMode} -\begin{chunk}{defun compDefineCategory1} -(defun |compDefineCategory1| (df mode env prefix fal) - (let (|$insideCategoryPackageIfTrue| |$categoryPredicateList| form - sig sc cat body categoryCapsule d tmp1 tmp3) - (declare (special |$insideCategoryPackageIfTrue| |$EmptyMode| - |$categoryPredicateList| |$lisplibCategory| - |$bootStrapMode|)) - ;; a category is a DEF form with 4 parts: - ;; ((DEF (|BasicType|) ((|Category|)) (NIL) - ;; (|add| (CATEGORY |domain| (SIGNATURE = ((|Boolean|) $ $)) - ;; (SIGNATURE ~= ((|Boolean|) $ $))) - ;; (CAPSULE (DEF (~= |x| |y|) ((|Boolean|) $ $) (NIL NIL NIL) - ;; (IF (= |x| |y|) |false| |true|)))))) +\defun{compDefineFunctor1}{compDefineFunctor1} +\calls{compDefineFunctor1}{isCategoryPackageName} +\calls{compDefineFunctor1}{getArgumentModeOrMoan} +\calls{compDefineFunctor1}{getModemap} +\calls{compDefineFunctor1}{giveFormalParametersValues} +\calls{compDefineFunctor1}{compMakeCategoryObject} +\calls{compDefineFunctor1}{sayBrightly} +\calls{compDefineFunctor1}{pp} +\calls{compDefineFunctor1}{strconc} +\calls{compDefineFunctor1}{pname} +\calls{compDefineFunctor1}{disallowNilAttribute} +\calls{compDefineFunctor1}{remdup} +\calls{compDefineFunctor1}{NRTgenInitialAttributeAlist} +\calls{compDefineFunctor1}{NRTgetLocalIndex} +\calls{compDefineFunctor1}{compMakeDeclaration} +\calls{compDefineFunctor1}{augModemapsFromCategoryRep} +\calls{compDefineFunctor1}{augModemapsFromCategory} +\calls{compDefineFunctor1}{sublis} +\calls{compDefineFunctor1}{maxindex} +\calls{compDefineFunctor1}{makeFunctorArgumentParameters} +\calls{compDefineFunctor1}{compFunctorBody} +\calls{compDefineFunctor1}{reportOnFunctorCompilation} +\calls{compDefineFunctor1}{compile} +\calls{compDefineFunctor1}{augmentLisplibModemapsFromFunctor} +\calls{compDefineFunctor1}{reportOnFunctorCompilation} +\calls{compDefineFunctor1}{getParentsFor} +\calls{compDefineFunctor1}{computeAncestorsOf} +\calls{compDefineFunctor1}{constructor?} +\calls{compDefineFunctor1}{NRTmakeSlot1Info} +\calls{compDefineFunctor1}{isCategoryPackageName} +\calls{compDefineFunctor1}{lisplibWrite} +\calls{compDefineFunctor1}{mkq} +\calls{compDefineFunctor1}{getdatabase} +\calls{compDefineFunctor1}{NRTgetLookupFunction} +\calls{compDefineFunctor1}{simpBool} +\calls{compDefineFunctor1}{removeZeroOne} +\calls{compDefineFunctor1}{evalAndRwriteLispForm} +\usesdollar{compDefineFunctor1}{lisplib} +\usesdollar{compDefineFunctor1}{top-level} +\usesdollar{compDefineFunctor1}{bootStrapMode} +\usesdollar{compDefineFunctor1}{CategoryFrame} +\usesdollar{compDefineFunctor1}{CheckVectorList} +\usesdollar{compDefineFunctor1}{FormalMapVariableList} +\usesdollar{compDefineFunctor1}{LocalDomainAlist} +\usesdollar{compDefineFunctor1}{NRTaddForm} +\usesdollar{compDefineFunctor1}{NRTaddList} +\usesdollar{compDefineFunctor1}{NRTattributeAlist} +\usesdollar{compDefineFunctor1}{NRTbase} +\usesdollar{compDefineFunctor1}{NRTdeltaLength} +\usesdollar{compDefineFunctor1}{NRTdeltaListComp} +\usesdollar{compDefineFunctor1}{NRTdeltaList} +\usesdollar{compDefineFunctor1}{NRTdomainFormList} +\usesdollar{compDefineFunctor1}{NRTloadTimeAlist} +\usesdollar{compDefineFunctor1}{NRTslot1Info} +\usesdollar{compDefineFunctor1}{NRTslot1PredicateList} +\usesdollar{compDefineFunctor1}{Representation} +\usesdollar{compDefineFunctor1}{addForm} +\usesdollar{compDefineFunctor1}{attributesName} +\usesdollar{compDefineFunctor1}{byteAddress} +\usesdollar{compDefineFunctor1}{byteVec} +\usesdollar{compDefineFunctor1}{compileOnlyCertainItems} +\usesdollar{compDefineFunctor1}{condAlist} +\usesdollar{compDefineFunctor1}{domainShell} +\usesdollar{compDefineFunctor1}{form} +\usesdollar{compDefineFunctor1}{functionLocations} +\usesdollar{compDefineFunctor1}{functionStats} +\usesdollar{compDefineFunctor1}{functorForm} +\usesdollar{compDefineFunctor1}{functorLocalParameters} +\usesdollar{compDefineFunctor1}{functorStats} +\usesdollar{compDefineFunctor1}{functorSpecialCases} +\usesdollar{compDefineFunctor1}{functorTarget} +\usesdollar{compDefineFunctor1}{functorsUsed} +\usesdollar{compDefineFunctor1}{genFVar} +\usesdollar{compDefineFunctor1}{genSDVar} +\usesdollar{compDefineFunctor1}{getDomainCode} +\usesdollar{compDefineFunctor1}{goGetList} +\usesdollar{compDefineFunctor1}{insideCategoryPackageIfTrue} +\usesdollar{compDefineFunctor1}{insideFunctorIfTrue} +\usesdollar{compDefineFunctor1}{isOpPackageName} +\usesdollar{compDefineFunctor1}{libFile} +\usesdollar{compDefineFunctor1}{lisplibAbbreviation} +\usesdollar{compDefineFunctor1}{lisplibAncestors} +\usesdollar{compDefineFunctor1}{lisplibCategoriesExtended} +\usesdollar{compDefineFunctor1}{lisplibCategory} +\usesdollar{compDefineFunctor1}{lisplibForm} +\usesdollar{compDefineFunctor1}{lisplibKind} +\usesdollar{compDefineFunctor1}{lisplibMissingFunctions} +\usesdollar{compDefineFunctor1}{lisplibModemap} +\usesdollar{compDefineFunctor1}{lisplibOperationAlist} +\usesdollar{compDefineFunctor1}{lisplibParents} +\usesdollar{compDefineFunctor1}{lisplibSlot1} +\usesdollar{compDefineFunctor1}{lookupFunction} +\usesdollar{compDefineFunctor1}{myFunctorBody} +\usesdollar{compDefineFunctor1}{mutableDomain} +\usesdollar{compDefineFunctor1}{mutableDomains} +\usesdollar{compDefineFunctor1}{op} +\usesdollar{compDefineFunctor1}{pairlis} +\usesdollar{compDefineFunctor1}{QuickCode} +\usesdollar{compDefineFunctor1}{setelt} +\usesdollar{compDefineFunctor1}{signature} +\usesdollar{compDefineFunctor1}{template} +\usesdollar{compDefineFunctor1}{uncondAlist} +\usesdollar{compDefineFunctor1}{viewNames} +\usesdollar{compDefineFunctor1}{lisplibFunctionLocations} +\begin{chunk}{defun compDefineFunctor1} +(defun |compDefineFunctor1| (df mode |$e| |$prefix| |$formalArgList|) + (declare (special |$e| |$prefix| |$formalArgList|)) + (labels ( + (FindRep (cb) + (loop while cb do + (when (atom cb) (return nil)) + (when (and (consp cb) (consp (qfirst cb)) (eq (qcaar cb) 'let) + (consp (qcdar cb)) (eq (qcadar cb) '|Rep|) + (consp (qcddar cb))) + (return (caddar cb))) + (pop cb)))) + (let (|$addForm| |$viewNames| |$functionStats| |$functorStats| + |$form| |$op| |$signature| |$functorTarget| + |$Representation| |$LocalDomainAlist| |$functorForm| + |$functorLocalParameters| |$CheckVectorList| + |$getDomainCode| |$insideFunctorIfTrue| |$functorsUsed| + |$setelt| $TOP_LEVEL |$genFVar| |$genSDVar| + |$mutableDomain| |$attributesName| |$goGetList| + |$condAlist| |$uncondAlist| |$NRTslot1PredicateList| + |$NRTattributeAlist| |$NRTslot1Info| |$NRTbase| + |$NRTaddForm| |$NRTdeltaList| |$NRTdeltaListComp| + |$NRTaddList| |$NRTdeltaLength| |$NRTloadTimeAlist| + |$NRTdomainFormList| |$template| |$functionLocations| + |$isOpPackageName| |$lookupFunction| |$byteAddress| + |$byteVec| form signature body originale argl signaturep target ds + attributeList parSignature parForm + argPars opp rettype tt bodyp lamOrSlam fun + operationAlist modemap libFn tmp1) + (declare (special $lisplib $top_level |$bootStrapMode| |$CategoryFrame| + |$CheckVectorList| |$FormalMapVariableList| + |$LocalDomainAlist| |$NRTaddForm| |$NRTaddList| + |$NRTattributeAlist| |$NRTbase| |$NRTdeltaLength| + |$NRTdeltaListComp| |$NRTdeltaList| |$NRTdomainFormList| + |$NRTloadTimeAlist| |$NRTslot1Info| |$NRTslot1PredicateList| + |$Representation| |$addForm| |$attributesName| + |$byteAddress| |$byteVec| |$compileOnlyCertainItems| + |$condAlist| |$domainShell| |$form| |$functionLocations| + |$functionStats| |$functorForm| |$functorLocalParameters| + |$functorStats| |$functorSpecialCases| |$functorTarget| + |$functorsUsed| |$genFVar| |$genSDVar| |$getDomainCode| + |$goGetList| |$insideCategoryPackageIfTrue| + |$insideFunctorIfTrue| |$isOpPackageName| |$libFile| + |$lisplibAbbreviation| |$lisplibAncestors| + |$lisplibCategoriesExtended| |$lisplibCategory| + |$lisplibForm| |$lisplibKind| |$lisplibMissingFunctions| + |$lisplibModemap| |$lisplibOperationAlist| |$lisplibParents| + |$lisplibSlot1| |$lookupFunction| |$myFunctorBody| + |$mutableDomain| |$mutableDomains| |$op| |$pairlis| + |$QuickCode| |$setelt| |$signature| |$template| + |$uncondAlist| |$viewNames| |$lisplibFunctionLocations|)) (setq form (second df)) - (setq sig (third df)) - (setq sc (fourth df)) + (setq signature (third df)) + (setq |$functorSpecialCases| (fourth df)) (setq body (fifth df)) - (setq categoryCapsule - (when (and (consp body) (eq (qfirst body) '|add|) - (consp (qrest body)) (consp (qcddr body)) - (eq (qcdddr body) nil)) - (setq tmp1 (third body)) - (setq body (second body)) - tmp1)) - (setq tmp3 (|compDefineCategory2| form sig sc body mode env prefix fal)) - (setq d (first tmp3)) - (setq mode (second tmp3)) - (setq env (third tmp3)) - (when (and categoryCapsule (null |$bootStrapMode|)) - (setq |$insideCategoryPackageIfTrue| t) - (setq |$categoryPredicateList| - (|makeCategoryPredicates| form |$lisplibCategory|)) - (setq env (third - (|compDefine1| - (|mkCategoryPackage| form cat categoryCapsule) |$EmptyMode| env)))) - (list d mode env))) - -\end{chunk} - -\defun{makeCategoryPredicates}{makeCategoryPredicates} -\usesdollar{makeCategoryPredicates}{FormalMapVariableList} -\usesdollar{makeCategoryPredicates}{TriangleVariableList} -\usesdollar{makeCategoryPredicates}{mvl} -\usesdollar{makeCategoryPredicates}{tvl} -\begin{chunk}{defun makeCategoryPredicates} -(defun |makeCategoryPredicates| (form u) - (labels ( - (fn (u pl) - (declare (special |$tvl| |$mvl|)) - (cond - ((and (consp u) (eq (qfirst u) '|Join|) (consp (qrest u))) - (fn (car (reverse (qrest u))) pl)) - ((and (consp u) (eq (qfirst u) '|has|)) - (|insert| (eqsubstlist |$mvl| |$tvl| u) pl)) - ((and (consp u) (member (qfirst u) '(signature attribute))) pl) - ((atom u) pl) - (t (fnl u pl)))) - (fnl (u pl) - (dolist (x u) (setq pl (fn x pl))) - pl)) - (declare (special |$FormalMapVariableList| |$mvl| |$tvl| - |$TriangleVariableList|)) - (setq |$tvl| (take (|#| (cdr form)) |$TriangleVariableList|)) - (setq |$mvl| (take (|#| (cdr form)) (cdr |$FormalMapVariableList|))) - (fn u nil))) - -\end{chunk} - -\defun{mkCategoryPackage}{mkCategoryPackage} -\calls{mkCategoryPackage}{strconc} -\calls{mkCategoryPackage}{pname} -\calls{mkCategoryPackage}{getdatabase} -\calls{mkCategoryPackage}{abbreviationsSpad2Cmd} -\calls{mkCategoryPackage}{JoinInner} -\calls{mkCategoryPackage}{assoc} -\calls{mkCategoryPackage}{sublislis} -\usesdollar{mkCategoryPackage}{options} -\usesdollar{mkCategoryPackage}{categoryPredicateList} -\usesdollar{mkCategoryPackage}{e} -\usesdollar{mkCategoryPackage}{FormalMapVariableList} -\begin{chunk}{defun mkCategoryPackage} -(defun |mkCategoryPackage| (form cat def) - (labels ( - (fn (x oplist) - (cond - ((atom x) oplist) - ((and (consp x) (eq (qfirst x) 'def) (consp (qrest x))) - (cons (second x) oplist)) - (t - (fn (cdr x) (fn (car x) oplist))))) - (gn (cat) - (cond - ((and (consp cat) (eq (qfirst cat) 'category)) (cddr cat)) - ((and (consp cat) (eq (qfirst cat) '|Join|)) (gn (|last| (qrest cat)))) - (t nil)))) - (let (|$options| op argl packageName packageAbb nameForDollar packageArgl - capsuleDefAlist explicitCatPart catvec fullCatOpList op1 sig - catOpList packageCategory nils packageSig) - (declare (special |$options| |$categoryPredicateList| |$e| - |$FormalMapVariableList|)) - (setq op (car form)) - (setq argl (cdr form)) - (setq packageName (intern (strconc (pname op) "&"))) - (setq packageAbb (intern (strconc (getdatabase op 'abbreviation) "-"))) - (setq |$options| nil) - (|abbreviationsSpad2Cmd| (list '|domain| packageAbb packageName)) - (setq nameForDollar (car (setdifference '(s a b c d e f g h i) argl))) - (setq packageArgl (cons nameForDollar argl)) - (setq capsuleDefAlist (fn def nil)) - (setq explicitCatPart (gn cat)) - (setq catvec (|eval| (|mkEvalableCategoryForm| form))) - (setq fullCatOpList (elt (|JoinInner| (list catvec) |$e|) 1)) - (setq catOpList - (loop for x in fullCatOpList do - (setq op1 (caar x)) - (setq sig (cadar x)) - when (|assoc| op1 capsuleDefAlist) - collect (list 'signature op1 sig))) - (when catOpList - (setq packageCategory - (cons 'category - (cons '|domain| (sublislis argl |$FormalMapVariableList| catOpList)))) - (setq nils (loop for x in argl collect nil)) - (setq packageSig (cons packageCategory (cons form nils))) - (setq |$categoryPredicateList| - (subst nameForDollar '$ |$categoryPredicateList| :test #'equal)) - (subst nameForDollar '$ - (list 'def (cons packageName packageArgl) - packageSig (cons nil nils) def) :test #'equal))))) - -\end{chunk} - -\defun{mkEvalableCategoryForm}{mkEvalableCategoryForm} -\calls{mkEvalableCategoryForm}{qcar} -\calls{mkEvalableCategoryForm}{qcdr} -\calls{mkEvalableCategoryForm}{mkEvalableCategoryForm} -\calls{mkEvalableCategoryForm}{compOrCroak} -\calls{mkEvalableCategoryForm}{getdatabase} -\calls{mkEvalableCategoryForm}{get} -\calls{mkEvalableCategoryForm}{mkq} -\refsdollar{mkEvalableCategoryForm}{Category} -\refsdollar{mkEvalableCategoryForm}{e} -\refsdollar{mkEvalableCategoryForm}{EmptyMode} -\refsdollar{mkEvalableCategoryForm}{CategoryFrame} -\refsdollar{mkEvalableCategoryForm}{Category} -\refsdollar{mkEvalableCategoryForm}{CategoryNames} -\defsdollar{mkEvalableCategoryForm}{e} -\begin{chunk}{defun mkEvalableCategoryForm} -(defun |mkEvalableCategoryForm| (c) - (let (op argl tmp1 x m) - (declare (special |$Category| |$e| |$EmptyMode| |$CategoryFrame| - |$CategoryNames|)) - (if (consp c) - (progn - (setq op (qfirst c)) - (setq argl (qrest c)) - (cond - ((eq op '|Join|) - (cons '|Join| - (loop for x in argl - collect (|mkEvalableCategoryForm| x)))) - ((eq op '|DomainSubstitutionMacro|) - (|mkEvalableCategoryForm| (cadr argl))) - ((eq op '|mkCategory|) c) - ((member op |$CategoryNames|) - (setq tmp1 (|compOrCroak| c |$EmptyMode| |$e|)) - (setq x (car tmp1)) - (setq m (cadr tmp1)) - (setq |$e| (caddr tmp1)) - (when (equal m |$Category|) x)) - ((or (eq (getdatabase op 'constructorkind) '|category|) - (|get| op '|isCategory| |$CategoryFrame|)) - (cons op - (loop for x in argl - collect (mkq x)))) - (t - (setq tmp1 (|compOrCroak| c |$EmptyMode| |$e|)) - (setq x (car tmp1)) - (setq m (cadr tmp1)) - (setq |$e| (caddr tmp1)) - (when (equal m |$Category|) x)))) - (mkq c)))) - -\end{chunk} - -\defun{compDefineCategory2}{compDefineCategory2} -\calls{compDefineCategory2}{addBinding} -\calls{compDefineCategory2}{getArgumentModeOrMoan} -\calls{compDefineCategory2}{giveFormalParametersValues} -\calls{compDefineCategory2}{take} -\calls{compDefineCategory2}{sublis} -\calls{compDefineCategory2}{compMakeDeclaration} -\calls{compDefineCategory2}{opOf} -\calls{compDefineCategory2}{optFunctorBody} -\calls{compDefineCategory2}{compOrCroak} -\calls{compDefineCategory2}{mkConstructor} -\calls{compDefineCategory2}{compile} -\calls{compDefineCategory2}{lisplibWrite} -\calls{compDefineCategory2}{removeZeroOne} -\calls{compDefineCategory2}{mkq} -\calls{compDefineCategory2}{evalAndRwriteLispForm} -\calls{compDefineCategory2}{eval} -\calls{compDefineCategory2}{getParentsFor} -\calls{compDefineCategory2}{computeAncestorsOf} -\calls{compDefineCategory2}{constructor?} -\calls{compDefineCategory2}{augLisplibModemapsFromCategory} -\usesdollar{compDefineCategory2}{prefix} -\refsdollar{compDefineCategory2}{formalArgList} -\refsdollar{compDefineCategory2}{definition} -\refsdollar{compDefineCategory2}{form} -\refsdollar{compDefineCategory2}{op} -\refsdollar{compDefineCategory2}{extraParms} -\refsdollar{compDefineCategory2}{lisplibCategory} -\refsdollar{compDefineCategory2}{FormalMapVariableList} -\refsdollar{compDefineCategory2}{libFile} -\refsdollar{compDefineCategory2}{TriangleVariableList} -\refsdollar{compDefineCategory2}{lisplib} -\defsdollar{compDefineCategory2}{formalArgList} -\defsdollar{compDefineCategory2}{insideCategoryIfTrue} -\defsdollar{compDefineCategory2}{top-level} -\defsdollar{compDefineCategory2}{definition} -\defsdollar{compDefineCategory2}{form} -\defsdollar{compDefineCategory2}{op} -\defsdollar{compDefineCategory2}{extraParms} -\defsdollar{compDefineCategory2}{functionStats} -\defsdollar{compDefineCategory2}{functorStats} -\defsdollar{compDefineCategory2}{frontier} -\defsdollar{compDefineCategory2}{getDomainCode} -\defsdollar{compDefineCategory2}{addForm} -\defsdollar{compDefineCategory2}{lisplibAbbreviation} -\defsdollar{compDefineCategory2}{functorForm} -\defsdollar{compDefineCategory2}{lisplibAncestors} -\defsdollar{compDefineCategory2}{lisplibCategory} -\defsdollar{compDefineCategory2}{lisplibParents} -\defsdollar{compDefineCategory2}{lisplibModemap} -\defsdollar{compDefineCategory2}{lisplibKind} -\defsdollar{compDefineCategory2}{lisplibForm} -\defsdollar{compDefineCategory2}{domainShell} -\begin{chunk}{defun compDefineCategory2} -(defun |compDefineCategory2| - (form signature specialCases body mode env |$prefix| |$formalArgList|) - (declare (special |$prefix| |$formalArgList|) (ignore specialCases)) - (let (|$insideCategoryIfTrue| $TOP_LEVEL |$definition| |$form| |$op| - |$extraParms| |$functionStats| |$functorStats| |$frontier| - |$getDomainCode| |$addForm| argl sargl aList signaturep opp formp - formalBody formals actuals g fun pairlis parSignature parForm modemap) - (declare (special |$insideCategoryIfTrue| $top_level |$definition| - |$form| |$op| |$extraParms| |$functionStats| - |$functorStats| |$frontier| |$getDomainCode| - |$addForm| |$lisplibAbbreviation| |$functorForm| - |$lisplibAncestors| |$lisplibCategory| - |$FormalMapVariableList| |$lisplibParents| - |$lisplibModemap| |$lisplibKind| |$lisplibForm| - $lisplib |$domainShell| |$libFile| - |$TriangleVariableList|)) -; 1. bind global variables - (setq |$insideCategoryIfTrue| t) - (setq $top_level nil) - (setq |$definition| nil) - (setq |$form| nil) - (setq |$op| nil) - (setq |$extraParms| nil) -; 1.1 augment e to add declaration $:
- (setq |$definition| form) - (setq |$op| (car |$definition|)) - (setq argl (cdr |$definition|)) - (setq env (|addBinding| '$ (list (cons '|mode| |$definition|)) env)) -; 2. obtain signature - (setq signaturep - (cons (car signature) - (loop for a in argl - collect (|getArgumentModeOrMoan| a |$definition| env)))) - (setq env (|giveFormalParametersValues| argl env)) -; 3. replace arguments by $1,..., substitute into body, -; and introduce declarations into environment - (setq sargl (take (|#| argl) |$TriangleVariableList|)) - (setq |$form| (cons |$op| sargl)) - (setq |$functorForm| |$form|) - (setq |$formalArgList| (append sargl |$formalArgList|)) - (setq aList (loop for a in argl for sa in sargl collect (cons a sa))) - (setq formalBody (sublis aList body)) - (setq signaturep (sublis aList signaturep)) - ; Begin lines for category default definitions + (setq |$addForm| nil) + (setq |$viewNames| nil) (setq |$functionStats| (list 0 0)) (setq |$functorStats| (list 0 0)) - (setq |$frontier| 0) + (setq |$form| nil) + (setq |$op| nil) + (setq |$signature| nil) + (setq |$functorTarget| nil) + (setq |$Representation| nil) + (setq |$LocalDomainAlist| nil) + (setq |$functorForm| nil) + (setq |$functorLocalParameters| nil) + (setq |$myFunctorBody| body) + (setq |$CheckVectorList| nil) (setq |$getDomainCode| nil) - (setq |$addForm| nil) - (loop for x in sargl for r in (rest signaturep) - do (setq env (third (|compMakeDeclaration| (list '|:| x r) mode env)))) -; 4. compile body in environment of %type declarations for arguments - (setq opp |$op|) - (when (and (not (eq (|opOf| formalBody) '|Join|)) - (not (eq (|opOf| formalBody) '|mkCategory|))) - (setq formalBody (list '|Join| formalBody))) - (setq body - (|optFunctorBody| (car (|compOrCroak| formalBody (car signaturep) env)))) - (when |$extraParms| - (setq actuals nil) - (setq formals nil) - (loop for u in |$extraParms| do - (setq formals (cons (car u) formals)) - (setq actuals (cons (mkq (cdr u)) actuals))) - (setq body - (list '|sublisV| (list 'pair (list 'quote formals) (cons 'list actuals)) - body))) -; always subst for args after extraparms - (when argl - (setq body - (list '|sublisV| - (list 'pair - (list 'quote sargl) - (cons 'list (loop for u in sargl collect (list '|devaluate| u)))) - body))) - (setq body - (list 'prog1 (list 'let (setq g (gensym)) body) - (list 'setelt g 0 (|mkConstructor| |$form|)))) - (setq fun (|compile| (list opp (list 'lam sargl body)))) -; 5. give operator a 'modemap property - (setq pairlis + (setq |$insideFunctorIfTrue| t) + (setq |$functorsUsed| nil) + (setq |$setelt| (if |$QuickCode| 'qsetrefv 'setelt)) + (setq $top_level nil) + (setq |$genFVar| 0) + (setq |$genSDVar| 0) + (setq originale |$e|) + (setq |$op| (first form)) + (setq argl (rest form)) + (setq |$formalArgList| (append argl |$formalArgList|)) + (setq |$pairlis| (loop for a in argl for v in |$FormalMapVariableList| collect (cons a v))) - (setq parSignature (sublis pairlis signaturep)) - (setq parForm (sublis pairlis form)) - (|lisplibWrite| "compilerInfo" - (|removeZeroOne| - (list 'setq '|$CategoryFrame| - (list '|put| (list 'quote opp) ''|isCategory| t - (list '|addModemap| (mkq opp) (mkq parForm) - (mkq parSignature) t (mkq fun) '|$CategoryFrame|)))) - |$libFile|) - (unless sargl - (|evalAndRwriteLispForm| 'niladic - `(setf (get ',opp 'niladic) t))) -;; 6 put modemaps into InteractiveModemapFrame - (setq |$domainShell| (|eval| (cons opp (mapcar 'mkq sargl)))) - (setq |$lisplibCategory| formalBody) - (when $lisplib - (setq |$lisplibForm| form) - (setq |$lisplibKind| '|category|) - (setq modemap (list (cons parForm parSignature) (list t opp))) - (setq |$lisplibModemap| modemap) - (setq |$lisplibParents| - (|getParentsFor| |$op| |$FormalMapVariableList| |$lisplibCategory|)) - (setq |$lisplibAncestors| (|computeAncestorsOf| |$form| nil)) - (setq |$lisplibAbbreviation| (|constructor?| |$op|)) - (setq formp (cons opp sargl)) - (|augLisplibModemapsFromCategory| formp formalBody signaturep)) - (list fun '(|Category|) env))) + (setq |$mutableDomain| + (OR (|isCategoryPackageName| |$op|) + (COND + ((boundp '|$mutableDomains|) + (member |$op| |$mutableDomains|)) + ('T NIL)))) + (setq signaturep + (cons (car signature) + (loop for a in argl collect (|getArgumentModeOrMoan| a form |$e|)))) + (setq |$form| (cons |$op| argl)) + (setq |$functorForm| |$form|) + (unless (car signaturep) + (setq signaturep (cdar (|getModemap| |$form| |$e|)))) + (setq target (first signaturep)) + (setq |$functorTarget| target) + (setq |$e| (|giveFormalParametersValues| argl |$e|)) + (setq tmp1 (|compMakeCategoryObject| target |$e|)) + (if tmp1 + (progn + (setq ds (first tmp1)) + (setq |$e| (third tmp1)) + (setq |$domainShell| (copy-seq ds)) + (setq |$attributesName| (intern (strconc (pname |$op|) ";attributes"))) + (setq attributeList (|disallowNilAttribute| (elt ds 2))) + (setq |$goGetList| nil) + (setq |$condAlist| nil) + (setq |$uncondAlist| nil) + (setq |$NRTslot1PredicateList| + (remdup (loop for x in attributeList collect (second x)))) + (setq |$NRTattributeAlist| (|NRTgenInitialAttributeAlist| attributeList)) + (setq |$NRTslot1Info| nil) + (setq |$NRTbase| 6) + (setq |$NRTaddForm| nil) + (setq |$NRTdeltaList| nil) + (setq |$NRTdeltaListComp| nil) + (setq |$NRTaddList| nil) + (setq |$NRTdeltaLength| 0) + (setq |$NRTloadTimeAlist| nil) + (setq |$NRTdomainFormList| nil) + (setq |$template| nil) + (setq |$functionLocations| nil) + (loop for x in argl do (|NRTgetLocalIndex| x)) + (setq |$e| + (third (|compMakeDeclaration| (list '|:| '$ target) mode |$e|))) + (unless |$insideCategoryPackageIfTrue| + (if + (and (consp body) (eq (qfirst body) '|add|) + (consp (qrest body)) + (consp (qsecond body)) + (consp (qcddr body)) + (eq (qcdddr body) nil) + (consp (qthird body)) + (eq (qcaaddr body) 'capsule) + (member (qcaadr body) '(|List| |Vector|)) + (equal (FindRep (qcdaddr body)) (second body))) + (setq |$e| (|augModemapsFromCategoryRep| '$ + (second body) (cdaddr body) target |$e|)) + (setq |$e| (|augModemapsFromCategory| '$ '$ target |$e|)))) + (setq |$signature| signaturep) + (setq operationAlist (sublis |$pairlis| (elt |$domainShell| 1))) + (setq parSignature (sublis |$pairlis| signaturep)) + (setq parForm (sublis |$pairlis| form)) + (setq argPars (|makeFunctorArgumentParameters| argl + (cdr signaturep) (car signaturep))) + (setq |$functorLocalParameters| argl) + (setq opp |$op|) + (setq rettype (CAR signaturep)) + (setq tt (|compFunctorBody| body rettype |$e| parForm)) + (cond + (|$compileOnlyCertainItems| + (|reportOnFunctorCompilation|) + (list nil (cons '|Mapping| signaturep) originale)) + (t + (setq bodyp (first tt)) + (setq lamOrSlam (if |$mutableDomain| 'lam 'spadslam)) + (setq fun + (|compile| (sublis |$pairlis| (list opp (list lamOrSlam argl bodyp))))) + (setq operationAlist (sublis |$pairlis| |$lisplibOperationAlist|)) + (cond + ($lisplib + (|augmentLisplibModemapsFromFunctor| parForm + operationAlist parSignature))) + (|reportOnFunctorCompilation|) + (cond + ($lisplib + (setq modemap (list (cons parForm parSignature) (list t opp))) + (setq |$lisplibModemap| modemap) + (setq |$lisplibCategory| (cadar modemap)) + (setq |$lisplibParents| + (|getParentsFor| |$op| |$FormalMapVariableList| |$lisplibCategory|)) + (setq |$lisplibAncestors| (|computeAncestorsOf| |$form| NIL)) + (setq |$lisplibAbbreviation| (|constructor?| |$op|)))) + (setq |$insideFunctorIfTrue| NIL) + (cond + ($lisplib + (setq |$lisplibKind| + (if (and (consp |$functorTarget|) + (eq (qfirst |$functorTarget|) 'category) + (consp (qrest |$functorTarget|)) + (not (eq (qsecond |$functorTarget|) '|domain|))) + '|package| + '|domain|)) + (setq |$lisplibForm| form) + (cond + ((null |$bootStrapMode|) + (setq |$NRTslot1Info| (|NRTmakeSlot1Info|)) + (setq |$isOpPackageName| (|isCategoryPackageName| |$op|)) + (when |$isOpPackageName| + (|lisplibWrite| "slot1DataBase" + (list '|updateSlot1DataBase| (mkq |$NRTslot1Info|)) + |$libFile|)) + (setq |$lisplibFunctionLocations| + (sublis |$pairlis| |$functionLocations|)) + (setq |$lisplibCategoriesExtended| + (sublis |$pairlis| |$lisplibCategoriesExtended|)) + (setq libFn (getdatabase opp 'abbreviation)) + (setq |$lookupFunction| + (|NRTgetLookupFunction| |$functorForm| + (cadar |$lisplibModemap|) |$NRTaddForm|)) + (setq |$byteAddress| 0) + (setq |$byteVec| NIL) + (setq |$NRTslot1PredicateList| + (loop for x in |$NRTslot1PredicateList| + collect (|simpBool| x))) + (|rwriteLispForm| '|loadTimeStuff| + `(setf (get ,(mkq |$op|) '|infovec|) ,(|getInfovecCode|))))) + (setq |$lisplibSlot1| |$NRTslot1Info|) + (setq |$lisplibOperationAlist| operationAlist) + (setq |$lisplibMissingFunctions| |$CheckVectorList|))) + (|lisplibWrite| "compilerInfo" + (|removeZeroOne| + (list 'setq '|$CategoryFrame| + (list '|put| (list 'quote opp) ''|isFunctor| + (list 'quote operationAlist) + (list '|addModemap| + (list 'quote opp) + (list 'quote parForm) + (list 'quote parSignature) + t + (list 'quote opp) + (list '|put| (list 'quote opp) ''|mode| + (list 'quote (cons '|Mapping| parSignature)) + '|$CategoryFrame|))))) + |$libFile|) + (unless argl + (|evalAndRwriteLispForm| 'niladic + `(setf (get ',opp 'niladic) t))) + (list fun (cons '|Mapping| signaturep) originale)))) + (progn + (|sayBrightly| " cannot produce category object:") + (|pp| target) + nil))))) \end{chunk} -\defun{compile}{compile} -\calls{compile}{member} -\calls{compile}{getmode} -\calls{compile}{get} -\calls{compile}{modeEqual} -\calls{compile}{userError} -\calls{compile}{encodeItem} -\calls{compile}{strconc} -\calls{compile}{kar} -\calls{compile}{encodeFunctionName} -\calls{compile}{splitEncodedFunctionName} -\calls{compile}{sayBrightly} -\calls{compile}{optimizeFunctionDef} -\calls{compile}{putInLocalDomainReferences} -\calls{compile}{constructMacro} -\calls{compile}{spadCompileOrSetq} -\calls{compile}{elapsedTime} -\calls{compile}{addStats} -\calls{compile}{printStats} -\refsdollar{compile}{functionStats} -\refsdollar{compile}{macroIfTrue} -\refsdollar{compile}{doNotCompileJustPrint} -\refsdollar{compile}{insideCapsuleFunctionIfTrue} -\refsdollar{compile}{saveableItems} -\refsdollar{compile}{lisplibItemsAlreadyThere} -\refsdollar{compile}{splitUpItemsAlreadyThere} -\refsdollar{compile}{lisplib} -\refsdollar{compile}{compileOnlyCertainItems} -\refsdollar{compile}{functorForm} -\refsdollar{compile}{signatureOfForm} -\refsdollar{compile}{suffix} -\refsdollar{compile}{prefix} -\refsdollar{compile}{signatureOfForm} -\refsdollar{compile}{e} -\defsdollar{compile}{functionStats} -\defsdollar{compile}{savableItems} -\defsdollar{compile}{suffix} -\begin{chunk}{defun compile} -(defun |compile| (u) - (labels ( - (isLocalFunction (op) - (let (tmp1) - (declare (special |$e| |$formalArgList|)) - (and (null (|member| op |$formalArgList|)) - (progn - (setq tmp1 (|getmode| op |$e|)) - (and (consp tmp1) (eq (qfirst tmp1) '|Mapping|))))))) - (let (op lamExpr DC sig sel opexport opmodes opp parts s tt unew - optimizedBody stuffToCompile result functionStats) - (declare (special |$functionStats| |$macroIfTrue| |$doNotCompileJustPrint| - |$insideCapsuleFunctionIfTrue| |$saveableItems| |$e| - |$lisplibItemsAlreadyThere| |$splitUpItemsAlreadyThere| - |$compileOnlyCertainItems| $LISPLIB |$suffix| - |$signatureOfForm| |$functorForm| |$prefix| - |$savableItems|)) - (setq op (first u)) - (setq lamExpr (second u)) - (when |$suffix| - (setq |$suffix| (1+ |$suffix|)) - (setq opp - (progn - (setq opexport nil) - (setq opmodes - (loop for item in (|get| op '|modemap| |$e|) - do - (setq dc (caar item)) - (setq sig (cdar item)) - (setq sel (cadadr item)) - when (and (eq dc '$) - (setq opexport t) - (let ((result t)) - (loop for x in sig for y in |$signatureOfForm| - do (setq result (|modeEqual| x y))) - result)) - collect sel)) +\defun{compDefineCapsuleFunction}{compDefineCapsuleFunction} +\calls{compDefineCapsuleFunction}{length} +\calls{compDefineCapsuleFunction}{get} +\calls{compDefineCapsuleFunction}{profileRecord} +\calls{compDefineCapsuleFunction}{compArgumentConditions} +\calls{compDefineCapsuleFunction}{addDomain} +\calls{compDefineCapsuleFunction}{giveFormalParametersValues} +\calls{compDefineCapsuleFunction}{getSignature} +\calls{compDefineCapsuleFunction}{put} +\calls{compDefineCapsuleFunction}{getArgumentModeOrMoan} +\calls{compDefineCapsuleFunction}{checkAndDeclare} +\calls{compDefineCapsuleFunction}{hasSigInTargetCategory} +\calls{compDefineCapsuleFunction}{stripOffSubdomainConditions} +\calls{compDefineCapsuleFunction}{stripOffArgumentConditions} +\calls{compDefineCapsuleFunction}{resolve} +\calls{compDefineCapsuleFunction}{member} +\calls{compDefineCapsuleFunction}{getmode} +\calls{compDefineCapsuleFunction}{formatUnabbreviated} +\calls{compDefineCapsuleFunction}{sayBrightly} +\calls{compDefineCapsuleFunction}{compOrCroak} +\calls{compDefineCapsuleFunction}{NRTassignCapsuleFunctionSlot} +\calls{compDefineCapsuleFunction}{mkq} +\calls{compDefineCapsuleFunction}{replaceExitEtc} +\calls{compDefineCapsuleFunction}{addArgumentConditions} +\calls{compDefineCapsuleFunction}{compileCases} +\calls{compDefineCapsuleFunction}{addStats} +\refsdollar{compDefineCapsuleFunction}{semanticErrorStack} +\refsdollar{compDefineCapsuleFunction}{DomainsInScope} +\refsdollar{compDefineCapsuleFunction}{op} +\refsdollar{compDefineCapsuleFunction}{formalArgList} +\refsdollar{compDefineCapsuleFunction}{signatureOfForm} +\refsdollar{compDefineCapsuleFunction}{functionLocations} +\refsdollar{compDefineCapsuleFunction}{profileCompiler} +\refsdollar{compDefineCapsuleFunction}{compileOnlyCertainItems} +\refsdollar{compDefineCapsuleFunction}{returnMode} +\refsdollar{compDefineCapsuleFunction}{functorStats} +\refsdollar{compDefineCapsuleFunction}{functionStats} +\defsdollar{compDefineCapsuleFunction}{form} +\defsdollar{compDefineCapsuleFunction}{functionStats} +\defsdollar{compDefineCapsuleFunction}{argumentConditionList} +\defsdollar{compDefineCapsuleFunction}{finalEnv} +\defsdollar{compDefineCapsuleFunction}{initCapsuleErrorCount} +\defsdollar{compDefineCapsuleFunction}{insideCapsuleFunctionIfTrue} +\defsdollar{compDefineCapsuleFunction}{CapsuleModemapFrame} +\defsdollar{compDefineCapsuleFunction}{CapsuleDomainsInScope} +\defsdollar{compDefineCapsuleFunction}{insideExpressionIfTrue} +\defsdollar{compDefineCapsuleFunction}{returnMode} +\defsdollar{compDefineCapsuleFunction}{op} +\defsdollar{compDefineCapsuleFunction}{formalArgList} +\defsdollar{compDefineCapsuleFunction}{signatureOfForm} +\defsdollar{compDefineCapsuleFunction}{functionLocations} +\begin{chunk}{defun compDefineCapsuleFunction} +(defun |compDefineCapsuleFunction| (df m oldE |$prefix| |$formalArgList|) + (declare (special |$prefix| |$formalArgList|)) + (let (|$form| |$op| |$functionStats| |$argumentConditionList| |$finalEnv| + |$initCapsuleErrorCount| |$insideCapsuleFunctionIfTrue| + |$CapsuleModemapFrame| |$CapsuleDomainsInScope| + |$insideExpressionIfTrue| form signature body tmp1 lineNumber + specialCases argl identSig argModeList signaturep e rettype tmp2 + localOrExported formattedSig tt catchTag bodyp finalBody fun val) + (declare (special |$form| |$op| |$functionStats| |$functorStats| + |$argumentConditionList| |$finalEnv| |$returnMode| + |$initCapsuleErrorCount| |$newCompCompare| |$NoValueMode| + |$insideCapsuleFunctionIfTrue| + |$CapsuleModemapFrame| |$CapsuleDomainsInScope| + |$insideExpressionIfTrue| |$compileOnlyCertainItems| + |$profileCompiler| |$functionLocations| |$finalEnv| + |$signatureOfForm| |$semanticErrorStack|)) + (setq form (second df)) + (setq signature (third df)) + (setq specialCases (fourth df)) + (setq body (fifth df)) + (setq tmp1 specialCases) + (setq lineNumber (first tmp1)) + (setq specialCases (rest tmp1)) + (setq e oldE) +;-1. bind global variables + (setq |$form| nil) + (setq |$op| nil) + (setq |$functionStats| (list 0 0)) + (setq |$argumentConditionList| nil) + (setq |$finalEnv| nil) +; used by ReplaceExitEtc to get a common environment + (setq |$initCapsuleErrorCount| (|#| |$semanticErrorStack|)) + (setq |$insideCapsuleFunctionIfTrue| t) + (setq |$CapsuleModemapFrame| e) + (setq |$CapsuleDomainsInScope| (|get| '|$DomainsInScope| 'special e)) + (setq |$insideExpressionIfTrue| t) + (setq |$returnMode| m) + (setq |$op| (first form)) + (setq argl (rest form)) + (setq |$form| (cons |$op| argl)) + (setq argl (|stripOffArgumentConditions| argl)) + (setq |$formalArgList| (append argl |$formalArgList|)) +; let target and local signatures help determine modes of arguments + (setq argModeList + (cond + ((setq identSig (|hasSigInTargetCategory| argl form (car signature) e)) + (setq e (|checkAndDeclare| argl form identSig e)) + (cdr identSig)) + (t + (loop for a in argl + collect (|getArgumentModeOrMoan| a form e))))) + (setq argModeList (|stripOffSubdomainConditions| argModeList argl)) + (setq signaturep (cons (car signature) argModeList)) + (unless identSig + (setq oldE (|put| |$op| '|mode| (cons '|Mapping| signaturep) oldE))) +; obtain target type if not given + (cond + ((null (car signaturep)) + (setq signaturep (cond - ((isLocalFunction op) - (when opexport - (|userError| (list '|%b| op '|%d| " is local and exported"))) - (intern (strconc (|encodeItem| |$prefix|) ";" (|encodeItem| op)))) - (t - (|encodeFunctionName| op |$functorForm| |$signatureOfForm| - '|;| |$suffix|))))) - (setq u (list opp lamExpr))) - (when (and $lisplib |$compileOnlyCertainItems|) - (setq parts (|splitEncodedFunctionName| (elt u 0) '|;|)) + (identSig identSig) + (t (|getSignature| |$op| (cdr signaturep) e)))))) + (when signaturep + (setq e (|giveFormalParametersValues| argl e)) + (setq |$signatureOfForm| signaturep) + (setq |$functionLocations| + (cons (cons (list |$op| |$signatureOfForm|) lineNumber) + |$functionLocations|)) + (setq e (|addDomain| (car signaturep) e)) + (setq e (|compArgumentConditions| e)) + (when |$profileCompiler| + (loop for x in argl for y in signaturep + do (|profileRecord| '|arguments| x y))) +; 4. introduce needed domains into extendedEnv + (loop for domain in signaturep + do (setq e (|addDomain| domain e))) +; 6. compile body in environment with extended environment + (setq rettype (|resolve| (car signaturep) |$returnMode|)) + (setq localOrExported (cond - ((eq parts '|inner|) - (setq |$savableItems| (cons (elt u 0) |$savableItems|))) - (t - (setq unew nil) - (loop for item in |$splitUpItemsAlreadyThere| - do - (setq s (first item)) - (setq tt (second item)) - (when - (and (equal (elt parts 0) (elt s 0)) - (equal (elt parts 1) (elt s 1)) - (equal (elt parts 2) (elt s 2))) - (setq unew tt))) - (cond - ((null unew) - (|sayBrightly| (list " Error: Item did not previously exist")) - (|sayBrightly| (cons " Item not saved: " (|bright| (elt u 0)))) - (|sayBrightly| - (list " What's there is: " |$lisplibItemsAlreadyThere|)) - nil) - (t - (|sayBrightly| (list " Renaming " (elt u 0) " as " unew)) - (setq u (cons unew (cdr u))) - (setq |$savableItems| (cons unew |$saveableItems|))))))) - (setq optimizedBody (|optimizeFunctionDef| u)) - (setq stuffToCompile - (if |$insideCapsuleFunctionIfTrue| - (|putInLocalDomainReferences| optimizedBody) - optimizedBody)) + ((and (null (|member| |$op| |$formalArgList|)) + (progn + (setq tmp2 (|getmode| |$op| e)) + (and (consp tmp2) (eq (qfirst tmp2) '|Mapping|)))) + '|local|) + (t '|exported|))) +; 6a skip if compiling only certain items but not this one +; could be moved closer to the top + (setq formattedSig (|formatUnabbreviated| (cons '|Mapping| signaturep))) (cond - ((eq |$doNotCompileJustPrint| t) - (prettyprint stuffToCompile) - opp) - (|$macroIfTrue| (|constructMacro| stuffToCompile)) + ((and |$compileOnlyCertainItems| + (null (|member| |$op| |$compileOnlyCertainItems|))) + (|sayBrightly| + (cons " skipping " (cons localOrExported (|bright| |$op|)))) + (list nil (cons '|Mapping| signaturep) oldE)) (t - (setq result (|spadCompileOrSetq| stuffToCompile)) - (setq functionStats (list 0 (|elapsedTime|))) - (setq |$functionStats| (|addStats| |$functionStats| functionStats)) - (|printStats| functionStats) - result))))) + (|sayBrightly| + (cons " compiling " (cons localOrExported (append (|bright| |$op|) + (cons ": " formattedSig))))) + (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 + (setq catchTag (mkq (gensym))) + (setq fun + (progn + (setq bodyp + (|replaceExitEtc| (car tt) catchTag '|TAGGEDreturn| |$returnMode|)) + (setq bodyp (|addArgumentConditions| bodyp |$op|)) + (setq finalBody (list 'catch catchTag bodyp)) + (|compileCases| + (list |$op| (list 'lam (append argl (list '$)) finalBody)) + oldE))) + (setq |$functorStats| (|addStats| |$functorStats| |$functionStats|)) +; 7. give operator a 'value property + (setq val (list fun signaturep e)) + (list fun (list '|Mapping| signaturep) oldE)))))) \end{chunk} -\defun{encodeFunctionName}{encodeFunctionName} -Code for encoding function names inside package or domain -\calls{encodeFunctionName}{mkRepititionAssoc} -\calls{encodeFunctionName}{encodeItem} -\calls{encodeFunctionName}{stringimage} -\calls{encodeFunctionName}{internl} -\calls{encodeFunctionName}{getAbbreviation} -\calls{encodeFunctionName}{length} -\refsdollar{encodeFunctionName}{lisplib} -\refsdollar{encodeFunctionName}{lisplibSignatureAlist} -\defsdollar{encodeFunctionName}{lisplibSignatureAlist} -\begin{chunk}{defun encodeFunctionName} -(defun |encodeFunctionName| (fun package signature sep count) - (let (packageName arglist signaturep reducedSig n x encodedSig encodedName) - (declare (special |$lisplibSignatureAlist| $lisplib)) - (setq packageName (car package)) - (setq arglist (cdr package)) - (setq signaturep (subst '$ package signature :test #'equal)) - (setq reducedSig - (|mkRepititionAssoc| (append (cdr signaturep) (list (car signaturep))))) - (setq encodedSig - (let ((result "")) - (loop for item in reducedSig - do - (setq n (car item)) - (setq x (cdr item)) - (setq result - (strconc result - (if (eql n 1) - (|encodeItem| x) - (strconc (stringimage n) (|encodeItem| x)))))) - result)) - (setq encodedName - (internl (|getAbbreviation| packageName (|#| arglist)) - '|;| (|encodeItem| fun) '|;| encodedSig sep (stringimage count))) - (when $lisplib - (setq |$lisplibSignatureAlist| - (cons (cons encodedName signaturep) |$lisplibSignatureAlist|))) - encodedName)) - -\end{chunk} - -\defun{mkRepititionAssoc}{mkRepititionAssoc} -\calls{mkRepititionAssoc}{mkRepfun} -\begin{chunk}{defun mkRepititionAssoc} -(defun |mkRepititionAssoc| (z) - (labels ( - (mkRepfun (z n) - (cond - ((null z) nil) - ((and (consp z) (eq (qrest z) nil) (list (cons n (qfirst z))))) - ((and (consp z) (consp (qrest z)) (equal (qsecond z) (qfirst z))) - (mkRepfun (cdr z) (1+ n))) - (t (cons (cons n (car z)) (mkRepfun (cdr z) 1)))))) - (mkRepfun z 1))) - -\end{chunk} - -\defun{splitEncodedFunctionName}{splitEncodedFunctionName} -\calls{splitEncodedFunctionName}{stringimage} -\calls{splitEncodedFunctionName}{strpos} -\begin{chunk}{defun splitEncodedFunctionName} -(defun |splitEncodedFunctionName| (encodedName sep) - (let (sep0 p1 p2 p3 s1 s2 s3 s4) - ; sep0 is the separator used in "encodeFunctionName". - (setq sep0 ";") - (unless (stringp encodedName) (setq encodedName (stringimage encodedName))) +\defun{compInternalFunction}{compInternalFunction} +\calls{compInternalFunction}{identp} +\calls{compInternalFunction}{stackAndThrow} +\begin{chunk}{defun compInternalFunction} +(defun |compInternalFunction| (df m env) + (let (form signature specialCases body op argl nbody nf ress) + (setq form (second df)) + (setq signature (third df)) + (setq specialCases (fourth df)) + (setq body (fifth df)) + (setq op (first form)) + (setq argl (rest form)) (cond - ((null (setq p1 (strpos sep0 encodedName 0 "*"))) nil) - ; This is picked up in compile for inner functions in partial compilation - ((null (setq p2 (strpos sep0 encodedName (1+ p1) "*"))) '|inner|) - ((null (setq p3 (strpos sep encodedName (1+ p2) "*"))) nil) + ((null (identp op)) + (|stackAndThrow| (list '|Bad name for internal function:| op))) + ((eql (|#| argl) 0) + (|stackAndThrow| + (list '|Argumentless internal functions unsupported:| op ))) (t - (setq s1 (substring encodedName 0 p1)) - (setq s2 (substring encodedName (1+ p1) (- p2 p1 1))) - (setq s3 (substring encodedName (1+ p2) (- p3 p2 1))) - (setq s4 (substring encodedName (1+ p3) nil)) - (list s1 s2 s3 s4))))) + (setq nbody (list '+-> argl body)) + (setq nf (list 'let (list '|:| op (cons '|Mapping| signature)) nbody)) + (setq ress (|comp| nf m env)) ress)))) \end{chunk} -\defun{encodeItem}{encodeItem} -\calls{encodeItem}{getCaps} -\calls{encodeItem}{identp} -\calls{encodeItem}{pname} -\calls{encodeItem}{stringimage} -\begin{chunk}{defun encodeItem} -(defun |encodeItem| (x) - (cond - ((consp x) (|getCaps| (qfirst x))) - ((identp x) (pname x)) - (t (stringimage x)))) +\defun{compDefWhereClause}{compDefWhereClause} +\calls{compDefWhereClause}{getmode} +\calls{compDefWhereClause}{userError} +\calls{compDefWhereClause}{concat} +\calls{compDefWhereClause}{lassoc} +\calls{compDefWhereClause}{pairList} +\calls{compDefWhereClause}{union} +\calls{compDefWhereClause}{listOfIdentifersIn} +\calls{compDefWhereClause}{delete} +\calls{compDefWhereClause}{orderByDependency} +\calls{compDefWhereClause}{assocleft} +\calls{compDefWhereClause}{assocright} +\calls{compDefWhereClause}{comp} +\usesdollar{compDefWhereClause}{sigAlist} +\usesdollar{compDefWhereClause}{predAlist} +\begin{chunk}{defun compDefWhereClause} +(defun |compDefWhereClause| (arg mode env) + (labels ( + (transformType (x) + (declare (special |$sigAlist|)) + (cond + ((atom x) x) + ((and (consp x) (eq (qfirst x) '|:|) (consp (qrest x)) + (consp (qcddr x)) (eq (qcdddr x) nil)) + (setq |$sigAlist| + (cons (cons (second x) (transformType (third x))) + |$sigAlist|)) + x) + ((and (consp x) (eq (qfirst x) '|Record|)) x) + (t + (cons (first x) + (loop for y in (rest x) + collect (transformType y)))))) + (removeSuchthat (x) + (declare (special |$predAlist|)) + (if (and (consp x) (eq (qfirst x) '|\||) (consp (qrest x)) + (consp (qcddr x)) (eq (qcdddr x) nil)) + (progn + (setq |$predAlist| (cons (cons (second x) (third x)) |$predAlist|)) + (second x)) + x)) + (fetchType (a x env form) + (if x + x + (or (|getmode| a env) + (|userError| (|concat| + "There is no mode for argument" a "of function" (first form)))))) + (addSuchthat (x y) + (let (p) + (declare (special |$predAlist|)) + (if (setq p (lassoc x |$predAlist|)) (list '|\|| y p) y))) + ) + (let (|$sigAlist| |$predAlist| form signature specialCases body sigList + argList argSigAlist argDepAlist varList whereList formxx signaturex + defform formx) + (declare (special |$sigAlist| |$predAlist|)) +; form is lhs (f a1 ... an) of definition; body is rhs; +; signature is (t0 t1 ... tn) where t0= target type, ti=type of ai, i > 0; +; specialCases is (NIL l1 ... ln) where li is list of special cases +; which can be given for each ti +; +; removes declarative and assignment information from form and +; signature, placing it in list L, replacing form by ("where",form',:L), +; signature by a list of NILs (signifying declarations are in e) + (setq form (second arg)) + (setq signature (third arg)) + (setq specialCases (fourth arg)) + (setq body (fifth arg)) + (setq |$sigAlist| nil) + (setq |$predAlist| nil) +; 1. create sigList= list of all signatures which have embedded +; declarations moved into global variable $sigAlist + (setq sigList + (loop for a in (rest form) for x in (rest signature) + collect (transformType (fetchType a x env form)))) +; 2. replace each argument of the form (|| x p) by x, recording +; the given predicate in global variable $predAlist + (setq argList + (loop for a in (rest form) + collect (removeSuchthat a))) + (setq argSigAlist (append |$sigAlist| (|pairList| argList sigList))) + (setq argDepAlist + (loop for pear in argSigAlist + collect + (cons (car pear) + (|union| (|listOfIdentifiersIn| (cdr pear)) + (|delete| (car pear) + (|listOfIdentifiersIn| (lassoc (car pear) |$predAlist|))))))) +; 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that +; the type of xi is independent of xj if i < j + (setq varList + (|orderByDependency| (assocleft argDepAlist) (assocright argDepAlist))) +; 4. construct a WhereList which declares and/or defines the xi's in +; the order constructed in step 3 + (setq whereList + (loop for x in varList + collect (addSuchthat x (list '|:| x (lassoc x argSigAlist))))) + (setq formxx (cons (car form) argList)) + (setq signaturex + (cons (car signature) + (loop for x in (rest signature) collect nil))) + (setq defform (list 'def formxx signaturex specialCases body)) + (setq formx (cons '|where| (cons defform whereList))) +; 5. compile new ('DEF,("where",form',:WhereList),:.) where +; all argument parameters of form' are bound/declared in WhereList + (|comp| formx mode env)))) \end{chunk} -\defun{getCaps}{getCaps} -\calls{getCaps}{stringimage} -\calls{getCaps}{maxindex} -\calls{getCaps}{l-case} -\calls{getCaps}{strconc} -\begin{chunk}{defun getCaps} -(defun |getCaps| (x) - (let (s c clist tmp1) - (setq s (stringimage x)) - (setq clist - (loop for i from 0 to (maxindex s) - when (upper-case-p (setq c (elt s i))) - collect c)) - (cond - ((null clist) "_") - (t - (setq tmp1 - (cons (first clist) (loop for u in (rest clist) collect (l-case u)))) - (let ((result "")) - (loop for u in tmp1 - do (setq result (strconc result u))) - result))))) +\defun{compDefineCategory}{compDefineCategory} +\calls{compDefineCategory}{compDefineLisplib} +\calls{compDefineCategory}{compDefineCategory1} +\usesdollar{compDefineCategory}{domainShell} +\usesdollar{compDefineCategory}{lisplibCategory} +\usesdollar{compDefineCategory}{lisplib} +\usesdollar{compDefineCategory}{insideFunctorIfTrue} +\begin{chunk}{defun compDefineCategory} +(defun |compDefineCategory| (df mode env prefix fal) + (let (|$domainShell| |$lisplibCategory|) + (declare (special |$domainShell| |$lisplibCategory| $lisplib + |$insideFunctorIfTrue|)) + (setq |$domainShell| nil) ; holds the category of the object being compiled + (setq |$lisplibCategory| nil) + (if (and (null |$insideFunctorIfTrue|) $lisplib) + (|compDefineLisplib| df mode env prefix fal '|compDefineCategory1|) + (|compDefineCategory1| df mode env prefix fal)))) \end{chunk} -\defun{constructMacro}{constructMacro} -constructMacro (form is [nam,[lam,vl,body]]) -\calls{constructMacro}{stackSemanticError} -\calls{constructMacro}{identp} -\begin{chunk}{defun constructMacro} -(defun |constructMacro| (form) - (let (vl body) - (setq vl (cadadr form)) - (setq body (car (cddadr form))) - (cond - ((null (let ((result t)) - (loop for x in vl - do (setq result (and result (atom x)))) - result)) - (|stackSemanticError| (list '|illegal parameters for macro: | vl) nil)) - (t - (list 'xlam (loop for x in vl when (identp x) collect x) body))))) - -\end{chunk} - -\defun{spadCompileOrSetq}{spadCompileOrSetq} -\calls{spadCompileOrSetq}{contained} -\calls{spadCompileOrSetq}{sayBrightly} -\calls{spadCompileOrSetq}{bright} -\calls{spadCompileOrSetq}{LAM,EVALANDFILEACTQ} -\calls{spadCompileOrSetq}{mkq} -\calls{spadCompileOrSetq}{comp} -\calls{spadCompileOrSetq}{compileConstructor} -\refsdollar{spadCompileOrSetq}{insideCapsuleFunctionIfTrue} -\begin{chunk}{defun spadCompileOrSetq} -(defun |spadCompileOrSetq| (form) - (let (nam lam vl body namp tmp1 e vlp macform) - (declare (special |$insideCapsuleFunctionIfTrue|)) - (setq nam (car form)) - (setq lam (caadr form)) - (setq vl (cadadr form)) - (setq body (car (cddadr form))) - (cond - ((and (consp vl) (progn (setq tmp1 (reverse vl)) t) - (consp tmp1) - (progn - (setq e (qfirst tmp1)) - (setq vlp (qrest tmp1)) - t) - (progn (setq vlp (nreverse vlp)) t) - (consp body) - (progn (setq namp (qfirst body)) t) - (equal (qrest 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)) - (consp vl) - (progn (setq tmp1 (reverse vl)) t) - (consp tmp1) - (progn - (setq e (qfirst tmp1)) - (setq vlp (qrest 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} - -\defun{compileConstructor}{compileConstructor} -\calls{compileConstructor}{compileConstructor1} -\calls{compileConstructor}{clearClams} -\begin{chunk}{defun compileConstructor} -(defun |compileConstructor| (form) - (let (u) - (setq u (|compileConstructor1| form)) - (|clearClams|) - u)) - -\end{chunk} - -\defun{compileConstructor1}{compileConstructor1} -\calls{compileConstructor1}{getdatabase} -\calls{compileConstructor1}{compAndDefine} -\calls{compileConstructor1}{comp} -\calls{compileConstructor1}{clearConstructorCache} -\refsdollar{compileConstructor1}{mutableDomain} -\refsdollar{compileConstructor1}{ConstructorCache} -\refsdollar{compileConstructor1}{clamList} -\defsdollar{compileConstructor1}{clamList} -\begin{chunk}{defun compileConstructor1} -(defun |compileConstructor1| (form) - (let (|$clamList| fn key vl bodyl lambdaOrSlam compForm u) - (declare (special |$clamList| |$ConstructorCache| |$mutableDomain|)) - (setq fn (car form)) - (setq key (caadr form)) - (setq vl (cadadr form)) - (setq bodyl (cddadr form)) - (setq |$clamList| nil) - (setq lambdaOrSlam - (cond - ((eq (getdatabase fn 'constructorkind) '|category|) 'spadslam) - (|$mutableDomain| 'lambda) - (t - (setq |$clamList| - (cons (list fn '|$ConstructorCache| '|domainEqualList| '|count|) - |$clamList|)) - 'lambda))) - (setq compForm (list (list fn (cons lambdaorslam (cons vl bodyl))))) - (if (eq (getdatabase fn 'constructorkind) '|category|) - (setq u (|compAndDefine| compForm)) - (setq u (comp compForm))) - (|clearConstructorCache| fn) - (car u))) - -\end{chunk} - -\defun{compAndDefine}{compAndDefine} -This function is used but never defined. -We define a dummy function here. -All references to it should be removed. -\tpdhere{This function is used but never defined. Remove it.} -\begin{chunk}{defun compAndDefine} -(defun compAndDefine (arg) - (declare (ignore arg)) - nil) - -\end{chunk} - -\defun{putInLocalDomainReferences}{putInLocalDomainReferences} -\calls{putInLocalDomainReferences}{NRTputInTail} -\refsdollar{putInLocalDomainReferences}{QuickCode} -\defsdollar{putInLocalDomainReferences}{elt} -\begin{chunk}{defun putInLocalDomainReferences} -(defun |putInLocalDomainReferences| (def) - (let (|$elt| opName lam varl body) - (declare (special |$elt| |$QuickCode|)) - (setq opName (car def)) - (setq lam (caadr def)) - (setq varl (cadadr def)) - (setq body (car (cddadr def))) - (setq |$elt| (if |$QuickCode| 'qrefelt 'elt)) - (|NRTputInTail| (cddadr def)) - def)) - -\end{chunk} - -\defun{NRTputInTail}{NRTputInTail} -\calls{NRTputInTail}{lassoc} -\calls{NRTputInTail}{NRTassocIndex} -\calls{NRTputInTail}{rplaca} -\calls{NRTputInTail}{NRTputInHead} -\refsdollar{NRTputInTail}{elt} -\refsdollar{NRTputInTail}{devaluateList} -\begin{chunk}{defun NRTputInTail} -(defun |NRTputInTail| (x) - (let (u k) - (declare (special |$elt| |$devaluateList|)) - (maplist #'(lambda (y) - (cond - ((atom (setq u (car y))) - (cond - ((or (eq u '$) (lassoc u |$devaluateList|)) - nil) - ((setq k (|NRTassocIndex| u)) - (cond - ; u atomic means that the slot will always contain a vector - ((atom u) (rplaca y (list |$elt| '$ k))) - ; this reference must check that slot is a vector - (t (rplaca y (list 'spadcheckelt '$ k))))) - (t nil))) - (t (|NRTputInHead| u)))) - x) - x)) +\defun{compDefineCategory1}{compDefineCategory1} +\calls{compDefineCategory1}{compDefineCategory2} +\calls{compDefineCategory1}{makeCategoryPredicates} +\calls{compDefineCategory1}{compDefine1} +\calls{compDefineCategory1}{mkCategoryPackage} +\usesdollar{compDefineCategory1}{insideCategoryPackageIfTrue} +\usesdollar{compDefineCategory1}{EmptyMode} +\usesdollar{compDefineCategory1}{categoryPredicateList} +\usesdollar{compDefineCategory1}{lisplibCategory} +\usesdollar{compDefineCategory1}{bootStrapMode} +\begin{chunk}{defun compDefineCategory1} +(defun |compDefineCategory1| (df mode env prefix fal) + (let (|$insideCategoryPackageIfTrue| |$categoryPredicateList| form + sig sc cat body categoryCapsule d tmp1 tmp3) + (declare (special |$insideCategoryPackageIfTrue| |$EmptyMode| + |$categoryPredicateList| |$lisplibCategory| + |$bootStrapMode|)) + ;; a category is a DEF form with 4 parts: + ;; ((DEF (|BasicType|) ((|Category|)) (NIL) + ;; (|add| (CATEGORY |domain| (SIGNATURE = ((|Boolean|) $ $)) + ;; (SIGNATURE ~= ((|Boolean|) $ $))) + ;; (CAPSULE (DEF (~= |x| |y|) ((|Boolean|) $ $) (NIL NIL NIL) + ;; (IF (= |x| |y|) |false| |true|)))))) + (setq form (second df)) + (setq sig (third df)) + (setq sc (fourth df)) + (setq body (fifth df)) + (setq categoryCapsule + (when (and (consp body) (eq (qfirst body) '|add|) + (consp (qrest body)) (consp (qcddr body)) + (eq (qcdddr body) nil)) + (setq tmp1 (third body)) + (setq body (second body)) + tmp1)) + (setq tmp3 (|compDefineCategory2| form sig sc body mode env prefix fal)) + (setq d (first tmp3)) + (setq mode (second tmp3)) + (setq env (third tmp3)) + (when (and categoryCapsule (null |$bootStrapMode|)) + (setq |$insideCategoryPackageIfTrue| t) + (setq |$categoryPredicateList| + (|makeCategoryPredicates| form |$lisplibCategory|)) + (setq env (third + (|compDefine1| + (|mkCategoryPackage| form cat categoryCapsule) |$EmptyMode| env)))) + (list d mode env))) \end{chunk} -\defun{NRTputInHead}{NRTputInHead} -\calls{NRTputInHead}{NRTputInTail} -\calls{NRTputInHead}{NRTassocIndex} -\calls{NRTputInHead}{NRTputInHead} -\calls{NRTputInHead}{lastnode} -\calls{NRTputInHead}{keyedSystemError} -\refsdollar{NRTputInHead}{elt} -\begin{chunk}{defun NRTputInHead} -(defun |NRTputInHead| (bod) - (let (fn clauses dom tmp2 ind k) - (declare (special |$elt|)) - (cond - ((atom bod) bod) - ((and (consp bod) (eq (qcar bod) 'spadcall) (consp (qcdr bod)) - (progn (setq tmp2 (reverse (qcdr bod))) t) (consp tmp2)) - (setq fn (qcar tmp2)) - (|NRTputInTail| (cdr bod)) - (cond - ((and (consp fn) (consp (qcdr fn)) (consp (qcdr (qcdr fn))) - (eq (qcdddr fn) nil) (null (eq (qsecond fn) '$)) - (member (qcar fn) '(elt qrefelt const))) - (when (setq k (|NRTassocIndex| (qsecond fn))) - (rplaca (lastnode bod) (list |$elt| '$ k)))) - (t (|NRTputInHead| fn) bod))) - ((and (consp bod) (eq (qcar bod) 'cond)) - (setq clauses (qcdr bod)) - (loop for cc in clauses do (|NRTputInTail| cc)) - bod) - ((and (consp bod) (eq (qcar bod) 'quote)) bod) - ((and (consp bod) (eq (qcar bod) 'closedfn)) bod) - ((and (consp bod) (eq (qcar bod) 'spadconst) (consp (qcdr bod)) - (consp (qcddr bod)) (eq (qcdddr bod) nil)) - (setq dom (qsecond bod)) - (setq ind (qthird bod)) - (rplaca bod |$elt|) - (cond - ((eq dom '$) nil) - ((setq k (|NRTassocIndex| dom)) - (rplaca (lastnode bod) (list |$elt| '$ k)) - bod) - (t - (|keyedSystemError| 'S2GE0016 - (list "NRTputInHead" "unexpected SPADCONST form"))))) - (t - (|NRTputInHead| (car bod)) - (|NRTputInTail| (cdr bod)) bod)))))) - -\end{chunk} - -\defun{getArgumentModeOrMoan}{getArgumentModeOrMoan} -\calls{getArgumentModeOrMoan}{getArgumentMode} -\calls{getArgumentModeOrMoan}{stackSemanticError} -\begin{chunk}{defun getArgumentModeOrMoan} -(defun |getArgumentModeOrMoan| (x form env) - (or (|getArgumentMode| x env) - (|stackSemanticError| - (list '|argument | x '| of | form '| is not declared|) nil))) - -\end{chunk} - -\defun{augLisplibModemapsFromCategory}{augLisplibModemapsFromCategory} -\calls{augLisplibModemapsFromCategory}{sublis} -\calls{augLisplibModemapsFromCategory}{mkAlistOfExplicitCategoryOps} -\calls{augLisplibModemapsFromCategory}{isCategoryForm} -\calls{augLisplibModemapsFromCategory}{lassoc} -\calls{augLisplibModemapsFromCategory}{member} -\calls{augLisplibModemapsFromCategory}{mkpf} -\calls{augLisplibModemapsFromCategory}{interactiveModemapForm} -\refsdollar{augLisplibModemapsFromCategory}{lisplibModemapAlist} -\refsdollar{augLisplibModemapsFromCategory}{EmptyEnvironment} -\refsdollar{augLisplibModemapsFromCategory}{domainShell} -\refsdollar{augLisplibModemapsFromCategory}{PatternVariableList} -\defsdollar{augLisplibModemapsFromCategory}{lisplibModemapAlist} -\begin{chunk}{defun augLisplibModemapsFromCategory} -(defun |augLisplibModemapsFromCategory| (form body signature) - (let (argl sl opAlist nonCategorySigAlist domainList catPredList op sig - pred sel predp modemap) - (declare (special |$lisplibModemapAlist| |$EmptyEnvironment| - |$domainShell| |$PatternVariableList|)) - (setq op (car form)) - (setq argl (cdr form)) - (setq sl - (cons (cons '$ '*1) - (loop for a in argl for p in (rest |$PatternVariableList|) - collect (cons a p)))) - (setq form (sublis sl form)) - (setq body (sublis sl body)) - (setq signature (sublis sl signature)) - (when (setq opAlist (sublis sl (elt |$domainShell| 1))) - (setq nonCategorySigAlist - (|mkAlistOfExplicitCategoryOps| (subst '*1 '$ body :test #'equal))) - (setq domainList - (loop for a in (rest form) for m in (rest signature) - when (|isCategoryForm| m |$EmptyEnvironment|) - collect (list a m))) - (setq catPredList - (loop for u in (cons (list '*1 form) domainList) - collect (cons '|ofCategory| u))) - (loop for entry in opAlist - when (|member| (cadar entry) (lassoc (caar entry) nonCategorySigAlist)) - do - (setq op (caar entry)) - (setq sig (cadar entry)) - (setq pred (cadr entry)) - (setq sel (caddr entry)) - (setq predp (mkpf (cons pred catPredList) 'and)) - (setq modemap (list (cons '*1 sig) (list predp sel))) - (setq |$lisplibModemapAlist| - (cons (cons op (|interactiveModemapForm| modemap)) - |$lisplibModemapAlist|)))))) +\defun{compDefineCategory2}{compDefineCategory2} +\calls{compDefineCategory2}{addBinding} +\calls{compDefineCategory2}{getArgumentModeOrMoan} +\calls{compDefineCategory2}{giveFormalParametersValues} +\calls{compDefineCategory2}{take} +\calls{compDefineCategory2}{sublis} +\calls{compDefineCategory2}{compMakeDeclaration} +\calls{compDefineCategory2}{opOf} +\calls{compDefineCategory2}{optFunctorBody} +\calls{compDefineCategory2}{compOrCroak} +\calls{compDefineCategory2}{mkConstructor} +\calls{compDefineCategory2}{compile} +\calls{compDefineCategory2}{lisplibWrite} +\calls{compDefineCategory2}{removeZeroOne} +\calls{compDefineCategory2}{mkq} +\calls{compDefineCategory2}{evalAndRwriteLispForm} +\calls{compDefineCategory2}{eval} +\calls{compDefineCategory2}{getParentsFor} +\calls{compDefineCategory2}{computeAncestorsOf} +\calls{compDefineCategory2}{constructor?} +\calls{compDefineCategory2}{augLisplibModemapsFromCategory} +\usesdollar{compDefineCategory2}{prefix} +\refsdollar{compDefineCategory2}{formalArgList} +\refsdollar{compDefineCategory2}{definition} +\refsdollar{compDefineCategory2}{form} +\refsdollar{compDefineCategory2}{op} +\refsdollar{compDefineCategory2}{extraParms} +\refsdollar{compDefineCategory2}{lisplibCategory} +\refsdollar{compDefineCategory2}{FormalMapVariableList} +\refsdollar{compDefineCategory2}{libFile} +\refsdollar{compDefineCategory2}{TriangleVariableList} +\refsdollar{compDefineCategory2}{lisplib} +\defsdollar{compDefineCategory2}{formalArgList} +\defsdollar{compDefineCategory2}{insideCategoryIfTrue} +\defsdollar{compDefineCategory2}{top-level} +\defsdollar{compDefineCategory2}{definition} +\defsdollar{compDefineCategory2}{form} +\defsdollar{compDefineCategory2}{op} +\defsdollar{compDefineCategory2}{extraParms} +\defsdollar{compDefineCategory2}{functionStats} +\defsdollar{compDefineCategory2}{functorStats} +\defsdollar{compDefineCategory2}{frontier} +\defsdollar{compDefineCategory2}{getDomainCode} +\defsdollar{compDefineCategory2}{addForm} +\defsdollar{compDefineCategory2}{lisplibAbbreviation} +\defsdollar{compDefineCategory2}{functorForm} +\defsdollar{compDefineCategory2}{lisplibAncestors} +\defsdollar{compDefineCategory2}{lisplibCategory} +\defsdollar{compDefineCategory2}{lisplibParents} +\defsdollar{compDefineCategory2}{lisplibModemap} +\defsdollar{compDefineCategory2}{lisplibKind} +\defsdollar{compDefineCategory2}{lisplibForm} +\defsdollar{compDefineCategory2}{domainShell} +\begin{chunk}{defun compDefineCategory2} +(defun |compDefineCategory2| + (form signature specialCases body mode env |$prefix| |$formalArgList|) + (declare (special |$prefix| |$formalArgList|) (ignore specialCases)) + (let (|$insideCategoryIfTrue| $TOP_LEVEL |$definition| |$form| |$op| + |$extraParms| |$functionStats| |$functorStats| |$frontier| + |$getDomainCode| |$addForm| argl sargl aList signaturep opp formp + formalBody formals actuals g fun pairlis parSignature parForm modemap) + (declare (special |$insideCategoryIfTrue| $top_level |$definition| + |$form| |$op| |$extraParms| |$functionStats| + |$functorStats| |$frontier| |$getDomainCode| + |$addForm| |$lisplibAbbreviation| |$functorForm| + |$lisplibAncestors| |$lisplibCategory| + |$FormalMapVariableList| |$lisplibParents| + |$lisplibModemap| |$lisplibKind| |$lisplibForm| + $lisplib |$domainShell| |$libFile| + |$TriangleVariableList|)) +; 1. bind global variables + (setq |$insideCategoryIfTrue| t) + (setq $top_level nil) + (setq |$definition| nil) + (setq |$form| nil) + (setq |$op| nil) + (setq |$extraParms| nil) +; 1.1 augment e to add declaration $: + (setq |$definition| form) + (setq |$op| (car |$definition|)) + (setq argl (cdr |$definition|)) + (setq env (|addBinding| '$ (list (cons '|mode| |$definition|)) env)) +; 2. obtain signature + (setq signaturep + (cons (car signature) + (loop for a in argl + collect (|getArgumentModeOrMoan| a |$definition| env)))) + (setq env (|giveFormalParametersValues| argl env)) +; 3. replace arguments by $1,..., substitute into body, +; and introduce declarations into environment + (setq sargl (take (|#| argl) |$TriangleVariableList|)) + (setq |$form| (cons |$op| sargl)) + (setq |$functorForm| |$form|) + (setq |$formalArgList| (append sargl |$formalArgList|)) + (setq aList (loop for a in argl for sa in sargl collect (cons a sa))) + (setq formalBody (sublis aList body)) + (setq signaturep (sublis aList signaturep)) + ; Begin lines for category default definitions + (setq |$functionStats| (list 0 0)) + (setq |$functorStats| (list 0 0)) + (setq |$frontier| 0) + (setq |$getDomainCode| nil) + (setq |$addForm| nil) + (loop for x in sargl for r in (rest signaturep) + do (setq env (third (|compMakeDeclaration| (list '|:| x r) mode env)))) +; 4. compile body in environment of %type declarations for arguments + (setq opp |$op|) + (when (and (not (eq (|opOf| formalBody) '|Join|)) + (not (eq (|opOf| formalBody) '|mkCategory|))) + (setq formalBody (list '|Join| formalBody))) + (setq body + (|optFunctorBody| (car (|compOrCroak| formalBody (car signaturep) env)))) + (when |$extraParms| + (setq actuals nil) + (setq formals nil) + (loop for u in |$extraParms| do + (setq formals (cons (car u) formals)) + (setq actuals (cons (mkq (cdr u)) actuals))) + (setq body + (list '|sublisV| (list 'pair (list 'quote formals) (cons 'list actuals)) + body))) +; always subst for args after extraparms + (when argl + (setq body + (list '|sublisV| + (list 'pair + (list 'quote sargl) + (cons 'list (loop for u in sargl collect (list '|devaluate| u)))) + body))) + (setq body + (list 'prog1 (list 'let (setq g (gensym)) body) + (list 'setelt g 0 (|mkConstructor| |$form|)))) + (setq fun (|compile| (list opp (list 'lam sargl body)))) +; 5. give operator a 'modemap property + (setq pairlis + (loop for a in argl for v in |$FormalMapVariableList| + collect (cons a v))) + (setq parSignature (sublis pairlis signaturep)) + (setq parForm (sublis pairlis form)) + (|lisplibWrite| "compilerInfo" + (|removeZeroOne| + (list 'setq '|$CategoryFrame| + (list '|put| (list 'quote opp) ''|isCategory| t + (list '|addModemap| (mkq opp) (mkq parForm) + (mkq parSignature) t (mkq fun) '|$CategoryFrame|)))) + |$libFile|) + (unless sargl + (|evalAndRwriteLispForm| 'niladic + `(setf (get ',opp 'niladic) t))) +;; 6 put modemaps into InteractiveModemapFrame + (setq |$domainShell| (|eval| (cons opp (mapcar 'mkq sargl)))) + (setq |$lisplibCategory| formalBody) + (when $lisplib + (setq |$lisplibForm| form) + (setq |$lisplibKind| '|category|) + (setq modemap (list (cons parForm parSignature) (list t opp))) + (setq |$lisplibModemap| modemap) + (setq |$lisplibParents| + (|getParentsFor| |$op| |$FormalMapVariableList| |$lisplibCategory|)) + (setq |$lisplibAncestors| (|computeAncestorsOf| |$form| nil)) + (setq |$lisplibAbbreviation| (|constructor?| |$op|)) + (setq formp (cons opp sargl)) + (|augLisplibModemapsFromCategory| formp formalBody signaturep)) + (list fun '(|Category|) env))) \end{chunk} -\defun{mkAlistOfExplicitCategoryOps}{mkAlistOfExplicitCategoryOps} -\calls{mkAlistOfExplicitCategoryOps}{qcar} -\calls{mkAlistOfExplicitCategoryOps}{qcdr} -\calls{mkAlistOfExplicitCategoryOps}{keyedSystemError} -\calls{mkAlistOfExplicitCategoryOps}{union} -\calls{mkAlistOfExplicitCategoryOps}{mkAlistOfExplicitCategoryOps} -\calls{mkAlistOfExplicitCategoryOps}{flattenSignatureList} -\calls{mkAlistOfExplicitCategoryOps}{nreverse0} -\calls{mkAlistOfExplicitCategoryOps}{remdup} -\calls{mkAlistOfExplicitCategoryOps}{assocleft} -\calls{mkAlistOfExplicitCategoryOps}{isCategoryForm} -\refsdollar{mkAlistOfExplicitCategoryOps}{e} -\begin{chunk}{defun mkAlistOfExplicitCategoryOps} -(defun |mkAlistOfExplicitCategoryOps| (target) - (labels ( - (atomizeOp (op) - (cond - ((atom op) op) - ((and (consp op) (eq (qrest op) nil)) (qfirst op)) - (t (|keyedSystemError| 'S2GE0016 - (list "mkAlistOfExplicitCategoryOps" "bad signature"))))) - (fn (op u) - (if (and (consp u) (consp (qfirst u))) - (if (equal (qcaar u) op) - (cons (qcdar u) (fn op (qrest u))) - (fn op (qrest u)))))) - (let (z tmp1 op sig u opList) - (declare (special |$e|)) - (when (and (consp target) (eq (qfirst target) '|add|) (consp (qrest target))) - (setq target (second target))) +\defun{compDefineLisplib}{compDefineLisplib} +\calls{compDefineLisplib}{sayMSG} +\calls{compDefineLisplib}{fillerSpaces} +\calls{compDefineLisplib}{getConstructorAbbreviation} +\calls{compDefineLisplib}{compileDocumentation} +\calls{compDefineLisplib}{bright} +\calls{compDefineLisplib}{finalizeLisplib} +\calls{compDefineLisplib}{rshut} +\calls{compDefineLisplib}{lisplibDoRename} +\calls{compDefineLisplib}{filep} +\calls{compDefineLisplib}{rpackfile} +\calls{compDefineLisplib}{unloadOneConstructor} +\calls{compDefineLisplib}{localdatabase} +\calls{compDefineLisplib}{getdatabase} +\calls{compDefineLisplib}{updateCategoryFrameForCategory} +\calls{compDefineLisplib}{updateCategoryFrameForConstructor} +\refsdollar{compDefineLisplib}{compileDocumentation} +\refsdollar{compDefineLisplib}{filep} +\refsdollar{compDefineLisplib}{spadLibFT} +\refsdollar{compDefineLisplib}{algebraOutputStream} +\refsdollar{compDefineLisplib}{newConlist} +\refsdollar{compDefineLisplib}{lisplibKind} +\defsdollar{compDefineLisplib}{lisplib} +\defsdollar{compDefineLisplib}{op} +\defsdollar{compDefineLisplib}{lisplibParents} +\defsdollar{compDefineLisplib}{lisplibPredicates} +\defsdollar{compDefineLisplib}{lisplibCategoriesExtended} +\defsdollar{compDefineLisplib}{lisplibForm} +\defsdollar{compDefineLisplib}{lisplibKind} +\defsdollar{compDefineLisplib}{lisplibAbbreviation} +\defsdollar{compDefineLisplib}{lisplibAncestors} +\defsdollar{compDefineLisplib}{lisplibModemap} +\defsdollar{compDefineLisplib}{lisplibModemapAlist} +\defsdollar{compDefineLisplib}{lisplibSlot1} +\defsdollar{compDefineLisplib}{lisplibOperationAlist} +\defsdollar{compDefineLisplib}{lisplibSuperDomain} +\defsdollar{compDefineLisplib}{libFile} +\defsdollar{compDefineLisplib}{lisplibVariableAlist} +\defsdollar{compDefineLisplib}{lisplibCategory} +\defsdollar{compDefineLisplib}{newConlist} +\begin{chunk}{defun compDefineLisplib} +(defun |compDefineLisplib| (df m env prefix fal fn) + (let ($LISPLIB |$op| |$lisplibAttributes| |$lisplibPredicates| + |$lisplibCategoriesExtended| |$lisplibForm| |$lisplibKind| + |$lisplibAbbreviation| |$lisplibParents| |$lisplibAncestors| + |$lisplibModemap| |$lisplibModemapAlist| |$lisplibSlot1| + |$lisplibOperationAlist| |$lisplibSuperDomain| |$libFile| + |$lisplibVariableAlist| |$lisplibCategory| op libname res ok filearg) + (declare (special $lisplib |$op| |$lisplibAttributes| |$newConlist| + |$lisplibPredicates| |$lisplibCategoriesExtended| + |$lisplibForm| |$lisplibKind| |$algebraOutputStream| + |$lisplibAbbreviation| |$lisplibParents| |$spadLibFT| + |$lisplibAncestors| |$lisplibModemap| $filep + |$lisplibModemapAlist| |$lisplibSlot1| + |$lisplibOperationAlist| |$lisplibSuperDomain| + |$libFile| |$lisplibVariableAlist| + |$lisplibCategory| |$compileDocumentation|)) + (when (eq (car df) 'def) (car df)) + (setq op (caadr df)) + (|sayMSG| (|fillerSpaces| 72 "-")) + (setq $lisplib t) + (setq |$op| op) + (setq |$lisplibAttributes| nil) + (setq |$lisplibPredicates| nil) + (setq |$lisplibCategoriesExtended| nil) + (setq |$lisplibForm| nil) + (setq |$lisplibKind| nil) + (setq |$lisplibAbbreviation| nil) + (setq |$lisplibParents| nil) + (setq |$lisplibAncestors| nil) + (setq |$lisplibModemap| nil) + (setq |$lisplibModemapAlist| nil) + (setq |$lisplibSlot1| nil) + (setq |$lisplibOperationAlist| nil) + (setq |$lisplibSuperDomain| nil) + (setq |$libFile| nil) + (setq |$lisplibVariableAlist| nil) + (setq |$lisplibCategory| nil) + (setq libname (|getConstructorAbbreviation| op)) (cond - ((and (consp target) (eq (qfirst target) '|Join|)) - (setq z (qrest target)) - (PROG (tmp1) - (RETURN - (DO ((G167566 z (CDR G167566)) (cat nil)) - ((OR (ATOM G167566) (PROGN (setq cat (CAR G167566)) nil)) - tmp1) - (setq tmp1 (|union| tmp1 (|mkAlistOfExplicitCategoryOps| cat))))))) - ((and (consp target) (eq (qfirst target) 'category) - (progn - (setq tmp1 (qrest target)) - (and (consp tmp1) - (progn (setq z (qrest tmp1)) t)))) - (setq z (|flattenSignatureList| (cons 'progn z))) - (setq u - (prog (G167577) - (return - (do ((G167583 z (cdr G167583)) (x nil)) - ((or (atom G167583)) (nreverse0 G167577)) - (setq x (car G167583)) - (cond - ((and (consp x) (eq (qfirst x) 'signature) (consp (qrest x)) - (consp (qcddr x))) - (setq op (qsecond x)) - (setq sig (qthird x)) - (setq G167577 (cons (cons (atomizeOp op) sig) G167577)))))))) - (setq opList (remdup (assocleft u))) - (prog (G167593) - (return - (do ((G167598 opList (cdr G167598)) (x nil)) - ((or (atom G167598)) (nreverse0 G167593)) - (setq x (car G167598)) - (setq G167593 (cons (cons x (fn x u)) G167593)))))) - ((|isCategoryForm| target |$e|) nil) + ((and (boundp '|$compileDocumentation|) |$compileDocumentation|) + (|compileDocumentation| libname)) (t - (|keyedSystemError| 'S2GE0016 - (list "mkAlistOfExplicitCategoryOps" "bad signature"))))))) + (|sayMSG| (cons " initializing " (cons |$spadLibFT| + (append (|bright| libname) (cons "for" (|bright| op)))))) + (|initializeLisplib| libname) + (|sayMSG| + (cons " compiling into " (cons |$spadLibFT| (|bright| libname)))) + (setq ok nil) + (unwind-protect + (progn + (setq res (funcall fn df m env prefix fal)) + (|sayMSG| (cons " finalizing " (cons |$spadLibFT| (|bright| libname)))) + (|finalizeLisplib| libname) + (setq ok t)) + (rshut |$libFile|)) + (when ok (|lisplibDoRename| libname)) + (setq filearg ($filep libname |$spadLibFT| 'a)) + (rpackfile filearg) + (fresh-line |$algebraOutputStream|) + (|sayMSG| (|fillerSpaces| 72 "-")) + (|unloadOneConstructor| op libname) + (localdatabase (list (getdatabase op 'abbreviation)) nil) + (setq |$newConlist| (cons op |$newConlist|)) + (when (eq |$lisplibKind| '|category|) + (|updateCategoryFrameForCategory| op) + (|updateCategoryFrameForConstructor| op)) + res)))) \end{chunk} -\defun{flattenSignatureList}{flattenSignatureList} -\calls{flattenSignatureList}{qcar} -\calls{flattenSignatureList}{qcdr} -\calls{flattenSignatureList}{flattenSignatureList} -\begin{chunk}{defun flattenSignatureList} -(defun |flattenSignatureList| (x) - (let (zz) - (cond - ((atom x) nil) - ((and (consp x) (eq (qfirst x) 'signature)) (list x)) - ((and (consp x) (eq (qfirst x) 'if) (consp (qrest x)) - (consp (qcddr x)) (consp (qcdddr x)) - (eq (qcddddr x) nil)) - (append (|flattenSignatureList| (third x)) - (|flattenSignatureList| (fourth x)))) - ((and (consp x) (eq (qfirst x) 'progn)) - (loop for x in (qrest x) - do - (if (and (consp x) (eq (qfirst x) 'signature)) - (setq zz (cons x zz)) - (setq zz (append (|flattenSignatureList| x) zz)))) - zz) - (t nil)))) +\defun{compileDocumentation}{compileDocumentation} +\calls{compileDocumentation}{make-input-filename} +\calls{compileDocumentation}{rdefiostream} +\calls{compileDocumentation}{lisplibWrite} +\calls{compileDocumentation}{finalizeDocumentation} +\calls{compileDocumentation}{rshut} +\calls{compileDocumentation}{rpackfile} +\calls{compileDocumentation}{replaceFile} +\refsdollar{compileDocumentation}{fcopy} +\refsdollar{compileDocumentation}{spadLibFT} +\refsdollar{compileDocumentation}{EmptyMode} +\refsdollar{compileDocumentation}{e} +\begin{chunk}{defun compileDocumentation} +(defun |compileDocumentation| (libName) + (let (filename stream) + (declare (special |$e| |$EmptyMode| |$spadLibFT| $fcopy)) + (setq filename (make-input-filename libName |$spadLibFT|)) + ($fcopy filename (cons libname (list 'doclb))) + (setq stream + (rdefiostream (cons (list 'file libName 'doclb) (list (cons 'mode 'o))))) + (|lisplibWrite| "documentation" (|finalizeDocumentation|) stream) + (rshut stream) + (rpackfile (list libName 'doclb)) + (replaceFile (list libName |$spadLibFT|) (list libName 'doclb)) + (list '|dummy| |$EmptyMode| |$e|))) \end{chunk} -\defun{interactiveModemapForm}{interactiveModemapForm} -Create modemap form for use by the interpreter. This function -replaces all specific domains mentioned in the modemap with pattern -variables, and predicates -\calls{interactiveModemapForm}{qcar} -\calls{interactiveModemapForm}{qcdr} -\calls{interactiveModemapForm}{replaceVars} -\calls{interactiveModemapForm}{modemapPattern} -\calls{interactiveModemapForm}{substVars} -\calls{interactiveModemapForm}{fixUpPredicate} -\refsdollar{interactiveModemapForm}{PatternVariableList} -\refsdollar{interactiveModemapForm}{FormalMapVariableList} -\begin{chunk}{defun interactiveModemapForm} -(defun |interactiveModemapForm| (mm) +\defun{compArgumentConditions}{compArgumentConditions} +\calls{compArgumentConditions}{compOrCroak} +\refsdollar{compArgumentConditions}{Boolean} +\refsdollar{compArgumentConditions}{argumentConditionList} +\defsdollar{compArgumentConditions}{argumentConditionList} +\begin{chunk}{defun compArgumentConditions} +(defun |compArgumentConditions| (env) + (let (n a x y tmp1) + (declare (special |$Boolean| |$argumentConditionList|)) + (setq |$argumentConditionList| + (loop for item in |$argumentConditionList| + do + (setq n (first item)) + (setq a (second item)) + (setq x (third item)) + (setq y (subst a '|#1| x :test #'equal)) + (setq tmp1 (|compOrCroak| y |$Boolean| env)) + (setq env (third tmp1)) + collect + (list n x (first tmp1)))) + env)) + +\end{chunk} + +\defun{compileCases}{compileCases} +\calls{compileCases}{eval} +\calls{compileCases}{compile} +\calls{compileCases}{getSpecialCaseAssoc} +\calls{compileCases}{get} +\calls{compileCases}{assocleft} +\calls{compileCases}{outerProduct} +\calls{compileCases}{assocright} +\calls{compileCases}{mkpf} +\refsdollar{compileCases}{getDomainCode} +\refsdollar{compileCases}{insideFunctorIfTrue} +\defsdollar{compileCases}{specialCaseKeyList} +\begin{chunk}{defun compileCases} +(defun |compileCases| (x |$e|) + (declare (special |$e|)) (labels ( - (fn (x) - (if (and (consp x) (consp (qrest x)) - (consp (qcddr x)) (eq (qcdddr x) nil) - (not (eq (qfirst x) '|isFreeFunction|)) - (atom (qthird x))) - (list (first x) (second x) (list (third x))) - x))) - (let (pattern dc sig mmpat patternAlist partial patvars - domainPredicateList tmp1 pred dependList cond) - (declare (special |$PatternVariableList| |$FormalMapVariableList|)) - (setq mm - (|replaceVars| (copy mm) |$PatternVariableList| |$FormalMapVariableList|)) - (setq pattern (car mm)) - (setq dc (caar mm)) - (setq sig (cdar mm)) - (setq pred (cadr mm)) - (setq pred - (prog () - (return - (do ((x pred (cdr x)) (result nil)) - ((atom x) (nreverse0 result)) - (setq result (cons (fn (car x)) result)))))) - (setq tmp1 (|modemapPattern| pattern sig)) - (setq mmpat (car tmp1)) - (setq patternAlist (cadr tmp1)) - (setq partial (caddr tmp1)) - (setq patvars (cadddr tmp1)) - (setq tmp1 (|substVars| pred patternAlist patvars)) - (setq pred (car tmp1)) - (setq domainPredicateList (cadr tmp1)) - (setq tmp1 (|fixUpPredicate| pred domainPredicateList partial (cdr mmpat))) - (setq pred (car tmp1)) - (setq dependList (cdr tmp1)) - (setq cond (car pred)) - (list mmpat cond)))) - -\end{chunk} - -\defun{replaceVars}{replaceVars} -Replace every identifier in oldvars with the corresponding -identifier in newvars in the expression x -\begin{chunk}{defun replaceVars} -(defun |replaceVars| (x oldvars newvars) - (loop for old in oldvars for new in newvars - do (setq x (subst new old x :test #'equal))) - x) - -\end{chunk} - -\defun{fixUpPredicate}{fixUpPredicate} -\calls{fixUpPredicate}{qcar} -\calls{fixUpPredicate}{qcdr} -\calls{fixUpPredicate}{length} -\calls{fixUpPredicate}{orderPredicateItems} -\calls{fixUpPredicate}{moveORsOutside} -\begin{chunk}{defun fixUpPredicate} -(defun |fixUpPredicate| (predClause domainPreds partial sig) - (let (predicate fn skip predicates tmp1 dependList pred) - (setq predicate (car predClause)) - (setq fn (cadr predClause)) - (setq skip (cddr predClause)) - (cond - ((eq (car predicate) 'and) - (setq predicates (append domainPreds (cdr predicate)))) - ((not (equal predicate (mkq t))) - (setq predicates (cons predicate domainPreds))) - (t - (setq predicates (or domainPreds (list predicate))))) + (isEltArgumentIn (Rlist x) + (cond + ((atom x) nil) + ((and (consp x) (eq (qfirst x) 'elt) (consp (qrest x)) + (consp (qcddr x)) (eq (qcdddr x) nil)) + (or (member (second x) Rlist) + (isEltArgumentIn Rlist (cdr x)))) + ((and (consp x) (eq (qfirst x) 'qrefelt) (consp (qrest x)) + (consp (qcddr x)) (eq (qcdddr x) nil)) + (or (member (second x) Rlist) + (isEltArgumentIn Rlist (cdr x)))) + (t + (or (isEltArgumentIn Rlist (car x)) + (isEltArgumentIn Rlist (CDR x)))))) + (FindNamesFor (r rp) + (let (v u) + (declare (special |$getDomainCode|)) + (cons r + (loop for item in |$getDomainCode| + do + (setq v (second item)) + (setq u (third item)) + when (and (equal (second u) r) (|eval| (subst rp r u :test #'equal))) + collect v))))) + (let (|$specialCaseKeyList| specialCaseAssoc listOfDomains listOfAllCases cl) + (declare (special |$specialCaseKeyList| |$true| |$insideFunctorIfTrue|)) + (setq |$specialCaseKeyList| nil) (cond - ((> (|#| predicates) 1) - (setq pred (cons 'and predicates)) - (setq tmp1 (|orderPredicateItems| pred sig skip)) - (setq pred (car tmp1)) - (setq dependlist (cdr tmp1)) - tmp1) + ((null (eq |$insideFunctorIfTrue| t)) (|compile| x)) (t - (setq pred (|orderPredicateItems| (car predicates) sig skip)) - (setq dependList - (when (and (consp pred) (eq (qfirst pred) '|isDomain|) - (consp (qrest pred)) (consp (qcddr pred)) - (eq (qcdddr pred) nil) - (consp (qthird pred)) - (eq (qcdaddr pred) nil)) - (list (second pred)))))) - (setq pred (|moveORsOutside| pred)) - (when partial (setq pred (cons '|partial| pred))) - (cons (cons pred (cons fn skip)) dependList))) - -\end{chunk} - -\defun{orderPredicateItems}{orderPredicateItems} -\calls{orderPredicateItems}{qcar} -\calls{orderPredicateItems}{qcdr} -\calls{orderPredicateItems}{signatureTran} -\calls{orderPredicateItems}{orderPredTran} -\begin{chunk}{defun orderPredicateItems} -(defun |orderPredicateItems| (pred1 sig skip) - (let (pred) - (setq pred (|signatureTran| pred1)) - (if (and (consp pred) (eq (qfirst pred) 'and)) - (|orderPredTran| (qrest pred) sig skip) - pred))) + (setq specialCaseAssoc + (loop for y in (|getSpecialCaseAssoc|) + when (and (null (|get| (first y) '|specialCase| |$e|)) + (isEltArgumentIn (FindNamesFor (first y) (second y)) x)) + collect y)) + (cond + ((null specialCaseAssoc) (|compile| x)) + (t + (setq listOfDomains (assocleft specialCaseAssoc)) + (setq listOfAllCases (|outerProduct| (assocright specialCaseAssoc))) + (setq cl + (loop for z in listOfAllCases + collect + (progn + (setq |$specialCaseKeyList| + (loop for d in listOfDomains for c in z + collect (cons d c))) + (cons + (mkpf + (loop for d in listOfDomains for c in z + collect (list 'equal d c)) + 'and) + (list (|compile| (copy x))))))) + (setq |$specialCaseKeyList| nil) + (cons 'cond (append cl (list (list |$true| (|compile| x)))))))))))) \end{chunk} -\defun{signatureTran}{signatureTran} -\calls{signatureTran}{signatureTran} -\calls{signatureTran}{isCategoryForm} -\refsdollar{signatureTran}{e} -\begin{chunk}{defun signatureTran} -(defun |signatureTran| (pred) - (declare (special |$e|)) - (cond - ((atom pred) pred) - ((and (consp pred) (eq (qfirst pred) '|has|) (CONSP (qrest pred)) - (consp (qcddr pred)) - (eq (qcdddr pred) nil) - (|isCategoryForm| (third pred) |$e|)) - (list '|ofCategory| (second pred) (third pred))) - (t - (loop for p in pred - collect (|signatureTran| p))))) +\defun{compFunctorBody}{compFunctorBody} +\calls{compFunctorBody}{bootStrapError} +\calls{compFunctorBody}{compOrCroak} +\uses{compFunctorBody}{/editfile} +\usesdollar{compFunctorBody}{NRTaddForm} +\usesdollar{compFunctorBody}{functorForm} +\usesdollar{compFunctorBody}{bootStrapMode} +\begin{chunk}{defun compFunctorBody} +(defun |compFunctorBody| (form mode env parForm) + (declare (ignore parForm)) + (let (tt) + (declare (special |$NRTaddForm| |$functorForm| |$bootStrapMode| /editfile)) + (if |$bootStrapMode| + (list (|bootStrapError| |$functorForm| /editfile) mode env) + (progn + (setq tt (|compOrCroak| form mode env)) + (if (and (consp form) (member (qfirst form) '(|add| capsule))) + tt + (progn + (setq |$NRTaddForm| + (if (and (consp form) (eq (qfirst form) '|SubDomain|) + (consp (qrest form)) (consp (qcddr form)) + (eq (qcdddr form) nil)) + (qsecond form) + form)) + tt)))))) \end{chunk} -\defun{orderPredTran}{orderPredTran} -\calls{orderPredTran}{qcar} -\calls{orderPredTran}{qcdr} -\calls{orderPredTran}{member} -\calls{orderPredTran}{delete} -\calls{orderPredTran}{unionq} -\calls{orderPredTran}{listOfPatternIds} -\calls{orderPredTran}{intersectionq} -\calls{orderPredTran}{setdifference} -\calls{orderPredTran}{insertWOC} -\calls{orderPredTran}{isDomainSubst} -\begin{chunk}{defun orderPredTran} -(defun |orderPredTran| (oldList sig skip) - (let (lastDependList somethingDone lastPreds indepvl depvl dependList - noldList x ids fullDependList newList answer) -; --(1) make two kinds of predicates appear last: -; ----- (op *target ..) when *target does not appear later in sig -; ----- (isDomain *1 ..) - (SEQ - (loop for pred in oldList - do (cond - ((or (and (consp pred) (consp (qrest pred)) - (consp (qcddr pred)) - (eq (qcdddr pred) nil) - (member (qfirst pred) '(|isDomain| |ofCategory|)) - (equal (qsecond pred) (car sig)) - (null (|member| (qsecond pred) (cdr sig)))) - (and (null skip) (consp pred) (eq (qfirst pred) '|isDomain|) - (consp (qrest pred)) (consp (qcddr pred)) - (eq (qcdddr pred) nil) - (equal (qsecond pred) '*1))) - (setq oldList (|delete| pred oldList)) - (setq lastPreds (cons pred lastPreds))))) -; --(2a) lastDependList=list of all variables that lastPred forms depend upon - (setq lastDependList - (let (result) - (loop for x in lastPreds - do (setq result (unionq result (|listOfPatternIds| x)))) - result)) -; --(2b) dependList=list of all variables that isDom/ofCat forms depend upon - (setq dependList - (let (result) - (loop for x in oldList - do (when - (and (consp x) - (or (eq (qfirst x) '|isDomain|) (eq (qfirst x) '|ofCategory|)) - (consp (qrest x)) (consp (qcddr x)) - (eq (qcdddr x) nil)) - (setq result (unionq result (|listOfPatternIds| (third x)))))) - result)) -; --(3a) newList= list of ofCat/isDom entries that don't depend on - (loop for x in oldList - do - (cond - ((and (consp x) - (or (eq (qfirst x) '|ofCategory|) (eq (qfirst x) '|isDomain|)) - (consp (qrest x)) (consp (qcddr x)) - (eq (qcdddr x) nil)) - (setq indepvl (|listOfPatternIds| (second x))) - (setq depvl (|listOfPatternIds| (third x)))) - (t - (setq indepvl (|listOfPatternIds| x)) - (setq depvl nil))) - (when - (and (null (intersectionq indepvl dependList)) - (intersectionq indepvl lastDependList)) - (setq somethingDone t) - (setq lastPreds (append lastPreds (list x))) - (setq oldList (|delete| x oldList)))) -; --(3b) newList= list of ofCat/isDom entries that don't depend on - (loop while oldList do - (loop for x in oldList do - (cond - ((and (consp x) - (or (eq (qfirst x) '|ofCategory|) (eq (qfirst x) '|isDomain|)) - (consp (qrest x)) - (consp (qcddr x)) (eq (qcdddr x) nil)) - (setq indepvl (|listOfPatternIds| (second x))) - (setq depvl (|listOfPatternIds| (third x)))) - (t - (setq indepvl (|listOfPatternIds| x)) - (setq depvl nil))) - (when (null (intersectionq indepvl dependList)) - (setq dependList (SETDIFFERENCE dependList depvl)) - (setq newList (APPEND newList (list x))))) -; --(4) noldList= what is left over +\defun{compile}{compile} +\calls{compile}{member} +\calls{compile}{getmode} +\calls{compile}{get} +\calls{compile}{modeEqual} +\calls{compile}{userError} +\calls{compile}{encodeItem} +\calls{compile}{strconc} +\calls{compile}{kar} +\calls{compile}{encodeFunctionName} +\calls{compile}{splitEncodedFunctionName} +\calls{compile}{sayBrightly} +\calls{compile}{optimizeFunctionDef} +\calls{compile}{putInLocalDomainReferences} +\calls{compile}{constructMacro} +\calls{compile}{spadCompileOrSetq} +\calls{compile}{elapsedTime} +\calls{compile}{addStats} +\calls{compile}{printStats} +\refsdollar{compile}{functionStats} +\refsdollar{compile}{macroIfTrue} +\refsdollar{compile}{doNotCompileJustPrint} +\refsdollar{compile}{insideCapsuleFunctionIfTrue} +\refsdollar{compile}{saveableItems} +\refsdollar{compile}{lisplibItemsAlreadyThere} +\refsdollar{compile}{splitUpItemsAlreadyThere} +\refsdollar{compile}{lisplib} +\refsdollar{compile}{compileOnlyCertainItems} +\refsdollar{compile}{functorForm} +\refsdollar{compile}{signatureOfForm} +\refsdollar{compile}{suffix} +\refsdollar{compile}{prefix} +\refsdollar{compile}{signatureOfForm} +\refsdollar{compile}{e} +\defsdollar{compile}{functionStats} +\defsdollar{compile}{savableItems} +\defsdollar{compile}{suffix} +\begin{chunk}{defun compile} +(defun |compile| (u) + (labels ( + (isLocalFunction (op) + (let (tmp1) + (declare (special |$e| |$formalArgList|)) + (and (null (|member| op |$formalArgList|)) + (progn + (setq tmp1 (|getmode| op |$e|)) + (and (consp tmp1) (eq (qfirst tmp1) '|Mapping|))))))) + (let (op lamExpr DC sig sel opexport opmodes opp parts s tt unew + optimizedBody stuffToCompile result functionStats) + (declare (special |$functionStats| |$macroIfTrue| |$doNotCompileJustPrint| + |$insideCapsuleFunctionIfTrue| |$saveableItems| |$e| + |$lisplibItemsAlreadyThere| |$splitUpItemsAlreadyThere| + |$compileOnlyCertainItems| $LISPLIB |$suffix| + |$signatureOfForm| |$functorForm| |$prefix| + |$savableItems|)) + (setq op (first u)) + (setq lamExpr (second u)) + (when |$suffix| + (setq |$suffix| (1+ |$suffix|)) + (setq opp + (progn + (setq opexport nil) + (setq opmodes + (loop for item in (|get| op '|modemap| |$e|) + do + (setq dc (caar item)) + (setq sig (cdar item)) + (setq sel (cadadr item)) + when (and (eq dc '$) + (setq opexport t) + (let ((result t)) + (loop for x in sig for y in |$signatureOfForm| + do (setq result (|modeEqual| x y))) + result)) + collect sel)) + (cond + ((isLocalFunction op) + (when opexport + (|userError| (list '|%b| op '|%d| " is local and exported"))) + (intern (strconc (|encodeItem| |$prefix|) ";" (|encodeItem| op)))) + (t + (|encodeFunctionName| op |$functorForm| |$signatureOfForm| + '|;| |$suffix|))))) + (setq u (list opp lamExpr))) + (when (and $lisplib |$compileOnlyCertainItems|) + (setq parts (|splitEncodedFunctionName| (elt u 0) '|;|)) (cond - ((equal (setq noldList (setdifference oldList newList)) oldList) - (setq newList (APPEND newList oldList)) - (return nil)) + ((eq parts '|inner|) + (setq |$savableItems| (cons (elt u 0) |$savableItems|))) (t - (setq oldList noldList)))) - (loop for pred in newList do - (when - (and (consp pred) - (or (eq (qfirst pred) '|isDomain|) (eq (qfirst x) '|ofCategory|)) - (consp (qrest pred)) - (consp (qcddr pred)) - (eq (qcdddr pred) nil)) - (setq ids (|listOfPatternIds| (third pred))) + (setq unew nil) + (loop for item in |$splitUpItemsAlreadyThere| + do + (setq s (first item)) + (setq tt (second item)) (when - (let (result) - (loop for id in ids do - (setq result (and result (|member| id fullDependList)))) - result) - (setq fullDependList (|insertWOC| (second pred) fullDependList))) - (setq fullDependList (unionq fullDependList ids)))) - (setq newList (append newList lastPreds)) - (setq newList (|isDomainSubst| newList)) - (setq answer - (cons (cons 'and newList) (intersectionq fullDependList sig)))))) - -\end{chunk} - -\defun{isDomainSubst}{isDomainSubst} -\begin{chunk}{defun isDomainSubst} -(defun |isDomainSubst| (u) - (labels ( - (findSub (x alist) - (cond - ((null alist) nil) - ((and (consp alist) (consp (qfirst alist)) - (eq (qcaar alist) '|isDomain|) - (consp (qcdar alist)) - (consp (qcddar alist)) - (eq (qcdddar alist) nil) - (equal x (cadar alist))) - (caddar alist)) - (t (findSub x (cdr alist))))) - (fn (x alist) - (let (s) - (declare (special |$PatternVariableList|)) - (if (atom x) - (if - (and (identp x) - (member x |$PatternVariableList|) - (setq s (findSub x alist))) - s - x) - (cons (car x) - (loop for y in (cdr x) - collect (fn y alist))))))) - (let (head tail nhead) - (if (consp u) - (progn - (setq head (qfirst u)) - (setq tail (qrest u)) - (setq nhead - (cond - ((and (consp head) (eq (qfirst head) '|isDomain|) - (consp (qrest head)) (consp (qcddr head)) - (eq (qcdddr head) nil)) - (list '|isDomain| (second head) - (fn (third head) tail))) - (t head))) - (cons nhead (|isDomainSubst| (cdr u)))) - u)))) + (and (equal (elt parts 0) (elt s 0)) + (equal (elt parts 1) (elt s 1)) + (equal (elt parts 2) (elt s 2))) + (setq unew tt))) + (cond + ((null unew) + (|sayBrightly| (list " Error: Item did not previously exist")) + (|sayBrightly| (cons " Item not saved: " (|bright| (elt u 0)))) + (|sayBrightly| + (list " What's there is: " |$lisplibItemsAlreadyThere|)) + nil) + (t + (|sayBrightly| (list " Renaming " (elt u 0) " as " unew)) + (setq u (cons unew (cdr u))) + (setq |$savableItems| (cons unew |$saveableItems|))))))) + (setq optimizedBody (|optimizeFunctionDef| u)) + (setq stuffToCompile + (if |$insideCapsuleFunctionIfTrue| + (|putInLocalDomainReferences| optimizedBody) + optimizedBody)) + (cond + ((eq |$doNotCompileJustPrint| t) + (prettyprint stuffToCompile) + opp) + (|$macroIfTrue| (|constructMacro| stuffToCompile)) + (t + (setq result (|spadCompileOrSetq| stuffToCompile)) + (setq functionStats (list 0 (|elapsedTime|))) + (setq |$functionStats| (|addStats| |$functionStats| functionStats)) + (|printStats| functionStats) + result))))) \end{chunk} -\defun{moveORsOutside}{moveORsOutside} -\calls{moveORsOutside}{moveORsOutside} -\begin{chunk}{defun moveORsOutside} -(defun |moveORsOutside| (p) - (let (q x) - (cond - ((and (consp p) (eq (qfirst p) 'and)) - (setq q - (prog (G167169) - (return - (do ((G167174 (cdr p) (cdr G167174)) (|r| nil)) - ((or (atom G167174)) (nreverse0 G167169)) - (setq |r| (CAR G167174)) - (setq G167169 (cons (|moveORsOutside| |r|) G167169)))))) - (cond - ((setq x - (let (tmp1) - (loop for r in q - when (and (consp r) (eq (qfirst r) 'or)) - do (setq tmp1 (or tmp1 r))) - tmp1)) - (|moveORsOutside| - (cons 'or - (let (tmp1) - (loop for tt in (cdr x) - do (setq tmp1 (cons (cons 'and (subst tt x q :test #'equal)) tmp1))) - (nreverse0 tmp1))))) - (t (cons 'and q)))) - (t p)))) -;(defun |moveORsOutside| (p) -; (let (q s x tmp1) -; (cond -; ((and (consp p) (eq (qfirst p) 'and)) -; (setq q (loop for r in (qrest p) collect (|moveORsOutside| r))) -; (setq tmp1 -; (loop for r in q -; when (and (consp r) (eq (qrest r) 'or)) -; collect r)) -; (setq x (mapcar #'(lambda (a b) (or a b)) tmp1)) -; (if x -; (|moveORsOutside| -; (cons 'or -; (loop for tt in (cdr x) -; collect (cons 'and (subst tt x q :test #'equal))))) -; (cons 'and q))) -; ('t p)))) - -\end{chunk} - -\defun{substVars}{substVars} -Make pattern variable substitutions. -\calls{substVars}{nsubst} -\calls{substVars}{contained} -\refsdollar{substVars}{FormalMapVariableList} -\begin{chunk}{defun substVars} -(defun |substVars| (pred patternAlist patternVarList) - (let (patVar value everything replacementVar domainPredicates) - (declare (special |$FormalMapVariableList|)) - (setq domainPredicates NIL) - (maplist - #'(lambda (x) - (setq patVar (caar x)) - (setq value (cdar x)) - (setq pred (subst patVar value pred :test #'equal)) - (setq patternAlist (|nsubst| patVar value patternAlist)) - (setq domainPredicates - (subst patVar value domainPredicates :test #'equal)) - (unless (member value |$FormalMapVariableList|) - (setq domainPredicates - (cons (list '|isDomain| patVar value) domainPredicates)))) - patternAlist) - (setq everything (list pred patternAlist domainPredicates)) - (dolist (var |$FormalMapVariableList|) - (cond - ((contained var everything) - (setq replacementVar (car patternVarList)) - (setq patternVarList (cdr patternVarList)) - (setq pred (subst replacementVar var pred :test #'equal)) - (setq domainPredicates - (subst replacementVar var domainPredicates :test #'equal))))) - (list pred domainPredicates))) - -\end{chunk} - -\defun{modemapPattern}{modemapPattern} -\calls{modemapPattern}{qcar} -\calls{modemapPattern}{qcdr} -\calls{modemapPattern}{rassoc} -\refsdollar{modemapPattern}{PatternVariableList} -\begin{chunk}{defun modemapPattern} -(defun |modemapPattern| (mmPattern sig) - (let (partial patvar patvars mmpat patternAlist) - (declare (special |$PatternVariableList|)) - (setq patternAlist nil) - (setq mmpat nil) - (setq patvars |$PatternVariableList|) - (setq partial nil) - (maplist - #'(lambda (xTails) - (let ((x (car xTails))) - (when (and (consp x) (eq (qfirst x) '|Union|) - (consp (qrest x)) (consp (qcddr x)) - (eq (qcdddr x) nil) - (equal (third x) "failed") - (equal xTails sig)) - (setq x (second x)) - (setq partial t)) - (setq patvar (|rassoc| x patternAlist)) - (cond - ((null (null patvar)) - (setq mmpat (cons patvar mmpat))) - (t - (setq patvar (car patvars)) - (setq patvars (cdr patvars)) - (setq mmpat (cons patvar mmpat)) - (setq patternAlist (cons (cons patvar x) patternAlist)))))) - mmPattern) - (list (nreverse mmpat) patternAlist partial patvars))) - -\end{chunk} - -\defun{evalAndRwriteLispForm}{evalAndRwriteLispForm} -\calls{evalAndRwriteLispForm}{eval} -\calls{evalAndRwriteLispForm}{rwriteLispForm} -\begin{chunk}{defun evalAndRwriteLispForm} -(defun |evalAndRwriteLispForm| (key form) - (|eval| form) - (|rwriteLispForm| key form)) - -\end{chunk} - -\defun{rwriteLispForm}{rwriteLispForm} -\refsdollar{rwriteLispForm}{libFile} -\refsdollar{rwriteLispForm}{lisplib} -\begin{chunk}{defun rwriteLispForm} -(defun |rwriteLispForm| (key form) - (declare (special |$libFile| $lisplib)) - (when $lisplib - (|rwrite| key form |$libFile|) - (|LAM,FILEACTQ| key form))) - -\end{chunk} - -\defun{mkConstructor}{mkConstructor} -\calls{mkConstructor}{mkConstructor} -\begin{chunk}{defun mkConstructor} -(defun |mkConstructor| (form) - (cond - ((atom form) (list '|devaluate| form)) - ((null (rest form)) (list 'quote (list (first form)))) - (t - (cons 'list - (cons (mkq (first form)) - (loop for x in (rest form) collect (|mkConstructor| x))))))) - -\end{chunk} - -\defun{compDefineCategory}{compDefineCategory} -\calls{compDefineCategory}{compDefineLisplib} -\calls{compDefineCategory}{compDefineCategory1} -\usesdollar{compDefineCategory}{domainShell} -\usesdollar{compDefineCategory}{lisplibCategory} -\usesdollar{compDefineCategory}{lisplib} -\usesdollar{compDefineCategory}{insideFunctorIfTrue} -\begin{chunk}{defun compDefineCategory} -(defun |compDefineCategory| (df mode env prefix fal) - (let (|$domainShell| |$lisplibCategory|) - (declare (special |$domainShell| |$lisplibCategory| $lisplib - |$insideFunctorIfTrue|)) - (setq |$domainShell| nil) ; holds the category of the object being compiled - (setq |$lisplibCategory| nil) - (if (and (null |$insideFunctorIfTrue|) $lisplib) - (|compDefineLisplib| df mode env prefix fal '|compDefineCategory1|) - (|compDefineCategory1| df mode env prefix fal)))) - -\end{chunk} - -\defun{compDefineLisplib}{compDefineLisplib} -\calls{compDefineLisplib}{sayMSG} -\calls{compDefineLisplib}{fillerSpaces} -\calls{compDefineLisplib}{getConstructorAbbreviation} -\calls{compDefineLisplib}{compileDocumentation} -\calls{compDefineLisplib}{bright} -\calls{compDefineLisplib}{finalizeLisplib} -\calls{compDefineLisplib}{rshut} -\calls{compDefineLisplib}{lisplibDoRename} -\calls{compDefineLisplib}{filep} -\calls{compDefineLisplib}{rpackfile} -\calls{compDefineLisplib}{unloadOneConstructor} -\calls{compDefineLisplib}{localdatabase} -\calls{compDefineLisplib}{getdatabase} -\calls{compDefineLisplib}{updateCategoryFrameForCategory} -\calls{compDefineLisplib}{updateCategoryFrameForConstructor} -\refsdollar{compDefineLisplib}{compileDocumentation} -\refsdollar{compDefineLisplib}{filep} -\refsdollar{compDefineLisplib}{spadLibFT} -\refsdollar{compDefineLisplib}{algebraOutputStream} -\refsdollar{compDefineLisplib}{newConlist} -\refsdollar{compDefineLisplib}{lisplibKind} -\defsdollar{compDefineLisplib}{lisplib} -\defsdollar{compDefineLisplib}{op} -\defsdollar{compDefineLisplib}{lisplibParents} -\defsdollar{compDefineLisplib}{lisplibPredicates} -\defsdollar{compDefineLisplib}{lisplibCategoriesExtended} -\defsdollar{compDefineLisplib}{lisplibForm} -\defsdollar{compDefineLisplib}{lisplibKind} -\defsdollar{compDefineLisplib}{lisplibAbbreviation} -\defsdollar{compDefineLisplib}{lisplibAncestors} -\defsdollar{compDefineLisplib}{lisplibModemap} -\defsdollar{compDefineLisplib}{lisplibModemapAlist} -\defsdollar{compDefineLisplib}{lisplibSlot1} -\defsdollar{compDefineLisplib}{lisplibOperationAlist} -\defsdollar{compDefineLisplib}{lisplibSuperDomain} -\defsdollar{compDefineLisplib}{libFile} -\defsdollar{compDefineLisplib}{lisplibVariableAlist} -\defsdollar{compDefineLisplib}{lisplibCategory} -\defsdollar{compDefineLisplib}{newConlist} -\begin{chunk}{defun compDefineLisplib} -(defun |compDefineLisplib| (df m env prefix fal fn) - (let ($LISPLIB |$op| |$lisplibAttributes| |$lisplibPredicates| - |$lisplibCategoriesExtended| |$lisplibForm| |$lisplibKind| - |$lisplibAbbreviation| |$lisplibParents| |$lisplibAncestors| - |$lisplibModemap| |$lisplibModemapAlist| |$lisplibSlot1| - |$lisplibOperationAlist| |$lisplibSuperDomain| |$libFile| - |$lisplibVariableAlist| |$lisplibCategory| op libname res ok filearg) - (declare (special $lisplib |$op| |$lisplibAttributes| |$newConlist| - |$lisplibPredicates| |$lisplibCategoriesExtended| - |$lisplibForm| |$lisplibKind| |$algebraOutputStream| - |$lisplibAbbreviation| |$lisplibParents| |$spadLibFT| - |$lisplibAncestors| |$lisplibModemap| $filep - |$lisplibModemapAlist| |$lisplibSlot1| - |$lisplibOperationAlist| |$lisplibSuperDomain| - |$libFile| |$lisplibVariableAlist| - |$lisplibCategory| |$compileDocumentation|)) - (when (eq (car df) 'def) (car df)) - (setq op (caadr df)) - (|sayMSG| (|fillerSpaces| 72 "-")) - (setq $lisplib t) - (setq |$op| op) - (setq |$lisplibAttributes| nil) - (setq |$lisplibPredicates| nil) - (setq |$lisplibCategoriesExtended| nil) - (setq |$lisplibForm| nil) - (setq |$lisplibKind| nil) - (setq |$lisplibAbbreviation| nil) - (setq |$lisplibParents| nil) - (setq |$lisplibAncestors| nil) - (setq |$lisplibModemap| nil) - (setq |$lisplibModemapAlist| nil) - (setq |$lisplibSlot1| nil) - (setq |$lisplibOperationAlist| nil) - (setq |$lisplibSuperDomain| nil) - (setq |$libFile| nil) - (setq |$lisplibVariableAlist| nil) - (setq |$lisplibCategory| nil) - (setq libname (|getConstructorAbbreviation| op)) - (cond - ((and (boundp '|$compileDocumentation|) |$compileDocumentation|) - (|compileDocumentation| libname)) - (t - (|sayMSG| (cons " initializing " (cons |$spadLibFT| - (append (|bright| libname) (cons "for" (|bright| op)))))) - (|initializeLisplib| libname) - (|sayMSG| - (cons " compiling into " (cons |$spadLibFT| (|bright| libname)))) - (setq ok nil) - (unwind-protect - (progn - (setq res (funcall fn df m env prefix fal)) - (|sayMSG| (cons " finalizing " (cons |$spadLibFT| (|bright| libname)))) - (|finalizeLisplib| libname) - (setq ok t)) - (rshut |$libFile|)) - (when ok (|lisplibDoRename| libname)) - (setq filearg ($filep libname |$spadLibFT| 'a)) - (rpackfile filearg) - (fresh-line |$algebraOutputStream|) - (|sayMSG| (|fillerSpaces| 72 "-")) - (|unloadOneConstructor| op libname) - (localdatabase (list (getdatabase op 'abbreviation)) nil) - (setq |$newConlist| (cons op |$newConlist|)) - (when (eq |$lisplibKind| '|category|) - (|updateCategoryFrameForCategory| op) - (|updateCategoryFrameForConstructor| op)) - res)))) - -\end{chunk} - -\defun{unloadOneConstructor}{unloadOneConstructor} -\calls{unloadOneConstructor}{remprop} -\calls{unloadOneConstructor}{mkAutoLoad} -\begin{chunk}{defun unloadOneConstructor} -(defun |unloadOneConstructor| (cnam fn) - (remprop cnam 'loaded) - (setf (symbol-function cnam) (|mkAutoLoad| fn cnam))) - -\end{chunk} - -\defun{compileDocumentation}{compileDocumentation} -\calls{compileDocumentation}{make-input-filename} -\calls{compileDocumentation}{rdefiostream} -\calls{compileDocumentation}{lisplibWrite} -\calls{compileDocumentation}{finalizeDocumentation} -\calls{compileDocumentation}{rshut} -\calls{compileDocumentation}{rpackfile} -\calls{compileDocumentation}{replaceFile} -\refsdollar{compileDocumentation}{fcopy} -\refsdollar{compileDocumentation}{spadLibFT} -\refsdollar{compileDocumentation}{EmptyMode} -\refsdollar{compileDocumentation}{e} -\begin{chunk}{defun compileDocumentation} -(defun |compileDocumentation| (libName) - (let (filename stream) - (declare (special |$e| |$EmptyMode| |$spadLibFT| $fcopy)) - (setq filename (make-input-filename libName |$spadLibFT|)) - ($fcopy filename (cons libname (list 'doclb))) - (setq stream - (rdefiostream (cons (list 'file libName 'doclb) (list (cons 'mode 'o))))) - (|lisplibWrite| "documentation" (|finalizeDocumentation|) stream) - (rshut stream) - (rpackfile (list libName 'doclb)) - (replaceFile (list libName |$spadLibFT|) (list libName 'doclb)) - (list '|dummy| |$EmptyMode| |$e|))) - -\end{chunk} - -\defun{lisplibDoRename}{lisplibDoRename} -\calls{lisplibDoRename}{replaceFile} -\refsdollar{lisplibDoRename}{spadLibFT} -\begin{chunk}{defun lisplibDoRename} -(defun |lisplibDoRename| (libName) - (declare (special |$spadLibFT|)) - (replaceFile (list libName |$spadLibFT| 'a) (list libName 'errorlib 'a))) - -\end{chunk} - -\defun{initializeLisplib}{initializeLisplib} -\calls{initializeLisplib}{erase} -\calls{initializeLisplib}{writeLib1} -\calls{initializeLisplib}{addoptions} -\calls{initializeLisplib}{pathnameTypeId} -\calls{initializeLisplib}{LAM,FILEACTQ} -\refsdollar{initializeLisplib}{erase} -\refsdollar{initializeLisplib}{libFile} -\defsdollar{initializeLisplib}{libFile} -\defsdollar{initializeLisplib}{lisplibForm} -\defsdollar{initializeLisplib}{lisplibModemap} -\defsdollar{initializeLisplib}{lisplibKind} -\defsdollar{initializeLisplib}{lisplibModemapAlist} -\defsdollar{initializeLisplib}{lisplibAbbreviation} -\defsdollar{initializeLisplib}{lisplibAncestors} -\defsdollar{initializeLisplib}{lisplibOpAlist} -\defsdollar{initializeLisplib}{lisplibOperationAlist} -\defsdollar{initializeLisplib}{lisplibSuperDomain} -\defsdollar{initializeLisplib}{lisplibVariableAlist} -\defsdollar{initializeLisplib}{lisplibSignatureAlist} -\uses{initializeLisplib}{/editfile} -\uses{initializeLisplib}{/major-version} -\uses{initializeLisplib}{errors} -\begin{chunk}{defun initializeLisplib} -(defun |initializeLisplib| (libName) - (declare (special $erase |$libFile| |$lisplibForm| - |$lisplibModemap| |$lisplibKind| |$lisplibModemapAlist| - |$lisplibAbbreviation| |$lisplibAncestors| - |$lisplibOpAlist| |$lisplibOperationAlist| - |$lisplibSuperDomain| |$lisplibVariableAlist| errors - |$lisplibSignatureAlist| /editfile /major-version errors)) - ($erase libName 'errorlib 'a) - (setq errors 0) - (setq |$libFile| (|writeLib1| libname 'errorlib 'a)) - (addoptions 'file |$libFile|) - (setq |$lisplibForm| nil) - (setq |$lisplibModemap| nil) - (setq |$lisplibKind| nil) - (setq |$lisplibModemapAlist| nil) - (setq |$lisplibAbbreviation| nil) - (setq |$lisplibAncestors| nil) - (setq |$lisplibOpAlist| nil) - (setq |$lisplibOperationAlist| nil) - (setq |$lisplibSuperDomain| nil) - (setq |$lisplibVariableAlist| nil) - (setq |$lisplibSignatureAlist| nil) - (when (eq (|pathnameTypeId| /editfile) 'spad) - (|LAM,FILEACTQ| 'version (list '/versioncheck /major-version)))) - -\end{chunk} - -\defun{writeLib1}{writeLib1} -\calls{writeLib1}{rdefiostream} -\begin{chunk}{defun writeLib1} -(defun |writeLib1| (fn ft fm) - (rdefiostream (cons (list 'file fn ft fm) (list '(mode . output))))) - -\end{chunk} - - -\defun{finalizeLisplib}{finalizeLisplib} -\calls{finalizeLisplib}{lisplibWrite} -\calls{finalizeLisplib}{removeZeroOne} -\calls{finalizeLisplib}{namestring} -\calls{finalizeLisplib}{getConstructorOpsAndAtts} -\calls{finalizeLisplib}{NRTgenInitialAttributeAlist} -\calls{finalizeLisplib}{mergeSignatureAndLocalVarAlists} -\calls{finalizeLisplib}{finalizeDocumentation} -\calls{finalizeLisplib}{profileWrite} -\calls{finalizeLisplib}{sayMSG} -\refsdollar{finalizeLisplib}{lisplibForm} -\refsdollar{finalizeLisplib}{libFile} -\refsdollar{finalizeLisplib}{lisplibKind} -\refsdollar{finalizeLisplib}{lisplibModemap} -\refsdollar{finalizeLisplib}{lisplibCategory} -\refsdollar{finalizeLisplib}{/editfile} -\refsdollar{finalizeLisplib}{lisplibModemapAlist} -\refsdollar{finalizeLisplib}{lisplibForm} -\refsdollar{finalizeLisplib}{lisplibModemap} -\refsdollar{finalizeLisplib}{FormalMapVariableList} -\refsdollar{finalizeLisplib}{lisplibSuperDomain} -\refsdollar{finalizeLisplib}{lisplibSignatureAlist} -\refsdollar{finalizeLisplib}{lisplibVariableAlist} -\refsdollar{finalizeLisplib}{lisplibAttributes} -\refsdollar{finalizeLisplib}{lisplibPredicates} -\refsdollar{finalizeLisplib}{lisplibAbbreviation} -\refsdollar{finalizeLisplib}{lisplibParents} -\refsdollar{finalizeLisplib}{lisplibAncestors} -\refsdollar{finalizeLisplib}{lisplibSlot1} -\refsdollar{finalizeLisplib}{profileCompiler} -\refsdollar{finalizeLisplib}{spadLibFT} -\defsdollar{finalizeLisplib}{lisplibCategory} -\defsdollar{finalizeLisplib}{pairlis} -\defsdollar{finalizeLisplib}{NRTslot1PredicateList} -\begin{chunk}{defun finalizeLisplib} -(defun |finalizeLisplib| (libName) - (let (|$pairlis| |$NRTslot1PredicateList| kind opsAndAtts) - (declare (special |$pairlis| |$NRTslot1PredicateList| |$spadLibFT| - |$lisplibForm| |$profileCompiler| |$libFile| - |$lisplibSlot1| |$lisplibAncestors| |$lisplibParents| - |$lisplibAbbreviation| |$lisplibPredicates| - |$lisplibAttributes| |$lisplibVariableAlist| - |$lisplibSignatureAlist| |$lisplibSuperDomain| - |$FormalMapVariableList| |$lisplibModemap| - |$lisplibModemapAlist| /editfile |$lisplibCategory| - |$lisplibKind| errors)) - (|lisplibWrite| "constructorForm" - (|removeZeroOne| |$lisplibForm|) |$libFile|) - (|lisplibWrite| "constructorKind" - (setq kind (|removeZeroOne| |$lisplibKind|)) |$libFile|) - (|lisplibWrite| "constructorModemap" - (|removeZeroOne| |$lisplibModemap|) |$libFile|) - (setq |$lisplibCategory| (or |$lisplibCategory| (cadar |$lisplibModemap|))) - (|lisplibWrite| "constructorCategory" |$lisplibCategory| |$libFile|) - (|lisplibWrite| "sourceFile" (|namestring| /editfile) |$libFile|) - (|lisplibWrite| "modemaps" - (|removeZeroOne| |$lisplibModemapAlist|) |$libFile|) - (setq opsAndAtts - (|getConstructorOpsAndAtts| |$lisplibForm| kind |$lisplibModemap|)) - (|lisplibWrite| "operationAlist" - (|removeZeroOne| (car opsAndAtts)) |$libFile|) - (when (eq kind '|category|) - (setq |$pairlis| - (loop for a in (rest |$lisplibForm|) - for v in |$FormalMapVariableList| - collect (cons a v))) - (setq |$NRTslot1PredicateList| nil) - (|NRTgenInitialAttributeAlist| (cdr opsAndAtts))) - (|lisplibWrite| "superDomain" - (|removeZeroOne| |$lisplibSuperDomain|) |$libFile|) - (|lisplibWrite| "signaturesAndLocals" - (|removeZeroOne| - (|mergeSignatureAndLocalVarAlists| |$lisplibSignatureAlist| - |$lisplibVariableAlist|)) - |$libFile|) - (|lisplibWrite| "attributes" - (|removeZeroOne| |$lisplibAttributes|) |$libFile|) - (|lisplibWrite| "predicates" - (|removeZeroOne| |$lisplibPredicates|) |$libFile|) - (|lisplibWrite| "abbreviation" |$lisplibAbbreviation| |$libFile|) - (|lisplibWrite| "parents" (|removeZeroOne| |$lisplibParents|) |$libFile|) - (|lisplibWrite| "ancestors" (|removeZeroOne| |$lisplibAncestors|) |$libFile|) - (|lisplibWrite| "documentation" (|finalizeDocumentation|) |$libFile|) - (|lisplibWrite| "slot1Info" (|removeZeroOne| |$lisplibSlot1|) |$libFile|) - (when |$profileCompiler| (|profileWrite|)) - (when (and |$lisplibForm| (null (cdr |$lisplibForm|))) - (setf (get (car |$lisplibForm|) 'niladic) t)) - (unless (eql errors 0) - (|sayMSG| (list " Errors in processing " kind " " libName ":")) - (|sayMSG| (list " not replacing " |$spadLibFT| " for" libName))))) - -\end{chunk} - -\defun{getConstructorOpsAndAtts}{getConstructorOpsAndAtts} -\calls{getConstructorOpsAndAtts}{getCategoryOpsAndAtts} -\calls{getConstructorOpsAndAtts}{getFunctorOpsAndAtts} -\begin{chunk}{defun getConstructorOpsAndAtts} -(defun |getConstructorOpsAndAtts| (form kind modemap) - (if (eq kind '|category|) - (|getCategoryOpsAndAtts| form) - (|getFunctorOpsAndAtts| form modemap))) - -\end{chunk} - -\defun{getCategoryOpsAndAtts}{getCategoryOpsAndAtts} -\calls{getCategoryOpsAndAtts}{transformOperationAlist} -\calls{getCategoryOpsAndAtts}{getSlotFromCategoryForm} -\calls{getCategoryOpsAndAtts}{getSlotFromCategoryForm} -\begin{chunk}{defun getCategoryOpsAndAtts} -(defun |getCategoryOpsAndAtts| (catForm) - (cons (|transformOperationAlist| (|getSlotFromCategoryForm| catForm 1)) - (|getSlotFromCategoryForm| catForm 2))) - -\end{chunk} - -\defun{getSlotFromCategoryForm}{getSlotFromCategoryForm} -\calls{getSlotFromCategoryForm}{eval} -\calls{getSlotFromCategoryForm}{take} -\calls{getSlotFromCategoryForm}{systemErrorHere} -\refsdollar{getSlotFromCategoryForm}{FormalMapVariableList} -\begin{chunk}{defun getSlotFromCategoryForm} -(defun |getSlotFromCategoryForm| (opargs index) - (let (op argl u) - (declare (special |$FormalMapVariableList|)) - (setq op (first opargs)) - (setq argl (rest opargs)) - (setq u - (|eval| (cons op (mapcar 'mkq (take (|#| argl) |$FormalMapVariableList|))))) - (if (null (vecp u)) - (|systemErrorHere| "getSlotFromCategoryForm") - (elt u index)))) - -\end{chunk} - -\defun{transformOperationAlist}{transformOperationAlist} -This transforms the operationAlist which is written out onto LISPLIBs. -The original form of this list is a list of items of the form: -\begin{verbatim} - (( ) ( (ELT $ n))) -\end{verbatim} -The new form is an op-Alist which has entries -\begin{verbatim} - ( . signature-Alist) -\end{verbatim} -where signature-Alist has entries -\begin{verbatim} - ( . item) -\end{verbatim} -where item has form -\begin{verbatim} - ( ) -\end{verbatim} -\begin{verbatim} - where = - NIL => function - CONST => constant ... and others -\end{verbatim} -\calls{transformOperationAlist}{member} -\calls{transformOperationAlist}{keyedSystemError} -\calls{transformOperationAlist}{assoc} -\calls{transformOperationAlist}{lassq} -\calls{transformOperationAlist}{insertAlist} -\refsdollar{transformOperationAlist}{functionLocations} -\begin{chunk}{defun transformOperationAlist} -(defun |transformOperationAlist| (operationAlist) - (let (op sig condition implementation eltEtc impOp kind u n signatureItem - itemList newAlist) - (declare (special |$functionLocations|)) - (setq newAlist nil) - (dolist (item operationAlist) - (setq op (caar item)) - (setq sig (cadar item)) - (setq condition (cadr item)) - (setq implementation (caddr item)) - (setq kind - (cond - ((and (consp implementation) (consp (qrest implementation)) - (consp (qcddr implementation)) - (eq (qcdddr implementation) nil) - (progn (setq n (qthird implementation)) t) - (|member| (setq eltEtc (qfirst implementation)) '(const elt))) - eltEtc) - ((consp implementation) - (setq impOp (qfirst implementation)) - (cond - ((eq impop 'xlam) implementation) - ((|member| impOp '(const |Subsumed|)) impOp) - (t (|keyedSystemError| 's2il0025 (list impop))))) - ((eq implementation '|mkRecord|) '|mkRecord|) - (t (|keyedSystemError| 's2il0025 (list implementation))))) - (when (setq u (|assoc| (list op sig) |$functionLocations|)) - (setq n (cons n (cdr u)))) - (setq signatureItem - (if (eq kind 'elt) - (if (eq condition t) - (list sig n) - (list sig n condition)) - (list sig n condition kind))) - (setq itemList (cons signatureItem (lassq op newAlist))) - (setq newAlist (|insertAlist| op itemList newAlist))) - newAlist)) - -\end{chunk} - -\defun{getFunctorOpsAndAtts}{getFunctorOpsAndAtts} -\calls{getFunctorOpsAndAtts}{transformOperationAlist} -\calls{getFunctorOpsAndAtts}{getSlotFromFunctor} -\begin{chunk}{defun getFunctorOpsAndAtts} -(defun |getFunctorOpsAndAtts| (form modemap) - (cons (|transformOperationAlist| (|getSlotFromFunctor| form 1 modemap)) - (|getSlotFromFunctor| form 2 modemap))) - -\end{chunk} - -\defun{getSlotFromFunctor}{getSlotFromFunctor} -\calls{getSlotFromFunctor}{compMakeCategoryObject} -\calls{getSlotFromFunctor}{systemErrorHere} -\refsdollar{getSlotFromFunctor}{e} -\refsdollar{getSlotFromFunctor}{lisplibOperationAlist} -\begin{chunk}{defun getSlotFromFunctor} -(defun |getSlotFromFunctor| (arg1 slot arg2) - (declare (ignore arg1)) - (let (tt) - (declare (special |$e| |$lisplibOperationAlist|)) - (cond - ((eql slot 1) |$lisplibOperationAlist|) - (t - (setq tt (or (|compMakeCategoryObject| (cadar arg2) |$e|) - (|systemErrorHere| "getSlotFromFunctor"))) - (elt (car tt) slot))))) - -\end{chunk} - -\defun{compMakeCategoryObject}{compMakeCategoryObject} -\calls{compMakeCategoryObject}{isCategoryForm} -\calls{compMakeCategoryObject}{mkEvalableCategoryForm} -\refsdollar{compMakeCategoryObject}{e} -\refsdollar{compMakeCategoryObject}{Category} -\begin{chunk}{defun compMakeCategoryObject} -(defun |compMakeCategoryObject| (c |$e|) - (declare (special |$e|)) - (let (u) - (declare (special |$Category|)) - (cond - ((null (|isCategoryForm| c |$e|)) nil) - ((setq u (|mkEvalableCategoryForm| c)) (list (|eval| u) |$Category| |$e|)) - (t nil)))) - -\end{chunk} - -\defun{mergeSignatureAndLocalVarAlists}{mergeSignatureAndLocalVarAlists} -\calls{mergeSignatureAndLocalVarAlists}{lassoc} -\begin{chunk}{defun mergeSignatureAndLocalVarAlists} -(defun |mergeSignatureAndLocalVarAlists| (signatureAlist localVarAlist) - (loop for item in signatureAlist - collect - (cons (first item) - (cons (rest item) - (lassoc (first item) localVarAlist))))) - -\end{chunk} - -\defun{lisplibWrite}{lisplibWrite} -\calls{lisplibWrite}{rwrite128} -\refsdollar{lisplibWrite}{lisplib} -\begin{chunk}{defun lisplibWrite} -(defun |lisplibWrite| (prop val filename) - (declare (special $lisplib)) - (when $lisplib (|rwrite| prop val filename))) - -\end{chunk} - -\defun{compDefineFunctor}{compDefineFunctor} -\calls{compDefineFunctor}{compDefineLisplib} -\calls{compDefineFunctor}{compDefineFunctor1} -\usesdollar{compDefineFunctor}{domainShell} -\usesdollar{compDefineFunctor}{profileCompiler} -\usesdollar{compDefineFunctor}{lisplib} -\usesdollar{compDefineFunctor}{profileAlist} -\begin{chunk}{defun compDefineFunctor} -(defun |compDefineFunctor| (df mode env prefix fal) - (let (|$domainShell| |$profileCompiler| |$profileAlist|) - (declare (special |$domainShell| |$profileCompiler| $lisplib |$profileAlist|)) - (setq |$domainShell| nil) - (setq |$profileCompiler| t) - (setq |$profileAlist| nil) - (if $lisplib - (|compDefineLisplib| df mode env prefix fal '|compDefineFunctor1|) - (|compDefineFunctor1| df mode env prefix fal)))) - -\end{chunk} - -\defun{compDefineFunctor1}{compDefineFunctor1} -\calls{compDefineFunctor1}{isCategoryPackageName} -\calls{compDefineFunctor1}{getArgumentModeOrMoan} -\calls{compDefineFunctor1}{getModemap} -\calls{compDefineFunctor1}{giveFormalParametersValues} -\calls{compDefineFunctor1}{compMakeCategoryObject} -\calls{compDefineFunctor1}{sayBrightly} -\calls{compDefineFunctor1}{pp} -\calls{compDefineFunctor1}{strconc} -\calls{compDefineFunctor1}{pname} -\calls{compDefineFunctor1}{disallowNilAttribute} -\calls{compDefineFunctor1}{remdup} -\calls{compDefineFunctor1}{NRTgenInitialAttributeAlist} -\calls{compDefineFunctor1}{NRTgetLocalIndex} -\calls{compDefineFunctor1}{compMakeDeclaration} -\calls{compDefineFunctor1}{qcar} -\calls{compDefineFunctor1}{qcdr} -\calls{compDefineFunctor1}{augModemapsFromCategoryRep} -\calls{compDefineFunctor1}{augModemapsFromCategory} -\calls{compDefineFunctor1}{sublis} -\calls{compDefineFunctor1}{maxindex} -\calls{compDefineFunctor1}{makeFunctorArgumentParameters} -\calls{compDefineFunctor1}{compFunctorBody} -\calls{compDefineFunctor1}{reportOnFunctorCompilation} -\calls{compDefineFunctor1}{compile} -\calls{compDefineFunctor1}{augmentLisplibModemapsFromFunctor} -\calls{compDefineFunctor1}{reportOnFunctorCompilation} -\calls{compDefineFunctor1}{getParentsFor} -\calls{compDefineFunctor1}{computeAncestorsOf} -\calls{compDefineFunctor1}{constructor?} -\calls{compDefineFunctor1}{NRTmakeSlot1Info} -\calls{compDefineFunctor1}{isCategoryPackageName} -\calls{compDefineFunctor1}{lisplibWrite} -\calls{compDefineFunctor1}{mkq} -\calls{compDefineFunctor1}{getdatabase} -\calls{compDefineFunctor1}{NRTgetLookupFunction} -\calls{compDefineFunctor1}{simpBool} -\calls{compDefineFunctor1}{removeZeroOne} -\calls{compDefineFunctor1}{evalAndRwriteLispForm} -\usesdollar{compDefineFunctor1}{lisplib} -\usesdollar{compDefineFunctor1}{top-level} -\usesdollar{compDefineFunctor1}{bootStrapMode} -\usesdollar{compDefineFunctor1}{CategoryFrame} -\usesdollar{compDefineFunctor1}{CheckVectorList} -\usesdollar{compDefineFunctor1}{FormalMapVariableList} -\usesdollar{compDefineFunctor1}{LocalDomainAlist} -\usesdollar{compDefineFunctor1}{NRTaddForm} -\usesdollar{compDefineFunctor1}{NRTaddList} -\usesdollar{compDefineFunctor1}{NRTattributeAlist} -\usesdollar{compDefineFunctor1}{NRTbase} -\usesdollar{compDefineFunctor1}{NRTdeltaLength} -\usesdollar{compDefineFunctor1}{NRTdeltaListComp} -\usesdollar{compDefineFunctor1}{NRTdeltaList} -\usesdollar{compDefineFunctor1}{NRTdomainFormList} -\usesdollar{compDefineFunctor1}{NRTloadTimeAlist} -\usesdollar{compDefineFunctor1}{NRTslot1Info} -\usesdollar{compDefineFunctor1}{NRTslot1PredicateList} -\usesdollar{compDefineFunctor1}{Representation} -\usesdollar{compDefineFunctor1}{addForm} -\usesdollar{compDefineFunctor1}{attributesName} -\usesdollar{compDefineFunctor1}{byteAddress} -\usesdollar{compDefineFunctor1}{byteVec} -\usesdollar{compDefineFunctor1}{compileOnlyCertainItems} -\usesdollar{compDefineFunctor1}{condAlist} -\usesdollar{compDefineFunctor1}{domainShell} -\usesdollar{compDefineFunctor1}{form} -\usesdollar{compDefineFunctor1}{functionLocations} -\usesdollar{compDefineFunctor1}{functionStats} -\usesdollar{compDefineFunctor1}{functorForm} -\usesdollar{compDefineFunctor1}{functorLocalParameters} -\usesdollar{compDefineFunctor1}{functorStats} -\usesdollar{compDefineFunctor1}{functorSpecialCases} -\usesdollar{compDefineFunctor1}{functorTarget} -\usesdollar{compDefineFunctor1}{functorsUsed} -\usesdollar{compDefineFunctor1}{genFVar} -\usesdollar{compDefineFunctor1}{genSDVar} -\usesdollar{compDefineFunctor1}{getDomainCode} -\usesdollar{compDefineFunctor1}{goGetList} -\usesdollar{compDefineFunctor1}{insideCategoryPackageIfTrue} -\usesdollar{compDefineFunctor1}{insideFunctorIfTrue} -\usesdollar{compDefineFunctor1}{isOpPackageName} -\usesdollar{compDefineFunctor1}{libFile} -\usesdollar{compDefineFunctor1}{lisplibAbbreviation} -\usesdollar{compDefineFunctor1}{lisplibAncestors} -\usesdollar{compDefineFunctor1}{lisplibCategoriesExtended} -\usesdollar{compDefineFunctor1}{lisplibCategory} -\usesdollar{compDefineFunctor1}{lisplibForm} -\usesdollar{compDefineFunctor1}{lisplibKind} -\usesdollar{compDefineFunctor1}{lisplibMissingFunctions} -\usesdollar{compDefineFunctor1}{lisplibModemap} -\usesdollar{compDefineFunctor1}{lisplibOperationAlist} -\usesdollar{compDefineFunctor1}{lisplibParents} -\usesdollar{compDefineFunctor1}{lisplibSlot1} -\usesdollar{compDefineFunctor1}{lookupFunction} -\usesdollar{compDefineFunctor1}{myFunctorBody} -\usesdollar{compDefineFunctor1}{mutableDomain} -\usesdollar{compDefineFunctor1}{mutableDomains} -\usesdollar{compDefineFunctor1}{op} -\usesdollar{compDefineFunctor1}{pairlis} -\usesdollar{compDefineFunctor1}{QuickCode} -\usesdollar{compDefineFunctor1}{setelt} -\usesdollar{compDefineFunctor1}{signature} -\usesdollar{compDefineFunctor1}{template} -\usesdollar{compDefineFunctor1}{uncondAlist} -\usesdollar{compDefineFunctor1}{viewNames} -\usesdollar{compDefineFunctor1}{lisplibFunctionLocations} -\begin{chunk}{defun compDefineFunctor1} -(defun |compDefineFunctor1| (df mode |$e| |$prefix| |$formalArgList|) - (declare (special |$e| |$prefix| |$formalArgList|)) - (labels ( - (FindRep (cb) - (loop while cb do - (when (atom cb) (return nil)) - (when (and (consp cb) (consp (qfirst cb)) (eq (qcaar cb) 'let) - (consp (qcdar cb)) (eq (qcadar cb) '|Rep|) - (consp (qcddar cb))) - (return (caddar cb))) - (pop cb)))) - (let (|$addForm| |$viewNames| |$functionStats| |$functorStats| - |$form| |$op| |$signature| |$functorTarget| - |$Representation| |$LocalDomainAlist| |$functorForm| - |$functorLocalParameters| |$CheckVectorList| - |$getDomainCode| |$insideFunctorIfTrue| |$functorsUsed| - |$setelt| $TOP_LEVEL |$genFVar| |$genSDVar| - |$mutableDomain| |$attributesName| |$goGetList| - |$condAlist| |$uncondAlist| |$NRTslot1PredicateList| - |$NRTattributeAlist| |$NRTslot1Info| |$NRTbase| - |$NRTaddForm| |$NRTdeltaList| |$NRTdeltaListComp| - |$NRTaddList| |$NRTdeltaLength| |$NRTloadTimeAlist| - |$NRTdomainFormList| |$template| |$functionLocations| - |$isOpPackageName| |$lookupFunction| |$byteAddress| - |$byteVec| form signature body originale argl signaturep target ds - attributeList parSignature parForm - argPars opp rettype tt bodyp lamOrSlam fun - operationAlist modemap libFn tmp1) - (declare (special $lisplib $top_level |$bootStrapMode| |$CategoryFrame| - |$CheckVectorList| |$FormalMapVariableList| - |$LocalDomainAlist| |$NRTaddForm| |$NRTaddList| - |$NRTattributeAlist| |$NRTbase| |$NRTdeltaLength| - |$NRTdeltaListComp| |$NRTdeltaList| |$NRTdomainFormList| - |$NRTloadTimeAlist| |$NRTslot1Info| |$NRTslot1PredicateList| - |$Representation| |$addForm| |$attributesName| - |$byteAddress| |$byteVec| |$compileOnlyCertainItems| - |$condAlist| |$domainShell| |$form| |$functionLocations| - |$functionStats| |$functorForm| |$functorLocalParameters| - |$functorStats| |$functorSpecialCases| |$functorTarget| - |$functorsUsed| |$genFVar| |$genSDVar| |$getDomainCode| - |$goGetList| |$insideCategoryPackageIfTrue| - |$insideFunctorIfTrue| |$isOpPackageName| |$libFile| - |$lisplibAbbreviation| |$lisplibAncestors| - |$lisplibCategoriesExtended| |$lisplibCategory| - |$lisplibForm| |$lisplibKind| |$lisplibMissingFunctions| - |$lisplibModemap| |$lisplibOperationAlist| |$lisplibParents| - |$lisplibSlot1| |$lookupFunction| |$myFunctorBody| - |$mutableDomain| |$mutableDomains| |$op| |$pairlis| - |$QuickCode| |$setelt| |$signature| |$template| - |$uncondAlist| |$viewNames| |$lisplibFunctionLocations|)) - (setq form (second df)) - (setq signature (third df)) - (setq |$functorSpecialCases| (fourth df)) - (setq body (fifth df)) - (setq |$addForm| nil) - (setq |$viewNames| nil) - (setq |$functionStats| (list 0 0)) - (setq |$functorStats| (list 0 0)) - (setq |$form| nil) - (setq |$op| nil) - (setq |$signature| nil) - (setq |$functorTarget| nil) - (setq |$Representation| nil) - (setq |$LocalDomainAlist| nil) - (setq |$functorForm| nil) - (setq |$functorLocalParameters| nil) - (setq |$myFunctorBody| body) - (setq |$CheckVectorList| nil) - (setq |$getDomainCode| nil) - (setq |$insideFunctorIfTrue| t) - (setq |$functorsUsed| nil) - (setq |$setelt| (if |$QuickCode| 'qsetrefv 'setelt)) - (setq $top_level nil) - (setq |$genFVar| 0) - (setq |$genSDVar| 0) - (setq originale |$e|) - (setq |$op| (first form)) - (setq argl (rest form)) - (setq |$formalArgList| (append argl |$formalArgList|)) - (setq |$pairlis| - (loop for a in argl for v in |$FormalMapVariableList| - collect (cons a v))) - (setq |$mutableDomain| - (OR (|isCategoryPackageName| |$op|) - (COND - ((boundp '|$mutableDomains|) - (member |$op| |$mutableDomains|)) - ('T NIL)))) - (setq signaturep - (cons (car signature) - (loop for a in argl collect (|getArgumentModeOrMoan| a form |$e|)))) - (setq |$form| (cons |$op| argl)) - (setq |$functorForm| |$form|) - (unless (car signaturep) - (setq signaturep (cdar (|getModemap| |$form| |$e|)))) - (setq target (first signaturep)) - (setq |$functorTarget| target) - (setq |$e| (|giveFormalParametersValues| argl |$e|)) - (setq tmp1 (|compMakeCategoryObject| target |$e|)) - (if tmp1 - (progn - (setq ds (first tmp1)) - (setq |$e| (third tmp1)) - (setq |$domainShell| (copy-seq ds)) - (setq |$attributesName| (intern (strconc (pname |$op|) ";attributes"))) - (setq attributeList (|disallowNilAttribute| (elt ds 2))) - (setq |$goGetList| nil) - (setq |$condAlist| nil) - (setq |$uncondAlist| nil) - (setq |$NRTslot1PredicateList| - (remdup (loop for x in attributeList collect (second x)))) - (setq |$NRTattributeAlist| (|NRTgenInitialAttributeAlist| attributeList)) - (setq |$NRTslot1Info| nil) - (setq |$NRTbase| 6) - (setq |$NRTaddForm| nil) - (setq |$NRTdeltaList| nil) - (setq |$NRTdeltaListComp| nil) - (setq |$NRTaddList| nil) - (setq |$NRTdeltaLength| 0) - (setq |$NRTloadTimeAlist| nil) - (setq |$NRTdomainFormList| nil) - (setq |$template| nil) - (setq |$functionLocations| nil) - (loop for x in argl do (|NRTgetLocalIndex| x)) - (setq |$e| - (third (|compMakeDeclaration| (list '|:| '$ target) mode |$e|))) - (unless |$insideCategoryPackageIfTrue| - (if - (and (consp body) (eq (qfirst body) '|add|) - (consp (qrest body)) - (consp (qsecond body)) - (consp (qcddr body)) - (eq (qcdddr body) nil) - (consp (qthird body)) - (eq (qcaaddr body) 'capsule) - (member (qcaadr body) '(|List| |Vector|)) - (equal (FindRep (qcdaddr body)) (second body))) - (setq |$e| (|augModemapsFromCategoryRep| '$ - (second body) (cdaddr body) target |$e|)) - (setq |$e| (|augModemapsFromCategory| '$ '$ target |$e|)))) - (setq |$signature| signaturep) - (setq operationAlist (sublis |$pairlis| (elt |$domainShell| 1))) - (setq parSignature (sublis |$pairlis| signaturep)) - (setq parForm (sublis |$pairlis| form)) - (setq argPars (|makeFunctorArgumentParameters| argl - (cdr signaturep) (car signaturep))) - (setq |$functorLocalParameters| argl) - (setq opp |$op|) - (setq rettype (CAR signaturep)) - (setq tt (|compFunctorBody| body rettype |$e| parForm)) - (cond - (|$compileOnlyCertainItems| - (|reportOnFunctorCompilation|) - (list nil (cons '|Mapping| signaturep) originale)) - (t - (setq bodyp (first tt)) - (setq lamOrSlam (if |$mutableDomain| 'lam 'spadslam)) - (setq fun - (|compile| (sublis |$pairlis| (list opp (list lamOrSlam argl bodyp))))) - (setq operationAlist (sublis |$pairlis| |$lisplibOperationAlist|)) - (cond - ($lisplib - (|augmentLisplibModemapsFromFunctor| parForm - operationAlist parSignature))) - (|reportOnFunctorCompilation|) - (cond - ($lisplib - (setq modemap (list (cons parForm parSignature) (list t opp))) - (setq |$lisplibModemap| modemap) - (setq |$lisplibCategory| (cadar modemap)) - (setq |$lisplibParents| - (|getParentsFor| |$op| |$FormalMapVariableList| |$lisplibCategory|)) - (setq |$lisplibAncestors| (|computeAncestorsOf| |$form| NIL)) - (setq |$lisplibAbbreviation| (|constructor?| |$op|)))) - (setq |$insideFunctorIfTrue| NIL) - (cond - ($lisplib - (setq |$lisplibKind| - (if (and (consp |$functorTarget|) - (eq (qfirst |$functorTarget|) 'category) - (consp (qrest |$functorTarget|)) - (not (eq (qsecond |$functorTarget|) '|domain|))) - '|package| - '|domain|)) - (setq |$lisplibForm| form) - (cond - ((null |$bootStrapMode|) - (setq |$NRTslot1Info| (|NRTmakeSlot1Info|)) - (setq |$isOpPackageName| (|isCategoryPackageName| |$op|)) - (when |$isOpPackageName| - (|lisplibWrite| "slot1DataBase" - (list '|updateSlot1DataBase| (mkq |$NRTslot1Info|)) - |$libFile|)) - (setq |$lisplibFunctionLocations| - (sublis |$pairlis| |$functionLocations|)) - (setq |$lisplibCategoriesExtended| - (sublis |$pairlis| |$lisplibCategoriesExtended|)) - (setq libFn (getdatabase opp 'abbreviation)) - (setq |$lookupFunction| - (|NRTgetLookupFunction| |$functorForm| - (cadar |$lisplibModemap|) |$NRTaddForm|)) - (setq |$byteAddress| 0) - (setq |$byteVec| NIL) - (setq |$NRTslot1PredicateList| - (loop for x in |$NRTslot1PredicateList| - collect (|simpBool| x))) - (|rwriteLispForm| '|loadTimeStuff| - `(setf (get ,(mkq |$op|) '|infovec|) ,(|getInfovecCode|))))) - (setq |$lisplibSlot1| |$NRTslot1Info|) - (setq |$lisplibOperationAlist| operationAlist) - (setq |$lisplibMissingFunctions| |$CheckVectorList|))) - (|lisplibWrite| "compilerInfo" - (|removeZeroOne| - (list 'setq '|$CategoryFrame| - (list '|put| (list 'quote opp) ''|isFunctor| - (list 'quote operationAlist) - (list '|addModemap| - (list 'quote opp) - (list 'quote parForm) - (list 'quote parSignature) - t - (list 'quote opp) - (list '|put| (list 'quote opp) ''|mode| - (list 'quote (cons '|Mapping| parSignature)) - '|$CategoryFrame|))))) - |$libFile|) - (unless argl - (|evalAndRwriteLispForm| 'niladic - `(setf (get ',opp 'niladic) t))) - (list fun (cons '|Mapping| signaturep) originale)))) - (progn - (|sayBrightly| " cannot produce category object:") - (|pp| target) - nil))))) + + +\defdollar{NoValueMode} +\begin{chunk}{initvars} +(defvar |$NoValueMode| '|NoValueMode|) \end{chunk} -\defun{isCategoryPackageName}{isCategoryPackageName} -\calls{isCategoryPackageName}{pname} -\calls{isCategoryPackageName}{maxindex} -\calls{isCategoryPackageName}{char} -\begin{chunk}{defun isCategoryPackageName} -(defun |isCategoryPackageName| (nam) - (let (p) - (setq p (pname (|opOf| nam))) - (equal (elt p (maxindex p)) (|char| '&)))) +\defdollar{EmptyMode} +\verb|$EmptyMode| is a contant whose value is \verb|$EmptyMode|. +It is used by isPartialMode to +decide if a modemap is partially constructed. If the \verb|$EmptyMode| +constant occurs anywhere in the modemap structure at any depth +then the modemap is still incomplete. To find this constant the +isPartialMode function calls CONTAINED \verb|$EmptyMode| $Y$ +which will walk the structure $Y$ looking for this constant. +\begin{chunk}{initvars} +(defvar |$EmptyMode| '|EmptyMode|) \end{chunk} -\defun{NRTgetLookupFunction}{NRTgetLookupFunction} -Compute the lookup function (complete or incomplete) -\calls{NRTgetLookupFunction}{sublis} -\calls{NRTgetLookupFunction}{NRTextendsCategory1} -\calls{NRTgetLookupFunction}{getExportCategory} -\calls{NRTgetLookupFunction}{sayBrightly} -\calls{NRTgetLookupFunction}{sayBrightlyNT} -\calls{NRTgetLookupFunction}{bright} -\calls{NRTgetLookupFunction}{form2String} -\defsdollar{NRTgetLookupFunction}{why} -\refsdollar{NRTgetLookupFunction}{why} -\refsdollar{NRTgetLookupFunction}{pairlis} -\begin{chunk}{defun NRTgetLookupFunction} -(defun |NRTgetLookupFunction| (domform exCategory addForm) - (let (|$why| extends u msg v) - (declare (special |$why| |$pairlis|)) - (setq domform (sublis |$pairlis| domform)) - (setq addForm (sublis |$pairlis| addForm)) - (setq |$why| nil) +\defun{hasFullSignature}{hasFullSignature} +\tpdhere{test with BASTYPE} +\calls{hasFullSignature}{get} +\begin{chunk}{defun hasFullSignature} +(defun |hasFullSignature| (argl signature env) + (let (target ml u) + (setq target (first signature)) + (setq ml (rest signature)) + (when target + (setq u + (loop for x in argl for m in ml + collect (or m (|get| x '|mode| env) (return 'failed)))) + (unless (eq u 'failed) (cons target u))))) + +\end{chunk} + +\defun{addEmptyCapsuleIfNecessary}{addEmptyCapsuleIfNecessary} +\calls{addEmptyCapsuleIfNecessary}{kar} +\usesdollar{addEmptyCapsuleIfNecessary}{SpecialDomainNames} +\begin{chunk}{defun addEmptyCapsuleIfNecessary} +(defun |addEmptyCapsuleIfNecessary| (target rhs) + (declare (special |$SpecialDomainNames|) (ignore target)) + (if (member (kar rhs) |$SpecialDomainNames|) + rhs + (list '|add| rhs (list 'capsule)))) + +\end{chunk} + +\defun{getTargetFromRhs}{getTargetFromRhs} +\calls{getTargetFromRhs}{stackSemanticError} +\calls{getTargetFromRhs}{getTargetFromRhs} +\calls{getTargetFromRhs}{compOrCroak} +\begin{chunk}{defun getTargetFromRhs} +(defun |getTargetFromRhs| (lhs rhs env) + (declare (special |$EmptyMode|)) (cond - ((atom addForm) '|lookupComplete|) - (t - (setq extends - (|NRTextendsCategory1| domform exCategory (|getExportCategory| addForm))) - (cond - ((null extends) - (setq u (car |$why|)) - (setq msg (cadr |$why|)) - (setq v (cddr |$why|)) - (|sayBrightly| - "--------------non extending category----------------------") - (|sayBrightlyNT| - (cons ".." - (append (|bright| (|form2String| domform)) (list '|of cat |)))) - (print u) - (|sayBrightlyNT| (|bright| msg)) - (if v (print (car v)) (terpri)))) - (if extends - '|lookupIncomplete| - '|lookupComplete|))))) + ((and (consp rhs) (eq (qfirst rhs) 'capsule)) + (|stackSemanticError| + (list "target category of " lhs + " cannot be determined from definition") + nil)) + ((and (consp rhs) (eq (qfirst rhs) '|SubDomain|) (consp (qrest rhs))) + (|getTargetFromRhs| lhs (second rhs) env)) + ((and (consp rhs) (eq (qfirst rhs) '|add|) + (consp (qrest rhs)) (consp (qcddr rhs)) + (eq (qcdddr rhs) nil) + (consp (qthird rhs)) + (eq (qcaaddr rhs) 'capsule)) + (|getTargetFromRhs| lhs (second rhs) env)) + ((and (consp rhs) (eq (qfirst rhs) '|Record|)) + (cons '|RecordCategory| (rest rhs))) + ((and (consp rhs) (eq (qfirst rhs) '|Union|)) + (cons '|UnionCategory| (rest rhs))) + ((and (consp rhs) (eq (qfirst rhs) '|List|)) + (cons '|ListCategory| (rest rhs))) + ((and (consp rhs) (eq (qfirst rhs) '|Vector|)) + (cons '|VectorCategory| (rest rhs))) + (t + (second (|compOrCroak| rhs |$EmptyMode| env))))) \end{chunk} -\defun{NRTgetLocalIndex}{NRTgetLocalIndex} -\calls{NRTgetLocalIndex}{NRTassocIndex} -\calls{NRTgetLocalIndex}{NRTaddInner} -\calls{NRTgetLocalIndex}{compOrCroak} -\calls{NRTgetLocalIndex}{rplaca} -\refsdollar{NRTgetLocalIndex}{NRTaddForm} -\refsdollar{NRTgetLocalIndex}{formalArgList} -\refsdollar{NRTgetLocalIndex}{NRTdeltaList} -\refsdollar{NRTgetLocalIndex}{NRTdeltaListComp} -\refsdollar{NRTgetLocalIndex}{NRTdeltaLength} -\defsdollar{NRTgetLocalIndex}{NRTbase} -\defsdollar{NRTgetLocalIndex}{EmptyMode} -\defsdollar{NRTgetLocalIndex}{e} -\begin{chunk}{defun NRTgetLocalIndex} -(defun |NRTgetLocalIndex| (item) - (let (k value saveNRTdeltaListComp saveIndex compEntry) - (declare (special |$e| |$EmptyMode| |$NRTdeltaLength| |$NRTbase| - |$NRTdeltaListComp| |$NRTdeltaList| |$formalArgList| - |$NRTaddForm|)) - (cond - ((setq k (|NRTassocIndex| item)) k) - ((equal item |$NRTaddForm|) 5) - ((eq item '$) 0) - ((eq item '$$) 2) - (t - (when (member item |$formalArgList|) (setq value item)) - (cond - ((and (atom item) (null (member item '($ $$))) (null value)) - (setq |$NRTdeltaList| - (cons (cons '|domain| (cons (|NRTaddInner| item) value)) - |$NRTdeltaList|)) - (setq |$NRTdeltaListComp| (cons item |$NRTdeltaListComp|)) - (setq |$NRTdeltaLength| (1+ |$NRTdeltaLength|)) - (1- (+ |$NRTbase| |$NRTdeltaLength|))) - (t - (setq |$NRTdeltaList| - (cons (cons '|domain| (cons (|NRTaddInner| item) value)) - |$NRTdeltaList|)) - (setq saveNRTdeltaListComp - (setq |$NRTdeltaListComp| (cons nil |$NRTdeltaListComp|))) - (setq saveIndex (+ |$NRTbase| |$NRTdeltaLength|)) - (setq |$NRTdeltaLength| (1+ |$NRTdeltaLength|)) - (setq compEntry (car (|compOrCroak| item |$EmptyMode| |$e|))) - (rplaca saveNRTdeltaListComp compEntry) - saveIndex)))))) +\defun{giveFormalParametersValues}{giveFormalParametersValues} +\calls{giveFormalParametersValues}{put} +\calls{giveFormalParametersValues}{get} +\begin{chunk}{defun giveFormalParametersValues} +(defun |giveFormalParametersValues| (argl env) + (dolist (x argl) + (setq env + (|put| x '|value| + (list (|genSomeVariable|) (|get| x '|mode| env) nil) env))) + env) \end{chunk} -\defun{augmentLisplibModemapsFromFunctor}{augmentLisplibModemapsFromFunctor} -\calls{augmentLisplibModemapsFromFunctor}{formal2Pattern} -\calls{augmentLisplibModemapsFromFunctor}{mkAlistOfExplicitCategoryOps} -\calls{augmentLisplibModemapsFromFunctor}{allLASSOCs} -\calls{augmentLisplibModemapsFromFunctor}{member} -\calls{augmentLisplibModemapsFromFunctor}{mkDatabasePred} -\calls{augmentLisplibModemapsFromFunctor}{mkpf} -\calls{augmentLisplibModemapsFromFunctor}{listOfPatternIds} -\calls{augmentLisplibModemapsFromFunctor}{interactiveModemapForm} -\refsdollar{augmentLisplibModemapsFromFunctor}{lisplibModemapAlist} -\refsdollar{augmentLisplibModemapsFromFunctor}{PatternVariableList} -\refsdollar{augmentLisplibModemapsFromFunctor}{e} -\defsdollar{augmentLisplibModemapsFromFunctor}{lisplibModemapAlist} -\defsdollar{augmentLisplibModemapsFromFunctor}{e} -\begin{chunk}{defun augmentLisplibModemapsFromFunctor} -(defun |augmentLisplibModemapsFromFunctor| (form opAlist signature) - (let (argl nonCategorySigAlist op pred sel predList sig predp z skip modemap) - (declare (special |$lisplibModemapAlist| |$PatternVariableList| |$e|)) - (setq form (|formal2Pattern| form)) - (setq argl (cdr form)) - (setq opAlist (|formal2Pattern| opAlist)) - (setq signature (|formal2Pattern| signature)) - ; We are going to be EVALing categories containing these pattern variables - (loop for u in form for v in signature - do (when (member u |$PatternVariableList|) - (setq |$e| (|put| u '|mode| v |$e|)))) - (when - (setq nonCategorySigAlist (|mkAlistOfExplicitCategoryOps| (CAR signature))) - (loop for entry in opAlist - do - (setq op (caar entry)) - (setq sig (cadar entry)) - (setq pred (cadr entry)) - (setq sel (caddr entry)) - (when - (let (result) - (loop for catSig in (|allLASSOCs| op nonCategorySigAlist) - do (setq result (or result (|member| sig catSig)))) - result) - (setq skip (when (and argl (contained '$ (cdr sig))) 'skip)) - (setq sel (subst form '$ sel :test #'equal)) - (setq predList - (loop for a in argl for m in (rest signature) - when (|member| a |$PatternVariableList|) - collect (list a m))) - (setq sig (subst form '$ sig :test #'equal)) - (setq predp - (mkpf - (cons pred (loop for y in predList collect (|mkDatabasePred| y))) - 'and)) - (setq z (|listOfPatternIds| predList)) - (when (some #'(lambda (u) (null (member u z))) argl) - (|sayMSG| (list "cannot handle modemap for " op "by pattern match")) - (setq skip 'skip)) - (setq modemap (list (cons form sig) (cons predp (cons sel skip)))) - (setq |$lisplibModemapAlist| - (cons - (cons op (|interactiveModemapForm| modemap)) - |$lisplibModemapAlist|)))))))) +\defun{macroExpandInPlace}{macroExpandInPlace} +\calls{macroExpandInPlace}{macroExpand} +\begin{chunk}{defun macroExpandInPlace} +(defun |macroExpandInPlace| (form env) + (let (y) + (setq y (|macroExpand| form env)) + (if (or (atom form) (atom y)) + y + (progn + (rplaca form (car y)) + (rplacd form (cdr y)) + form + )))) + +\end{chunk} + +\defun{macroExpand}{macroExpand} +\calls{macroExpand}{macroExpand} +\calls{macroExpand}{macroExpandList} +\begin{chunk}{defun macroExpand} +(defun |macroExpand| (form env) + (let (u) + (cond + ((atom form) + (if (setq u (|get| form '|macro| env)) + (|macroExpand| u env) + form)) + ((and (consp form) (eq (qfirst form) 'def) + (consp (qrest form)) + (consp (qcddr form)) + (consp (qcdddr form)) + (consp (qcddddr form)) + (eq (qrest (qcddddr form)) nil)) + (list 'def (|macroExpand| (second form) env) + (|macroExpandList| (third form) env) + (|macroExpandList| (fourth form) env) + (|macroExpand| (fifth form) env))) + (t (|macroExpandList| form env))))) \end{chunk} -\defun{allLASSOCs}{allLASSOCs} -\begin{chunk}{defun allLASSOCs} -(defun |allLASSOCs| (op alist) - (loop for value in alist - when (equal (car value) op) - collect value)) +\defun{macroExpandList}{macroExpandList} +\calls{macroExpandList}{macroExpand} +\calls{macroExpandList}{getdatabase} +\begin{chunk}{defun macroExpandList} +(defun |macroExpandList| (lst env) + (let (tmp) + (if (and (consp lst) (eq (qrest lst) nil) + (identp (qfirst lst)) (getdatabase (qfirst lst) 'niladic) + (setq tmp (|get| (qfirst lst) '|macro| env))) + (|macroExpand| tmp env) + (loop for x in lst collect (|macroExpand| x env))))) \end{chunk} -\defun{formal2Pattern}{formal2Pattern} -\calls{formal2Pattern}{sublis} -\calls{formal2Pattern}{pairList} -\refsdollar{formal2Pattern}{PatternVariableList} -\begin{chunk}{defun formal2Pattern} -(defun |formal2Pattern| (x) - (declare (special |$PatternVariableList|)) - (sublis (|pairList| |$FormalMapVariableList| (cdr |$PatternVariableList|)) x)) +\defun{makeCategoryPredicates}{makeCategoryPredicates} +\usesdollar{makeCategoryPredicates}{FormalMapVariableList} +\usesdollar{makeCategoryPredicates}{TriangleVariableList} +\usesdollar{makeCategoryPredicates}{mvl} +\usesdollar{makeCategoryPredicates}{tvl} +\begin{chunk}{defun makeCategoryPredicates} +(defun |makeCategoryPredicates| (form u) + (labels ( + (fn (u pl) + (declare (special |$tvl| |$mvl|)) + (cond + ((and (consp u) (eq (qfirst u) '|Join|) (consp (qrest u))) + (fn (car (reverse (qrest u))) pl)) + ((and (consp u) (eq (qfirst u) '|has|)) + (|insert| (eqsubstlist |$mvl| |$tvl| u) pl)) + ((and (consp u) (member (qfirst u) '(signature attribute))) pl) + ((atom u) pl) + (t (fnl u pl)))) + (fnl (u pl) + (dolist (x u) (setq pl (fn x pl))) + pl)) + (declare (special |$FormalMapVariableList| |$mvl| |$tvl| + |$TriangleVariableList|)) + (setq |$tvl| (take (|#| (cdr form)) |$TriangleVariableList|)) + (setq |$mvl| (take (|#| (cdr form)) (cdr |$FormalMapVariableList|))) + (fn u nil))) \end{chunk} -\defun{mkDatabasePred}{mkDatabasePred} -\calls{mkDatabasePred}{isCategoryForm} -\refsdollar{mkDatabasePred}{e} -\begin{chunk}{defun mkDatabasePred} -(defun |mkDatabasePred| (arg) - (let (a z) - (declare (special |$e|)) - (setq a (car arg)) - (setq z (cadr arg)) - (if (|isCategoryForm| z |$e|) - (list '|ofCategory| a z) - (list '|ofType| a z)))) +\defun{mkCategoryPackage}{mkCategoryPackage} +\calls{mkCategoryPackage}{strconc} +\calls{mkCategoryPackage}{pname} +\calls{mkCategoryPackage}{getdatabase} +\calls{mkCategoryPackage}{abbreviationsSpad2Cmd} +\calls{mkCategoryPackage}{JoinInner} +\calls{mkCategoryPackage}{assoc} +\calls{mkCategoryPackage}{sublislis} +\usesdollar{mkCategoryPackage}{options} +\usesdollar{mkCategoryPackage}{categoryPredicateList} +\usesdollar{mkCategoryPackage}{e} +\usesdollar{mkCategoryPackage}{FormalMapVariableList} +\begin{chunk}{defun mkCategoryPackage} +(defun |mkCategoryPackage| (form cat def) + (labels ( + (fn (x oplist) + (cond + ((atom x) oplist) + ((and (consp x) (eq (qfirst x) 'def) (consp (qrest x))) + (cons (second x) oplist)) + (t + (fn (cdr x) (fn (car x) oplist))))) + (gn (cat) + (cond + ((and (consp cat) (eq (qfirst cat) 'category)) (cddr cat)) + ((and (consp cat) (eq (qfirst cat) '|Join|)) (gn (|last| (qrest cat)))) + (t nil)))) + (let (|$options| op argl packageName packageAbb nameForDollar packageArgl + capsuleDefAlist explicitCatPart catvec fullCatOpList op1 sig + catOpList packageCategory nils packageSig) + (declare (special |$options| |$categoryPredicateList| |$e| + |$FormalMapVariableList|)) + (setq op (car form)) + (setq argl (cdr form)) + (setq packageName (intern (strconc (pname op) "&"))) + (setq packageAbb (intern (strconc (getdatabase op 'abbreviation) "-"))) + (setq |$options| nil) + (|abbreviationsSpad2Cmd| (list '|domain| packageAbb packageName)) + (setq nameForDollar (car (setdifference '(s a b c d e f g h i) argl))) + (setq packageArgl (cons nameForDollar argl)) + (setq capsuleDefAlist (fn def nil)) + (setq explicitCatPart (gn cat)) + (setq catvec (|eval| (|mkEvalableCategoryForm| form))) + (setq fullCatOpList (elt (|JoinInner| (list catvec) |$e|) 1)) + (setq catOpList + (loop for x in fullCatOpList do + (setq op1 (caar x)) + (setq sig (cadar x)) + when (|assoc| op1 capsuleDefAlist) + collect (list 'signature op1 sig))) + (when catOpList + (setq packageCategory + (cons 'category + (cons '|domain| (sublislis argl |$FormalMapVariableList| catOpList)))) + (setq nils (loop for x in argl collect nil)) + (setq packageSig (cons packageCategory (cons form nils))) + (setq |$categoryPredicateList| + (subst nameForDollar '$ |$categoryPredicateList| :test #'equal)) + (subst nameForDollar '$ + (list 'def (cons packageName packageArgl) + packageSig (cons nil nils) def) :test #'equal))))) \end{chunk} -\defun{disallowNilAttribute}{disallowNilAttribute} -\begin{chunk}{defun disallowNilAttribute} -(defun |disallowNilAttribute| (x) - (loop for y in x when (and (car y) (not (eq (car y) '|nil|))) - collect y)) +\defun{mkEvalableCategoryForm}{mkEvalableCategoryForm} +\calls{mkEvalableCategoryForm}{mkEvalableCategoryForm} +\calls{mkEvalableCategoryForm}{compOrCroak} +\calls{mkEvalableCategoryForm}{getdatabase} +\calls{mkEvalableCategoryForm}{get} +\calls{mkEvalableCategoryForm}{mkq} +\refsdollar{mkEvalableCategoryForm}{Category} +\refsdollar{mkEvalableCategoryForm}{e} +\refsdollar{mkEvalableCategoryForm}{EmptyMode} +\refsdollar{mkEvalableCategoryForm}{CategoryFrame} +\refsdollar{mkEvalableCategoryForm}{Category} +\refsdollar{mkEvalableCategoryForm}{CategoryNames} +\defsdollar{mkEvalableCategoryForm}{e} +\begin{chunk}{defun mkEvalableCategoryForm} +(defun |mkEvalableCategoryForm| (c) + (let (op argl tmp1 x m) + (declare (special |$Category| |$e| |$EmptyMode| |$CategoryFrame| + |$CategoryNames|)) + (if (consp c) + (progn + (setq op (qfirst c)) + (setq argl (qrest c)) + (cond + ((eq op '|Join|) + (cons '|Join| + (loop for x in argl + collect (|mkEvalableCategoryForm| x)))) + ((eq op '|DomainSubstitutionMacro|) + (|mkEvalableCategoryForm| (cadr argl))) + ((eq op '|mkCategory|) c) + ((member op |$CategoryNames|) + (setq tmp1 (|compOrCroak| c |$EmptyMode| |$e|)) + (setq x (car tmp1)) + (setq m (cadr tmp1)) + (setq |$e| (caddr tmp1)) + (when (equal m |$Category|) x)) + ((or (eq (getdatabase op 'constructorkind) '|category|) + (|get| op '|isCategory| |$CategoryFrame|)) + (cons op + (loop for x in argl + collect (mkq x)))) + (t + (setq tmp1 (|compOrCroak| c |$EmptyMode| |$e|)) + (setq x (car tmp1)) + (setq m (cadr tmp1)) + (setq |$e| (caddr tmp1)) + (when (equal m |$Category|) x)))) + (mkq c)))) \end{chunk} -\defun{compFunctorBody}{compFunctorBody} -\calls{compFunctorBody}{bootStrapError} -\calls{compFunctorBody}{compOrCroak} -\uses{compFunctorBody}{/editfile} -\usesdollar{compFunctorBody}{NRTaddForm} -\usesdollar{compFunctorBody}{functorForm} -\usesdollar{compFunctorBody}{bootStrapMode} -\begin{chunk}{defun compFunctorBody} -(defun |compFunctorBody| (form mode env parForm) - (declare (ignore parForm)) - (let (tt) - (declare (special |$NRTaddForm| |$functorForm| |$bootStrapMode| /editfile)) - (if |$bootStrapMode| - (list (|bootStrapError| |$functorForm| /editfile) mode env) - (progn - (setq tt (|compOrCroak| form mode env)) - (if (and (consp form) (member (qfirst form) '(|add| capsule))) - tt - (progn - (setq |$NRTaddForm| - (if (and (consp form) (eq (qfirst form) '|SubDomain|) - (consp (qrest form)) (consp (qcddr form)) - (eq (qcdddr form) nil)) - (qsecond form) - form)) - tt)))))) +\defun{encodeFunctionName}{encodeFunctionName} +Code for encoding function names inside package or domain +\calls{encodeFunctionName}{mkRepititionAssoc} +\calls{encodeFunctionName}{encodeItem} +\calls{encodeFunctionName}{stringimage} +\calls{encodeFunctionName}{internl} +\calls{encodeFunctionName}{getAbbreviation} +\calls{encodeFunctionName}{length} +\refsdollar{encodeFunctionName}{lisplib} +\refsdollar{encodeFunctionName}{lisplibSignatureAlist} +\defsdollar{encodeFunctionName}{lisplibSignatureAlist} +\begin{chunk}{defun encodeFunctionName} +(defun |encodeFunctionName| (fun package signature sep count) + (let (packageName arglist signaturep reducedSig n x encodedSig encodedName) + (declare (special |$lisplibSignatureAlist| $lisplib)) + (setq packageName (car package)) + (setq arglist (cdr package)) + (setq signaturep (subst '$ package signature :test #'equal)) + (setq reducedSig + (|mkRepititionAssoc| (append (cdr signaturep) (list (car signaturep))))) + (setq encodedSig + (let ((result "")) + (loop for item in reducedSig + do + (setq n (car item)) + (setq x (cdr item)) + (setq result + (strconc result + (if (eql n 1) + (|encodeItem| x) + (strconc (stringimage n) (|encodeItem| x)))))) + result)) + (setq encodedName + (internl (|getAbbreviation| packageName (|#| arglist)) + '|;| (|encodeItem| fun) '|;| encodedSig sep (stringimage count))) + (when $lisplib + (setq |$lisplibSignatureAlist| + (cons (cons encodedName signaturep) |$lisplibSignatureAlist|))) + encodedName)) \end{chunk} -\defun{bootStrapError}{bootStrapError} -\calls{bootStrapError}{mkq} -\calls{bootStrapError}{namestring} -\calls{bootStrapError}{mkDomainConstructor} -\begin{chunk}{defun bootStrapError} -(defun |bootStrapError| (functorForm sourceFile) - (list 'cond - (list '|$bootStrapMode| - (list 'vector (|mkDomainConstructor| functorForm) nil nil nil nil nil)) - (list ''t - (list '|systemError| - (list 'list ''|%b| (MKQ (CAR functorForm)) ''|%d| "from" ''|%b| - (mkq (|namestring| sourceFile)) ''|%d| "needs to be compiled"))))) +\defun{mkRepititionAssoc}{mkRepititionAssoc} +\calls{mkRepititionAssoc}{mkRepfun} +\begin{chunk}{defun mkRepititionAssoc} +(defun |mkRepititionAssoc| (z) + (labels ( + (mkRepfun (z n) + (cond + ((null z) nil) + ((and (consp z) (eq (qrest z) nil) (list (cons n (qfirst z))))) + ((and (consp z) (consp (qrest z)) (equal (qsecond z) (qfirst z))) + (mkRepfun (cdr z) (1+ n))) + (t (cons (cons n (car z)) (mkRepfun (cdr z) 1)))))) + (mkRepfun z 1))) \end{chunk} -\defun{reportOnFunctorCompilation}{reportOnFunctorCompilation} -\calls{reportOnFunctorCompilation}{displayMissingFunctions} -\calls{reportOnFunctorCompilation}{sayBrightly} -\calls{reportOnFunctorCompilation}{displaySemanticErrors} -\calls{reportOnFunctorCompilation}{displayWarnings} -\calls{reportOnFunctorCompilation}{addStats} -\calls{reportOnFunctorCompilation}{normalizeStatAndStringify} -\usesdollar{reportOnFunctorCompilation}{op} -\usesdollar{reportOnFunctorCompilation}{functorStats} -\usesdollar{reportOnFunctorCompilation}{functionStats} -\usesdollar{reportOnFunctorCompilation}{warningStack} -\usesdollar{reportOnFunctorCompilation}{semanticErrorStack} -\begin{chunk}{defun reportOnFunctorCompilation} -(defun |reportOnFunctorCompilation| () - (declare (special |$op| |$functorStats| |$functionStats| - |$warningStack| |$semanticErrorStack|)) - (|displayMissingFunctions|) - (when |$semanticErrorStack| (|sayBrightly| " ")) - (|displaySemanticErrors|) - (when |$warningStack| (|sayBrightly| " ")) - (|displayWarnings|) - (setq |$functorStats| (|addStats| |$functorStats| |$functionStats|)) - (|sayBrightly| - (cons '|%l| - (append (|bright| " Cumulative Statistics for Constructor") - (list |$op|)))) - (|sayBrightly| - (cons " Time:" - (append (|bright| (|normalizeStatAndStringify| (second |$functorStats|))) - (list "seconds")))) - (|sayBrightly| " ") - '|done|) +\defun{splitEncodedFunctionName}{splitEncodedFunctionName} +\calls{splitEncodedFunctionName}{stringimage} +\calls{splitEncodedFunctionName}{strpos} +\begin{chunk}{defun splitEncodedFunctionName} +(defun |splitEncodedFunctionName| (encodedName sep) + (let (sep0 p1 p2 p3 s1 s2 s3 s4) + ; sep0 is the separator used in "encodeFunctionName". + (setq sep0 ";") + (unless (stringp encodedName) (setq encodedName (stringimage encodedName))) + (cond + ((null (setq p1 (strpos sep0 encodedName 0 "*"))) nil) + ; This is picked up in compile for inner functions in partial compilation + ((null (setq p2 (strpos sep0 encodedName (1+ p1) "*"))) '|inner|) + ((null (setq p3 (strpos sep encodedName (1+ p2) "*"))) nil) + (t + (setq s1 (substring encodedName 0 p1)) + (setq s2 (substring encodedName (1+ p1) (- p2 p1 1))) + (setq s3 (substring encodedName (1+ p2) (- p3 p2 1))) + (setq s4 (substring encodedName (1+ p3) nil)) + (list s1 s2 s3 s4))))) \end{chunk} -\defun{displayMissingFunctions}{displayMissingFunctions} -\calls{displayMissingFunctions}{member} -\calls{displayMissingFunctions}{getmode} -\calls{displayMissingFunctions}{sayBrightly} -\calls{displayMissingFunctions}{bright} -\calls{displayMissingFunctions}{formatUnabbreviatedSig} -\usesdollar{displayMissingFunctions}{env} -\usesdollar{displayMissingFunctions}{formalArgList} -\usesdollar{displayMissingFunctions}{CheckVectorList} -\begin{chunk}{defun displayMissingFunctions} -(defun |displayMissingFunctions| () - (let (i loc exp) - (declare (special |$env| |$formalArgList| |$CheckVectorList|)) - (unless |$CheckVectorList| - (setq loc nil) - (setq exp nil) - (loop for cvl in |$CheckVectorList| do - (unless (cdr cvl) - (if (and (null (|member| (caar cvl) |$formalArgList|)) - (consp (|getmode| (caar cvl) |$env|)) - (eq (qfirst (|getmode| (caar cvl) |$env|)) '|Mapping|)) - (push (list (caar cvl) (cadar cvl)) loc) - (push (list (caar cvl) (cadar cvl)) exp)))) - (when loc - (|sayBrightly| (cons '|%l| (|bright| " Missing Local Functions:"))) - (setq i 0) - (loop for item in loc do - (|sayBrightly| - (cons " [" (cons (incf i) (cons "]" - (append (|bright| (first item)) - (cons '|: | (|formatUnabbreviatedSig| (second item)))))))))) - (when exp - (|sayBrightly| (cons '|%l| (|bright| " Missing Exported Functions:"))) - (setq i 0) - (loop for item in exp do - (|sayBrightly| - (cons " [" (cons (incf i) (cons "]" - (append (|bright| (first item)) - (cons '|: | (|formatUnabbreviatedSig| (second item))))))))))))) +\defun{encodeItem}{encodeItem} +\calls{encodeItem}{getCaps} +\calls{encodeItem}{identp} +\calls{encodeItem}{pname} +\calls{encodeItem}{stringimage} +\begin{chunk}{defun encodeItem} +(defun |encodeItem| (x) + (cond + ((consp x) (|getCaps| (qfirst x))) + ((identp x) (pname x)) + (t (stringimage x)))) \end{chunk} -\defun{makeFunctorArgumentParameters}{makeFunctorArgumentParameters} -\calls{makeFunctorArgumentParameters}{assq} -\calls{makeFunctorArgumentParameters}{isCategoryForm} -\calls{makeFunctorArgumentParameters}{qcar} -\calls{makeFunctorArgumentParameters}{qcdr} -\calls{makeFunctorArgumentParameters}{genDomainViewList0} -\calls{makeFunctorArgumentParameters}{union} -\usesdollar{makeFunctorArgumentParameters}{ConditionalOperators} -\usesdollar{makeFunctorArgumentParameters}{alternateViewList} -\usesdollar{makeFunctorArgumentParameters}{forceAdd} -\begin{chunk}{defun makeFunctorArgumentParameters} -(defun |makeFunctorArgumentParameters| (argl sigl target) - (labels ( - (augmentSig (s ss) - (let (u) - (declare (special |$ConditionalOperators|)) - (if ss - (progn - (loop for u in ss do (push (rest u) |$ConditionalOperators|)) - (if (and (consp s) (eq (qfirst s) '|Join|)) - (progn - (if (setq u (assq 'category ss)) - (subst (append u ss) u s :test #'equal) - (cons '|Join| - (append (rest s) (list (cons 'category (cons '|package| ss))))))) - (list '|Join| s (cons 'category (cons '|package| ss))))) - s))) - (fn (a s) - (declare (special |$CategoryFrame|)) - (if (|isCategoryForm| s |$CategoryFrame|) - (if (and (consp s) (eq (qfirst s) '|Join|)) - (|genDomainViewList0| a (rest s)) - (list (|genDomainView| a s '|getDomainView|))) - (list a))) - (findExtras (a target) - (cond - ((and (consp target) (eq (qfirst target) '|Join|)) - (reduce #'|union| - (loop for x in (qrest target) - collect (findExtras a x)))) - ((and (consp target) (eq (qfirst target) 'category)) - (reduce #'|union| - (loop for x in (qcddr target) - collect (findExtras1 a x)))))) - (findExtras1 (a x) - (cond - ((and (consp x) (or (eq (qfirst x) 'and)) (eq (qfirst x) 'or)) - (reduce #'|union| - (loop for y in (rest x) collect (findExtras1 a y)))) - ((and (consp x) (eq (qfirst x) 'if) - (consp (qrest x)) (consp (qcddr x)) - (consp (qcdddr x)) - (eq (qcddddr x) nil)) - (|union| (findExtrasP a (second x)) - (|union| - (findExtras1 a (third x)) - (findExtras1 a (fourth x))))))) - (findExtrasP (a x) - (cond - ((and (consp x) (or (eq (qfirst x) 'and)) (eq (qfirst x) 'or)) - (reduce #'|union| - (loop for y in (rest x) collect (findExtrasP a y)))) - ((and (consp x) (eq (qfirst x) '|has|) - (consp (qrest x)) (consp (qcddr x)) - (consp (qcdddr x)) - (eq (qcddddr x) nil)) - (|union| (findExtrasP a (second x)) - (|union| - (findExtras1 a (third x)) - (findExtras1 a (fourth x))))) - ((and (consp x) (eq (qfirst x) '|has|) - (consp (qrest x)) (equal (qsecond x) a) - (consp (qcddr x)) - (eq (qcdddr x) nil) - (consp (qthird x)) - (eq (qcaaddr x) 'signature)) - (list (third x))))) +\defun{getCaps}{getCaps} +\calls{getCaps}{stringimage} +\calls{getCaps}{maxindex} +\calls{getCaps}{l-case} +\calls{getCaps}{strconc} +\begin{chunk}{defun getCaps} +(defun |getCaps| (x) + (let (s c clist tmp1) + (setq s (stringimage x)) + (setq clist + (loop for i from 0 to (maxindex s) + when (upper-case-p (setq c (elt s i))) + collect c)) + (cond + ((null clist) "_") + (t + (setq tmp1 + (cons (first clist) (loop for u in (rest clist) collect (l-case u)))) + (let ((result "")) + (loop for u in tmp1 + do (setq result (strconc result u))) + result))))) - ) - (let (|$alternateViewList| |$forceAdd| |$ConditionalOperators|) - (declare (special |$alternateViewList| |$forceAdd| |$ConditionalOperators|)) - (setq |$alternateViewList| nil) - (setq |$forceAdd| t) - (setq |$ConditionalOperators| nil) - (mapcar #'reduce - (loop for a in argl for s in sigl do - (fn a (augmentSig s (findExtras a target)))))))) +\end{chunk} + +\defun{constructMacro}{constructMacro} +constructMacro (form is [nam,[lam,vl,body]]) +\calls{constructMacro}{stackSemanticError} +\calls{constructMacro}{identp} +\begin{chunk}{defun constructMacro} +(defun |constructMacro| (form) + (let (vl body) + (setq vl (cadadr form)) + (setq body (car (cddadr form))) + (cond + ((null (let ((result t)) + (loop for x in vl + do (setq result (and result (atom x)))) + result)) + (|stackSemanticError| (list '|illegal parameters for macro: | vl) nil)) + (t + (list 'xlam (loop for x in vl when (identp x) collect x) body))))) \end{chunk} -\defun{genDomainViewList0}{genDomainViewList0} -\calls{genDomainViewList0}{getDomainViewList} -\begin{chunk}{defun genDomainViewList0} -(defun |genDomainViewList0| (id catlist) - (|genDomainViewList| id catlist t)) +\defun{spadCompileOrSetq}{spadCompileOrSetq} +\calls{spadCompileOrSetq}{contained} +\calls{spadCompileOrSetq}{sayBrightly} +\calls{spadCompileOrSetq}{bright} +\calls{spadCompileOrSetq}{LAM,EVALANDFILEACTQ} +\calls{spadCompileOrSetq}{mkq} +\calls{spadCompileOrSetq}{comp} +\calls{spadCompileOrSetq}{compileConstructor} +\refsdollar{spadCompileOrSetq}{insideCapsuleFunctionIfTrue} +\begin{chunk}{defun spadCompileOrSetq} +(defun |spadCompileOrSetq| (form) + (let (nam lam vl body namp tmp1 e vlp macform) + (declare (special |$insideCapsuleFunctionIfTrue|)) + (setq nam (car form)) + (setq lam (caadr form)) + (setq vl (cadadr form)) + (setq body (car (cddadr form))) + (cond + ((and (consp vl) (progn (setq tmp1 (reverse vl)) t) + (consp tmp1) + (progn + (setq e (qfirst tmp1)) + (setq vlp (qrest tmp1)) + t) + (progn (setq vlp (nreverse vlp)) t) + (consp body) + (progn (setq namp (qfirst body)) t) + (equal (qrest 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)) + (consp vl) + (progn (setq tmp1 (reverse vl)) t) + (consp tmp1) + (progn + (setq e (qfirst tmp1)) + (setq vlp (qrest 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} -\defun{genDomainViewList}{genDomainViewList} -\calls{genDomainViewList}{qcdr} -\calls{genDomainViewList}{isCategoryForm} -\calls{genDomainViewList}{genDomainView} -\calls{genDomainViewList}{genDomainViewList} -\usesdollar{genDomainViewList}{EmptyEnvironment} -\begin{chunk}{defun genDomainViewList} -(defun |genDomainViewList| (id catlist firsttime) - (declare (special |$EmptyEnvironment|) (ignore firsttime)) - (cond - ((null catlist) nil) - ((and (consp catlist) (eq (qrest catlist) nil) - (null (|isCategoryForm| (first catlist) |$EmptyEnvironment|))) - nil) - (t - (cons - (|genDomainView| id (first catlist) '|getDomainView|) - (|genDomainViewList| id (rest catlist) nil))))) +\defun{compileConstructor}{compileConstructor} +\calls{compileConstructor}{compileConstructor1} +\calls{compileConstructor}{clearClams} +\begin{chunk}{defun compileConstructor} +(defun |compileConstructor| (form) + (let (u) + (setq u (|compileConstructor1| form)) + (|clearClams|) + u)) \end{chunk} -\defun{genDomainView}{genDomainView} -\calls{genDomainView}{genDomainOps} -\calls{genDomainView}{qcar} -\calls{genDomainView}{qcdr} -\calls{genDomainView}{augModemapsFromCategory} -\calls{genDomainView}{mkDomainConstructor} -\calls{genDomainView}{member} -\usesdollar{genDomainView}{e} -\usesdollar{genDomainView}{getDomainCode} -\begin{chunk}{defun genDomainView} -(defun |genDomainView| (name c viewSelector) - (let (code cd) - (declare (special |$getDomainCode| |$e|)) - (cond - ((and (consp c) (eq (qfirst c) 'category) (consp (qrest c))) - (|genDomainOps| name name c)) - (t - (setq code - (if (and (consp c) (eq (qfirst c) '|SubsetCategory|) - (consp (qrest c)) (consp (qcddr c)) - (eq (qcdddr c) nil)) - (second c) - c)) - (setq |$e| (|augModemapsFromCategory| name nil c |$e|)) - (setq cd - (list 'let name (list viewSelector name (|mkDomainConstructor| code)))) - (unless (|member| cd |$getDomainCode|) - (setq |$getDomainCode| (cons cd |$getDomainCode|))) - name)))) +\defun{compileConstructor1}{compileConstructor1} +\calls{compileConstructor1}{getdatabase} +\calls{compileConstructor1}{compAndDefine} +\calls{compileConstructor1}{comp} +\calls{compileConstructor1}{clearConstructorCache} +\refsdollar{compileConstructor1}{mutableDomain} +\refsdollar{compileConstructor1}{ConstructorCache} +\refsdollar{compileConstructor1}{clamList} +\defsdollar{compileConstructor1}{clamList} +\begin{chunk}{defun compileConstructor1} +(defun |compileConstructor1| (form) + (let (|$clamList| fn key vl bodyl lambdaOrSlam compForm u) + (declare (special |$clamList| |$ConstructorCache| |$mutableDomain|)) + (setq fn (car form)) + (setq key (caadr form)) + (setq vl (cadadr form)) + (setq bodyl (cddadr form)) + (setq |$clamList| nil) + (setq lambdaOrSlam + (cond + ((eq (getdatabase fn 'constructorkind) '|category|) 'spadslam) + (|$mutableDomain| 'lambda) + (t + (setq |$clamList| + (cons (list fn '|$ConstructorCache| '|domainEqualList| '|count|) + |$clamList|)) + 'lambda))) + (setq compForm (list (list fn (cons lambdaorslam (cons vl bodyl))))) + (if (eq (getdatabase fn 'constructorkind) '|category|) + (setq u (|compAndDefine| compForm)) + (setq u (comp compForm))) + (|clearConstructorCache| fn) + (car u))) \end{chunk} -\defun{genDomainOps}{genDomainOps} -\calls{genDomainOps}{getOperationAlist} -\calls{genDomainOps}{substNames} -\calls{genDomainOps}{mkq} -\calls{genDomainOps}{mkDomainConstructor} -\calls{genDomainOps}{addModemap} -\usesdollar{genDomainOps}{e} -\usesdollar{genDomainOps}{ConditionalOperators} -\usesdollar{genDomainOps}{getDomainCode} -\begin{chunk}{defun genDomainOps} -(defun |genDomainOps| (viewName dom cat) - (let (siglist oplist cd i) - (declare (special |$e| |$ConditionalOperators| |$getDomainCode|)) - (setq oplist (|getOperationAlist| dom dom cat)) - (setq siglist (loop for lst in oplist collect (first lst))) - (setq oplist (|substNames| dom viewName dom oplist)) - (setq cd - (list 'let viewName - (list '|mkOpVec| dom - (cons 'list - (loop for opsig in siglist - collect - (list 'list (mkq (first opsig)) - (cons 'list - (loop for mode in (rest opsig) - collect (|mkDomainConstructor| mode))))))))) - (setq |$getDomainCode| (cons cd |$getDomainCode|)) - (setq i 0) - (loop for item in oplist do - (if (|member| (first item) |$ConditionalOperators|) - (setq |$e| (|addModemap| (caar item) dom (cadar item) nil - (list 'elt viewName (incf i)) |$e|)) - (setq |$e| (|addModemap| (caar item) dom (cadar item) (second item) - (list 'elt viewName (incf i)) |$e|)))) - viewName)) +\defun{compAndDefine}{compAndDefine} +This function is used but never defined. +We define a dummy function here. +All references to it should be removed. +\tpdhere{This function is used but never defined. Remove it.} +\begin{chunk}{defun compAndDefine} +(defun compAndDefine (arg) + (declare (ignore arg)) + nil) \end{chunk} -\defun{mkOpVec}{mkOpVec} -\calls{mkOpVec}{getPrincipalView} -\calls{mkOpVec}{getOperationAlistFromLisplib} -\calls{mkOpVec}{opOf} -\calls{mkOpVec}{length} -\calls{mkOpVec}{assq} -\calls{mkOpVec}{assoc} -\calls{mkOpVec}{qcar} -\calls{mkOpVec}{qcdr} -\calls{mkOpVec}{sublis} -\calls{mkOpVec}{AssocBarGensym} -\usesdollar{mkOpVec}{FormalMapVariableList} -\uses{mkOpVec}{Undef} -\begin{chunk}{defun mkOpVec} -(defun |mkOpVec| (dom siglist) - (let (substargs oplist ops u noplist i tmp1) - (declare (special |$FormalMapVariableList| |Undef|)) - (setq dom (|getPrincipalView| dom)) - (setq substargs - (cons (cons '$ (elt dom 0)) - (loop for a in |$FormalMapVariableList| for x in (rest (elt dom 0)) - collect (cons a x)))) - (setq oplist (|getOperationAlistFromLisplib| (|opOf| (elt dom 0)))) - (setq ops (make-array (|#| siglist))) - (setq i -1) - (loop for opSig in siglist do - (incf i) - (setq u (assq (first opSig) oplist)) - (setq tmp1 (|assoc| (second opSig) u)) - (cond - ((and (consp tmp1) (consp (qrest tmp1)) - (consp (qcddr tmp1)) (consp (qcdddr tmp1)) - (eq (qcddddr tmp1) nil) - (eq (qfourth tmp1) 'elt)) - (setelt ops i (elt dom (second tmp1)))) - (t - (setq noplist (sublis substargs u)) - (setq tmp1 - (|AssocBarGensym| - (subst (elt dom 0) '$ (second opSig) :test #'equal) noplist)) - (cond - ((and (consp tmp1) (consp (qrest tmp1)) (consp (qcddr tmp1)) - (consp (qcdddr tmp1)) - (eq (qcddddr tmp1) nil) - (eq (qfourth tmp1) 'elt)) - (setelt ops i (elt dom (second tmp1)))) - (t - (setelt ops i (cons |Undef| (cons (list (elt dom 0) i) opSig)))))))) - ops)) +\defun{putInLocalDomainReferences}{putInLocalDomainReferences} +\calls{putInLocalDomainReferences}{NRTputInTail} +\refsdollar{putInLocalDomainReferences}{QuickCode} +\defsdollar{putInLocalDomainReferences}{elt} +\begin{chunk}{defun putInLocalDomainReferences} +(defun |putInLocalDomainReferences| (def) + (let (|$elt| opName lam varl body) + (declare (special |$elt| |$QuickCode|)) + (setq opName (car def)) + (setq lam (caadr def)) + (setq varl (cadadr def)) + (setq body (car (cddadr def))) + (setq |$elt| (if |$QuickCode| 'qrefelt 'elt)) + (|NRTputInTail| (cddadr def)) + def)) + +\end{chunk} + +\defun{NRTputInTail}{NRTputInTail} +\calls{NRTputInTail}{lassoc} +\calls{NRTputInTail}{NRTassocIndex} +\calls{NRTputInTail}{rplaca} +\calls{NRTputInTail}{NRTputInHead} +\refsdollar{NRTputInTail}{elt} +\refsdollar{NRTputInTail}{devaluateList} +\begin{chunk}{defun NRTputInTail} +(defun |NRTputInTail| (x) + (let (u k) + (declare (special |$elt| |$devaluateList|)) + (maplist #'(lambda (y) + (cond + ((atom (setq u (car y))) + (cond + ((or (eq u '$) (lassoc u |$devaluateList|)) + nil) + ((setq k (|NRTassocIndex| u)) + (cond + ; u atomic means that the slot will always contain a vector + ((atom u) (rplaca y (list |$elt| '$ k))) + ; this reference must check that slot is a vector + (t (rplaca y (list 'spadcheckelt '$ k))))) + (t nil))) + (t (|NRTputInHead| u)))) + x) + x)) \end{chunk} -\defun{AssocBarGensym}{AssocBarGensym} -\calls{AssocBarGensym}{EqualBarGensym} -\begin{chunk}{defun AssocBarGensym} -(defun |AssocBarGensym| (key z) - (loop for x in z - do (when (and (consp x) (|EqualBarGensym| key (car x))) (return x)))) +\defun{NRTputInHead}{NRTputInHead} +\calls{NRTputInHead}{NRTputInTail} +\calls{NRTputInHead}{NRTassocIndex} +\calls{NRTputInHead}{NRTputInHead} +\calls{NRTputInHead}{lastnode} +\calls{NRTputInHead}{keyedSystemError} +\refsdollar{NRTputInHead}{elt} +\begin{chunk}{defun NRTputInHead} +(defun |NRTputInHead| (bod) + (let (fn clauses dom tmp2 ind k) + (declare (special |$elt|)) + (cond + ((atom bod) bod) + ((and (consp bod) (eq (qcar bod) 'spadcall) (consp (qcdr bod)) + (progn (setq tmp2 (reverse (qcdr bod))) t) (consp tmp2)) + (setq fn (qcar tmp2)) + (|NRTputInTail| (cdr bod)) + (cond + ((and (consp fn) (consp (qcdr fn)) (consp (qcdr (qcdr fn))) + (eq (qcdddr fn) nil) (null (eq (qsecond fn) '$)) + (member (qcar fn) '(elt qrefelt const))) + (when (setq k (|NRTassocIndex| (qsecond fn))) + (rplaca (lastnode bod) (list |$elt| '$ k)))) + (t (|NRTputInHead| fn) bod))) + ((and (consp bod) (eq (qcar bod) 'cond)) + (setq clauses (qcdr bod)) + (loop for cc in clauses do (|NRTputInTail| cc)) + bod) + ((and (consp bod) (eq (qcar bod) 'quote)) bod) + ((and (consp bod) (eq (qcar bod) 'closedfn)) bod) + ((and (consp bod) (eq (qcar bod) 'spadconst) (consp (qcdr bod)) + (consp (qcddr bod)) (eq (qcdddr bod) nil)) + (setq dom (qsecond bod)) + (setq ind (qthird bod)) + (rplaca bod |$elt|) + (cond + ((eq dom '$) nil) + ((setq k (|NRTassocIndex| dom)) + (rplaca (lastnode bod) (list |$elt| '$ k)) + bod) + (t + (|keyedSystemError| 'S2GE0016 + (list "NRTputInHead" "unexpected SPADCONST form"))))) + (t + (|NRTputInHead| (car bod)) + (|NRTputInTail| (cdr bod)) bod)))))) \end{chunk} -\defun{compDefWhereClause}{compDefWhereClause} -\calls{compDefWhereClause}{qcar} -\calls{compDefWhereClause}{qcdr} -\calls{compDefWhereClause}{getmode} -\calls{compDefWhereClause}{userError} -\calls{compDefWhereClause}{concat} -\calls{compDefWhereClause}{lassoc} -\calls{compDefWhereClause}{pairList} -\calls{compDefWhereClause}{union} -\calls{compDefWhereClause}{listOfIdentifersIn} -\calls{compDefWhereClause}{delete} -\calls{compDefWhereClause}{orderByDependency} -\calls{compDefWhereClause}{assocleft} -\calls{compDefWhereClause}{assocright} -\calls{compDefWhereClause}{comp} -\usesdollar{compDefWhereClause}{sigAlist} -\usesdollar{compDefWhereClause}{predAlist} -\begin{chunk}{defun compDefWhereClause} -(defun |compDefWhereClause| (arg mode env) - (labels ( - (transformType (x) - (declare (special |$sigAlist|)) - (cond - ((atom x) x) - ((and (consp x) (eq (qfirst x) '|:|) (consp (qrest x)) - (consp (qcddr x)) (eq (qcdddr x) nil)) - (setq |$sigAlist| - (cons (cons (second x) (transformType (third x))) - |$sigAlist|)) - x) - ((and (consp x) (eq (qfirst x) '|Record|)) x) - (t - (cons (first x) - (loop for y in (rest x) - collect (transformType y)))))) - (removeSuchthat (x) - (declare (special |$predAlist|)) - (if (and (consp x) (eq (qfirst x) '|\||) (consp (qrest x)) - (consp (qcddr x)) (eq (qcdddr x) nil)) - (progn - (setq |$predAlist| (cons (cons (second x) (third x)) |$predAlist|)) - (second x)) - x)) - (fetchType (a x env form) - (if x - x - (or (|getmode| a env) - (|userError| (|concat| - "There is no mode for argument" a "of function" (first form)))))) - (addSuchthat (x y) - (let (p) - (declare (special |$predAlist|)) - (if (setq p (lassoc x |$predAlist|)) (list '|\|| y p) y))) - ) - (let (|$sigAlist| |$predAlist| form signature specialCases body sigList - argList argSigAlist argDepAlist varList whereList formxx signaturex - defform formx) - (declare (special |$sigAlist| |$predAlist|)) -; form is lhs (f a1 ... an) of definition; body is rhs; -; signature is (t0 t1 ... tn) where t0= target type, ti=type of ai, i > 0; -; specialCases is (NIL l1 ... ln) where li is list of special cases -; which can be given for each ti -; -; removes declarative and assignment information from form and -; signature, placing it in list L, replacing form by ("where",form',:L), -; signature by a list of NILs (signifying declarations are in e) - (setq form (second arg)) - (setq signature (third arg)) - (setq specialCases (fourth arg)) - (setq body (fifth arg)) - (setq |$sigAlist| nil) - (setq |$predAlist| nil) -; 1. create sigList= list of all signatures which have embedded -; declarations moved into global variable $sigAlist - (setq sigList - (loop for a in (rest form) for x in (rest signature) - collect (transformType (fetchType a x env form)))) -; 2. replace each argument of the form (|| x p) by x, recording -; the given predicate in global variable $predAlist - (setq argList - (loop for a in (rest form) - collect (removeSuchthat a))) - (setq argSigAlist (append |$sigAlist| (|pairList| argList sigList))) - (setq argDepAlist - (loop for pear in argSigAlist - collect - (cons (car pear) - (|union| (|listOfIdentifiersIn| (cdr pear)) - (|delete| (car pear) - (|listOfIdentifiersIn| (lassoc (car pear) |$predAlist|))))))) -; 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that -; the type of xi is independent of xj if i < j - (setq varList - (|orderByDependency| (assocleft argDepAlist) (assocright argDepAlist))) -; 4. construct a WhereList which declares and/or defines the xi's in -; the order constructed in step 3 - (setq whereList - (loop for x in varList - collect (addSuchthat x (list '|:| x (lassoc x argSigAlist))))) - (setq formxx (cons (car form) argList)) - (setq signaturex - (cons (car signature) - (loop for x in (rest signature) collect nil))) - (setq defform (list 'def formxx signaturex specialCases body)) - (setq formx (cons '|where| (cons defform whereList))) -; 5. compile new ('DEF,("where",form',:WhereList),:.) where -; all argument parameters of form' are bound/declared in WhereList - (|comp| formx mode env)))) +\defun{getArgumentModeOrMoan}{getArgumentModeOrMoan} +\calls{getArgumentModeOrMoan}{getArgumentMode} +\calls{getArgumentModeOrMoan}{stackSemanticError} +\begin{chunk}{defun getArgumentModeOrMoan} +(defun |getArgumentModeOrMoan| (x form env) + (or (|getArgumentMode| x env) + (|stackSemanticError| + (list '|argument | x '| of | form '| is not declared|) nil))) \end{chunk} -\defun{orderByDependency}{orderByDependency} -\calls{orderByDependency}{say} -\calls{orderByDependency}{userError} -\calls{orderByDependency}{intersection} -\calls{orderByDependency}{member} -\calls{orderByDependency}{remdup} -\begin{chunk}{defun orderByDependency} -(defun |orderByDependency| (vl dl) - (let (selfDependents fatalError newl orderedVarList vlp dlp) - (setq selfDependents - (loop for v in vl for d in dl - when (member v d) - collect v)) - (loop for v in vl for d in dl - when (member v d) - do (say v "depends on itself") - (setq fatalError t)) +\defun{augLisplibModemapsFromCategory}{augLisplibModemapsFromCategory} +\calls{augLisplibModemapsFromCategory}{sublis} +\calls{augLisplibModemapsFromCategory}{mkAlistOfExplicitCategoryOps} +\calls{augLisplibModemapsFromCategory}{isCategoryForm} +\calls{augLisplibModemapsFromCategory}{lassoc} +\calls{augLisplibModemapsFromCategory}{member} +\calls{augLisplibModemapsFromCategory}{mkpf} +\calls{augLisplibModemapsFromCategory}{interactiveModemapForm} +\refsdollar{augLisplibModemapsFromCategory}{lisplibModemapAlist} +\refsdollar{augLisplibModemapsFromCategory}{EmptyEnvironment} +\refsdollar{augLisplibModemapsFromCategory}{domainShell} +\refsdollar{augLisplibModemapsFromCategory}{PatternVariableList} +\defsdollar{augLisplibModemapsFromCategory}{lisplibModemapAlist} +\begin{chunk}{defun augLisplibModemapsFromCategory} +(defun |augLisplibModemapsFromCategory| (form body signature) + (let (argl sl opAlist nonCategorySigAlist domainList catPredList op sig + pred sel predp modemap) + (declare (special |$lisplibModemapAlist| |$EmptyEnvironment| + |$domainShell| |$PatternVariableList|)) + (setq op (car form)) + (setq argl (cdr form)) + (setq sl + (cons (cons '$ '*1) + (loop for a in argl for p in (rest |$PatternVariableList|) + collect (cons a p)))) + (setq form (sublis sl form)) + (setq body (sublis sl body)) + (setq signature (sublis sl signature)) + (when (setq opAlist (sublis sl (elt |$domainShell| 1))) + (setq nonCategorySigAlist + (|mkAlistOfExplicitCategoryOps| (subst '*1 '$ body :test #'equal))) + (setq domainList + (loop for a in (rest form) for m in (rest signature) + when (|isCategoryForm| m |$EmptyEnvironment|) + collect (list a m))) + (setq catPredList + (loop for u in (cons (list '*1 form) domainList) + collect (cons '|ofCategory| u))) + (loop for entry in opAlist + when (|member| (cadar entry) (lassoc (caar entry) nonCategorySigAlist)) + do + (setq op (caar entry)) + (setq sig (cadar entry)) + (setq pred (cadr entry)) + (setq sel (caddr entry)) + (setq predp (mkpf (cons pred catPredList) 'and)) + (setq modemap (list (cons '*1 sig) (list predp sel))) + (setq |$lisplibModemapAlist| + (cons (cons op (|interactiveModemapForm| modemap)) + |$lisplibModemapAlist|)))))) + +\end{chunk} + +\defun{mkAlistOfExplicitCategoryOps}{mkAlistOfExplicitCategoryOps} +\calls{mkAlistOfExplicitCategoryOps}{keyedSystemError} +\calls{mkAlistOfExplicitCategoryOps}{union} +\calls{mkAlistOfExplicitCategoryOps}{mkAlistOfExplicitCategoryOps} +\calls{mkAlistOfExplicitCategoryOps}{flattenSignatureList} +\calls{mkAlistOfExplicitCategoryOps}{nreverse0} +\calls{mkAlistOfExplicitCategoryOps}{remdup} +\calls{mkAlistOfExplicitCategoryOps}{assocleft} +\calls{mkAlistOfExplicitCategoryOps}{isCategoryForm} +\refsdollar{mkAlistOfExplicitCategoryOps}{e} +\begin{chunk}{defun mkAlistOfExplicitCategoryOps} +(defun |mkAlistOfExplicitCategoryOps| (target) + (labels ( + (atomizeOp (op) + (cond + ((atom op) op) + ((and (consp op) (eq (qrest op) nil)) (qfirst op)) + (t (|keyedSystemError| 'S2GE0016 + (list "mkAlistOfExplicitCategoryOps" "bad signature"))))) + (fn (op u) + (if (and (consp u) (consp (qfirst u))) + (if (equal (qcaar u) op) + (cons (qcdar u) (fn op (qrest u))) + (fn op (qrest u)))))) + (let (z tmp1 op sig u opList) + (declare (special |$e|)) + (when (and (consp target) (eq (qfirst target) '|add|) (consp (qrest target))) + (setq target (second target))) (cond - (fatalError (|userError| "Parameter specification error")) - (t - (loop until (null vl) do - (setq newl - (loop for v in vl for d in dl - when (null (|intersection| d vl)) - collect v)) - (if (null newl) - (setq vl nil) ; force loop exit + ((and (consp target) (eq (qfirst target) '|Join|)) + (setq z (qrest target)) + (PROG (tmp1) + (RETURN + (DO ((G167566 z (CDR G167566)) (cat nil)) + ((OR (ATOM G167566) (PROGN (setq cat (CAR G167566)) nil)) + tmp1) + (setq tmp1 (|union| tmp1 (|mkAlistOfExplicitCategoryOps| cat))))))) + ((and (consp target) (eq (qfirst target) 'category) (progn - (setq orderedVarList (append newl orderedVarList)) - (setq vlp (setdifference vl newl)) - (setq dlp - (loop for x in vl for d in dl - when (|member| x vlp) - collect (setdifference d newl))) - (setq vl vlp) - (setq dl dlp)))) - (when (and newl orderedVarList) (remdup (nreverse orderedVarList))))))) + (setq tmp1 (qrest target)) + (and (consp tmp1) + (progn (setq z (qrest tmp1)) t)))) + (setq z (|flattenSignatureList| (cons 'progn z))) + (setq u + (prog (G167577) + (return + (do ((G167583 z (cdr G167583)) (x nil)) + ((or (atom G167583)) (nreverse0 G167577)) + (setq x (car G167583)) + (cond + ((and (consp x) (eq (qfirst x) 'signature) (consp (qrest x)) + (consp (qcddr x))) + (setq op (qsecond x)) + (setq sig (qthird x)) + (setq G167577 (cons (cons (atomizeOp op) sig) G167577)))))))) + (setq opList (remdup (assocleft u))) + (prog (G167593) + (return + (do ((G167598 opList (cdr G167598)) (x nil)) + ((or (atom G167598)) (nreverse0 G167593)) + (setq x (car G167598)) + (setq G167593 (cons (cons x (fn x u)) G167593)))))) + ((|isCategoryForm| target |$e|) nil) + (t + (|keyedSystemError| 'S2GE0016 + (list "mkAlistOfExplicitCategoryOps" "bad signature"))))))) \end{chunk} -\section{Code optimization routines} -\defun{optimizeFunctionDef}{optimizeFunctionDef} -\calls{optimizeFunctionDef}{qcar} -\calls{optimizeFunctionDef}{qcdr} -\calls{optimizeFunctionDef}{rplac} -\calls{optimizeFunctionDef}{sayBrightlyI} -\calls{optimizeFunctionDef}{optimize} -\calls{optimizeFunctionDef}{pp} -\calls{optimizeFunctionDef}{bright} -\refsdollar{optimizeFunctionDef}{reportOptimization} -\begin{chunk}{defun optimizeFunctionDef} -(defun |optimizeFunctionDef| (def) - (labels ( - (fn (x g) - (cond - ((and (consp x) (eq (qfirst x) 'throw) (consp (qrest x)) - (equal (qsecond x) g)) - (|rplac| (car x) 'return) - (|rplac| (cdr x) - (replaceThrowByReturn (qcddr x) g))) - ((atom x) nil) - (t - (replaceThrowByReturn (car x) g) - (replaceThrowByReturn (cdr x) g)))) - (replaceThrowByReturn (x g) - (fn x g) - x) - (removeTopLevelCatch (body) - (if (and (consp body) (eq (qfirst body) 'catch) (consp (qrest body)) - (consp (qcddr body)) (eq (qcdddr body) nil)) - (removeTopLevelCatch - (replaceThrowByReturn - (qthird body) (qsecond body))) - body))) - (let (defp name slamOrLam args body bodyp) - (declare (special |$reportOptimization|)) - (when |$reportOptimization| - (|sayBrightlyI| (|bright| "Original LISP code:")) - (|pp| def)) - (setq defp (|optimize| (copy def))) - (when |$reportOptimization| - (|sayBrightlyI| (|bright| "Optimized LISP code:")) - (|pp| defp) - (|sayBrightlyI| (|bright| "Final LISP code:"))) - (setq name (car defp)) - (setq slamOrLam (caadr defp)) - (setq args (cadadr defp)) - (setq body (car (cddadr defp))) - (setq bodyp (removeTopLevelCatch body)) - (list name (list slamOrLam args bodyp))))) +\defun{flattenSignatureList}{flattenSignatureList} +\calls{flattenSignatureList}{flattenSignatureList} +\begin{chunk}{defun flattenSignatureList} +(defun |flattenSignatureList| (x) + (let (zz) + (cond + ((atom x) nil) + ((and (consp x) (eq (qfirst x) 'signature)) (list x)) + ((and (consp x) (eq (qfirst x) 'if) (consp (qrest x)) + (consp (qcddr x)) (consp (qcdddr x)) + (eq (qcddddr x) nil)) + (append (|flattenSignatureList| (third x)) + (|flattenSignatureList| (fourth x)))) + ((and (consp x) (eq (qfirst x) 'progn)) + (loop for x in (qrest x) + do + (if (and (consp x) (eq (qfirst x) 'signature)) + (setq zz (cons x zz)) + (setq zz (append (|flattenSignatureList| x) zz)))) + zz) + (t nil)))) \end{chunk} -\defun{optimize}{optimize} -\calls{optimize}{qcar} -\calls{optimize}{qcdr} -\calls{optimize}{optimize} -\calls{optimize}{say} -\calls{optimize}{prettyprint} -\calls{optimize}{rplac} -\calls{optimize}{optIF2COND} -\calls{optimize}{getl} -\calls{optimize}{subrname} -\begin{chunk}{defun optimize} -(defun |optimize| (x) +\defun{interactiveModemapForm}{interactiveModemapForm} +Create modemap form for use by the interpreter. This function +replaces all specific domains mentioned in the modemap with pattern +variables, and predicates +\calls{interactiveModemapForm}{replaceVars} +\calls{interactiveModemapForm}{modemapPattern} +\calls{interactiveModemapForm}{substVars} +\calls{interactiveModemapForm}{fixUpPredicate} +\refsdollar{interactiveModemapForm}{PatternVariableList} +\refsdollar{interactiveModemapForm}{FormalMapVariableList} +\begin{chunk}{defun interactiveModemapForm} +(defun |interactiveModemapForm| (mm) (labels ( - (opt (x) - (let (argl body a y op) - (cond - ((atom x) nil) - ((eq (setq y (car x)) 'quote) nil) - ((eq y 'closedfn) nil) - ((and (consp y) (consp (qfirst y)) (eq (qcaar y) 'xlam) - (consp (qcdar y)) (consp (qcddar y)) - (eq (qcdddar y) nil)) - (setq argl (qcadar y)) - (setq body (qcaddar y)) - (setq a (qrest y)) - (|optimize| (cdr x)) - (cond - ((eq argl '|ignore|) (rplac (car x) body)) - (t - (when (null (<= (length argl) (length a))) - (say "length mismatch in XLAM expression") - (prettyprint y)) - (rplac (car x) - (|optimize| - (|optXLAMCond| - (sublis (|pairList| argl a) body))))))) - ((atom y) - (|optimize| (cdr x)) - (cond - ((eq y '|true|) (rplac (car x) '''T)) - ((eq y '|false|) (rplac (car x) nil)))) - ((eq (car y) 'if) - (rplac (car x) (|optIF2COND| y)) - (setq y (car x)) - (when (setq op (getl (|subrname| (car y)) 'optimize)) - (|optimize| (cdr x)) - (rplac (car x) (funcall op (|optimize| (car x)))))) - ((setq op (getl (|subrname| (car y)) 'optimize)) - (|optimize| (cdr x)) - (rplac (car x) (funcall op (|optimize| (car x))))) - (t - (rplac (car x) (|optimize| (car x))) - (|optimize| (cdr x))))))) - (opt x) - x)) + (fn (x) + (if (and (consp x) (consp (qrest x)) + (consp (qcddr x)) (eq (qcdddr x) nil) + (not (eq (qfirst x) '|isFreeFunction|)) + (atom (qthird x))) + (list (first x) (second x) (list (third x))) + x))) + (let (pattern dc sig mmpat patternAlist partial patvars + domainPredicateList tmp1 pred dependList cond) + (declare (special |$PatternVariableList| |$FormalMapVariableList|)) + (setq mm + (|replaceVars| (copy mm) |$PatternVariableList| |$FormalMapVariableList|)) + (setq pattern (car mm)) + (setq dc (caar mm)) + (setq sig (cdar mm)) + (setq pred (cadr mm)) + (setq pred + (prog () + (return + (do ((x pred (cdr x)) (result nil)) + ((atom x) (nreverse0 result)) + (setq result (cons (fn (car x)) result)))))) + (setq tmp1 (|modemapPattern| pattern sig)) + (setq mmpat (car tmp1)) + (setq patternAlist (cadr tmp1)) + (setq partial (caddr tmp1)) + (setq patvars (cadddr tmp1)) + (setq tmp1 (|substVars| pred patternAlist patvars)) + (setq pred (car tmp1)) + (setq domainPredicateList (cadr tmp1)) + (setq tmp1 (|fixUpPredicate| pred domainPredicateList partial (cdr mmpat))) + (setq pred (car tmp1)) + (setq dependList (cdr tmp1)) + (setq cond (car pred)) + (list mmpat cond)))) \end{chunk} -\defun{optXLAMCond}{optXLAMCond} -\calls{optXLAMCond}{optCONDtail} -\calls{optXLAMCond}{optPredicateIfTrue} -\calls{optXLAMCond}{optXLAMCond} -\calls{optXLAMCond}{qcar} -\calls{optXLAMCond}{qcdr} -\calls{optXLAMCond}{rplac} -\begin{chunk}{defun optXLAMCond} -(defun |optXLAMCond| (x) - (cond - ((and (consp x) (eq (qfirst x) 'cond) (consp (qrest x)) - (consp (qsecond x)) (consp (qcdadr x)) - (eq (qcddadr x) nil)) - (if (|optPredicateIfTrue| (qcaadr x)) - (qcadadr x) - (cons 'cond (cons (qsecond x) (|optCONDtail| (qcddr x)))))) - ((atom x) x) +\defun{replaceVars}{replaceVars} +Replace every identifier in oldvars with the corresponding +identifier in newvars in the expression x +\begin{chunk}{defun replaceVars} +(defun |replaceVars| (x oldvars newvars) + (loop for old in oldvars for new in newvars + do (setq x (subst new old x :test #'equal))) + x) + +\end{chunk} + +\defun{fixUpPredicate}{fixUpPredicate} +\calls{fixUpPredicate}{length} +\calls{fixUpPredicate}{orderPredicateItems} +\calls{fixUpPredicate}{moveORsOutside} +\begin{chunk}{defun fixUpPredicate} +(defun |fixUpPredicate| (predClause domainPreds partial sig) + (let (predicate fn skip predicates tmp1 dependList pred) + (setq predicate (car predClause)) + (setq fn (cadr predClause)) + (setq skip (cddr predClause)) + (cond + ((eq (car predicate) 'and) + (setq predicates (append domainPreds (cdr predicate)))) + ((not (equal predicate (mkq t))) + (setq predicates (cons predicate domainPreds))) (t - (rplac (car x) (|optXLAMCond| (car x))) - (rplac (cdr x) (|optXLAMCond| (cdr x))) - x))) + (setq predicates (or domainPreds (list predicate))))) + (cond + ((> (|#| predicates) 1) + (setq pred (cons 'and predicates)) + (setq tmp1 (|orderPredicateItems| pred sig skip)) + (setq pred (car tmp1)) + (setq dependlist (cdr tmp1)) + tmp1) + (t + (setq pred (|orderPredicateItems| (car predicates) sig skip)) + (setq dependList + (when (and (consp pred) (eq (qfirst pred) '|isDomain|) + (consp (qrest pred)) (consp (qcddr pred)) + (eq (qcdddr pred) nil) + (consp (qthird pred)) + (eq (qcdaddr pred) nil)) + (list (second pred)))))) + (setq pred (|moveORsOutside| pred)) + (when partial (setq pred (cons '|partial| pred))) + (cons (cons pred (cons fn skip)) dependList))) \end{chunk} -\defun{optCONDtail}{optCONDtail} -\calls{optCONDtail}{optCONDtail} -\refsdollar{optCONDtail}{true} -\begin{chunk}{defun optCONDtail} -(defun |optCONDtail| (z) - (declare (special |$true|)) - (when z +\defun{orderPredicateItems}{orderPredicateItems} +\calls{orderPredicateItems}{signatureTran} +\calls{orderPredicateItems}{orderPredTran} +\begin{chunk}{defun orderPredicateItems} +(defun |orderPredicateItems| (pred1 sig skip) + (let (pred) + (setq pred (|signatureTran| pred1)) + (if (and (consp pred) (eq (qfirst pred) 'and)) + (|orderPredTran| (qrest pred) sig skip) + pred))) + +\end{chunk} + +\defun{signatureTran}{signatureTran} +\calls{signatureTran}{signatureTran} +\calls{signatureTran}{isCategoryForm} +\refsdollar{signatureTran}{e} +\begin{chunk}{defun signatureTran} +(defun |signatureTran| (pred) + (declare (special |$e|)) (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))))))) + ((atom pred) pred) + ((and (consp pred) (eq (qfirst pred) '|has|) (CONSP (qrest pred)) + (consp (qcddr pred)) + (eq (qcdddr pred) nil) + (|isCategoryForm| (third pred) |$e|)) + (list '|ofCategory| (second pred) (third pred))) + (t + (loop for p in pred + collect (|signatureTran| p))))) \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)) +\defun{orderPredTran}{orderPredTran} +\calls{orderPredTran}{member} +\calls{orderPredTran}{delete} +\calls{orderPredTran}{unionq} +\calls{orderPredTran}{listOfPatternIds} +\calls{orderPredTran}{intersectionq} +\calls{orderPredTran}{setdifference} +\calls{orderPredTran}{insertWOC} +\calls{orderPredTran}{isDomainSubst} +\begin{chunk}{defun orderPredTran} +(defun |orderPredTran| (oldList sig skip) + (let (lastDependList somethingDone lastPreds indepvl depvl dependList + noldList x ids fullDependList newList answer) +; --(1) make two kinds of predicates appear last: +; ----- (op *target ..) when *target does not appear later in sig +; ----- (isDomain *1 ..) + (SEQ + (loop for pred in oldList + do (cond + ((or (and (consp pred) (consp (qrest pred)) + (consp (qcddr pred)) + (eq (qcdddr pred) nil) + (member (qfirst pred) '(|isDomain| |ofCategory|)) + (equal (qsecond pred) (car sig)) + (null (|member| (qsecond pred) (cdr sig)))) + (and (null skip) (consp pred) (eq (qfirst pred) '|isDomain|) + (consp (qrest pred)) (consp (qcddr pred)) + (eq (qcdddr pred) nil) + (equal (qsecond pred) '*1))) + (setq oldList (|delete| pred oldList)) + (setq lastPreds (cons pred lastPreds))))) +; --(2a) lastDependList=list of all variables that lastPred forms depend upon + (setq lastDependList + (let (result) + (loop for x in lastPreds + do (setq result (unionq result (|listOfPatternIds| x)))) + result)) +; --(2b) dependList=list of all variables that isDom/ofCat forms depend upon + (setq dependList + (let (result) + (loop for x in oldList + do (when + (and (consp x) + (or (eq (qfirst x) '|isDomain|) (eq (qfirst x) '|ofCategory|)) + (consp (qrest x)) (consp (qcddr x)) + (eq (qcdddr x) nil)) + (setq result (unionq result (|listOfPatternIds| (third x)))))) + result)) +; --(3a) newList= list of ofCat/isDom entries that don't depend on + (loop for x in oldList + do + (cond + ((and (consp x) + (or (eq (qfirst x) '|ofCategory|) (eq (qfirst x) '|isDomain|)) + (consp (qrest x)) (consp (qcddr x)) + (eq (qcdddr x) nil)) + (setq indepvl (|listOfPatternIds| (second x))) + (setq depvl (|listOfPatternIds| (third x)))) + (t + (setq indepvl (|listOfPatternIds| x)) + (setq depvl nil))) + (when + (and (null (intersectionq indepvl dependList)) + (intersectionq indepvl lastDependList)) + (setq somethingDone t) + (setq lastPreds (append lastPreds (list x))) + (setq oldList (|delete| x oldList)))) +; --(3b) newList= list of ofCat/isDom entries that don't depend on + (loop while oldList do + (loop for x in oldList do + (cond + ((and (consp x) + (or (eq (qfirst x) '|ofCategory|) (eq (qfirst x) '|isDomain|)) + (consp (qrest x)) + (consp (qcddr x)) (eq (qcdddr x) nil)) + (setq indepvl (|listOfPatternIds| (second x))) + (setq depvl (|listOfPatternIds| (third x)))) + (t + (setq indepvl (|listOfPatternIds| x)) + (setq depvl nil))) + (when (null (intersectionq indepvl dependList)) + (setq dependList (SETDIFFERENCE dependList depvl)) + (setq newList (APPEND newList (list x))))) +; --(4) noldList= what is left over + (cond + ((equal (setq noldList (setdifference oldList newList)) oldList) + (setq newList (APPEND newList oldList)) + (return nil)) + (t + (setq oldList noldList)))) + (loop for pred in newList do + (when + (and (consp pred) + (or (eq (qfirst pred) '|isDomain|) (eq (qfirst x) '|ofCategory|)) + (consp (qrest pred)) + (consp (qcddr pred)) + (eq (qcdddr pred) nil)) + (setq ids (|listOfPatternIds| (third pred))) + (when + (let (result) + (loop for id in ids do + (setq result (and result (|member| id fullDependList)))) + result) + (setq fullDependList (|insertWOC| (second pred) fullDependList))) + (setq fullDependList (unionq fullDependList ids)))) + (setq newList (append newList lastPreds)) + (setq newList (|isDomainSubst| newList)) + (setq answer + (cons (cons 'and newList) (intersectionq fullDependList sig)))))) + +\end{chunk} + +\defun{isDomainSubst}{isDomainSubst} +\begin{chunk}{defun isDomainSubst} +(defun |isDomainSubst| (u) + (labels ( + (findSub (x alist) + (cond + ((null alist) nil) + ((and (consp alist) (consp (qfirst alist)) + (eq (qcaar alist) '|isDomain|) + (consp (qcdar alist)) + (consp (qcddar alist)) + (eq (qcdddar alist) nil) + (equal x (cadar alist))) + (caddar alist)) + (t (findSub x (cdr alist))))) + (fn (x alist) + (let (s) + (declare (special |$PatternVariableList|)) + (if (atom x) + (if + (and (identp x) + (member x |$PatternVariableList|) + (setq s (findSub x alist))) + s + x) + (cons (car x) + (loop for y in (cdr x) + collect (fn y alist))))))) + (let (head tail nhead) + (if (consp u) + (progn + (setq head (qfirst u)) + (setq tail (qrest u)) + (setq nhead + (cond + ((and (consp head) (eq (qfirst head) '|isDomain|) + (consp (qrest head)) (consp (qcddr head)) + (eq (qcdddr head) nil)) + (list '|isDomain| (second head) + (fn (third head) tail))) + (t head))) + (cons nhead (|isDomainSubst| (cdr u)))) + u)))) \end{chunk} -\defun{optPredicateIfTrue}{optPredicateIfTrue} -\refsdollar{optPredicateIfTrue}{BasicPredicates} -\begin{chunk}{defun optPredicateIfTrue} -(defun |optPredicateIfTrue| (p) - (declare (special |$BasicPredicates|)) +\defun{moveORsOutside}{moveORsOutside} +\calls{moveORsOutside}{moveORsOutside} +\begin{chunk}{defun moveORsOutside} +(defun |moveORsOutside| (p) + (let (q x) (cond - ((and (consp p) (eq (qfirst p) 'quote)) T) - ((and (consp p) (consp (qrest p)) (eq (qcddr p) nil) - (member (qfirst p) |$BasicPredicates|) (funcall (qfirst p) (qsecond p))) - t) - (t nil))) - -\end{chunk} + ((and (consp p) (eq (qfirst p) 'and)) + (setq q + (prog (G167169) + (return + (do ((G167174 (cdr p) (cdr G167174)) (|r| nil)) + ((or (atom G167174)) (nreverse0 G167169)) + (setq |r| (CAR G167174)) + (setq G167169 (cons (|moveORsOutside| |r|) G167169)))))) + (cond + ((setq x + (let (tmp1) + (loop for r in q + when (and (consp r) (eq (qfirst r) 'or)) + do (setq tmp1 (or tmp1 r))) + tmp1)) + (|moveORsOutside| + (cons 'or + (let (tmp1) + (loop for tt in (cdr x) + do (setq tmp1 (cons (cons 'and (subst tt x q :test #'equal)) tmp1))) + (nreverse0 tmp1))))) + (t (cons 'and q)))) + (t p)))) -\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 (consp c) (eq (qfirst c) 'if)) - (cons 'cond (cons (list a b) (cdr (|optIF2COND| c))))) - ((and (consp c) (eq (qfirst c) 'cond)) - (cons 'cond (cons (list a b) (qrest c)))) - (t - (list 'cond (list a b) (list |$true| c)))))) +;(defun |moveORsOutside| (p) +; (let (q s x tmp1) +; (cond +; ((and (consp p) (eq (qfirst p) 'and)) +; (setq q (loop for r in (qrest p) collect (|moveORsOutside| r))) +; (setq tmp1 +; (loop for r in q +; when (and (consp r) (eq (qrest r) 'or)) +; collect r)) +; (setq x (mapcar #'(lambda (a b) (or a b)) tmp1)) +; (if x +; (|moveORsOutside| +; (cons 'or +; (loop for tt in (cdr x) +; collect (cons 'and (subst tt x q :test #'equal))))) +; (cons 'and q))) +; ('t p)))) \end{chunk} -\defun{subrname}{subrname} -\calls{subrname}{identp} -\calls{subrname}{compiled-function-p} -\calls{subrname}{mbpip} -\calls{subrname}{bpiname} -\begin{chunk}{defun subrname} -(defun |subrname| (u) - (cond - ((identp u) u) - ((or (compiled-function-p u) (mbpip u)) (bpiname u)) - (t nil))) +\defun{substVars}{substVars} +Make pattern variable substitutions. +\calls{substVars}{nsubst} +\calls{substVars}{contained} +\refsdollar{substVars}{FormalMapVariableList} +\begin{chunk}{defun substVars} +(defun |substVars| (pred patternAlist patternVarList) + (let (patVar value everything replacementVar domainPredicates) + (declare (special |$FormalMapVariableList|)) + (setq domainPredicates NIL) + (maplist + #'(lambda (x) + (setq patVar (caar x)) + (setq value (cdar x)) + (setq pred (subst patVar value pred :test #'equal)) + (setq patternAlist (|nsubst| patVar value patternAlist)) + (setq domainPredicates + (subst patVar value domainPredicates :test #'equal)) + (unless (member value |$FormalMapVariableList|) + (setq domainPredicates + (cons (list '|isDomain| patVar value) domainPredicates)))) + patternAlist) + (setq everything (list pred patternAlist domainPredicates)) + (dolist (var |$FormalMapVariableList|) + (cond + ((contained var everything) + (setq replacementVar (car patternVarList)) + (setq patternVarList (cdr patternVarList)) + (setq pred (subst replacementVar var pred :test #'equal)) + (setq domainPredicates + (subst replacementVar var domainPredicates :test #'equal))))) + (list pred domainPredicates))) \end{chunk} -\subsection{Special case optimizers} -Optimization functions are called through the OPTIMIZE property on the -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. +\defun{modemapPattern}{modemapPattern} +\calls{modemapPattern}{rassoc} +\refsdollar{modemapPattern}{PatternVariableList} +\begin{chunk}{defun modemapPattern} +(defun |modemapPattern| (mmPattern sig) + (let (partial patvar patvars mmpat patternAlist) + (declare (special |$PatternVariableList|)) + (setq patternAlist nil) + (setq mmpat nil) + (setq patvars |$PatternVariableList|) + (setq partial nil) + (maplist + #'(lambda (xTails) + (let ((x (car xTails))) + (when (and (consp x) (eq (qfirst x) '|Union|) + (consp (qrest x)) (consp (qcddr x)) + (eq (qcdddr x) nil) + (equal (third x) "failed") + (equal xTails sig)) + (setq x (second x)) + (setq partial t)) + (setq patvar (|rassoc| x patternAlist)) + (cond + ((null (null patvar)) + (setq mmpat (cons patvar mmpat))) + (t + (setq patvar (car patvars)) + (setq patvars (cdr patvars)) + (setq mmpat (cons patvar mmpat)) + (setq patternAlist (cons (cons patvar x) patternAlist)))))) + mmPattern) + (list (nreverse mmpat) patternAlist partial patvars))) -Not all of the optimization routines are called through the property -list. Some are called only from other optimization routines, e.g. -optPackageCall. +\end{chunk} -\defplist{call}{optCall} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get '|call| 'optimize) '|optCall|)) +\defun{evalAndRwriteLispForm}{evalAndRwriteLispForm} +\calls{evalAndRwriteLispForm}{eval} +\calls{evalAndRwriteLispForm}{rwriteLispForm} +\begin{chunk}{defun evalAndRwriteLispForm} +(defun |evalAndRwriteLispForm| (key form) + (|eval| form) + (|rwriteLispForm| key form)) \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 (consp fn) (eq (qfirst fn) 'pac)) (|optPackageCall| x fn a)) - ((and (consp fn) (eq (qfirst fn) '|applyFun|) - (consp (qrest fn)) (eq (qcddr fn) nil)) - (setq name (qsecond fn)) - (rplac (car x) 'spadcall) - (rplac (cdr x) (append a (cons name nil))) - x) - ((and (consp fn) (consp (qrest fn)) (consp (qcddr fn)) - (eq (qcdddr fn) nil) - (member (qfirst fn) '(elt qrefelt const))) - (setq q (qfirst fn)) - (setq r (qsecond fn)) - (setq n (qthird 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"))))))) +\defun{rwriteLispForm}{rwriteLispForm} +\refsdollar{rwriteLispForm}{libFile} +\refsdollar{rwriteLispForm}{lisplib} +\begin{chunk}{defun rwriteLispForm} +(defun |rwriteLispForm| (key form) + (declare (special |$libFile| $lisplib)) + (when $lisplib + (|rwrite| key form |$libFile|) + (|LAM,FILEACTQ| key form))) \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)) +\defun{mkConstructor}{mkConstructor} +\calls{mkConstructor}{mkConstructor} +\begin{chunk}{defun mkConstructor} +(defun |mkConstructor| (form) + (cond + ((atom form) (list '|devaluate| form)) + ((null (rest form)) (list 'quote (list (first form)))) + (t + (cons 'list + (cons (mkq (first form)) + (loop for x in (rest form) collect (|mkConstructor| 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 (consp zp) (eq (qfirst zp) 'let) (consp (qrest zp)) - (equal (qsecond zp) a) (consp (qcddr zp))) - (qthird 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))))) +\defun{unloadOneConstructor}{unloadOneConstructor} +\calls{unloadOneConstructor}{remprop} +\calls{unloadOneConstructor}{mkAutoLoad} +\begin{chunk}{defun unloadOneConstructor} +(defun |unloadOneConstructor| (cnam fn) + (remprop cnam 'loaded) + (setf (symbol-function cnam) (|mkAutoLoad| fn cnam))) \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 (consp fn) (eq (qfirst fn) 'xlam)) - (setq x (car (|optimize| (list x))))) - (if (and (consp x) (eq (qfirst x) 'equal) (progn (setq args (qrest 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)))) +\defun{lisplibDoRename}{lisplibDoRename} +\calls{lisplibDoRename}{replaceFile} +\refsdollar{lisplibDoRename}{spadLibFT} +\begin{chunk}{defun lisplibDoRename} +(defun |lisplibDoRename| (libName) + (declare (special |$spadLibFT|)) + (replaceFile (list libName |$spadLibFT| 'a) (list libName 'errorlib 'a))) + +\end{chunk} + +\defun{initializeLisplib}{initializeLisplib} +\calls{initializeLisplib}{erase} +\calls{initializeLisplib}{writeLib1} +\calls{initializeLisplib}{addoptions} +\calls{initializeLisplib}{pathnameTypeId} +\calls{initializeLisplib}{LAM,FILEACTQ} +\refsdollar{initializeLisplib}{erase} +\refsdollar{initializeLisplib}{libFile} +\defsdollar{initializeLisplib}{libFile} +\defsdollar{initializeLisplib}{lisplibForm} +\defsdollar{initializeLisplib}{lisplibModemap} +\defsdollar{initializeLisplib}{lisplibKind} +\defsdollar{initializeLisplib}{lisplibModemapAlist} +\defsdollar{initializeLisplib}{lisplibAbbreviation} +\defsdollar{initializeLisplib}{lisplibAncestors} +\defsdollar{initializeLisplib}{lisplibOpAlist} +\defsdollar{initializeLisplib}{lisplibOperationAlist} +\defsdollar{initializeLisplib}{lisplibSuperDomain} +\defsdollar{initializeLisplib}{lisplibVariableAlist} +\defsdollar{initializeLisplib}{lisplibSignatureAlist} +\uses{initializeLisplib}{/editfile} +\uses{initializeLisplib}{/major-version} +\uses{initializeLisplib}{errors} +\begin{chunk}{defun initializeLisplib} +(defun |initializeLisplib| (libName) + (declare (special $erase |$libFile| |$lisplibForm| + |$lisplibModemap| |$lisplibKind| |$lisplibModemapAlist| + |$lisplibAbbreviation| |$lisplibAncestors| + |$lisplibOpAlist| |$lisplibOperationAlist| + |$lisplibSuperDomain| |$lisplibVariableAlist| errors + |$lisplibSignatureAlist| /editfile /major-version errors)) + ($erase libName 'errorlib 'a) + (setq errors 0) + (setq |$libFile| (|writeLib1| libname 'errorlib 'a)) + (addoptions 'file |$libFile|) + (setq |$lisplibForm| nil) + (setq |$lisplibModemap| nil) + (setq |$lisplibKind| nil) + (setq |$lisplibModemapAlist| nil) + (setq |$lisplibAbbreviation| nil) + (setq |$lisplibAncestors| nil) + (setq |$lisplibOpAlist| nil) + (setq |$lisplibOperationAlist| nil) + (setq |$lisplibSuperDomain| nil) + (setq |$lisplibVariableAlist| nil) + (setq |$lisplibSignatureAlist| nil) + (when (eq (|pathnameTypeId| /editfile) 'spad) + (|LAM,FILEACTQ| 'version (list '/versioncheck /major-version)))) + +\end{chunk} + +\defun{writeLib1}{writeLib1} +\calls{writeLib1}{rdefiostream} +\begin{chunk}{defun writeLib1} +(defun |writeLib1| (fn ft fm) + (rdefiostream (cons (list 'file fn ft fm) (list '(mode . output))))) + +\end{chunk} + + +\defun{finalizeLisplib}{finalizeLisplib} +\calls{finalizeLisplib}{lisplibWrite} +\calls{finalizeLisplib}{removeZeroOne} +\calls{finalizeLisplib}{namestring} +\calls{finalizeLisplib}{getConstructorOpsAndAtts} +\calls{finalizeLisplib}{NRTgenInitialAttributeAlist} +\calls{finalizeLisplib}{mergeSignatureAndLocalVarAlists} +\calls{finalizeLisplib}{finalizeDocumentation} +\calls{finalizeLisplib}{profileWrite} +\calls{finalizeLisplib}{sayMSG} +\refsdollar{finalizeLisplib}{lisplibForm} +\refsdollar{finalizeLisplib}{libFile} +\refsdollar{finalizeLisplib}{lisplibKind} +\refsdollar{finalizeLisplib}{lisplibModemap} +\refsdollar{finalizeLisplib}{lisplibCategory} +\refsdollar{finalizeLisplib}{/editfile} +\refsdollar{finalizeLisplib}{lisplibModemapAlist} +\refsdollar{finalizeLisplib}{lisplibForm} +\refsdollar{finalizeLisplib}{lisplibModemap} +\refsdollar{finalizeLisplib}{FormalMapVariableList} +\refsdollar{finalizeLisplib}{lisplibSuperDomain} +\refsdollar{finalizeLisplib}{lisplibSignatureAlist} +\refsdollar{finalizeLisplib}{lisplibVariableAlist} +\refsdollar{finalizeLisplib}{lisplibAttributes} +\refsdollar{finalizeLisplib}{lisplibPredicates} +\refsdollar{finalizeLisplib}{lisplibAbbreviation} +\refsdollar{finalizeLisplib}{lisplibParents} +\refsdollar{finalizeLisplib}{lisplibAncestors} +\refsdollar{finalizeLisplib}{lisplibSlot1} +\refsdollar{finalizeLisplib}{profileCompiler} +\refsdollar{finalizeLisplib}{spadLibFT} +\defsdollar{finalizeLisplib}{lisplibCategory} +\defsdollar{finalizeLisplib}{pairlis} +\defsdollar{finalizeLisplib}{NRTslot1PredicateList} +\begin{chunk}{defun finalizeLisplib} +(defun |finalizeLisplib| (libName) + (let (|$pairlis| |$NRTslot1PredicateList| kind opsAndAtts) + (declare (special |$pairlis| |$NRTslot1PredicateList| |$spadLibFT| + |$lisplibForm| |$profileCompiler| |$libFile| + |$lisplibSlot1| |$lisplibAncestors| |$lisplibParents| + |$lisplibAbbreviation| |$lisplibPredicates| + |$lisplibAttributes| |$lisplibVariableAlist| + |$lisplibSignatureAlist| |$lisplibSuperDomain| + |$FormalMapVariableList| |$lisplibModemap| + |$lisplibModemapAlist| /editfile |$lisplibCategory| + |$lisplibKind| errors)) + (|lisplibWrite| "constructorForm" + (|removeZeroOne| |$lisplibForm|) |$libFile|) + (|lisplibWrite| "constructorKind" + (setq kind (|removeZeroOne| |$lisplibKind|)) |$libFile|) + (|lisplibWrite| "constructorModemap" + (|removeZeroOne| |$lisplibModemap|) |$libFile|) + (setq |$lisplibCategory| (or |$lisplibCategory| (cadar |$lisplibModemap|))) + (|lisplibWrite| "constructorCategory" |$lisplibCategory| |$libFile|) + (|lisplibWrite| "sourceFile" (|namestring| /editfile) |$libFile|) + (|lisplibWrite| "modemaps" + (|removeZeroOne| |$lisplibModemapAlist|) |$libFile|) + (setq opsAndAtts + (|getConstructorOpsAndAtts| |$lisplibForm| kind |$lisplibModemap|)) + (|lisplibWrite| "operationAlist" + (|removeZeroOne| (car opsAndAtts)) |$libFile|) + (when (eq kind '|category|) + (setq |$pairlis| + (loop for a in (rest |$lisplibForm|) + for v in |$FormalMapVariableList| + collect (cons a v))) + (setq |$NRTslot1PredicateList| nil) + (|NRTgenInitialAttributeAlist| (cdr opsAndAtts))) + (|lisplibWrite| "superDomain" + (|removeZeroOne| |$lisplibSuperDomain|) |$libFile|) + (|lisplibWrite| "signaturesAndLocals" + (|removeZeroOne| + (|mergeSignatureAndLocalVarAlists| |$lisplibSignatureAlist| + |$lisplibVariableAlist|)) + |$libFile|) + (|lisplibWrite| "attributes" + (|removeZeroOne| |$lisplibAttributes|) |$libFile|) + (|lisplibWrite| "predicates" + (|removeZeroOne| |$lisplibPredicates|) |$libFile|) + (|lisplibWrite| "abbreviation" |$lisplibAbbreviation| |$libFile|) + (|lisplibWrite| "parents" (|removeZeroOne| |$lisplibParents|) |$libFile|) + (|lisplibWrite| "ancestors" (|removeZeroOne| |$lisplibAncestors|) |$libFile|) + (|lisplibWrite| "documentation" (|finalizeDocumentation|) |$libFile|) + (|lisplibWrite| "slot1Info" (|removeZeroOne| |$lisplibSlot1|) |$libFile|) + (when |$profileCompiler| (|profileWrite|)) + (when (and |$lisplibForm| (null (cdr |$lisplibForm|))) + (setf (get (car |$lisplibForm|) 'niladic) t)) + (unless (eql errors 0) + (|sayMSG| (list " Errors in processing " kind " " libName ":")) + (|sayMSG| (list " not replacing " |$spadLibFT| " for" libName))))) \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)))) +\defun{getConstructorOpsAndAtts}{getConstructorOpsAndAtts} +\calls{getConstructorOpsAndAtts}{getCategoryOpsAndAtts} +\calls{getConstructorOpsAndAtts}{getFunctorOpsAndAtts} +\begin{chunk}{defun getConstructorOpsAndAtts} +(defun |getConstructorOpsAndAtts| (form kind modemap) + (if (eq kind '|category|) + (|getCategoryOpsAndAtts| form) + (|getFunctorOpsAndAtts| form modemap))) \end{chunk} -\defun{optCallEval}{optCallEval} -\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 (consp u) (eq (qfirst u) '|List|)) - (|List| (|Integer|))) - ((and (consp u) (eq (qfirst u) '|Vector|)) - (|Vector| (|Integer|))) - ((and (consp u) (eq (qfirst u) '|PrimitiveArray|)) - (|PrimitiveArray| (|Integer|))) - ((and (consp u) (eq (qfirst u) '|FactoredForm|)) - (|FactoredForm| (|Integer|))) - ((and (consp u) (eq (qfirst u) '|Matrix|)) - (|Matrix| (|Integer|))) - (t - (|eval| u)))) +\defun{getCategoryOpsAndAtts}{getCategoryOpsAndAtts} +\calls{getCategoryOpsAndAtts}{transformOperationAlist} +\calls{getCategoryOpsAndAtts}{getSlotFromCategoryForm} +\calls{getCategoryOpsAndAtts}{getSlotFromCategoryForm} +\begin{chunk}{defun getCategoryOpsAndAtts} +(defun |getCategoryOpsAndAtts| (catForm) + (cons (|transformOperationAlist| (|getSlotFromCategoryForm| catForm 1)) + (|getSlotFromCategoryForm| catForm 2))) \end{chunk} -\defplist{seq}{optSEQ} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get 'seq 'optimize) '|optSEQ|)) +\defun{getSlotFromCategoryForm}{getSlotFromCategoryForm} +\calls{getSlotFromCategoryForm}{eval} +\calls{getSlotFromCategoryForm}{take} +\calls{getSlotFromCategoryForm}{systemErrorHere} +\refsdollar{getSlotFromCategoryForm}{FormalMapVariableList} +\begin{chunk}{defun getSlotFromCategoryForm} +(defun |getSlotFromCategoryForm| (opargs index) + (let (op argl u) + (declare (special |$FormalMapVariableList|)) + (setq op (first opargs)) + (setq argl (rest opargs)) + (setq u + (|eval| (cons op (mapcar 'mkq (take (|#| argl) |$FormalMapVariableList|))))) + (if (null (vecp u)) + (|systemErrorHere| "getSlotFromCategoryForm") + (elt u index)))) \end{chunk} -\defun{optSEQ}{optSEQ} -\begin{chunk}{defun optSEQ} -(defun |optSEQ| (arg) - (labels ( - (tryToRemoveSEQ (z) - (if (and (consp z) (eq (qfirst z) 'seq) (consp (qrest z)) - (eq (qcddr z) nil) (consp (qsecond z)) - (consp (qcdadr z)) - (eq (qcddadr z) nil) - (member (qcaadr z) '(exit return throw))) - (qcadadr z) - z)) - (SEQToCOND (z) - (let (transform before aft) - (setq transform - (loop for x in z - while - (and (consp x) (eq (qfirst x) 'cond) (consp (qrest x)) - (eq (qcddr x) nil) (consp (qsecond x)) - (consp (qcdadr x)) - (eq (qcddadr x) nil) - (consp (qcadadr x)) - (eq (qfirst (qcadadr x)) 'exit) - (consp (qrest (qcadadr x))) - (eq (qcddr (qcadadr x)) nil)) - collect - (list (qcaadr x) - (qsecond (qcadadr 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) +\defun{transformOperationAlist}{transformOperationAlist} +This transforms the operationAlist which is written out onto LISPLIBs. +The original form of this list is a list of items of the form: +\begin{verbatim} + (( ) ( (ELT $ n))) +\end{verbatim} +The new form is an op-Alist which has entries +\begin{verbatim} + ( . signature-Alist) +\end{verbatim} +where signature-Alist has entries +\begin{verbatim} + ( . item) +\end{verbatim} +where item has form +\begin{verbatim} + ( ) +\end{verbatim} +\begin{verbatim} + where = + NIL => function + CONST => constant ... and others +\end{verbatim} +\calls{transformOperationAlist}{member} +\calls{transformOperationAlist}{keyedSystemError} +\calls{transformOperationAlist}{assoc} +\calls{transformOperationAlist}{lassq} +\calls{transformOperationAlist}{insertAlist} +\refsdollar{transformOperationAlist}{functionLocations} +\begin{chunk}{defun transformOperationAlist} +(defun |transformOperationAlist| (operationAlist) + (let (op sig condition implementation eltEtc impOp kind u n signatureItem + itemList newAlist) + (declare (special |$functionLocations|)) + (setq newAlist nil) + (dolist (item operationAlist) + (setq op (caar item)) + (setq sig (cadar item)) + (setq condition (cadr item)) + (setq implementation (caddr item)) + (setq kind (cond - ((null z) nil) - ((and (consp z) (consp (qfirst z)) (eq (qcaar z) 'let) - (consp (qcdar z)) (consp (qcddar z)) - (gensymp (qcadar z)) - (> 2 (|numOfOccurencesOf| (qcadar z) (qrest z)))) - (setq g (qcadar z)) - (setq x (qcaddar z)) - (setq r (qrest z)) - (getRidOfTemps (subst x g r :test #'equal))) - ((eq (car z) '|/throwAway|) - (getRidOfTemps (cdr z))) - (t - (cons (car z) (getRidOfTemps (cdr z)))))))) - (tryToRemoveSEQ (SEQToCOND (getRidOfTemps (cdr arg)))))) + ((and (consp implementation) (consp (qrest implementation)) + (consp (qcddr implementation)) + (eq (qcdddr implementation) nil) + (progn (setq n (qthird implementation)) t) + (|member| (setq eltEtc (qfirst implementation)) '(const elt))) + eltEtc) + ((consp implementation) + (setq impOp (qfirst implementation)) + (cond + ((eq impop 'xlam) implementation) + ((|member| impOp '(const |Subsumed|)) impOp) + (t (|keyedSystemError| 's2il0025 (list impop))))) + ((eq implementation '|mkRecord|) '|mkRecord|) + (t (|keyedSystemError| 's2il0025 (list implementation))))) + (when (setq u (|assoc| (list op sig) |$functionLocations|)) + (setq n (cons n (cdr u)))) + (setq signatureItem + (if (eq kind 'elt) + (if (eq condition t) + (list sig n) + (list sig n condition)) + (list sig n condition kind))) + (setq itemList (cons signatureItem (lassq op newAlist))) + (setq newAlist (|insertAlist| op itemList newAlist))) + newAlist)) \end{chunk} -\defplist{eq}{optEQ} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get 'eq 'optimize) '|optEQ|)) +\defun{getFunctorOpsAndAtts}{getFunctorOpsAndAtts} +\calls{getFunctorOpsAndAtts}{transformOperationAlist} +\calls{getFunctorOpsAndAtts}{getSlotFromFunctor} +\begin{chunk}{defun getFunctorOpsAndAtts} +(defun |getFunctorOpsAndAtts| (form modemap) + (cons (|transformOperationAlist| (|getSlotFromFunctor| form 1 modemap)) + (|getSlotFromFunctor| form 2 modemap))) \end{chunk} -\defun{optEQ}{optEQ} -\begin{chunk}{defun optEQ} -(defun |optEQ| (u) - (let (z r) +\defun{getSlotFromFunctor}{getSlotFromFunctor} +\calls{getSlotFromFunctor}{compMakeCategoryObject} +\calls{getSlotFromFunctor}{systemErrorHere} +\refsdollar{getSlotFromFunctor}{e} +\refsdollar{getSlotFromFunctor}{lisplibOperationAlist} +\begin{chunk}{defun getSlotFromFunctor} +(defun |getSlotFromFunctor| (arg1 slot arg2) + (declare (ignore arg1)) + (let (tt) + (declare (special |$e| |$lisplibOperationAlist|)) + (cond + ((eql slot 1) |$lisplibOperationAlist|) + (t + (setq tt (or (|compMakeCategoryObject| (cadar arg2) |$e|) + (|systemErrorHere| "getSlotFromFunctor"))) + (elt (car tt) slot))))) + +\end{chunk} + +\defun{compMakeCategoryObject}{compMakeCategoryObject} +\calls{compMakeCategoryObject}{isCategoryForm} +\calls{compMakeCategoryObject}{mkEvalableCategoryForm} +\refsdollar{compMakeCategoryObject}{e} +\refsdollar{compMakeCategoryObject}{Category} +\begin{chunk}{defun compMakeCategoryObject} +(defun |compMakeCategoryObject| (c |$e|) + (declare (special |$e|)) + (let (u) + (declare (special |$Category|)) (cond - ((and (consp u) (eq (qfirst u) 'eq) (consp (qrest u)) - (consp (qcddr u)) (eq (qcdddr u) nil)) - (setq z (qsecond u)) - (setq r (qthird 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)))) + ((null (|isCategoryForm| c |$e|)) nil) + ((setq u (|mkEvalableCategoryForm| c)) (list (|eval| u) |$Category| |$e|)) + (t nil)))) \end{chunk} -\defplist{minus}{optMINUS} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get 'minus 'optimize) '|optMINUS|)) +\defun{mergeSignatureAndLocalVarAlists}{mergeSignatureAndLocalVarAlists} +\calls{mergeSignatureAndLocalVarAlists}{lassoc} +\begin{chunk}{defun mergeSignatureAndLocalVarAlists} +(defun |mergeSignatureAndLocalVarAlists| (signatureAlist localVarAlist) + (loop for item in signatureAlist + collect + (cons (first item) + (cons (rest item) + (lassoc (first item) localVarAlist))))) \end{chunk} -\defun{optMINUS}{optMINUS} -\begin{chunk}{defun optMINUS} -(defun |optMINUS| (u) - (let (v) - (cond - ((and (consp u) (eq (qfirst u) 'minus) (consp (qrest u)) - (eq (qcddr u) nil)) - (setq v (qsecond u)) - (cond ((numberp v) (- v)) (t u))) - (t u)))) +\defun{lisplibWrite}{lisplibWrite} +\calls{lisplibWrite}{rwrite128} +\refsdollar{lisplibWrite}{lisplib} +\begin{chunk}{defun lisplibWrite} +(defun |lisplibWrite| (prop val filename) + (declare (special $lisplib)) + (when $lisplib (|rwrite| prop val filename))) \end{chunk} -\defplist{qsminus}{optQSMINUS} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get 'qsminus 'optimize) '|optQSMINUS|)) +\defun{isCategoryPackageName}{isCategoryPackageName} +\calls{isCategoryPackageName}{pname} +\calls{isCategoryPackageName}{maxindex} +\calls{isCategoryPackageName}{char} +\begin{chunk}{defun isCategoryPackageName} +(defun |isCategoryPackageName| (nam) + (let (p) + (setq p (pname (|opOf| nam))) + (equal (elt p (maxindex p)) (|char| '&)))) \end{chunk} -\defun{optQSMINUS}{optQSMINUS} -\begin{chunk}{defun optQSMINUS} -(defun |optQSMINUS| (u) - (let (v) +\defun{NRTgetLookupFunction}{NRTgetLookupFunction} +Compute the lookup function (complete or incomplete) +\calls{NRTgetLookupFunction}{sublis} +\calls{NRTgetLookupFunction}{NRTextendsCategory1} +\calls{NRTgetLookupFunction}{getExportCategory} +\calls{NRTgetLookupFunction}{sayBrightly} +\calls{NRTgetLookupFunction}{sayBrightlyNT} +\calls{NRTgetLookupFunction}{bright} +\calls{NRTgetLookupFunction}{form2String} +\defsdollar{NRTgetLookupFunction}{why} +\refsdollar{NRTgetLookupFunction}{why} +\refsdollar{NRTgetLookupFunction}{pairlis} +\begin{chunk}{defun NRTgetLookupFunction} +(defun |NRTgetLookupFunction| (domform exCategory addForm) + (let (|$why| extends u msg v) + (declare (special |$why| |$pairlis|)) + (setq domform (sublis |$pairlis| domform)) + (setq addForm (sublis |$pairlis| addForm)) + (setq |$why| nil) (cond - ((and (consp u) (eq (qfirst u) 'qsminus) (consp (qrest u)) - (eq (qcddr u) nil)) - (setq v (qsecond u)) - (cond ((numberp v) (- v)) (t u))) - (t u)))) + ((atom addForm) '|lookupComplete|) + (t + (setq extends + (|NRTextendsCategory1| domform exCategory (|getExportCategory| addForm))) + (cond + ((null extends) + (setq u (car |$why|)) + (setq msg (cadr |$why|)) + (setq v (cddr |$why|)) + (|sayBrightly| + "--------------non extending category----------------------") + (|sayBrightlyNT| + (cons ".." + (append (|bright| (|form2String| domform)) (list '|of cat |)))) + (print u) + (|sayBrightlyNT| (|bright| msg)) + (if v (print (car v)) (terpri)))) + (if extends + '|lookupIncomplete| + '|lookupComplete|))))) \end{chunk} -\defplist{-}{opt-} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get '- 'optimize) '|opt-|)) +\defun{NRTgetLocalIndex}{NRTgetLocalIndex} +\calls{NRTgetLocalIndex}{NRTassocIndex} +\calls{NRTgetLocalIndex}{NRTaddInner} +\calls{NRTgetLocalIndex}{compOrCroak} +\calls{NRTgetLocalIndex}{rplaca} +\refsdollar{NRTgetLocalIndex}{NRTaddForm} +\refsdollar{NRTgetLocalIndex}{formalArgList} +\refsdollar{NRTgetLocalIndex}{NRTdeltaList} +\refsdollar{NRTgetLocalIndex}{NRTdeltaListComp} +\refsdollar{NRTgetLocalIndex}{NRTdeltaLength} +\defsdollar{NRTgetLocalIndex}{NRTbase} +\defsdollar{NRTgetLocalIndex}{EmptyMode} +\defsdollar{NRTgetLocalIndex}{e} +\begin{chunk}{defun NRTgetLocalIndex} +(defun |NRTgetLocalIndex| (item) + (let (k value saveNRTdeltaListComp saveIndex compEntry) + (declare (special |$e| |$EmptyMode| |$NRTdeltaLength| |$NRTbase| + |$NRTdeltaListComp| |$NRTdeltaList| |$formalArgList| + |$NRTaddForm|)) + (cond + ((setq k (|NRTassocIndex| item)) k) + ((equal item |$NRTaddForm|) 5) + ((eq item '$) 0) + ((eq item '$$) 2) + (t + (when (member item |$formalArgList|) (setq value item)) + (cond + ((and (atom item) (null (member item '($ $$))) (null value)) + (setq |$NRTdeltaList| + (cons (cons '|domain| (cons (|NRTaddInner| item) value)) + |$NRTdeltaList|)) + (setq |$NRTdeltaListComp| (cons item |$NRTdeltaListComp|)) + (setq |$NRTdeltaLength| (1+ |$NRTdeltaLength|)) + (1- (+ |$NRTbase| |$NRTdeltaLength|))) + (t + (setq |$NRTdeltaList| + (cons (cons '|domain| (cons (|NRTaddInner| item) value)) + |$NRTdeltaList|)) + (setq saveNRTdeltaListComp + (setq |$NRTdeltaListComp| (cons nil |$NRTdeltaListComp|))) + (setq saveIndex (+ |$NRTbase| |$NRTdeltaLength|)) + (setq |$NRTdeltaLength| (1+ |$NRTdeltaLength|)) + (setq compEntry (car (|compOrCroak| item |$EmptyMode| |$e|))) + (rplaca saveNRTdeltaListComp compEntry) + saveIndex)))))) \end{chunk} -\defun{opt-}{opt-} -\begin{chunk}{defun opt-} -(defun |opt-| (u) - (let (v) - (cond - ((and (consp u) (eq (qfirst u) '-) (consp (qrest u)) - (eq (qcddr u) NIL)) - (setq v (qsecond u)) - (cond ((numberp v) (- v)) (t u))) - (t u)))) +\defun{augmentLisplibModemapsFromFunctor}{augmentLisplibModemapsFromFunctor} +\calls{augmentLisplibModemapsFromFunctor}{formal2Pattern} +\calls{augmentLisplibModemapsFromFunctor}{mkAlistOfExplicitCategoryOps} +\calls{augmentLisplibModemapsFromFunctor}{allLASSOCs} +\calls{augmentLisplibModemapsFromFunctor}{member} +\calls{augmentLisplibModemapsFromFunctor}{mkDatabasePred} +\calls{augmentLisplibModemapsFromFunctor}{mkpf} +\calls{augmentLisplibModemapsFromFunctor}{listOfPatternIds} +\calls{augmentLisplibModemapsFromFunctor}{interactiveModemapForm} +\refsdollar{augmentLisplibModemapsFromFunctor}{lisplibModemapAlist} +\refsdollar{augmentLisplibModemapsFromFunctor}{PatternVariableList} +\refsdollar{augmentLisplibModemapsFromFunctor}{e} +\defsdollar{augmentLisplibModemapsFromFunctor}{lisplibModemapAlist} +\defsdollar{augmentLisplibModemapsFromFunctor}{e} +\begin{chunk}{defun augmentLisplibModemapsFromFunctor} +(defun |augmentLisplibModemapsFromFunctor| (form opAlist signature) + (let (argl nonCategorySigAlist op pred sel predList sig predp z skip modemap) + (declare (special |$lisplibModemapAlist| |$PatternVariableList| |$e|)) + (setq form (|formal2Pattern| form)) + (setq argl (cdr form)) + (setq opAlist (|formal2Pattern| opAlist)) + (setq signature (|formal2Pattern| signature)) + ; We are going to be EVALing categories containing these pattern variables + (loop for u in form for v in signature + do (when (member u |$PatternVariableList|) + (setq |$e| (|put| u '|mode| v |$e|)))) + (when + (setq nonCategorySigAlist (|mkAlistOfExplicitCategoryOps| (CAR signature))) + (loop for entry in opAlist + do + (setq op (caar entry)) + (setq sig (cadar entry)) + (setq pred (cadr entry)) + (setq sel (caddr entry)) + (when + (let (result) + (loop for catSig in (|allLASSOCs| op nonCategorySigAlist) + do (setq result (or result (|member| sig catSig)))) + result) + (setq skip (when (and argl (contained '$ (cdr sig))) 'skip)) + (setq sel (subst form '$ sel :test #'equal)) + (setq predList + (loop for a in argl for m in (rest signature) + when (|member| a |$PatternVariableList|) + collect (list a m))) + (setq sig (subst form '$ sig :test #'equal)) + (setq predp + (mkpf + (cons pred (loop for y in predList collect (|mkDatabasePred| y))) + 'and)) + (setq z (|listOfPatternIds| predList)) + (when (some #'(lambda (u) (null (member u z))) argl) + (|sayMSG| (list "cannot handle modemap for " op "by pattern match")) + (setq skip 'skip)) + (setq modemap (list (cons form sig) (cons predp (cons sel skip)))) + (setq |$lisplibModemapAlist| + (cons + (cons op (|interactiveModemapForm| modemap)) + |$lisplibModemapAlist|)))))))) \end{chunk} -\defplist{lessp}{optLESSP} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get 'lessp 'optimize) '|optLESSP|)) +\defun{allLASSOCs}{allLASSOCs} +\begin{chunk}{defun allLASSOCs} +(defun |allLASSOCs| (op alist) + (loop for value in alist + when (equal (car value) op) + collect value)) \end{chunk} -\defun{optLESSP}{optLESSP} -\begin{chunk}{defun optLESSP} -(defun |optLESSP| (u) - (let (a b) - (cond - ((and (consp u) (eq (qfirst u) 'lessp) (consp (qrest u)) - (consp (qcddr u)) - (eq (qcdddr u) nil)) - (setq a (qsecond u)) - (setq b (qthird u)) - (if (eql b 0) - (list 'minusp a) - (list '> b a))) - (t u)))) +\defun{formal2Pattern}{formal2Pattern} +\calls{formal2Pattern}{sublis} +\calls{formal2Pattern}{pairList} +\refsdollar{formal2Pattern}{PatternVariableList} +\begin{chunk}{defun formal2Pattern} +(defun |formal2Pattern| (x) + (declare (special |$PatternVariableList|)) + (sublis (|pairList| |$FormalMapVariableList| (cdr |$PatternVariableList|)) x)) \end{chunk} -\defplist{spadcall}{optSPADCALL} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get 'spadcall 'optimize) '|optSPADCALL|)) +\defun{mkDatabasePred}{mkDatabasePred} +\calls{mkDatabasePred}{isCategoryForm} +\refsdollar{mkDatabasePred}{e} +\begin{chunk}{defun mkDatabasePred} +(defun |mkDatabasePred| (arg) + (let (a z) + (declare (special |$e|)) + (setq a (car arg)) + (setq z (cadr arg)) + (if (|isCategoryForm| z |$e|) + (list '|ofCategory| a z) + (list '|ofType| a z)))) \end{chunk} -\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 (consp argl) - (progn (setq tmp1 (reverse argl)) t) - (consp tmp1)) - (setq fun (qfirst tmp1)) - (setq argl (qrest tmp1)) - (setq argl (nreverse argl)) - (cond - ((and (consp fun) - (or (eq (qfirst fun) 'elt) (eq (qfirst fun) 'lispelt)) - (progn - (and (consp (qrest fun)) - (progn - (setq dom (qsecond fun)) - (and (consp (qcddr fun)) - (eq (qcdddr fun) nil) - (progn - (setq slot (qthird fun)) - t)))))) - (|optCall| (cons '|call| (cons (list 'elt dom slot) argl)))) - (t form))) - (t form)))) +\defun{disallowNilAttribute}{disallowNilAttribute} +\begin{chunk}{defun disallowNilAttribute} +(defun |disallowNilAttribute| (x) + (loop for y in x when (and (car y) (not (eq (car y) '|nil|))) + collect y)) \end{chunk} -\defplist{|}{optSuchthat} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get '|\|| 'optimize) '|optSuchthat|)) +\defun{bootStrapError}{bootStrapError} +\calls{bootStrapError}{mkq} +\calls{bootStrapError}{namestring} +\calls{bootStrapError}{mkDomainConstructor} +\begin{chunk}{defun bootStrapError} +(defun |bootStrapError| (functorForm sourceFile) + (list 'cond + (list '|$bootStrapMode| + (list 'vector (|mkDomainConstructor| functorForm) nil nil nil nil nil)) + (list ''t + (list '|systemError| + (list 'list ''|%b| (MKQ (CAR functorForm)) ''|%d| "from" ''|%b| + (mkq (|namestring| sourceFile)) ''|%d| "needs to be compiled"))))) \end{chunk} -\defun{optSuchthat}{optSuchthat} -\begin{chunk}{defun optSuchthat} -(defun |optSuchthat| (arg) - (cons 'suchthat (cdr arg))) +\defun{reportOnFunctorCompilation}{reportOnFunctorCompilation} +\calls{reportOnFunctorCompilation}{displayMissingFunctions} +\calls{reportOnFunctorCompilation}{sayBrightly} +\calls{reportOnFunctorCompilation}{displaySemanticErrors} +\calls{reportOnFunctorCompilation}{displayWarnings} +\calls{reportOnFunctorCompilation}{addStats} +\calls{reportOnFunctorCompilation}{normalizeStatAndStringify} +\usesdollar{reportOnFunctorCompilation}{op} +\usesdollar{reportOnFunctorCompilation}{functorStats} +\usesdollar{reportOnFunctorCompilation}{functionStats} +\usesdollar{reportOnFunctorCompilation}{warningStack} +\usesdollar{reportOnFunctorCompilation}{semanticErrorStack} +\begin{chunk}{defun reportOnFunctorCompilation} +(defun |reportOnFunctorCompilation| () + (declare (special |$op| |$functorStats| |$functionStats| + |$warningStack| |$semanticErrorStack|)) + (|displayMissingFunctions|) + (when |$semanticErrorStack| (|sayBrightly| " ")) + (|displaySemanticErrors|) + (when |$warningStack| (|sayBrightly| " ")) + (|displayWarnings|) + (setq |$functorStats| (|addStats| |$functorStats| |$functionStats|)) + (|sayBrightly| + (cons '|%l| + (append (|bright| " Cumulative Statistics for Constructor") + (list |$op|)))) + (|sayBrightly| + (cons " Time:" + (append (|bright| (|normalizeStatAndStringify| (second |$functorStats|))) + (list "seconds")))) + (|sayBrightly| " ") + '|done|) \end{chunk} -\defplist{catch}{optCatch} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get 'catch 'optimize) '|optCatch|)) +\defun{displayMissingFunctions}{displayMissingFunctions} +\calls{displayMissingFunctions}{member} +\calls{displayMissingFunctions}{getmode} +\calls{displayMissingFunctions}{sayBrightly} +\calls{displayMissingFunctions}{bright} +\calls{displayMissingFunctions}{formatUnabbreviatedSig} +\usesdollar{displayMissingFunctions}{env} +\usesdollar{displayMissingFunctions}{formalArgList} +\usesdollar{displayMissingFunctions}{CheckVectorList} +\begin{chunk}{defun displayMissingFunctions} +(defun |displayMissingFunctions| () + (let (i loc exp) + (declare (special |$env| |$formalArgList| |$CheckVectorList|)) + (unless |$CheckVectorList| + (setq loc nil) + (setq exp nil) + (loop for cvl in |$CheckVectorList| do + (unless (cdr cvl) + (if (and (null (|member| (caar cvl) |$formalArgList|)) + (consp (|getmode| (caar cvl) |$env|)) + (eq (qfirst (|getmode| (caar cvl) |$env|)) '|Mapping|)) + (push (list (caar cvl) (cadar cvl)) loc) + (push (list (caar cvl) (cadar cvl)) exp)))) + (when loc + (|sayBrightly| (cons '|%l| (|bright| " Missing Local Functions:"))) + (setq i 0) + (loop for item in loc do + (|sayBrightly| + (cons " [" (cons (incf i) (cons "]" + (append (|bright| (first item)) + (cons '|: | (|formatUnabbreviatedSig| (second item)))))))))) + (when exp + (|sayBrightly| (cons '|%l| (|bright| " Missing Exported Functions:"))) + (setq i 0) + (loop for item in exp do + (|sayBrightly| + (cons " [" (cons (incf i) (cons "]" + (append (|bright| (first item)) + (cons '|: | (|formatUnabbreviatedSig| (second item))))))))))))) \end{chunk} -\defun{optCatch}{optCatch} -\calls{optCatch}{qcar} -\calls{optCatch}{qcdr} -\calls{optCatch}{rplac} -\calls{optCatch}{optimize} -\refsdollar{optCatch}{InteractiveMode} -\begin{chunk}{defun optCatch} -(defun |optCatch| (x) +\defun{makeFunctorArgumentParameters}{makeFunctorArgumentParameters} +\calls{makeFunctorArgumentParameters}{assq} +\calls{makeFunctorArgumentParameters}{isCategoryForm} +\calls{makeFunctorArgumentParameters}{genDomainViewList0} +\calls{makeFunctorArgumentParameters}{union} +\usesdollar{makeFunctorArgumentParameters}{ConditionalOperators} +\usesdollar{makeFunctorArgumentParameters}{alternateViewList} +\usesdollar{makeFunctorArgumentParameters}{forceAdd} +\begin{chunk}{defun makeFunctorArgumentParameters} +(defun |makeFunctorArgumentParameters| (argl sigl target) (labels ( - (changeThrowToExit (s g) - (cond - ((or (atom s) (member (car s) '(quote seq repeat collect))) nil) - ((and (consp s) (eq (qfirst s) 'throw) (consp (qrest s)) - (equal (qsecond s) g)) - (|rplac| (car s) 'exit) - (|rplac| (cdr s) (qcddr s))) - (t - (changeThrowToExit (car s) g) - (changeThrowToExit (cdr s) g)))) - (hasNoThrows (a g) - (cond - ((and (consp a) (eq (qfirst a) 'throw) (consp (qrest a)) - (equal (qsecond a) g)) - nil) - ((atom a) t) - (t - (and (hasNoThrows (car a) g) - (hasNoThrows (cdr a) g))))) - (changeThrowToGo (s g) + (augmentSig (s ss) (let (u) - (cond - ((or (atom s) (eq (car s) 'quote)) nil) - ((and (consp s) (eq (qfirst s) 'throw) (consp (qrest s)) - (equal (qsecond s) g) (consp (qcddr s)) - (eq (qcdddr s) nil)) - (setq u (qthird 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)) + (declare (special |$ConditionalOperators|)) + (if ss + (progn + (loop for u in ss do (push (rest u) |$ConditionalOperators|)) + (if (and (consp s) (eq (qfirst s) '|Join|)) + (progn + (if (setq u (assq 'category ss)) + (subst (append u ss) u s :test #'equal) + (cons '|Join| + (append (rest s) (list (cons 'category (cons '|package| ss))))))) + (list '|Join| s (cons 'category (cons '|package| ss))))) + s))) + (fn (a s) + (declare (special |$CategoryFrame|)) + (if (|isCategoryForm| s |$CategoryFrame|) + (if (and (consp s) (eq (qfirst s) '|Join|)) + (|genDomainViewList0| a (rest s)) + (list (|genDomainView| a s '|getDomainView|))) + (list a))) + (findExtras (a target) (cond - (|$InteractiveMode| x) - ((atom a) a) - (t - (cond - ((and (consp a) (eq (qfirst a) 'seq) (consp (qrest a)) - (progn (setq tmp2 (reverse (qrest a))) t) - (consp tmp2) (consp (qfirst tmp2)) (eq (qcaar tmp2) 'throw) - (consp (qcdar tmp2)) - (equal (qcadar tmp2) g) - (consp (qcddar tmp2)) - (eq (qcdddar tmp2) nil)) - (setq u (qcaddar tmp2)) - (setq s (qrest 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))))) + ((and (consp target) (eq (qfirst target) '|Join|)) + (reduce #'|union| + (loop for x in (qrest target) + collect (findExtras a x)))) + ((and (consp target) (eq (qfirst target) 'category)) + (reduce #'|union| + (loop for x in (qcddr target) + collect (findExtras1 a x)))))) + (findExtras1 (a x) + (cond + ((and (consp x) (or (eq (qfirst x) 'and)) (eq (qfirst x) 'or)) + (reduce #'|union| + (loop for y in (rest x) collect (findExtras1 a y)))) + ((and (consp x) (eq (qfirst x) 'if) + (consp (qrest x)) (consp (qcddr x)) + (consp (qcdddr x)) + (eq (qcddddr x) nil)) + (|union| (findExtrasP a (second x)) + (|union| + (findExtras1 a (third x)) + (findExtras1 a (fourth x))))))) + (findExtrasP (a x) + (cond + ((and (consp x) (or (eq (qfirst x) 'and)) (eq (qfirst x) 'or)) + (reduce #'|union| + (loop for y in (rest x) collect (findExtrasP a y)))) + ((and (consp x) (eq (qfirst x) '|has|) + (consp (qrest x)) (consp (qcddr x)) + (consp (qcdddr x)) + (eq (qcddddr x) nil)) + (|union| (findExtrasP a (second x)) + (|union| + (findExtras1 a (third x)) + (findExtras1 a (fourth x))))) + ((and (consp x) (eq (qfirst x) '|has|) + (consp (qrest x)) (equal (qsecond x) a) + (consp (qcddr x)) + (eq (qcdddr x) nil) + (consp (qthird x)) + (eq (qcaaddr x) 'signature)) + (list (third x))))) + + ) + (let (|$alternateViewList| |$forceAdd| |$ConditionalOperators|) + (declare (special |$alternateViewList| |$forceAdd| |$ConditionalOperators|)) + (setq |$alternateViewList| nil) + (setq |$forceAdd| t) + (setq |$ConditionalOperators| nil) + (mapcar #'reduce + (loop for a in argl for s in sigl do + (fn a (augmentSig s (findExtras a target)))))))) \end{chunk} -\defplist{cond}{optCond} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get 'cond 'optimize) '|optCond|)) +\defun{genDomainViewList0}{genDomainViewList0} +\calls{genDomainViewList0}{getDomainViewList} +\begin{chunk}{defun genDomainViewList0} +(defun |genDomainViewList0| (id catlist) + (|genDomainViewList| id catlist t)) \end{chunk} -\defun{optCond}{optCond} -\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 (consp z) (consp (qrest z)) (eq (qcddr z) nil) - (consp (qsecond z)) (consp (qcdadr z)) - (eq (qrest (qcdadr z)) nil) - (|TruthP| (qcaadr z)) - (consp (qcadadr z)) - (eq (qfirst (qcadadr z)) 'cond)) - (rplacd (cdr x) (qrest (qcadadr z)))) - (cond - ((and (consp z) (consp (qfirst z)) (consp (qrest z)) (consp (qsecond z))) - (setq p1 (qcaar z)) - (setq c1 (qcdar z)) - (setq p2 (qcaadr z)) - (setq c2 (qcdadr z)) - (when - (or (and (consp p1) (eq (qfirst p1) 'null) (consp (qrest p1)) - (eq (qcddr p1) nil) - (equal (qsecond p1) p2)) - (and (consp p2) (eq (qfirst p2) 'null) (consp (qrest p2)) - (eq (qcddr p2) nil) - (equal (qsecond p2) p1))) - (setq z (list (cons p1 c1) (cons ''t c2))) - (rplacd x z)) - (when - (and (consp c1) (eq (qrest c1) nil) (equal (qfirst c1) 'nil) - (equal p2 ''t) (equal (car c2) ''t)) - (if (and (consp p1) (eq (qfirst p1) 'null) (consp (qrest p1)) - (eq (qcddr p1) nil)) - (setq result (qsecond p1)) - (setq result (list 'null p1)))))) - (if result - result - (cond - ((and (consp z) (consp (qfirst z)) (consp (qrest z)) (consp (qsecond z)) - (consp (qcddr z)) (eq (qcdddr z) nil) - (consp (qthird z)) - (|TruthP| (qcaaddr z))) - (setq p1 (qcaar z)) - (setq c1 (qcdar z)) - (setq p2 (qcaadr z)) - (setq c2 (qcdadr z)) - (setq c3 (qcdaddr 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 (consp y) (consp (qfirst y)) (consp (qcdar y)) - (eq (qcddar y) nil) (consp (qrest y)) - (consp (qsecond y)) (consp (qcdadr y)) - (eq (qcddadr y) nil) - (|EqualBarGensym| (qcadar y) - (qcadadr y)))) - nil) - (setq a (list 'or (qcaar y) (qcaadr y))) - (rplac (car (car y)) a) - (rplac (cdr y) (qcddr y)))) - x))))) +\defun{genDomainViewList}{genDomainViewList} +\calls{genDomainViewList}{isCategoryForm} +\calls{genDomainViewList}{genDomainView} +\calls{genDomainViewList}{genDomainViewList} +\usesdollar{genDomainViewList}{EmptyEnvironment} +\begin{chunk}{defun genDomainViewList} +(defun |genDomainViewList| (id catlist firsttime) + (declare (special |$EmptyEnvironment|) (ignore firsttime)) + (cond + ((null catlist) nil) + ((and (consp catlist) (eq (qrest catlist) nil) + (null (|isCategoryForm| (first catlist) |$EmptyEnvironment|))) + nil) + (t + (cons + (|genDomainView| id (first catlist) '|getDomainView|) + (|genDomainViewList| id (rest catlist) nil))))) \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 (consp y) (eq (qrest y) nil) (gensymp (qfirst y)))) - ((null y) (and (consp x) (eq (qrest x) nil) (gensymp (qfirst x)))) - ((or (atom x) (atom y)) nil) +\defun{genDomainView}{genDomainView} +\calls{genDomainView}{genDomainOps} +\calls{genDomainView}{augModemapsFromCategory} +\calls{genDomainView}{mkDomainConstructor} +\calls{genDomainView}{member} +\usesdollar{genDomainView}{e} +\usesdollar{genDomainView}{getDomainCode} +\begin{chunk}{defun genDomainView} +(defun |genDomainView| (name c viewSelector) + (let (code cd) + (declare (special |$getDomainCode| |$e|)) + (cond + ((and (consp c) (eq (qfirst c) 'category) (consp (qrest c))) + (|genDomainOps| name name c)) + (t + (setq code + (if (and (consp c) (eq (qfirst c) '|SubsetCategory|) + (consp (qrest c)) (consp (qcddr c)) + (eq (qcdddr c) nil)) + (second c) + c)) + (setq |$e| (|augModemapsFromCategory| name nil c |$e|)) + (setq cd + (list 'let name (list viewSelector name (|mkDomainConstructor| code)))) + (unless (|member| cd |$getDomainCode|) + (setq |$getDomainCode| (cons cd |$getDomainCode|))) + name)))) + +\end{chunk} + +\defun{genDomainOps}{genDomainOps} +\calls{genDomainOps}{getOperationAlist} +\calls{genDomainOps}{substNames} +\calls{genDomainOps}{mkq} +\calls{genDomainOps}{mkDomainConstructor} +\calls{genDomainOps}{addModemap} +\usesdollar{genDomainOps}{e} +\usesdollar{genDomainOps}{ConditionalOperators} +\usesdollar{genDomainOps}{getDomainCode} +\begin{chunk}{defun genDomainOps} +(defun |genDomainOps| (viewName dom cat) + (let (siglist oplist cd i) + (declare (special |$e| |$ConditionalOperators| |$getDomainCode|)) + (setq oplist (|getOperationAlist| dom dom cat)) + (setq siglist (loop for lst in oplist collect (first lst))) + (setq oplist (|substNames| dom viewName dom oplist)) + (setq cd + (list 'let viewName + (list '|mkOpVec| dom + (cons 'list + (loop for opsig in siglist + collect + (list 'list (mkq (first opsig)) + (cons 'list + (loop for mode in (rest opsig) + collect (|mkDomainConstructor| mode))))))))) + (setq |$getDomainCode| (cons cd |$getDomainCode|)) + (setq i 0) + (loop for item in oplist do + (if (|member| (first item) |$ConditionalOperators|) + (setq |$e| (|addModemap| (caar item) dom (cadar item) nil + (list 'elt viewName (incf i)) |$e|)) + (setq |$e| (|addModemap| (caar item) dom (cadar item) (second item) + (list 'elt viewName (incf i)) |$e|)))) + viewName)) + +\end{chunk} + +\defun{mkOpVec}{mkOpVec} +\calls{mkOpVec}{getPrincipalView} +\calls{mkOpVec}{getOperationAlistFromLisplib} +\calls{mkOpVec}{opOf} +\calls{mkOpVec}{length} +\calls{mkOpVec}{assq} +\calls{mkOpVec}{assoc} +\calls{mkOpVec}{sublis} +\calls{mkOpVec}{AssocBarGensym} +\usesdollar{mkOpVec}{FormalMapVariableList} +\uses{mkOpVec}{Undef} +\begin{chunk}{defun mkOpVec} +(defun |mkOpVec| (dom siglist) + (let (substargs oplist ops u noplist i tmp1) + (declare (special |$FormalMapVariableList| |Undef|)) + (setq dom (|getPrincipalView| dom)) + (setq substargs + (cons (cons '$ (elt dom 0)) + (loop for a in |$FormalMapVariableList| for x in (rest (elt dom 0)) + collect (cons a x)))) + (setq oplist (|getOperationAlistFromLisplib| (|opOf| (elt dom 0)))) + (setq ops (make-array (|#| siglist))) + (setq i -1) + (loop for opSig in siglist do + (incf i) + (setq u (assq (first opSig) oplist)) + (setq tmp1 (|assoc| (second opSig) u)) + (cond + ((and (consp tmp1) (consp (qrest tmp1)) + (consp (qcddr tmp1)) (consp (qcdddr tmp1)) + (eq (qcddddr tmp1) nil) + (eq (qfourth tmp1) 'elt)) + (setelt ops i (elt dom (second tmp1)))) (t - (and (fn (car x) (car y)) - (fn (cdr x) (cdr y)))))))) - (let (|$GensymAssoc|) - (declare (special |$GensymAssoc|)) - (setq |$GensymAssoc| NIL) - (fn x y)))) + (setq noplist (sublis substargs u)) + (setq tmp1 + (|AssocBarGensym| + (subst (elt dom 0) '$ (second opSig) :test #'equal) noplist)) + (cond + ((and (consp tmp1) (consp (qrest tmp1)) (consp (qcddr tmp1)) + (consp (qcdddr tmp1)) + (eq (qcddddr tmp1) nil) + (eq (qfourth tmp1) 'elt)) + (setelt ops i (elt dom (second tmp1)))) + (t + (setelt ops i (cons |Undef| (cons (list (elt dom 0) i) opSig)))))))) + ops)) \end{chunk} -\defplist{mkRecord}{optMkRecord} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get '|mkRecord| 'optimize) '|optMkRecord|)) +\defun{AssocBarGensym}{AssocBarGensym} +\calls{AssocBarGensym}{EqualBarGensym} +\begin{chunk}{defun AssocBarGensym} +(defun |AssocBarGensym| (key z) + (loop for x in z + do (when (and (consp x) (|EqualBarGensym| key (car x))) (return x)))) \end{chunk} -\defun{optMkRecord}{optMkRecord} -\calls{optMkRecord}{length} -\begin{chunk}{defun optMkRecord} -(defun |optMkRecord| (arg) - (let (u) - (setq u (cdr arg)) +\defun{orderByDependency}{orderByDependency} +\calls{orderByDependency}{say} +\calls{orderByDependency}{userError} +\calls{orderByDependency}{intersection} +\calls{orderByDependency}{member} +\calls{orderByDependency}{remdup} +\begin{chunk}{defun orderByDependency} +(defun |orderByDependency| (vl dl) + (let (selfDependents fatalError newl orderedVarList vlp dlp) + (setq selfDependents + (loop for v in vl for d in dl + when (member v d) + collect v)) + (loop for v in vl for d in dl + when (member v d) + do (say v "depends on itself") + (setq fatalError t)) (cond - ((and (consp u) (eq (qrest u) nil)) (list 'list (qfirst u))) - ((eql (|#| u) 2) (cons 'cons u)) - (t (cons 'vector u))))) - -\end{chunk} - -\defplist{recordelt}{optRECORDELT} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get 'recordelt 'optimize) '|optRECORDELT|)) + (fatalError (|userError| "Parameter specification error")) + (t + (loop until (null vl) do + (setq newl + (loop for v in vl for d in dl + when (null (|intersection| d vl)) + collect v)) + (if (null newl) + (setq vl nil) ; force loop exit + (progn + (setq orderedVarList (append newl orderedVarList)) + (setq vlp (setdifference vl newl)) + (setq dlp + (loop for x in vl for d in dl + when (|member| x vlp) + collect (setdifference d newl))) + (setq vl vlp) + (setq dl dlp)))) + (when (and newl orderedVarList) (remdup (nreverse orderedVarList))))))) \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) +\section{Code optimization routines} +\defun{optimizeFunctionDef}{optimizeFunctionDef} +\calls{optimizeFunctionDef}{rplac} +\calls{optimizeFunctionDef}{sayBrightlyI} +\calls{optimizeFunctionDef}{optimize} +\calls{optimizeFunctionDef}{pp} +\calls{optimizeFunctionDef}{bright} +\refsdollar{optimizeFunctionDef}{reportOptimization} +\begin{chunk}{defun optimizeFunctionDef} +(defun |optimizeFunctionDef| (def) + (labels ( + (fn (x g) (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) - (setf (get 'setrecordelt 'optimize) '|optSETRECORDELT|)) + ((and (consp x) (eq (qfirst x) 'throw) (consp (qrest x)) + (equal (qsecond x) g)) + (|rplac| (car x) 'return) + (|rplac| (cdr x) + (replaceThrowByReturn (qcddr x) g))) + ((atom x) nil) + (t + (replaceThrowByReturn (car x) g) + (replaceThrowByReturn (cdr x) g)))) + (replaceThrowByReturn (x g) + (fn x g) + x) + (removeTopLevelCatch (body) + (if (and (consp body) (eq (qfirst body) 'catch) (consp (qrest body)) + (consp (qcddr body)) (eq (qcdddr body) nil)) + (removeTopLevelCatch + (replaceThrowByReturn + (qthird body) (qsecond body))) + body))) + (let (defp name slamOrLam args body bodyp) + (declare (special |$reportOptimization|)) + (when |$reportOptimization| + (|sayBrightlyI| (|bright| "Original LISP code:")) + (|pp| def)) + (setq defp (|optimize| (copy def))) + (when |$reportOptimization| + (|sayBrightlyI| (|bright| "Optimized LISP code:")) + (|pp| defp) + (|sayBrightlyI| (|bright| "Final LISP code:"))) + (setq name (car defp)) + (setq slamOrLam (caadr defp)) + (setq args (cadadr defp)) + (setq body (car (cddadr defp))) + (setq bodyp (removeTopLevelCatch body)) + (list name (list slamOrLam args bodyp))))) \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) +\defun{optimize}{optimize} +\calls{optimize}{optimize} +\calls{optimize}{say} +\calls{optimize}{prettyprint} +\calls{optimize}{rplac} +\calls{optimize}{optIF2COND} +\calls{optimize}{getl} +\calls{optimize}{subrname} +\begin{chunk}{defun optimize} +(defun |optimize| (x) + (labels ( + (opt (x) + (let (argl body a y op) (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))))) + ((atom x) nil) + ((eq (setq y (car x)) 'quote) nil) + ((eq y 'closedfn) nil) + ((and (consp y) (consp (qfirst y)) (eq (qcaar y) 'xlam) + (consp (qcdar y)) (consp (qcddar y)) + (eq (qcdddar y) nil)) + (setq argl (qcadar y)) + (setq body (qcaddar y)) + (setq a (qrest y)) + (|optimize| (cdr x)) + (cond + ((eq argl '|ignore|) (rplac (car x) body)) + (t + (when (null (<= (length argl) (length a))) + (say "length mismatch in XLAM expression") + (prettyprint y)) + (rplac (car x) + (|optimize| + (|optXLAMCond| + (sublis (|pairList| argl a) body))))))) + ((atom y) + (|optimize| (cdr x)) + (cond + ((eq y '|true|) (rplac (car x) '''T)) + ((eq y '|false|) (rplac (car x) nil)))) + ((eq (car y) 'if) + (rplac (car x) (|optIF2COND| y)) + (setq y (car x)) + (when (setq op (getl (|subrname| (car y)) 'optimize)) + (|optimize| (cdr x)) + (rplac (car x) (funcall op (|optimize| (car x)))))) + ((setq op (getl (|subrname| (car y)) 'optimize)) + (|optimize| (cdr x)) + (rplac (car x) (funcall op (|optimize| (car x))))) (t - (list 'qsetvelt name ind expr))))) + (rplac (car x) (|optimize| (car x))) + (|optimize| (cdr x))))))) + (opt x) + x)) \end{chunk} -\defplist{recordcopy}{optRECORDCOPY} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get 'recordcopy 'optimize) '|optRECORDCOPY|)) +\defun{optXLAMCond}{optXLAMCond} +\calls{optXLAMCond}{optCONDtail} +\calls{optXLAMCond}{optPredicateIfTrue} +\calls{optXLAMCond}{optXLAMCond} +\calls{optXLAMCond}{rplac} +\begin{chunk}{defun optXLAMCond} +(defun |optXLAMCond| (x) + (cond + ((and (consp x) (eq (qfirst x) 'cond) (consp (qrest x)) + (consp (qsecond x)) (consp (qcdadr x)) + (eq (qcddadr x) nil)) + (if (|optPredicateIfTrue| (qcaadr x)) + (qcadadr x) + (cons 'cond (cons (qsecond x) (|optCONDtail| (qcddr x)))))) + ((atom x) x) + (t + (rplac (car x) (|optXLAMCond| (car x))) + (rplac (cdr x) (|optXLAMCond| (cdr x))) + x))) \end{chunk} -\defun{optRECORDCOPY}{optRECORDCOPY} -\begin{chunk}{defun optRECORDCOPY} -(defun |optRECORDCOPY| (arg) - (let (name len) - (setq name (cadr arg)) - (setq len (caddr arg)) +\defun{optCONDtail}{optCONDtail} +\calls{optCONDtail}{optCONDtail} +\refsdollar{optCONDtail}{true} +\begin{chunk}{defun optCONDtail} +(defun |optCONDtail| (z) + (declare (special |$true|)) + (when z (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))))) + ((|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} -\section{Functions to manipulate modemaps} +\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)) -\defun{addDomain}{addDomain} -\calls{addDomain}{identp} -\calls{addDomain}{qslessp} -\calls{addDomain}{getDomainsInScope} -\calls{addDomain}{domainMember} -\calls{addDomain}{isLiteral} -\calls{addDomain}{addNewDomain} -\calls{addDomain}{getmode} -\calls{addDomain}{isCategoryForm} -\calls{addDomain}{isFunctor} -\calls{addDomain}{constructor?} -\calls{addDomain}{member} -\calls{addDomain}{unknownTypeError} -\begin{chunk}{defun addDomain} -(defun |addDomain| (domain env) - (let (s name tmp1) +\end{chunk} + +\defun{optPredicateIfTrue}{optPredicateIfTrue} +\refsdollar{optPredicateIfTrue}{BasicPredicates} +\begin{chunk}{defun optPredicateIfTrue} +(defun |optPredicateIfTrue| (p) + (declare (special |$BasicPredicates|)) (cond - ((atom domain) - (cond - ((eq domain '|$EmptyMode|) env) - ((eq domain '|$NoValueMode|) env) - ((or (null (identp domain)) - (and (qslessp 2 (|#| (setq s (princ-to-string domain)))) - (eq (|char| '|#|) (elt s 0)) - (eq (|char| '|#|) (elt s 1)))) - env) - ((member domain (|getDomainsInScope| env)) env) - ((|isLiteral| domain env) env) - (t (|addNewDomain| domain env)))) - ((eq (setq name (car domain)) '|Category|) env) - ((|domainMember| domain (|getDomainsInScope| env)) env) - ((and (progn - (setq tmp1 (|getmode| name env)) - (and (consp tmp1) (eq (qfirst tmp1) '|Mapping|) - (consp (qrest tmp1)))) - (|isCategoryForm| (second tmp1) env)) - (|addNewDomain| domain env)) - ((or (|isFunctor| name) (|constructor?| name)) - (|addNewDomain| domain env)) - (t - (when (and (null (|isCategoryForm| domain env)) - (null (|member| name '(|Mapping| category)))) - (|unknownTypeError| name)) - env)))) + ((and (consp p) (eq (qfirst p) 'quote)) T) + ((and (consp p) (consp (qrest p)) (eq (qcddr p) nil) + (member (qfirst p) |$BasicPredicates|) (funcall (qfirst p) (qsecond p))) + t) + (t nil))) \end{chunk} -\defun{unknownTypeError}{unknownTypeError} -\calls{unknownTypeError}{qcar} -\calls{unknownTypeError}{stackSemanticError} -\begin{chunk}{defun unknownTypeError} -(defun |unknownTypeError| (name) - (let (op) - (setq name - (if (and (consp name) (setq op (qfirst name))) - op - name)) - (|stackSemanticError| (list '|%b| name '|%d| '|is not a known type|) nil))) +\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 (consp c) (eq (qfirst c) 'if)) + (cons 'cond (cons (list a b) (cdr (|optIF2COND| c))))) + ((and (consp c) (eq (qfirst c) 'cond)) + (cons 'cond (cons (list a b) (qrest c)))) + (t + (list 'cond (list a b) (list |$true| c)))))) \end{chunk} -\defun{isFunctor}{isFunctor} -\calls{isFunctor}{opOf} -\calls{isFunctor}{identp} -\calls{isFunctor}{getdatabase} -\calls{isFunctor}{get} -\calls{isFunctor}{constructor?} -\calls{isFunctor}{updateCategoryFrameForCategory} -\calls{isFunctor}{updateCategoryFrameForConstructor} -\refsdollar{isFunctor}{CategoryFrame} -\refsdollar{isFunctor}{InteractiveMode} -\begin{chunk}{defun isFunctor} -(defun |isFunctor| (x) - (let (op u prop) - (declare (special |$CategoryFrame| |$InteractiveMode|)) - (setq op (|opOf| x)) - (cond - ((null (identp op)) nil) - (|$InteractiveMode| - (if (member op '(|Union| |SubDomain| |Mapping| |Record|)) - t - (member (getdatabase op 'constructorkind) '(|domain| |package|)))) - ((setq u - (or (|get| op '|isFunctor| |$CategoryFrame|) - (member op '(|SubDomain| |Union| |Record|)))) - u) - ((|constructor?| op) - (cond - ((setq prop (|get| op '|isFunctor| |$CategoryFrame|)) prop) - (t - (if (eq (getdatabase op 'constructorkind) '|category|) - (|updateCategoryFrameForCategory| op) - (|updateCategoryFrameForConstructor| op)) - (|get| op '|isFunctor| |$CategoryFrame|)))) - (t nil)))) +\defun{subrname}{subrname} +\calls{subrname}{identp} +\calls{subrname}{compiled-function-p} +\calls{subrname}{mbpip} +\calls{subrname}{bpiname} +\begin{chunk}{defun subrname} +(defun |subrname| (u) + (cond + ((identp u) u) + ((or (compiled-function-p u) (mbpip u)) (bpiname u)) + (t nil))) \end{chunk} -\defun{getDomainsInScope}{getDomainsInScope} -The way XLAMs work: +\subsection{Special case optimizers} +Optimization functions are called through the OPTIMIZE property on the +symbol property list. The current list is: \begin{verbatim} - ((XLAM ($1 $2 $3) (SETELT $1 0 $3)) X "c" V) ==> (SETELT X 0 V) + |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} -\calls{getDomainsInScope}{get} -\refsdollar{getDomainsInScope}{CapsuleDomainsInScope} -\refsdollar{getDomainsInScope}{insideCapsuleFunctionIfTrue} -\begin{chunk}{defun getDomainsInScope} -(defun |getDomainsInScope| (env) - (declare (special |$CapsuleDomainsInScope| |$insideCapsuleFunctionIfTrue|)) - (if |$insideCapsuleFunctionIfTrue| - |$CapsuleDomainsInScope| - (|get| '|$DomainsInScope| 'special env))) -\end{chunk} +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. -\defun{putDomainsInScope}{putDomainsInScope} -\calls{putDomainsInScope}{getDomainsInScope} -\calls{putDomainsInScope}{put} -\calls{putDomainsInScope}{delete} -\calls{putDomainsInScope}{say} -\calls{putDomainsInScope}{member} -\defsdollar{putDomainsInScope}{CapsuleDomainsInScope} -\refsdollar{putDomainsInScope}{insideCapsuleFunctionIfTrue} -\begin{chunk}{defun putDomainsInScope} -(defun |putDomainsInScope| (x env) - (let (z newValue) - (declare (special |$CapsuleDomainsInScope| |$insideCapsuleFunctionIfTrue|)) - (setq z (|getDomainsInScope| env)) - (when (|member| x z) (say "****** Domain: " x " already in scope")) - (setq newValue (cons x (|delete| x z))) - (if |$insideCapsuleFunctionIfTrue| - (progn - (setq |$CapsuleDomainsInScope| newValue) - env) - (|put| '|$DomainsInScope| 'special newValue env)))) +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} +(eval-when (eval load) + (setf (get '|call| 'optimize) '|optCall|)) \end{chunk} -\defun{isSuperDomain}{isSuperDomain} -\calls{isSuperDomain}{isSubset} -\calls{isSuperDomain}{lassoc} -\calls{isSuperDomain}{opOf} -\calls{isSuperDomain}{get} -\begin{chunk}{defun isSuperDomain} -(defun |isSuperDomain| (domainForm domainFormp env) - (cond - ((|isSubset| domainFormp domainForm env) t) - ((and (eq domainForm '|Rep|) (eq domainFormp '$)) t) - (t (lassoc (|opOf| domainFormp) (|get| domainForm '|SubDomain| env))))) +\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 (consp fn) (eq (qfirst fn) 'pac)) (|optPackageCall| x fn a)) + ((and (consp fn) (eq (qfirst fn) '|applyFun|) + (consp (qrest fn)) (eq (qcddr fn) nil)) + (setq name (qsecond fn)) + (rplac (car x) 'spadcall) + (rplac (cdr x) (append a (cons name nil))) + x) + ((and (consp fn) (consp (qrest fn)) (consp (qcddr fn)) + (eq (qcdddr fn) nil) + (member (qfirst fn) '(elt qrefelt const))) + (setq q (qfirst fn)) + (setq r (qsecond fn)) + (setq n (qthird 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{addNewDomain}{addNewDomain} -\calls{addNewDomain}{augModemapsFromDomain} -\begin{chunk}{defun addNewDomain} -(defun |addNewDomain| (domain env) - (|augModemapsFromDomain| domain domain env)) +\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{augModemapsFromDomain}{augModemapsFromDomain} -\calls{augModemapsFromDomain}{member} -\calls{augModemapsFromDomain}{kar} -\calls{augModemapsFromDomain}{getDomainsInScope} -\calls{augModemapsFromDomain}{getdatabase} -\calls{augModemapsFromDomain}{opOf} -\calls{augModemapsFromDomain}{addNewDomain} -\calls{augModemapsFromDomain}{listOrVectorElementNode} -\calls{augModemapsFromDomain}{stripUnionTags} -\calls{augModemapsFromDomain}{augModemapsFromDomain1} -\refsdollar{augModemapsFromDomain}{Category} -\refsdollar{augModemapsFromDomain}{DummyFunctorNames} -\begin{chunk}{defun augModemapsFromDomain} -(defun |augModemapsFromDomain| (name functorForm env) - (let (curDomainsInScope u innerDom) - (declare (special |$Category| |$DummyFunctorNames|)) +\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 (consp zp) (eq (qfirst zp) 'let) (consp (qrest zp)) + (equal (qsecond zp) a) (consp (qcddr zp))) + (qthird zp) + (lookup a z)))))) + (let (tmp1 op y prop yy) + (declare (special |$specialCaseKeyList| |$getDomainCode| |$e| + |$optimizableConstructorNames|)) (cond - ((|member| (or (kar name) name) |$DummyFunctorNames|) - env) - ((or (equal name |$Category|) (|isCategoryForm| name env)) - env) - ((|member| name (setq curDomainsInScope (|getDomainsInScope| env))) - env) - (t - (when (setq u (getdatabase (|opOf| functorForm) 'superdomain)) - (setq env (|addNewDomain| (car u) env))) - (when (setq innerDom (|listOrVectorElementMode| name)) - (setq env (|addDomain| innerDom env))) - (when (and (consp name) (eq (qfirst name) '|Union|)) - (dolist (d (|stripUnionTags| (qrest name))) - (setq env (|addDomain| d env)))) - (|augModemapsFromDomain1| name functorForm env))))) + ((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{augModemapsFromDomain1}{augModemapsFromDomain1} -\calls{augModemapsFromDomain1}{getl} -\calls{augModemapsFromDomain1}{kar} -\calls{augModemapsFromDomain1}{addConstructorModemaps} -\calls{augModemapsFromDomain1}{getmode} -\calls{augModemapsFromDomain1}{augModemapsFromCategory} -\calls{augModemapsFromDomain1}{getmodeOrMapping} -\calls{augModemapsFromDomain1}{substituteCategoryArguments} -\calls{augModemapsFromDomain1}{stackMessage} -\begin{chunk}{defun augModemapsFromDomain1} -(defun |augModemapsFromDomain1| (name functorForm env) - (let (mappingForm categoryForm functArgTypes catform) +\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 - ((getl (kar functorForm) '|makeFunctionList|) - (|addConstructorModemaps| name functorForm env)) - ((and (atom functorForm) (setq catform (|getmode| functorForm env))) - (|augModemapsFromCategory| name functorForm catform env)) - ((setq mappingForm (|getmodeOrMapping| (kar functorForm) env)) - (when (eq (car mappingForm) '|Mapping|) (car mappingForm)) - (setq categoryForm (cadr mappingForm)) - (setq functArgTypes (cddr mappingForm)) - (setq catform - (|substituteCategoryArguments| (cdr functorForm) categoryForm)) - (|augModemapsFromCategory| name functorForm catform env)) + ((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 (consp fn) (eq (qfirst fn) 'xlam)) + (setq x (car (|optimize| (list x))))) + (if (and (consp x) (eq (qfirst x) 'equal) (progn (setq args (qrest x)) t)) + (rplacw x (def-equal args)) + x)) (t - (|stackMessage| (list functorForm '| is an unknown mode|)) - env)))) + (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{substituteCategoryArguments}{substituteCategoryArguments} -\calls{substituteCategoryArguments}{internl} -\calls{substituteCategoryArguments}{stringimage} -\calls{substituteCategoryArguments}{sublis} -\begin{chunk}{defun substituteCategoryArguments} -(defun |substituteCategoryArguments| (argl catform) - (let (arglAssoc (i 0)) - (setq argl (subst '$$ '$ argl :test #'equal)) - (setq arglAssoc - (loop for a in argl - collect (cons (internl '|#| (stringimage (incf i))) a))) - (sublis arglAssoc catform))) +\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{addConstructorModemaps}{addConstructorModemaps} -\calls{addConstructorModemaps}{putDomainsInScope} -\calls{addConstructorModemaps}{getl} -\calls{addConstructorModemaps}{addModemap} -\defsdollar{addConstructorModemaps}{InteractiveMode} -\begin{chunk}{defun addConstructorModemaps} -(defun |addConstructorModemaps| (name form env) - (let (|$InteractiveMode| functorName fn tmp1 funList op sig nsig opcode) - (declare (special |$InteractiveMode|)) - (setq functorName (car form)) - (setq |$InteractiveMode| nil) - (setq env (|putDomainsInScope| name env)) - (setq fn (getl functorName '|makeFunctionList|)) - (setq tmp1 (funcall fn name form env)) - (setq funList (car tmp1)) - (setq env (cadr tmp1)) - (dolist (item funList) - (setq op (first item)) - (setq sig (second item)) - (setq opcode (third item)) - (when (and (consp opcode) (consp (qrest opcode)) - (consp (qcddr opcode)) - (eq (qcdddr opcode) nil) - (eq (qfirst opcode) 'elt)) - (setq nsig (subst '$$$ name sig :test #'equal)) - (setq nsig - (subst '$ '$$$ (subst '$$ '$ nsig :test #'equal) :test #'equal)) - (setq opcode (list (first opcode) (second opcode) nsig))) - (setq env (|addModemap| op name sig t opcode env))) - env)) +\defun{optCallEval}{optCallEval} +\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 (consp u) (eq (qfirst u) '|List|)) + (|List| (|Integer|))) + ((and (consp u) (eq (qfirst u) '|Vector|)) + (|Vector| (|Integer|))) + ((and (consp u) (eq (qfirst u) '|PrimitiveArray|)) + (|PrimitiveArray| (|Integer|))) + ((and (consp u) (eq (qfirst u) '|FactoredForm|)) + (|FactoredForm| (|Integer|))) + ((and (consp u) (eq (qfirst u) '|Matrix|)) + (|Matrix| (|Integer|))) + (t + (|eval| u)))) \end{chunk} -\defun{getModemap}{getModemap} -\calls{getModemap}{get} -\calls{getModemap}{compApplyModemap} -\calls{getModemap}{sublis} -\begin{chunk}{defun getModemap} -(defun |getModemap| (x env) - (let (u) - (dolist (modemap (|get| (first x) '|modemap| env)) - (when (setq u (|compApplyModemap| x modemap env nil)) - (return (sublis (third u) modemap)))))) +\defplist{seq}{optSEQ} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'seq 'optimize) '|optSEQ|)) \end{chunk} -\defun{compApplyModemap}{compApplyModemap} -\calls{compApplyModemap}{length} -\calls{compApplyModemap}{pmatchWithSl} -\calls{compApplyModemap}{sublis} -\calls{compApplyModemap}{comp} -\calls{compApplyModemap}{coerce} -\calls{compApplyModemap}{compMapCond} -\calls{compApplyModemap}{member} -\calls{compApplyModemap}{genDeltaEntry} -\refsdollar{compApplyModemap}{e} -\refsdollar{compApplyModemap}{bindings} -\defsdollar{compApplyModemap}{e} -\defsdollar{compApplyModemap}{bindings} -\begin{chunk}{defun compApplyModemap} -(defun |compApplyModemap| (form modemap |$e| sl) - (declare (special |$e|)) - (let (op argl mc mr margl fnsel g mp lt ltp temp1 f) - (declare (special |$bindings| |$e|)) - ; -- $e is the current environment - ; -- sl substitution list, nil means bottom-up, otherwise top-down - ; -- 0. fail immediately if #argl=#margl - (setq op (car form)) - (setq argl (cdr form)) - (setq mc (caar modemap)) - (setq mr (cadar modemap)) - (setq margl (cddar modemap)) - (setq fnsel (cdr modemap)) - (when (= (|#| argl) (|#| margl)) - ; 1. use modemap to evaluate arguments, returning failed if not possible - (setq lt - (prog (t0) - (return - (do ((t1 argl (cdr t1)) (y NIL) (t2 margl (cdr t2)) (m nil)) - ((or (atom t1) (atom t2)) (nreverse0 t0)) - (setq y (car t1)) - (setq m (car t2)) - (setq t0 - (cons - (progn - (setq sl (|pmatchWithSl| mp m sl)) - (setq g (sublis sl m)) - (setq temp1 (or (|comp| y g |$e|) (return '|failed|))) - (setq mp (cadr temp1)) - (setq |$e| (caddr temp1)) - temp1) - t0))))))) - ; 2. coerce each argument to final domain, returning failed - ; if not possible - (unless (eq lt '|failed|) - (setq ltp - (loop for y in lt for d in (sublis sl margl) - collect (or (|coerce| y d) (return '|failed|)))) - (unless (eq ltp '|failed|) - ; 3. obtain domain-specific function, if possible, and return - ; $bindings is bound by compMapCond - (setq temp1 (|compMapCond| op mc sl fnsel)) - (when temp1 - ; can no longer trust what the modemap says for a reference into - ; an exterior domain (it is calculating the displacement based on view - ; information which is no longer valid; thus ignore this index and - ; store the signature instead. - (setq f (car temp1)) - (setq |$bindings| (cadr temp1)) - (if (and (consp f) (consp (qcdr f)) (consp (qcddr f)) ; f is [op1,.] - (eq (qcdddr f) nil) - (|member| (qcar f) '(elt const |Subsumed|))) - (list (|genDeltaEntry| (cons op modemap)) ltp |$bindings|) - (list f ltp |$bindings|)))))))) +\defun{optSEQ}{optSEQ} +\begin{chunk}{defun optSEQ} +(defun |optSEQ| (arg) + (labels ( + (tryToRemoveSEQ (z) + (if (and (consp z) (eq (qfirst z) 'seq) (consp (qrest z)) + (eq (qcddr z) nil) (consp (qsecond z)) + (consp (qcdadr z)) + (eq (qcddadr z) nil) + (member (qcaadr z) '(exit return throw))) + (qcadadr z) + z)) + (SEQToCOND (z) + (let (transform before aft) + (setq transform + (loop for x in z + while + (and (consp x) (eq (qfirst x) 'cond) (consp (qrest x)) + (eq (qcddr x) nil) (consp (qsecond x)) + (consp (qcdadr x)) + (eq (qcddadr x) nil) + (consp (qcadadr x)) + (eq (qfirst (qcadadr x)) 'exit) + (consp (qrest (qcadadr x))) + (eq (qcddr (qcadadr x)) nil)) + collect + (list (qcaadr x) + (qsecond (qcadadr 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 (consp z) (consp (qfirst z)) (eq (qcaar z) 'let) + (consp (qcdar z)) (consp (qcddar z)) + (gensymp (qcadar z)) + (> 2 (|numOfOccurencesOf| (qcadar z) (qrest z)))) + (setq g (qcadar z)) + (setq x (qcaddar z)) + (setq r (qrest z)) + (getRidOfTemps (subst x g r :test #'equal))) + ((eq (car z) '|/throwAway|) + (getRidOfTemps (cdr z))) + (t + (cons (car z) (getRidOfTemps (cdr z)))))))) + (tryToRemoveSEQ (SEQToCOND (getRidOfTemps (cdr arg)))))) \end{chunk} -\defun{compMapCond}{compMapCond} -\calls{compMapCond}{compMapCond'} -\refsdollar{compMapCond}{bindings} -\begin{chunk}{defun compMapCond} -(defun |compMapCond| (op mc |$bindings| fnsel) - (declare (special |$bindings|)) - (let (t0) - (do ((t1 nil t0) (t2 fnsel (cdr t2)) (u nil)) - ((or t1 (atom t2) (progn (setq u (car t2)) nil)) t0) - (setq t0 (or t0 (|compMapCond'| u op mc |$bindings|)))))) +\defplist{eq}{optEQ} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'eq 'optimize) '|optEQ|)) \end{chunk} -\defun{compMapCond'}{compMapCond'} -\calls{compMapCond'}{compMapCond''} -\calls{compMapCond'}{compMapConfFun} -\calls{compMapCond'}{stackMessage} -\begin{chunk}{defun compMapCond'} -(defun |compMapCond'| (t0 op dc bindings) - (let ((cexpr (car t0)) (fnexpr (cadr t0))) - (if (|compMapCond''| cexpr dc) - (|compMapCondFun| fnexpr op dc bindings) - (|stackMessage| `("not known that" %b ,dc %d "has" %b ,cexpr %d))))) +\defun{optEQ}{optEQ} +\begin{chunk}{defun optEQ} +(defun |optEQ| (u) + (let (z r) + (cond + ((and (consp u) (eq (qfirst u) 'eq) (consp (qrest u)) + (consp (qcddr u)) (eq (qcdddr u) nil)) + (setq z (qsecond u)) + (setq r (qthird 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} -\defun{compMapCond''}{compMapCond''} -\calls{compMapCond''}{compMapCond''} -\calls{compMapCond''}{knownInfo} -\calls{compMapCond''}{get} -\calls{compMapCond''}{stackMessage} -\refsdollar{compMapCond''}{Information} -\refsdollar{compMapCond''}{e} -\begin{chunk}{defun compMapCond''} -(defun |compMapCond''| (cexpr dc) - (let (l u tmp1 tmp2) - (declare (special |$Information| |$e|)) +\defplist{minus}{optMINUS} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'minus 'optimize) '|optMINUS|)) + +\end{chunk} + +\defun{optMINUS}{optMINUS} +\begin{chunk}{defun optMINUS} +(defun |optMINUS| (u) + (let (v) (cond - ((eq cexpr t) t) - ((and (consp cexpr) - (eq (qcar cexpr) 'and) - (progn (setq l (qcdr cexpr)) t)) - (prog (t0) - (setq t0 t) - (return - (do ((t1 nil (null t0)) (t2 l (cdr t2)) (u nil)) - ((or t1 (atom t2) (progn (setq u (car t2)) nil)) t0) - (setq t0 (and t0 (|compMapCond''| u dc))))))) - ((and (consp cexpr) - (eq (qcar cexpr) 'or) - (progn (setq l (qcdr cexpr)) t)) - (prog (t3) - (setq t3 nil) - (return - (do ((t4 nil t3) (t5 l (cdr t5)) (u nil)) - ((or t4 (atom t5) (progn (setq u (car t5)) nil)) t3) - (setq t3 (or t3 (|compMapCond''| u dc))))))) - ((and (consp cexpr) - (eq (qcar cexpr) '|not|) - (progn - (setq tmp1 (qcdr cexpr)) - (and (consp tmp1) - (eq (qcdr tmp1) nil) - (progn (setq u (qcar tmp1)) t)))) - (null (|compMapCond''| u dc))) - ((and (consp cexpr) - (eq (qcar cexpr) '|has|) - (progn - (setq tmp1 (qcdr cexpr)) - (and (consp tmp1) - (progn - (setq tmp2 (qcdr tmp1)) - (and (consp tmp2) - (eq (qcdr tmp2) nil)))))) - (cond - ((|knownInfo| cexpr) t) - (t nil))) - ((|member| - (cons 'attribute (cons dc (cons cexpr nil))) - (|get| '|$Information| 'special |$e|)) - t) - (t - (|stackMessage| `("not known that" %b ,dc %d "has" %b ,cexpr %d)) - nil)))) + ((and (consp u) (eq (qfirst u) 'minus) (consp (qrest u)) + (eq (qcddr u) nil)) + (setq v (qsecond u)) + (cond ((numberp v) (- v)) (t u))) + (t u)))) + +\end{chunk} + +\defplist{qsminus}{optQSMINUS} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'qsminus 'optimize) '|optQSMINUS|)) \end{chunk} -\defun{compMapCondFun}{compMapCondFun} -\begin{chunk}{defun compMapCondFun} -(defun |compMapCondFun| (fnexpr op dc bindings) - (declare (ignore op) (ignore dc)) - (cons fnexpr (cons bindings nil))) +\defun{optQSMINUS}{optQSMINUS} +\begin{chunk}{defun optQSMINUS} +(defun |optQSMINUS| (u) + (let (v) + (cond + ((and (consp u) (eq (qfirst u) 'qsminus) (consp (qrest u)) + (eq (qcddr u) nil)) + (setq v (qsecond u)) + (cond ((numberp v) (- v)) (t u))) + (t u)))) \end{chunk} -\defun{getUniqueSignature}{getUniqueSignature} -\calls{getUniqueSignature}{getUniqueModemap} -\begin{chunk}{defun getUniqueSignature} -(defun |getUniqueSignature| (form env) - (cdar (|getUniqueModemap| (first form) (|#| (rest form)) env))) +\defplist{-}{opt-} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '- 'optimize) '|opt-|)) \end{chunk} -\defun{getUniqueModemap}{getUniqueModemap} -\calls{getUniqueModemap}{getModemapList} -\calls{getUniqueModemap}{qslessp} -\calls{getUniqueModemap}{stackWarning} -\begin{chunk}{defun getUniqueModemap} -(defun |getUniqueModemap| (op numOfArgs env) - (let (mml) +\defun{opt-}{opt-} +\begin{chunk}{defun opt-} +(defun |opt-| (u) + (let (v) (cond - ((eql 1 (|#| (setq mml (|getModemapList| op numOfArgs env)))) - (car mml)) - ((qslessp 1 (|#| mml)) - (|stackWarning| - (list numOfArgs " argument form of: " op " has more than one modemap")) - (car mml)) - (t nil)))) + ((and (consp u) (eq (qfirst u) '-) (consp (qrest u)) + (eq (qcddr u) NIL)) + (setq v (qsecond u)) + (cond ((numberp v) (- v)) (t u))) + (t u)))) \end{chunk} -\defun{getModemapList}{getModemapList} -\calls{getModemapList}{qcar} -\calls{getModemapList}{qcdr} -\calls{getModemapList}{getModemapListFromDomain} -\calls{getModemapList}{nreverse0} -\calls{getModemapList}{get} -\begin{chunk}{defun getModemapList} -(defun |getModemapList| (op numOfArgs env) - (let (result) +\defplist{lessp}{optLESSP} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'lessp 'optimize) '|optLESSP|)) + +\end{chunk} + +\defun{optLESSP}{optLESSP} +\begin{chunk}{defun optLESSP} +(defun |optLESSP| (u) + (let (a b) (cond - ((and (consp op) (eq (qfirst op) '|elt|) (consp (qrest op)) - (consp (qcddr op)) (eq (qcdddr op) nil)) - (|getModemapListFromDomain| (third op) numOfArgs (second op) env)) - (t - (dolist (term (|get| op '|modemap| env) (nreverse0 result)) - (when (eql numOfArgs (|#| (cddar term))) (push term result))))))) + ((and (consp u) (eq (qfirst u) 'lessp) (consp (qrest u)) + (consp (qcddr u)) + (eq (qcdddr u) nil)) + (setq a (qsecond u)) + (setq b (qthird u)) + (if (eql b 0) + (list 'minusp a) + (list '> b a))) + (t u)))) \end{chunk} -\defun{getModemapListFromDomain}{getModemapListFromDomain} -\calls{getModemapListFromDomain}{get} -\begin{chunk}{defun getModemapListFromDomain} -(defun |getModemapListFromDomain| (op numOfArgs d env) - (loop for term in (|get| op '|modemap| env) - when (and (equal (caar term) d) (eql (|#| (cddar term)) numOfArgs)) - collect term)) - +\defplist{spadcall}{optSPADCALL} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'spadcall 'optimize) '|optSPADCALL|)) + \end{chunk} -\defun{domainMember}{domainMember} -\calls{domainMember}{modeEqual} -\begin{chunk}{defun domainMember} -(defun |domainMember| (dom domList) - (let (result) - (dolist (d domList result) - (setq result (or result (|modeEqual| dom d)))))) +\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 (consp argl) + (progn (setq tmp1 (reverse argl)) t) + (consp tmp1)) + (setq fun (qfirst tmp1)) + (setq argl (qrest tmp1)) + (setq argl (nreverse argl)) + (cond + ((and (consp fun) + (or (eq (qfirst fun) 'elt) (eq (qfirst fun) 'lispelt)) + (progn + (and (consp (qrest fun)) + (progn + (setq dom (qsecond fun)) + (and (consp (qcddr fun)) + (eq (qcdddr fun) nil) + (progn + (setq slot (qthird fun)) + t)))))) + (|optCall| (cons '|call| (cons (list 'elt dom slot) argl)))) + (t form))) + (t form)))) \end{chunk} -\defun{augModemapsFromCategory}{augModemapsFromCategory} -\calls{augModemapsFromCategory}{evalAndSub} -\calls{augModemapsFromCategory}{compilerMessage} -\calls{augModemapsFromCategory}{putDomainsInScope} -\calls{augModemapsFromCategory}{addModemapKnown} -\defsdollar{augModemapsFromCategory}{base} -\begin{chunk}{defun augModemapsFromCategory} -(defun |augModemapsFromCategory| (domainName functorform categoryForm env) - (let (tmp1 op sig cond fnsel) - (declare (special |$base|)) - (setq tmp1 (|evalAndSub| domainName domainName functorform categoryForm env)) - (|compilerMessage| (list '|Adding | domainName '| modemaps|)) - (setq env (|putDomainsInScope| domainName (second tmp1))) - (setq |$base| 4) - (dolist (u (first tmp1)) - (setq op (caar u)) - (setq sig (cadar u)) - (setq cond (cadr u)) - (setq fnsel (caddr u)) - (setq env (|addModemapKnown| op domainName sig cond fnsel env))) - env)) +\defplist{|}{optSuchthat} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '|\|| 'optimize) '|optSuchthat|)) \end{chunk} -\defun{addEltModemap}{addEltModemap} -This is a hack to change selectors from strings to identifiers; and to -add flag identifiers as literals in the environment -\calls{addEltModemap}{qcar} -\calls{addEltModemap}{qcdr} -\calls{addEltModemap}{makeLiteral} -\calls{addEltModemap}{addModemap1} -\calls{addEltModemap}{systemErrorHere} -\refsdollar{addEltModemap}{insideCapsuleFunctionIfTrue} -\defsdollar{addEltModemap}{e} -\begin{chunk}{defun addEltModemap} -(defun |addEltModemap| (op mc sig pred fn env) - (let (tmp1 v sel lt id) - (declare (special |$e| |$insideCapsuleFunctionIfTrue|)) - (cond - ((and (eq op '|elt|) (consp sig)) - (setq tmp1 (reverse sig)) - (setq sel (qfirst tmp1)) - (setq lt (nreverse (qrest tmp1))) +\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) + (setf (get 'catch 'optimize) '|optCatch|)) + +\end{chunk} + +\defun{optCatch}{optCatch} +\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 (consp s) (eq (qfirst s) 'throw) (consp (qrest s)) + (equal (qsecond s) g)) + (|rplac| (car s) 'exit) + (|rplac| (cdr s) (qcddr s))) + (t + (changeThrowToExit (car s) g) + (changeThrowToExit (cdr s) g)))) + (hasNoThrows (a g) + (cond + ((and (consp a) (eq (qfirst a) 'throw) (consp (qrest a)) + (equal (qsecond 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 (consp s) (eq (qfirst s) 'throw) (consp (qrest s)) + (equal (qsecond s) g) (consp (qcddr s)) + (eq (qcdddr s) nil)) + (setq u (qthird 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 - ((stringp sel) - (setq id (intern sel)) - (if |$insideCapsuleFunctionIfTrue| - (setq |$e| (|makeLiteral| id |$e|)) - (setq env (|makeLiteral| id env))) - (|addModemap1| op mc (append lt (list id)) pred fn env)) - (t (|addModemap1| op mc sig pred fn env)))) - ((and (eq op '|setelt|) (consp sig)) - (setq tmp1 (reverse sig)) - (setq v (qfirst tmp1)) - (setq sel (qsecond tmp1)) - (setq lt (nreverse (qcddr tmp1))) + ((and (consp a) (eq (qfirst a) 'seq) (consp (qrest a)) + (progn (setq tmp2 (reverse (qrest a))) t) + (consp tmp2) (consp (qfirst tmp2)) (eq (qcaar tmp2) 'throw) + (consp (qcdar tmp2)) + (equal (qcadar tmp2) g) + (consp (qcddar tmp2)) + (eq (qcdddar tmp2) nil)) + (setq u (qcaddar tmp2)) + (setq s (qrest 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 - ((stringp sel) (setq id (intern sel)) - (if |$insideCapsuleFunctionIfTrue| - (setq |$e| (|makeLiteral| id |$e|)) - (setq env (|makeLiteral| id env))) - (|addModemap1| op mc (append lt (list id v)) pred fn env)) - (t (|addModemap1| op mc sig pred fn env)))) - (t (|systemErrorHere| "addEltModemap"))))) + ((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} -\defun{mkNewModemapList}{mkNewModemapList} -\calls{mkNewModemapList}{member} -\calls{mkNewModemapList}{assoc} -\calls{mkNewModemapList}{qcar} -\calls{mkNewModemapList}{qcdr} -\calls{mkNewModemapList}{mergeModemap} -\calls{mkNewModemapList}{nreverse0} -\calls{mkNewModemapList}{insertModemap} -\refsdollar{mkNewModemapList}{InteractiveMode} -\refsdollar{mkNewModemapList}{forceAdd} -\begin{chunk}{defun mkNewModemapList} -(defun |mkNewModemapList| (mc sig pred fn curModemapList env filenameOrNil) - (let (map entry oldMap opred result) - (declare (special |$InteractiveMode| |$forceAdd|)) - (setq entry - (cons (setq map (cons mc sig)) (cons (list pred fn) filenameOrNil))) - (cond - ((|member| entry curModemapList) curModemapList) - ((and (setq oldMap (|assoc| map curModemapList)) - (consp oldMap) (consp (qrest oldMap)) - (consp (qsecond oldMap)) - (consp (qcdadr oldMap)) - (eq (qcddadr oldMap) nil) - (equal (qcadadr oldMap) fn)) - (setq opred (qcaadr oldMap)) - (cond - (|$forceAdd| (|mergeModemap| entry curModemapList env)) - ((eq opred t) curModemapList) - (t - (when (and (not (eq pred t)) (not (equal pred opred))) - (setq pred (list 'or pred opred))) - (dolist (x curModemapList (nreverse0 result)) - (push - (if (equal x oldMap) - (cons map (cons (list pred fn) filenameOrNil)) - x) - result))))) - (|$InteractiveMode| - (|insertModemap| entry curModemapList)) - (t - (|mergeModemap| entry curModemapList env))))) +\defplist{cond}{optCond} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'cond 'optimize) '|optCond|)) \end{chunk} -\defun{insertModemap}{insertModemap} -\begin{chunk}{defun insertModemap} -(defun |insertModemap| (new mmList) - (if (null mmList) (list new) (cons new mmList))) +\defun{optCond}{optCond} +\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 (consp z) (consp (qrest z)) (eq (qcddr z) nil) + (consp (qsecond z)) (consp (qcdadr z)) + (eq (qrest (qcdadr z)) nil) + (|TruthP| (qcaadr z)) + (consp (qcadadr z)) + (eq (qfirst (qcadadr z)) 'cond)) + (rplacd (cdr x) (qrest (qcadadr z)))) + (cond + ((and (consp z) (consp (qfirst z)) (consp (qrest z)) (consp (qsecond z))) + (setq p1 (qcaar z)) + (setq c1 (qcdar z)) + (setq p2 (qcaadr z)) + (setq c2 (qcdadr z)) + (when + (or (and (consp p1) (eq (qfirst p1) 'null) (consp (qrest p1)) + (eq (qcddr p1) nil) + (equal (qsecond p1) p2)) + (and (consp p2) (eq (qfirst p2) 'null) (consp (qrest p2)) + (eq (qcddr p2) nil) + (equal (qsecond p2) p1))) + (setq z (list (cons p1 c1) (cons ''t c2))) + (rplacd x z)) + (when + (and (consp c1) (eq (qrest c1) nil) (equal (qfirst c1) 'nil) + (equal p2 ''t) (equal (car c2) ''t)) + (if (and (consp p1) (eq (qfirst p1) 'null) (consp (qrest p1)) + (eq (qcddr p1) nil)) + (setq result (qsecond p1)) + (setq result (list 'null p1)))))) + (if result + result + (cond + ((and (consp z) (consp (qfirst z)) (consp (qrest z)) (consp (qsecond z)) + (consp (qcddr z)) (eq (qcdddr z) nil) + (consp (qthird z)) + (|TruthP| (qcaaddr z))) + (setq p1 (qcaar z)) + (setq c1 (qcdar z)) + (setq p2 (qcaadr z)) + (setq c2 (qcdadr z)) + (setq c3 (qcdaddr 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 (consp y) (consp (qfirst y)) (consp (qcdar y)) + (eq (qcddar y) nil) (consp (qrest y)) + (consp (qsecond y)) (consp (qcdadr y)) + (eq (qcddadr y) nil) + (|EqualBarGensym| (qcadar y) + (qcadadr y)))) + nil) + (setq a (list 'or (qcaar y) (qcaadr y))) + (rplac (car (car y)) a) + (rplac (cdr y) (qcddr y)))) + x))))) \end{chunk} -\defun{mergeModemap}{mergeModemap} -\calls{mergeModemap}{isSuperDomain} -\calls{mergeModemap}{TruthP} -\refsdollar{mergeModemap}{forceAdd} -\begin{chunk}{defun mergeModemap} -(defun |mergeModemap| (entry modemapList env) - (let (mc sig pred mcp sigp predp newmm mm) - (declare (special |$forceAdd|)) - ; break out the condition, signature, and predicate fields of the new entry - (setq mc (caar entry)) - (setq sig (cdar entry)) - (setq pred (caadr entry)) - (seq - ; walk across the successive tails of the modemap list - (do ((mmtail modemapList (cdr mmtail))) - ((atom mmtail) nil) - (setq mcp (caaar mmtail)) - (setq sigp (cdaar mmtail)) - (setq predp (caadar mmtail)) - (cond - ((or (equal mc mcp) (|isSuperDomain| mcp mc env)) - ; if this is a duplicate condition - (exit - (progn - (setq newmm nil) - (setq mm modemapList) - ; copy the unique modemap terms - (loop while (not (eq mm mmtail)) do - (setq newmm (cons (car mm) newmm)) - (setq mm (cdr mm))) - ; if the conditions and signatures are equal - (when (and (equal mc mcp) (equal sig sigp)) - ; we only need one of these unless the conditions are hairy - (cond - ((and (null |$forceAdd|) (|TruthP| predp)) - ; the new predicate buys us nothing - (setq entry nil) - (return modemapList)) - ((|TruthP| pred) - ; the thing we matched against is useless, by comparison - (setq mmtail (cdr mmtail))))) - (setq modemapList (nconc (nreverse newmm) (cons entry mmtail))) - (setq entry nil) - (return modemapList)))))) - ; if the entry is still defined, add it to the modemap - (if entry - (append modemapList (list entry)) - modemapList)))) +\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 (consp y) (eq (qrest y) nil) (gensymp (qfirst y)))) + ((null y) (and (consp x) (eq (qrest x) nil) (gensymp (qfirst 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} -\defun{TruthP}{TruthP} -\calls{TruthP}{qcar} -\begin{chunk}{defun TruthP} -(defun |TruthP| (x) - (cond - ((null x) nil) - ((eq x t) t) - ((and (consp x) (eq (qfirst x) 'quote)) t) - (t nil))) +\defplist{mkRecord}{optMkRecord} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '|mkRecord| 'optimize) '|optMkRecord|)) \end{chunk} -\defun{evalAndSub}{evalAndSub} -\calls{evalAndSub}{isCategory} -\calls{evalAndSub}{substNames} -\calls{evalAndSub}{contained} -\calls{evalAndSub}{put} -\calls{evalAndSub}{get} -\calls{evalAndSub}{getOperationAlist} -\defsdollar{evalAndSub}{lhsOfColon} -\begin{chunk}{defun evalAndSub} -(defun |evalAndSub| (domainName viewName functorForm form |$e|) - (declare (special |$e|)) - (let (|$lhsOfColon| opAlist substAlist) - (declare (special |$lhsOfColon|)) - (setq |$lhsOfColon| domainName) - (cond - ((|isCategory| form) - (list (|substNames| domainName viewName functorForm (elt form 1)) |$e|)) - (t - (when (contained '$$ form) - (setq |$e| (|put| '$$ '|mode| (|get| '$ '|mode| |$e|) |$e|))) - (setq opAlist (|getOperationAlist| domainName functorForm form)) - (setq substAlist (|substNames| domainName viewName functorForm opAlist)) - (list substAlist |$e|))))) +\defun{optMkRecord}{optMkRecord} +\calls{optMkRecord}{length} +\begin{chunk}{defun optMkRecord} +(defun |optMkRecord| (arg) + (let (u) + (setq u (cdr arg)) + (cond + ((and (consp u) (eq (qrest u) nil)) (list 'list (qfirst u))) + ((eql (|#| u) 2) (cons 'cons u)) + (t (cons 'vector u))))) \end{chunk} -\defun{getOperationAlist}{getOperationAlist} -\calls{getOperationAlist}{getdatabase} -\calls{getOperationAlist}{isFunctor} -\calls{getOperationAlist}{systemError} -\calls{getOperationAlist}{compMakeCategoryObject} -\calls{getOperationAlist}{stackMessage} -\usesdollar{getOperationAlist}{e} -\usesdollar{getOperationAlist}{domainShell} -\usesdollar{getOperationAlist}{insideFunctorIfTrue} -\usesdollar{getOperationAlist}{functorForm} -\begin{chunk}{defun getOperationAlist} -(defun |getOperationAlist| (name functorForm form) - (let (u tt) - (declare (special |$e| |$domainShell| |$insideFunctorIfTrue| |$functorForm|)) - (when (and (atom name) (getdatabase name 'niladic)) - (setq functorform (list functorForm))) - (cond - ((and (setq u (|isFunctor| functorForm)) - (null (and |$insideFunctorIfTrue| - (equal (first functorForm) (first |$functorForm|))))) - u) - ((and |$insideFunctorIfTrue| (eq name '$)) - (if |$domainShell| - (elt |$domainShell| 1) - (|systemError| "$ has no shell now"))) - ((setq tt (|compMakeCategoryObject| form |$e|)) - (setq |$e| (third tt)) - (elt (first tt) 1)) - (t - (|stackMessage| (list '|not a category form: | form)))))) +\defplist{recordelt}{optRECORDELT} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'recordelt 'optimize) '|optRECORDELT|)) \end{chunk} -\defdollar{FormalMapVariableList} -\begin{chunk}{initvars} -(defvar |$FormalMapVariableList| - '(\#1 \#2 \#3 \#4 \#5 \#6 \#7 \#8 \#9 \#10 \#11 \#12 \#13 \#14 \#15)) +\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} -\defun{substNames}{substNames} -\calls{substNames}{isCategoryPackageName} -\calls{substNames}{eqsubstlist} -\calls{substNames}{nreverse0} -\usesdollar{substNames}{FormalMapVariableList} -\begin{chunk}{defun substNames} -(defun |substNames| (domainName viewName functorForm opalist) - (let (nameForDollar sel pos modemapform tmp0 tmp1) - (declare (special |$FormalMapVariableList|)) - (setq functorForm (subst '$$ '$ functorForm)) - (setq nameForDollar - (if (|isCategoryPackageName| functorForm) - (second functorForm) - domainName)) -; following calls to SUBSTQ must copy to save RPLAC's in -; putInLocalDomainReferences - (dolist (term - (eqsubstlist (kdr functorForm) |$FormalMapVariableList| opalist) - (nreverse0 tmp0)) - (setq tmp1 (reverse term)) - (setq sel (caar tmp1)) - (setq pos (caddar tmp1)) - (setq modemapform (nreverse (cdr tmp1))) - (push - (append - (subst '$ '$$ (subst nameForDollar '$ modemapform)) - (list - (list sel viewName (if (eq domainName '$) pos (cadar modemapform))))) - tmp0)))) +\defplist{setrecordelt}{optSETRECORDELT} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'setrecordelt 'optimize) '|optSETRECORDELT|)) \end{chunk} -\defun{augModemapsFromCategoryRep}{augModemapsFromCategoryRep} -\calls{augModemapsFromCategoryRep}{evalAndSub} -\calls{augModemapsFromCategoryRep}{isCategory} -\calls{augModemapsFromCategoryRep}{compilerMessage} -\calls{augModemapsFromCategoryRep}{putDomainsInScope} -\calls{augModemapsFromCategoryRep}{assoc} -\calls{augModemapsFromCategoryRep}{addModemap} -\defsdollar{augModemapsFromCategoryRep}{base} -\begin{chunk}{defun augModemapsFromCategoryRep} -(defun |augModemapsFromCategoryRep| - (domainName repDefn functorBody categoryForm env) - (labels ( - (redefinedList (op z) - (let (result) - (dolist (u z result) - (setq result (or result (redefined op u)))))) - (redefined (opname u) - (let (op z result) - (when (consp u) - (setq op (qfirst u)) - (setq z (qrest u)) +\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 - ((eq op 'def) (equal opname (caar z))) - ((member op '(progn seq)) (redefinedList opname z)) - ((eq op 'cond) - (dolist (v z result) - (setq result (or result (redefinedList opname (cdr v))))))))))) - (let (fnAlist tmp1 repFnAlist catform lhs op sig cond fnsel u) - (declare (special |$base|)) - (setq tmp1 (|evalAndSub| domainName domainName domainName categoryForm env)) - (setq fnAlist (car tmp1)) - (setq env (cadr tmp1)) - (setq tmp1 (|evalAndSub| '|Rep| '|Rep| repDefn (|getmode| repDefn env) env)) - (setq repFnAlist (car tmp1)) - (setq env (cadr tmp1)) - (setq catform - (if (|isCategory| categoryForm) (elt categoryForm 0) categoryForm)) - (|compilerMessage| (list '|Adding | domainName '| modemaps|)) - (setq env (|putDomainsInScope| domainName env)) - (setq |$base| 4) - (dolist (term fnAlist) - (setq lhs (car term)) - (setq op (caar term)) - (setq sig (cadar term)) - (setq cond (cadr term)) - (setq fnsel (caddr term)) - (setq u (|assoc| (subst '|Rep| domainName lhs :test #'equal) repFnAlist)) - (if (and u (null (redefinedList op functorBody))) - (setq env (|addModemap| op domainName sig cond (caddr u) env)) - (setq env (|addModemap| op domainName sig cond fnsel env)))) - env))) + ((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} -\section{Maintaining Modemaps} -\defun{addModemapKnown}{addModemapKnown} -\calls{addModemapKnown}{addModemap0} -\refsdollar{addModemapKnown}{e} -\refsdollar{CapsuleModemapFrame}{insideCapsuleFunctionIfTrue} -\defsdollar{addModemapKnown}{CapsuleModemapFrame} -\begin{chunk}{defun addModemapKnown} -(defun |addModemapKnown| (op mc sig pred fn |$e|) - (declare (special |$e| |$CapsuleModemapFrame| |$insideCapsuleFunctionIfTrue|)) - (if (eq |$insideCapsuleFunctionIfTrue| t) - (progn - (setq |$CapsuleModemapFrame| - (|addModemap0| op mc sig pred fn |$CapsuleModemapFrame|)) - |$e|) - (|addModemap0| op mc sig pred fn |$e|))) +\defplist{recordcopy}{optRECORDCOPY} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'recordcopy 'optimize) '|optRECORDCOPY|)) \end{chunk} -\defun{addModemap}{addModemap} -\calls{addModemap}{addModemap0} -\calls{addModemap}{knownInfo} -\refsdollar{addModemap}{e} -\refsdollar{addModemap}{InteractiveMode} -\refsdollar{addModemap}{insideCapsuleFunctionIfTrue} -\refsdollar{addModemap}{CapsuleModemapFrame} -\defsdollar{addModemap}{CapsuleModemapFrame} -\begin{chunk}{defun addModemap} -(defun |addModemap| (op mc sig pred fn |$e|) - (declare (special |$e| |$CapsuleModemapFrame| |$InteractiveMode| - |$insideCapsuleFunctionIfTrue|)) +\defun{optRECORDCOPY}{optRECORDCOPY} +\begin{chunk}{defun optRECORDCOPY} +(defun |optRECORDCOPY| (arg) + (let (name len) + (setq name (cadr arg)) + (setq len (caddr arg)) (cond - (|$InteractiveMode| |$e|) - (t - (when (|knownInfo| pred) (setq pred t)) + ((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} +\calls{addDomain}{identp} +\calls{addDomain}{qslessp} +\calls{addDomain}{getDomainsInScope} +\calls{addDomain}{domainMember} +\calls{addDomain}{isLiteral} +\calls{addDomain}{addNewDomain} +\calls{addDomain}{getmode} +\calls{addDomain}{isCategoryForm} +\calls{addDomain}{isFunctor} +\calls{addDomain}{constructor?} +\calls{addDomain}{member} +\calls{addDomain}{unknownTypeError} +\begin{chunk}{defun addDomain} +(defun |addDomain| (domain env) + (let (s name tmp1) + (cond + ((atom domain) (cond - ((eq |$insideCapsuleFunctionIfTrue| t) - (setq |$CapsuleModemapFrame| - (|addModemap0| op mc sig pred fn |$CapsuleModemapFrame|)) - |$e|) - (t - (|addModemap0| op mc sig pred fn |$e|)))))) + ((eq domain '|$EmptyMode|) env) + ((eq domain '|$NoValueMode|) env) + ((or (null (identp domain)) + (and (qslessp 2 (|#| (setq s (princ-to-string domain)))) + (eq (|char| '|#|) (elt s 0)) + (eq (|char| '|#|) (elt s 1)))) + env) + ((member domain (|getDomainsInScope| env)) env) + ((|isLiteral| domain env) env) + (t (|addNewDomain| domain env)))) + ((eq (setq name (car domain)) '|Category|) env) + ((|domainMember| domain (|getDomainsInScope| env)) env) + ((and (progn + (setq tmp1 (|getmode| name env)) + (and (consp tmp1) (eq (qfirst tmp1) '|Mapping|) + (consp (qrest tmp1)))) + (|isCategoryForm| (second tmp1) env)) + (|addNewDomain| domain env)) + ((or (|isFunctor| name) (|constructor?| name)) + (|addNewDomain| domain env)) + (t + (when (and (null (|isCategoryForm| domain env)) + (null (|member| name '(|Mapping| category)))) + (|unknownTypeError| name)) + env)))) \end{chunk} -\defun{addModemap0}{addModemap0} -\calls{addModemap0}{qcar} -\calls{addModemap0}{addEltModemap} -\calls{addModemap0}{addModemap1} -\refsdollar{addModemap0}{functorForm} -\begin{chunk}{defun addModemap0} -(defun |addModemap0| (op mc sig pred fn env) - (declare (special |$functorForm|)) - (cond - ((and (consp |$functorForm|) - (eq (qfirst |$functorForm|) '|CategoryDefaults|) - (eq mc '$)) - env) - ((or (eq op '|elt|) (eq op '|setelt|)) - (|addEltModemap| op mc sig pred fn env)) - (t (|addModemap1| op mc sig pred fn env)))) +\defun{unknownTypeError}{unknownTypeError} +\calls{unknownTypeError}{stackSemanticError} +\begin{chunk}{defun unknownTypeError} +(defun |unknownTypeError| (name) + (let (op) + (setq name + (if (and (consp name) (setq op (qfirst name))) + op + name)) + (|stackSemanticError| (list '|%b| name '|%d| '|is not a known type|) nil))) \end{chunk} -\defun{addModemap1}{addModemap1} -\calls{addModemap1}{getProplist} -\calls{addModemap1}{mkNewModemapList} -\calls{addModemap1}{lassoc} -\calls{addModemap1}{augProplist} -\calls{addModemap1}{unErrorRef} -\calls{addModemap1}{addBinding} -\begin{chunk}{defun addModemap1} -(defun |addModemap1| (op mc sig pred fn env) - (let (currentProplist newModemapList newProplist newProplistp) - (when (eq mc '|Rep|) (setq sig (subst '$ '|Rep| sig :test #'equal))) - (setq currentProplist (or (|getProplist| op env) nil)) - (setq newModemapList - (|mkNewModemapList| mc sig pred fn - (lassoc '|modemap| currentProplist) env nil)) - (setq newProplist (|augProplist| currentProplist '|modemap| newModemapList)) - (setq newProplistp (|augProplist| newProplist 'fluid t)) - (|unErrorRef| op) - (|addBinding| op newProplistp env))) +\defun{isFunctor}{isFunctor} +\calls{isFunctor}{opOf} +\calls{isFunctor}{identp} +\calls{isFunctor}{getdatabase} +\calls{isFunctor}{get} +\calls{isFunctor}{constructor?} +\calls{isFunctor}{updateCategoryFrameForCategory} +\calls{isFunctor}{updateCategoryFrameForConstructor} +\refsdollar{isFunctor}{CategoryFrame} +\refsdollar{isFunctor}{InteractiveMode} +\begin{chunk}{defun isFunctor} +(defun |isFunctor| (x) + (let (op u prop) + (declare (special |$CategoryFrame| |$InteractiveMode|)) + (setq op (|opOf| x)) + (cond + ((null (identp op)) nil) + (|$InteractiveMode| + (if (member op '(|Union| |SubDomain| |Mapping| |Record|)) + t + (member (getdatabase op 'constructorkind) '(|domain| |package|)))) + ((setq u + (or (|get| op '|isFunctor| |$CategoryFrame|) + (member op '(|SubDomain| |Union| |Record|)))) + u) + ((|constructor?| op) + (cond + ((setq prop (|get| op '|isFunctor| |$CategoryFrame|)) prop) + (t + (if (eq (getdatabase op 'constructorkind) '|category|) + (|updateCategoryFrameForCategory| op) + (|updateCategoryFrameForConstructor| op)) + (|get| op '|isFunctor| |$CategoryFrame|)))) + (t nil)))) \end{chunk} - -\section{Indirect called comp routines} -In the {\bf compExpression} function there is the code: +\defun{getDomainsInScope}{getDomainsInScope} +The way XLAMs work: \begin{verbatim} - (if (and (atom (car x)) (setq fn (getl (car x) 'special))) - (funcall fn x m e) - (|compForm| x m e)))) + ((XLAM ($1 $2 $3) (SETELT $1 0 $3)) X "c" V) ==> (SETELT X 0 V) \end{verbatim} - - -\defplist{@}{compAdd plist} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get '|add| 'special) 'compAdd)) +\calls{getDomainsInScope}{get} +\refsdollar{getDomainsInScope}{CapsuleDomainsInScope} +\refsdollar{getDomainsInScope}{insideCapsuleFunctionIfTrue} +\begin{chunk}{defun getDomainsInScope} +(defun |getDomainsInScope| (env) + (declare (special |$CapsuleDomainsInScope| |$insideCapsuleFunctionIfTrue|)) + (if |$insideCapsuleFunctionIfTrue| + |$CapsuleDomainsInScope| + (|get| '|$DomainsInScope| 'special env))) \end{chunk} -\defun{compAdd}{compAdd} -The compAdd function expects three arguments: -\begin{enumerate} -\item the {\bf form} which is an |add| specifying the domain -to extend and a set of functions to be added -\item the {\bf mode} a |Join|, which is a set of categories and domains -\item the {\bf env} which is a list of functions and their modemaps -\end{enumerate} +\defun{putDomainsInScope}{putDomainsInScope} +\calls{putDomainsInScope}{getDomainsInScope} +\calls{putDomainsInScope}{put} +\calls{putDomainsInScope}{delete} +\calls{putDomainsInScope}{say} +\calls{putDomainsInScope}{member} +\defsdollar{putDomainsInScope}{CapsuleDomainsInScope} +\refsdollar{putDomainsInScope}{insideCapsuleFunctionIfTrue} +\begin{chunk}{defun putDomainsInScope} +(defun |putDomainsInScope| (x env) + (let (z newValue) + (declare (special |$CapsuleDomainsInScope| |$insideCapsuleFunctionIfTrue|)) + (setq z (|getDomainsInScope| env)) + (when (|member| x z) (say "****** Domain: " x " already in scope")) + (setq newValue (cons x (|delete| x z))) + (if |$insideCapsuleFunctionIfTrue| + (progn + (setq |$CapsuleDomainsInScope| newValue) + env) + (|put| '|$DomainsInScope| 'special newValue env)))) -The bulk of the work is performed by a call to compOrCroak which -compiles the functions in the add form capsule. +\end{chunk} -The compAdd function returns a triple, the result of a call to compCapsule. -\begin{enumerate} -\item the {\bf compiled capsule} which is a progn form which returns -the domain -\item the {\bf mode} from the input argument -\item the {\bf env} prepended with the signatures of the functions -in the body of the add. -\end{enumerate} -\calls{compAdd}{comp} -\calls{compAdd}{qcdr} -\calls{compAdd}{qcar} -\calls{compAdd}{compSubDomain1} -\calls{compAdd}{nreverse0} -\calls{compAdd}{NRTgetLocalIndex} -\calls{compAdd}{compTuple2Record} -\calls{compAdd}{compOrCroak} -\calls{compAdd}{compCapsule} -\uses{compAdd}{/editfile} -\usesdollar{compAdd}{addForm} -\usesdollar{compAdd}{addFormLhs} -\usesdollar{compAdd}{EmptyMode} -\usesdollar{compAdd}{NRTaddForm} -\usesdollar{compAdd}{packagesUsed} -\usesdollar{compAdd}{functorForm} -\usesdollar{compAdd}{bootStrapMode} -\begin{chunk}{defun compAdd} -(defun compAdd (form mode env) - (let (|$addForm| |$addFormLhs| code domainForm predicate tmp3 tmp4) - (declare (special |$addForm| |$addFormLhs| |$EmptyMode| |$NRTaddForm| - |$packagesUsed| |$functorForm| |$bootStrapMode| /editfile)) - (setq |$addForm| (second form)) - (cond - ((eq |$bootStrapMode| t) - (cond - ((and (consp |$addForm|) (eq (qfirst |$addForm|) '|@Tuple|)) - (setq code nil)) - (t - (setq tmp3 (|comp| |$addForm| mode env)) - (setq code (first tmp3)) - (setq mode (second tmp3)) - (setq env (third tmp3)) tmp3)) - (list - (list 'cond - (list '|$bootStrapMode| code) - (list 't - (list '|systemError| - (list 'list ''|%b| (mkq (car |$functorForm|)) ''|%d| "from" - ''|%b| (mkq (|namestring| /editfile)) ''|%d| - "needs to be compiled")))) - mode env)) - (t - (setq |$addFormLhs| |$addForm|) - (cond - ((and (consp |$addForm|) (eq (qfirst |$addForm|) '|SubDomain|) - (consp (qrest |$addForm|)) (consp (qcddr |$addForm|)) - (eq (qcdddr |$addForm|) nil)) - (setq domainForm (second |$addForm|)) - (setq predicate (third |$addForm|)) - (setq |$packagesUsed| (cons domainForm |$packagesUsed|)) - (setq |$NRTaddForm| domainForm) - (|NRTgetLocalIndex| domainForm) - ; need to generate slot for add form since all $ go-get - ; slots will need to access it - (setq tmp3 (|compSubDomain1| domainForm predicate mode env)) - (setq |$addForm| (first tmp3)) - (setq env (third tmp3)) tmp3) - (t - (setq |$packagesUsed| - (if (and (consp |$addForm|) (eq (qfirst |$addForm|) '|@Tuple|)) - (append (qrest |$addForm|) |$packagesUsed|) - (cons |$addForm| |$packagesUsed|))) - (setq |$NRTaddForm| |$addForm|) - (setq tmp3 - (cond - ((and (consp |$addForm|) (eq (qfirst |$addForm|) '|@Tuple|)) - (setq |$NRTaddForm| - (cons '|@Tuple| - (dolist (x (cdr |$addForm|) (nreverse0 tmp4)) - (push (|NRTgetLocalIndex| x) tmp4)))) - (|compOrCroak| (|compTuple2Record| |$addForm|) |$EmptyMode| env)) - (t - (|compOrCroak| |$addForm| |$EmptyMode| env)))) - (setq |$addForm| (first tmp3)) - (setq env (third tmp3)) - tmp3)) - (|compCapsule| (third form) mode env))))) +\defun{isSuperDomain}{isSuperDomain} +\calls{isSuperDomain}{isSubset} +\calls{isSuperDomain}{lassoc} +\calls{isSuperDomain}{opOf} +\calls{isSuperDomain}{get} +\begin{chunk}{defun isSuperDomain} +(defun |isSuperDomain| (domainForm domainFormp env) + (cond + ((|isSubset| domainFormp domainForm env) t) + ((and (eq domainForm '|Rep|) (eq domainFormp '$)) t) + (t (lassoc (|opOf| domainFormp) (|get| domainForm '|SubDomain| env))))) \end{chunk} -\defun{compTuple2Record}{compTuple2Record} -\begin{chunk}{defun compTuple2Record} -(defun |compTuple2Record| (u) - (let ((i 0)) - (cons '|Record| - (loop for x in (rest u) - collect (list '|:| (incf i) x))))) +\defun{addNewDomain}{addNewDomain} +\calls{addNewDomain}{augModemapsFromDomain} +\begin{chunk}{defun addNewDomain} +(defun |addNewDomain| (domain env) + (|augModemapsFromDomain| domain domain env)) \end{chunk} -\defplist{capsule}{compCapsule plist} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get 'capsule 'special) '|compCapsule|)) +\defun{augModemapsFromDomain}{augModemapsFromDomain} +\calls{augModemapsFromDomain}{member} +\calls{augModemapsFromDomain}{kar} +\calls{augModemapsFromDomain}{getDomainsInScope} +\calls{augModemapsFromDomain}{getdatabase} +\calls{augModemapsFromDomain}{opOf} +\calls{augModemapsFromDomain}{addNewDomain} +\calls{augModemapsFromDomain}{listOrVectorElementNode} +\calls{augModemapsFromDomain}{stripUnionTags} +\calls{augModemapsFromDomain}{augModemapsFromDomain1} +\refsdollar{augModemapsFromDomain}{Category} +\refsdollar{augModemapsFromDomain}{DummyFunctorNames} +\begin{chunk}{defun augModemapsFromDomain} +(defun |augModemapsFromDomain| (name functorForm env) + (let (curDomainsInScope u innerDom) + (declare (special |$Category| |$DummyFunctorNames|)) + (cond + ((|member| (or (kar name) name) |$DummyFunctorNames|) + env) + ((or (equal name |$Category|) (|isCategoryForm| name env)) + env) + ((|member| name (setq curDomainsInScope (|getDomainsInScope| env))) + env) + (t + (when (setq u (getdatabase (|opOf| functorForm) 'superdomain)) + (setq env (|addNewDomain| (car u) env))) + (when (setq innerDom (|listOrVectorElementMode| name)) + (setq env (|addDomain| innerDom env))) + (when (and (consp name) (eq (qfirst name) '|Union|)) + (dolist (d (|stripUnionTags| (qrest name))) + (setq env (|addDomain| d env)))) + (|augModemapsFromDomain1| name functorForm env))))) \end{chunk} -\defun{compCapsule}{compCapsule} -\calls{compCapsule}{bootStrapError} -\calls{compCapsule}{compCapsuleInner} -\calls{compCapsule}{addDomain} -\uses{compCapsule}{editfile} -\usesdollar{compCapsule}{insideExpressionIfTrue} -\usesdollar{compCapsule}{functorForm} -\usesdollar{compCapsule}{bootStrapMode} -\begin{chunk}{defun compCapsule} -(defun |compCapsule| (form mode env) - (let (|$insideExpressionIfTrue| itemList) - (declare (special |$insideExpressionIfTrue| |$functorForm| /editfile - |$bootStrapMode|)) - (setq itemList (cdr form)) +\defun{augModemapsFromDomain1}{augModemapsFromDomain1} +\calls{augModemapsFromDomain1}{getl} +\calls{augModemapsFromDomain1}{kar} +\calls{augModemapsFromDomain1}{addConstructorModemaps} +\calls{augModemapsFromDomain1}{getmode} +\calls{augModemapsFromDomain1}{augModemapsFromCategory} +\calls{augModemapsFromDomain1}{getmodeOrMapping} +\calls{augModemapsFromDomain1}{substituteCategoryArguments} +\calls{augModemapsFromDomain1}{stackMessage} +\begin{chunk}{defun augModemapsFromDomain1} +(defun |augModemapsFromDomain1| (name functorForm env) + (let (mappingForm categoryForm functArgTypes catform) (cond - ((eq |$bootStrapMode| t) - (list (|bootStrapError| |$functorForm| /editfile) mode env)) + ((getl (kar functorForm) '|makeFunctionList|) + (|addConstructorModemaps| name functorForm env)) + ((and (atom functorForm) (setq catform (|getmode| functorForm env))) + (|augModemapsFromCategory| name functorForm catform env)) + ((setq mappingForm (|getmodeOrMapping| (kar functorForm) env)) + (when (eq (car mappingForm) '|Mapping|) (car mappingForm)) + (setq categoryForm (cadr mappingForm)) + (setq functArgTypes (cddr mappingForm)) + (setq catform + (|substituteCategoryArguments| (cdr functorForm) categoryForm)) + (|augModemapsFromCategory| name functorForm catform env)) (t - (setq |$insideExpressionIfTrue| nil) - (|compCapsuleInner| itemList mode (|addDomain| '$ env)))))) + (|stackMessage| (list functorForm '| is an unknown mode|)) + env)))) \end{chunk} -\defun{compCapsuleInner}{compCapsuleInner} -\calls{compCapsuleInner}{addInformation} -\calls{compCapsuleInner}{compCapsuleItems} -\calls{compCapsuleInner}{processFunctor} -\calls{compCapsuleInner}{mkpf} -\usesdollar{compCapsuleInner}{getDomainCode} -\usesdollar{compCapsuleInner}{signature} -\usesdollar{compCapsuleInner}{form} -\usesdollar{compCapsuleInner}{addForm} -\usesdollar{compCapsuleInner}{insideCategoryPackageIfTrue} -\usesdollar{compCapsuleInner}{insideCategoryIfTrue} -\usesdollar{compCapsuleInner}{functorLocalParameters} -\begin{chunk}{defun compCapsuleInner} -(defun |compCapsuleInner| (form mode env) - (let (localParList data code) - (declare (special |$getDomainCode| |$signature| |$form| |$addForm| - |$insideCategoryPackageIfTrue| |$insideCategoryIfTrue| - |$functorLocalParameters|)) - (setq env (|addInformation| mode env)) - (setq data (cons 'progn form)) - (setq env (|compCapsuleItems| form nil env)) - (setq localParList |$functorLocalParameters|) - (when |$addForm| (setq data (list '|add| |$addForm| data))) - (setq code - (if (and |$insideCategoryIfTrue| (null |$insideCategoryPackageIfTrue|)) - data - (|processFunctor| |$form| |$signature| data localParList env))) - (cons (mkpf (append |$getDomainCode| (list code)) 'progn) (list mode env)))) +\defun{substituteCategoryArguments}{substituteCategoryArguments} +\calls{substituteCategoryArguments}{internl} +\calls{substituteCategoryArguments}{stringimage} +\calls{substituteCategoryArguments}{sublis} +\begin{chunk}{defun substituteCategoryArguments} +(defun |substituteCategoryArguments| (argl catform) + (let (arglAssoc (i 0)) + (setq argl (subst '$$ '$ argl :test #'equal)) + (setq arglAssoc + (loop for a in argl + collect (cons (internl '|#| (stringimage (incf i))) a))) + (sublis arglAssoc catform))) \end{chunk} -\defun{processFunctor}{processFunctor} -\calls{processFunctor}{error} -\calls{processFunctor}{buildFunctor} -\begin{chunk}{defun processFunctor} -(defun |processFunctor| (form signature data localParList e) - (cond - ((and (consp form) (eq (qrest form) nil) - (eq (qfirst form) '|CategoryDefaults|)) - (|error| '|CategoryDefaults is a reserved name|)) - (t (|buildFunctor| form signature data localParList e)))) +\defun{addConstructorModemaps}{addConstructorModemaps} +\calls{addConstructorModemaps}{putDomainsInScope} +\calls{addConstructorModemaps}{getl} +\calls{addConstructorModemaps}{addModemap} +\defsdollar{addConstructorModemaps}{InteractiveMode} +\begin{chunk}{defun addConstructorModemaps} +(defun |addConstructorModemaps| (name form env) + (let (|$InteractiveMode| functorName fn tmp1 funList op sig nsig opcode) + (declare (special |$InteractiveMode|)) + (setq functorName (car form)) + (setq |$InteractiveMode| nil) + (setq env (|putDomainsInScope| name env)) + (setq fn (getl functorName '|makeFunctionList|)) + (setq tmp1 (funcall fn name form env)) + (setq funList (car tmp1)) + (setq env (cadr tmp1)) + (dolist (item funList) + (setq op (first item)) + (setq sig (second item)) + (setq opcode (third item)) + (when (and (consp opcode) (consp (qrest opcode)) + (consp (qcddr opcode)) + (eq (qcdddr opcode) nil) + (eq (qfirst opcode) 'elt)) + (setq nsig (subst '$$$ name sig :test #'equal)) + (setq nsig + (subst '$ '$$$ (subst '$$ '$ nsig :test #'equal) :test #'equal)) + (setq opcode (list (first opcode) (second opcode) nsig))) + (setq env (|addModemap| op name sig t opcode env))) + env)) \end{chunk} -\defun{compCapsuleItems}{compCapsuleItems} -The variable data appears to be unbound at runtime. Optimized -code won't check for this but interpreted code fails. We should -PROVE that data is unbound at runtime but have not done so yet. -Rather than remove the code entirely (since there MIGHT be a -path where it is used) we check for the runtime bound case and -assign \verb|$myFunctorBody| if data has a value. +\defun{getModemap}{getModemap} +\calls{getModemap}{get} +\calls{getModemap}{compApplyModemap} +\calls{getModemap}{sublis} +\begin{chunk}{defun getModemap} +(defun |getModemap| (x env) + (let (u) + (dolist (modemap (|get| (first x) '|modemap| env)) + (when (setq u (|compApplyModemap| x modemap env nil)) + (return (sublis (third u) modemap)))))) -The compCapsuleInner function in this file LOOKS like it sets -data and expects code to manipulate the assigned data structure. -Since we can't be sure we take the least disruptive course of action. +\end{chunk} -\calls{compCapsuleItems}{compSingleCapsuleItem} -\defsdollar{compCapsuleItems}{top-level} -\defsdollar{compCapsuleItems}{myFunctorBody} -\defsdollar{compCapsuleItems}{signatureOfForm} -\defsdollar{compCapsuleItems}{suffix} -\defsdollar{compCapsuleItems}{e} -\refsdollar{compCapsuleItems}{pred} -\refsdollar{compCapsuleItems}{e} -\begin{chunk}{defun compCapsuleItems} -(defun |compCapsuleItems| (itemlist |$predl| |$e|) - (declare (special |$predl| |$e|)) - (let ($top_level |$myFunctorBody| |$signatureOfForm| |$suffix|) - (declare (special $top_level |$myFunctorBody| |$signatureOfForm| |$suffix|)) - (setq $top_level nil) - (setq |$myFunctorBody| nil) - (when (boundp '|data|) (setq |$myFunctorBody| |data|)) - (setq |$signatureOfForm| nil) - (setq |$suffix| 0) - (loop for item in itemlist do - (setq |$e| (|compSingleCapsuleItem| item |$predl| |$e|))) - |$e|)) +\defun{compApplyModemap}{compApplyModemap} +\calls{compApplyModemap}{length} +\calls{compApplyModemap}{pmatchWithSl} +\calls{compApplyModemap}{sublis} +\calls{compApplyModemap}{comp} +\calls{compApplyModemap}{coerce} +\calls{compApplyModemap}{compMapCond} +\calls{compApplyModemap}{member} +\calls{compApplyModemap}{genDeltaEntry} +\refsdollar{compApplyModemap}{e} +\refsdollar{compApplyModemap}{bindings} +\defsdollar{compApplyModemap}{e} +\defsdollar{compApplyModemap}{bindings} +\begin{chunk}{defun compApplyModemap} +(defun |compApplyModemap| (form modemap |$e| sl) + (declare (special |$e|)) + (let (op argl mc mr margl fnsel g mp lt ltp temp1 f) + (declare (special |$bindings| |$e|)) + ; -- $e is the current environment + ; -- sl substitution list, nil means bottom-up, otherwise top-down + ; -- 0. fail immediately if #argl=#margl + (setq op (car form)) + (setq argl (cdr form)) + (setq mc (caar modemap)) + (setq mr (cadar modemap)) + (setq margl (cddar modemap)) + (setq fnsel (cdr modemap)) + (when (= (|#| argl) (|#| margl)) + ; 1. use modemap to evaluate arguments, returning failed if not possible + (setq lt + (prog (t0) + (return + (do ((t1 argl (cdr t1)) (y NIL) (t2 margl (cdr t2)) (m nil)) + ((or (atom t1) (atom t2)) (nreverse0 t0)) + (setq y (car t1)) + (setq m (car t2)) + (setq t0 + (cons + (progn + (setq sl (|pmatchWithSl| mp m sl)) + (setq g (sublis sl m)) + (setq temp1 (or (|comp| y g |$e|) (return '|failed|))) + (setq mp (cadr temp1)) + (setq |$e| (caddr temp1)) + temp1) + t0))))))) + ; 2. coerce each argument to final domain, returning failed + ; if not possible + (unless (eq lt '|failed|) + (setq ltp + (loop for y in lt for d in (sublis sl margl) + collect (or (|coerce| y d) (return '|failed|)))) + (unless (eq ltp '|failed|) + ; 3. obtain domain-specific function, if possible, and return + ; $bindings is bound by compMapCond + (setq temp1 (|compMapCond| op mc sl fnsel)) + (when temp1 + ; can no longer trust what the modemap says for a reference into + ; an exterior domain (it is calculating the displacement based on view + ; information which is no longer valid; thus ignore this index and + ; store the signature instead. + (setq f (car temp1)) + (setq |$bindings| (cadr temp1)) + (if (and (consp f) (consp (qcdr f)) (consp (qcddr f)) ; f is [op1,.] + (eq (qcdddr f) nil) + (|member| (qcar f) '(elt const |Subsumed|))) + (list (|genDeltaEntry| (cons op modemap)) ltp |$bindings|) + (list f ltp |$bindings|)))))))) \end{chunk} -\defun{compSingleCapsuleItem}{compSingleCapsuleItem} -\calls{compSingleCapsuleItem}{doit} -\refsdollar{compSingleCapsuleItem}{pred} -\refsdollar{compSingleCapsuleItem}{e} -\calls{compSingleCapsuleItem}{macroExpandInPlace} -\begin{chunk}{defun compSingleCapsuleItem} -(defun |compSingleCapsuleItem| (item |$predl| |$e|) - (declare (special |$predl| |$e|)) - (|doIt| (|macroExpandInPlace| item |$e|) |$predl|) - |$e|) +\defun{compMapCond}{compMapCond} +\calls{compMapCond}{compMapCond'} +\refsdollar{compMapCond}{bindings} +\begin{chunk}{defun compMapCond} +(defun |compMapCond| (op mc |$bindings| fnsel) + (declare (special |$bindings|)) + (let (t0) + (do ((t1 nil t0) (t2 fnsel (cdr t2)) (u nil)) + ((or t1 (atom t2) (progn (setq u (car t2)) nil)) t0) + (setq t0 (or t0 (|compMapCond'| u op mc |$bindings|)))))) \end{chunk} -\defun{doIt}{doIt} -\calls{doIt}{qcar} -\calls{doIt}{qcdr} -\calls{doIt}{lastnode} -\calls{doIt}{compSingleCapsuleItem} -\calls{doIt}{isDomainForm} -\calls{doIt}{stackWarning} -\calls{doIt}{doIt} -\calls{doIt}{compOrCroak} -\calls{doIt}{stackSemanticError} -\calls{doIt}{bright} -\calls{doIt}{member} -\calls{doIt}{kar} -\calls{doIt}{|isFunctor} -\calls{doIt}{insert} -\calls{doIt}{opOf} -\calls{doIt}{get} -\calls{doIt}{NRTgetLocalIndex} -\calls{doIt}{sublis} -\calls{doIt}{compOrCroak} -\calls{doIt}{sayBrightly} -\calls{doIt}{formatUnabbreviated} -\calls{doIt}{doItIf} -\calls{doIt}{isMacro} -\calls{doIt}{put} -\calls{doIt}{cannotDo} -\refsdollar{doIt}{predl} -\refsdollar{doIt}{e} -\refsdollar{doIt}{EmptyMode} -\refsdollar{doIt}{NonMentionableDomainNames} -\refsdollar{doIt}{functorLocalParameters} -\refsdollar{doIt}{functorsUsed} -\refsdollar{doIt}{packagesUsed} -\refsdollar{doIt}{NRTopt} -\refsdollar{doIt}{Representation} -\refsdollar{doIt}{LocalDomainAlist} -\refsdollar{doIt}{QuickCode} -\refsdollar{doIt}{signatureOfForm} -\defsdollar{doIt}{genno} -\defsdollar{doIt}{e} -\defsdollar{doIt}{functorLocalParameters} -\defsdollar{doIt}{functorsUsed} -\defsdollar{doIt}{packagesUsed} -\defsdollar{doIt}{Representation} -\defsdollar{doIt}{LocalDomainAlist} -\begin{chunk}{defun doIt} -(defun |doIt| (item |$predl|) - (declare (special |$predl|)) - (prog ($genno x rhs lhsp lhs rhsp rhsCode z tmp1 tmp2 tmp6 op body tt - functionPart u code) - (declare (special $genno |$e| |$EmptyMode| |$signatureOfForm| - |$QuickCode| |$LocalDomainAlist| |$Representation| - |$NRTopt| |$packagesUsed| |$functorsUsed| - |$functorLocalParameters| |$NonMentionableDomainNames|)) - (setq $genno 0) +\defun{compMapCond'}{compMapCond'} +\calls{compMapCond'}{compMapCond''} +\calls{compMapCond'}{compMapConfFun} +\calls{compMapCond'}{stackMessage} +\begin{chunk}{defun compMapCond'} +(defun |compMapCond'| (t0 op dc bindings) + (let ((cexpr (car t0)) (fnexpr (cadr t0))) + (if (|compMapCond''| cexpr dc) + (|compMapCondFun| fnexpr op dc bindings) + (|stackMessage| `("not known that" %b ,dc %d "has" %b ,cexpr %d))))) + +\end{chunk} + +\defun{compMapCond''}{compMapCond''} +\calls{compMapCond''}{compMapCond''} +\calls{compMapCond''}{knownInfo} +\calls{compMapCond''}{get} +\calls{compMapCond''}{stackMessage} +\refsdollar{compMapCond''}{Information} +\refsdollar{compMapCond''}{e} +\begin{chunk}{defun compMapCond''} +(defun |compMapCond''| (cexpr dc) + (let (l u tmp1 tmp2) + (declare (special |$Information| |$e|)) (cond - ((and (consp item) (eq (qfirst item) 'seq) (consp (qrest item)) - (progn (setq tmp6 (reverse (qrest item))) t) - (consp tmp6) (consp (qfirst tmp6)) - (eq (qcaar tmp6) '|exit|) - (consp (qcdar tmp6)) - (equal (qcadar tmp6) 1) - (consp (qcddar tmp6)) - (eq (qcdddar tmp6) nil)) - (setq x (qcaddar tmp6)) - (setq z (qrest tmp6)) - (setq z (nreverse z)) - (rplaca item 'progn) - (rplaca (lastnode item) x) - (loop for it1 in (rest item) - do (setq |$e| (|compSingleCapsuleItem| it1 |$predl| |$e|)))) - ((|isDomainForm| item |$e|) - (setq u (list '|import| (cons (car item) (cdr item)))) - (|stackWarning| (list '|Use: import | (cons (car item) (cdr item)))) - (rplaca item (car u)) - (rplacd item (cdr u)) - (|doIt| item |$predl|)) - ((and (consp item) (eq (qfirst item) 'let) (consp (qrest item)) - (consp (qcddr item))) - (setq lhs (qsecond item)) - (setq rhs (qthird item)) - (cond - ((null (progn - (setq tmp2 (|compOrCroak| item |$EmptyMode| |$e|)) - (and (consp tmp2) - (progn - (setq code (qfirst tmp2)) - (and (consp (qrest tmp2)) - (progn - (and (consp (qcddr tmp2)) - (eq (qcdddr tmp2) nil) - (PROGN - (setq |$e| (qthird tmp2)) - t)))))))) - (|stackSemanticError| - (cons '|cannot compile assigned value to| (|bright| lhs)) - nil)) - ((null (and (consp code) (eq (qfirst code) 'let) - (progn - (and (consp (qrest code)) - (progn - (setq lhsp (qsecond code)) - (and (consp (qcddr code)))))) - (atom (qsecond code)))) - (cond - ((and (consp code) (eq (qfirst code) 'progn)) - (|stackSemanticError| - (list '|multiple assignment | item '| not allowed|) - nil)) - (t - (rplaca item (car code)) - (rplacd item (cdr code))))) - (t - (setq lhs lhsp) - (cond - ((and (null (|member| (kar rhs) |$NonMentionableDomainNames|)) - (null (member lhs |$functorLocalParameters|))) - (setq |$functorLocalParameters| - (append |$functorLocalParameters| (list lhs))))) - (cond - ((and (consp code) (eq (qfirst code) 'let) - (progn - (setq tmp2 (qrest code)) - (and (consp tmp2) - (progn - (setq tmp6 (qrest tmp2)) - (and (consp tmp6) - (progn - (setq rhsp (qfirst tmp6)) - t))))) - (|isDomainForm| rhsp |$e|)) - (cond - ((|isFunctor| rhsp) - (setq |$functorsUsed| (|insert| (|opOf| rhsp) |$functorsUsed|)) - (setq |$packagesUsed| (|insert| (list (|opOf| rhsp)) - |$packagesUsed|)))) - (cond - ((eq lhs '|Rep|) - (setq |$Representation| (elt (|get| '|Rep| '|value| |$e|) 0)) - (cond - ((eq |$NRTopt| t) - (|NRTgetLocalIndex| |$Representation|)) - (t nil)))) - (setq |$LocalDomainAlist| - (cons (cons lhs - (sublis |$LocalDomainAlist| (elt (|get| lhs '|value| |$e|) 0))) - |$LocalDomainAlist|)))) - (cond - ((and (consp code) (eq (qfirst code) 'let)) - (rplaca item (if |$QuickCode| 'qsetrefv 'setelt)) - (setq rhsCode rhsp) - (rplacd item (list '$ (|NRTgetLocalIndex| lhs) rhsCode))) - (t - (rplaca item (car code)) - (rplacd item (cdr code))))))) - ((and (consp item) (eq (qfirst item) '|:|) (consp (qrest item)) - (consp (qcddr item)) (eq (qcdddr item) nil)) - (setq tmp1 (|compOrCroak| item |$EmptyMode| |$e|)) - (setq |$e| (caddr tmp1)) - tmp1) - ((and (consp item) (eq (qfirst item) '|import|)) - (loop for dom in (qrest item) - do (|sayBrightly| (cons " importing " (|formatUnabbreviated| dom)))) - (setq tmp1 (|compOrCroak| item |$EmptyMode| |$e|)) - (setq |$e| (caddr tmp1)) - (rplaca item 'progn) - (rplacd item nil)) - ((and (consp item) (eq (qfirst item) 'if)) - (|doItIf| item |$predl| |$e|)) - ((and (consp item) (eq (qfirst item) '|where|) (consp (qrest item))) - (|compOrCroak| item |$EmptyMode| |$e|)) - ((and (consp item) (eq (qfirst item) 'mdef)) - (setq tmp1 (|compOrCroak| item |$EmptyMode| |$e|)) - (setq |$e| (caddr tmp1)) tmp1) - ((and (consp item) (eq (qfirst item) 'def) (consp (qrest item)) - (consp (qsecond item))) - (setq op (qcaadr item)) - (cond - ((setq body (|isMacro| item |$e|)) - (setq |$e| (|put| op '|macro| body |$e|))) - (t - (setq tt (|compOrCroak| item |$EmptyMode| |$e|)) - (setq |$e| (caddr tt)) - (rplaca item '|CodeDefine|) - (rplacd (cadr item) (list |$signatureOfForm|)) - (setq functionPart (list '|dispatchFunction| (car tt))) - (rplaca (cddr item) functionPart) - (rplacd (cddr item) nil)))) - ((setq u (|compOrCroak| item |$EmptyMode| |$e|)) - (setq code (car u)) - (setq |$e| (caddr u)) - (rplaca item (car code)) - (rplacd item (cdr code))) - (t (|cannotDo|))))) + ((eq cexpr t) t) + ((and (consp cexpr) + (eq (qcar cexpr) 'and) + (progn (setq l (qcdr cexpr)) t)) + (prog (t0) + (setq t0 t) + (return + (do ((t1 nil (null t0)) (t2 l (cdr t2)) (u nil)) + ((or t1 (atom t2) (progn (setq u (car t2)) nil)) t0) + (setq t0 (and t0 (|compMapCond''| u dc))))))) + ((and (consp cexpr) + (eq (qcar cexpr) 'or) + (progn (setq l (qcdr cexpr)) t)) + (prog (t3) + (setq t3 nil) + (return + (do ((t4 nil t3) (t5 l (cdr t5)) (u nil)) + ((or t4 (atom t5) (progn (setq u (car t5)) nil)) t3) + (setq t3 (or t3 (|compMapCond''| u dc))))))) + ((and (consp cexpr) + (eq (qcar cexpr) '|not|) + (progn + (setq tmp1 (qcdr cexpr)) + (and (consp tmp1) + (eq (qcdr tmp1) nil) + (progn (setq u (qcar tmp1)) t)))) + (null (|compMapCond''| u dc))) + ((and (consp cexpr) + (eq (qcar cexpr) '|has|) + (progn + (setq tmp1 (qcdr cexpr)) + (and (consp tmp1) + (progn + (setq tmp2 (qcdr tmp1)) + (and (consp tmp2) + (eq (qcdr tmp2) nil)))))) + (cond + ((|knownInfo| cexpr) t) + (t nil))) + ((|member| + (cons 'attribute (cons dc (cons cexpr nil))) + (|get| '|$Information| 'special |$e|)) + t) + (t + (|stackMessage| `("not known that" %b ,dc %d "has" %b ,cexpr %d)) + nil)))) \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|)) - (labels ( - (localExtras (oldFLP) - (let (oldFLPp flp1 gv ans nils n) - (declare (special |$functorLocalParameters| |$getDomainCode|)) - (unless (eq oldFLP |$functorLocalParameters|) - (setq flp1 |$functorLocalParameters|) - (setq oldFLPp oldFLP) - (setq n 0) - (loop while oldFLPp - do - (setq oldFLPp (cdr oldFLPp)) - (setq n (1+ n))) - (setq nils (setq ans nil)) - (loop for u in flp1 - do - (if (or (atom u) - (let (result) - (loop for v in |$getDomainCode| - do - (setq result (or result - (and (consp v) (consp (qrest v)) - (equal (qsecond v) u))))) - result)) - ; Now we have to add code to compile all the elements of - ; functorLocalParameters that were added during the conditional compilation - (setq nils (cons u nils)) - (progn - (setq gv (gensym)) - (setq ans (cons (list 'let gv u) ans)) - (setq nils (CONS gv nils)))) - (setq n (1+ n))) - (setq |$functorLocalParameters| (append oldFLP (nreverse nils))) - (nreverse ans))))) - (let (p x y olde tmp1 pp xp oldFLP yp) - (declare (special |$functorLocalParameters| |$Boolean|)) - (setq p (second item)) - (setq x (third item)) - (setq y (fourth item)) - (setq olde |$e|) - (setq tmp1 - (or (|comp| p |$Boolean| |$e|) - (|userError| (list "not a Boolean:" p)))) - (setq pp (first tmp1)) - (setq |$e| (third tmp1)) - (setq oldFLP |$functorLocalParameters|) - (unless (eq x '|noBranch|) - (|compSingleCapsuleItem| x |$predl| (|getSuccessEnvironment| p |$e|)) - (setq xp (localExtras oldFLP))) - (setq oldFLP |$functorLocalParameters|) - (unless (eq y '|noBranch|) - (|compSingleCapsuleItem| y |$predl| (|getInverseEnvironment| p olde)) - (setq yp (localExtras oldFLP))) - (rplaca item 'cond) - (rplacd item (list (cons pp (cons x xp)) (cons ''t (cons y yp))))))) +\defun{compMapCondFun}{compMapCondFun} +\begin{chunk}{defun compMapCondFun} +(defun |compMapCondFun| (fnexpr op dc bindings) + (declare (ignore op) (ignore dc)) + (cons fnexpr (cons bindings nil))) \end{chunk} -\defun{isMacro}{isMacro} -\calls{isMacro}{qcar} -\calls{isMacro}{qcdr} -\calls{isMacro}{get} -\begin{chunk}{defun isMacro} -(defun |isMacro| (x env) - (let (op args signature body) - (when - (and (consp x) (eq (qfirst x) 'def) (consp (qrest x)) - (consp (qsecond x)) (consp (qcddr x)) - (consp (qcdddr x)) - (consp (qcddddr x)) - (eq (qrest (qcddddr x)) nil)) - (setq op (qcaadr x)) - (setq args (qcdadr x)) - (setq signature (qthird x)) - (setq body (qfirst (qcddddr x))) - (when - (and (null (|get| op '|modemap| env)) - (null args) - (null (|get| op '|mode| env)) - (consp signature) - (eq (qrest signature) nil) - (null (qfirst signature))) - body)))) +\defun{getUniqueSignature}{getUniqueSignature} +\calls{getUniqueSignature}{getUniqueModemap} +\begin{chunk}{defun getUniqueSignature} +(defun |getUniqueSignature| (form env) + (cdar (|getUniqueModemap| (first form) (|#| (rest form)) env))) + +\end{chunk} + +\defun{getUniqueModemap}{getUniqueModemap} +\calls{getUniqueModemap}{getModemapList} +\calls{getUniqueModemap}{qslessp} +\calls{getUniqueModemap}{stackWarning} +\begin{chunk}{defun getUniqueModemap} +(defun |getUniqueModemap| (op numOfArgs env) + (let (mml) + (cond + ((eql 1 (|#| (setq mml (|getModemapList| op numOfArgs env)))) + (car mml)) + ((qslessp 1 (|#| mml)) + (|stackWarning| + (list numOfArgs " argument form of: " op " has more than one modemap")) + (car mml)) + (t nil)))) + +\end{chunk} + +\defun{getModemapList}{getModemapList} +\calls{getModemapList}{getModemapListFromDomain} +\calls{getModemapList}{nreverse0} +\calls{getModemapList}{get} +\begin{chunk}{defun getModemapList} +(defun |getModemapList| (op numOfArgs env) + (let (result) + (cond + ((and (consp op) (eq (qfirst op) '|elt|) (consp (qrest op)) + (consp (qcddr op)) (eq (qcdddr op) nil)) + (|getModemapListFromDomain| (third op) numOfArgs (second op) env)) + (t + (dolist (term (|get| op '|modemap| env) (nreverse0 result)) + (when (eql numOfArgs (|#| (cddar term))) (push term result))))))) + +\end{chunk} + +\defun{getModemapListFromDomain}{getModemapListFromDomain} +\calls{getModemapListFromDomain}{get} +\begin{chunk}{defun getModemapListFromDomain} +(defun |getModemapListFromDomain| (op numOfArgs d env) + (loop for term in (|get| op '|modemap| env) + when (and (equal (caar term) d) (eql (|#| (cddar term)) numOfArgs)) + collect term)) + +\end{chunk} + +\defun{domainMember}{domainMember} +\calls{domainMember}{modeEqual} +\begin{chunk}{defun domainMember} +(defun |domainMember| (dom domList) + (let (result) + (dolist (d domList result) + (setq result (or result (|modeEqual| dom d)))))) + +\end{chunk} + +\defun{augModemapsFromCategory}{augModemapsFromCategory} +\calls{augModemapsFromCategory}{evalAndSub} +\calls{augModemapsFromCategory}{compilerMessage} +\calls{augModemapsFromCategory}{putDomainsInScope} +\calls{augModemapsFromCategory}{addModemapKnown} +\defsdollar{augModemapsFromCategory}{base} +\begin{chunk}{defun augModemapsFromCategory} +(defun |augModemapsFromCategory| (domainName functorform categoryForm env) + (let (tmp1 op sig cond fnsel) + (declare (special |$base|)) + (setq tmp1 (|evalAndSub| domainName domainName functorform categoryForm env)) + (|compilerMessage| (list '|Adding | domainName '| modemaps|)) + (setq env (|putDomainsInScope| domainName (second tmp1))) + (setq |$base| 4) + (dolist (u (first tmp1)) + (setq op (caar u)) + (setq sig (cadar u)) + (setq cond (cadr u)) + (setq fnsel (caddr u)) + (setq env (|addModemapKnown| op domainName sig cond fnsel env))) + env)) + +\end{chunk} + +\defun{addEltModemap}{addEltModemap} +This is a hack to change selectors from strings to identifiers; and to +add flag identifiers as literals in the environment +\calls{addEltModemap}{makeLiteral} +\calls{addEltModemap}{addModemap1} +\calls{addEltModemap}{systemErrorHere} +\refsdollar{addEltModemap}{insideCapsuleFunctionIfTrue} +\defsdollar{addEltModemap}{e} +\begin{chunk}{defun addEltModemap} +(defun |addEltModemap| (op mc sig pred fn env) + (let (tmp1 v sel lt id) + (declare (special |$e| |$insideCapsuleFunctionIfTrue|)) + (cond + ((and (eq op '|elt|) (consp sig)) + (setq tmp1 (reverse sig)) + (setq sel (qfirst tmp1)) + (setq lt (nreverse (qrest tmp1))) + (cond + ((stringp sel) + (setq id (intern sel)) + (if |$insideCapsuleFunctionIfTrue| + (setq |$e| (|makeLiteral| id |$e|)) + (setq env (|makeLiteral| id env))) + (|addModemap1| op mc (append lt (list id)) pred fn env)) + (t (|addModemap1| op mc sig pred fn env)))) + ((and (eq op '|setelt|) (consp sig)) + (setq tmp1 (reverse sig)) + (setq v (qfirst tmp1)) + (setq sel (qsecond tmp1)) + (setq lt (nreverse (qcddr tmp1))) + (cond + ((stringp sel) (setq id (intern sel)) + (if |$insideCapsuleFunctionIfTrue| + (setq |$e| (|makeLiteral| id |$e|)) + (setq env (|makeLiteral| id env))) + (|addModemap1| op mc (append lt (list id v)) pred fn env)) + (t (|addModemap1| op mc sig pred fn env)))) + (t (|systemErrorHere| "addEltModemap"))))) \end{chunk} -\defplist{case}{compCase plist} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get '|case| 'special) '|compCase|)) +\defun{mkNewModemapList}{mkNewModemapList} +\calls{mkNewModemapList}{member} +\calls{mkNewModemapList}{assoc} +\calls{mkNewModemapList}{mergeModemap} +\calls{mkNewModemapList}{nreverse0} +\calls{mkNewModemapList}{insertModemap} +\refsdollar{mkNewModemapList}{InteractiveMode} +\refsdollar{mkNewModemapList}{forceAdd} +\begin{chunk}{defun mkNewModemapList} +(defun |mkNewModemapList| (mc sig pred fn curModemapList env filenameOrNil) + (let (map entry oldMap opred result) + (declare (special |$InteractiveMode| |$forceAdd|)) + (setq entry + (cons (setq map (cons mc sig)) (cons (list pred fn) filenameOrNil))) + (cond + ((|member| entry curModemapList) curModemapList) + ((and (setq oldMap (|assoc| map curModemapList)) + (consp oldMap) (consp (qrest oldMap)) + (consp (qsecond oldMap)) + (consp (qcdadr oldMap)) + (eq (qcddadr oldMap) nil) + (equal (qcadadr oldMap) fn)) + (setq opred (qcaadr oldMap)) + (cond + (|$forceAdd| (|mergeModemap| entry curModemapList env)) + ((eq opred t) curModemapList) + (t + (when (and (not (eq pred t)) (not (equal pred opred))) + (setq pred (list 'or pred opred))) + (dolist (x curModemapList (nreverse0 result)) + (push + (if (equal x oldMap) + (cons map (cons (list pred fn) filenameOrNil)) + x) + result))))) + (|$InteractiveMode| + (|insertModemap| entry curModemapList)) + (t + (|mergeModemap| entry curModemapList env))))) \end{chunk} -\defun{compCase}{compCase} -Will the jerk who commented out these two functions please NOT do so -again. These functions ARE needed, and case can NOT be done by -modemap alone. The reason is that A case B requires to take A -evaluated, but B unevaluated. Therefore a special function is -required. You may have thought that you had tested this on ``failed'' -etc., but ``failed'' evaluates to it's own mode. Try it on x case \$ -next time. +\defun{insertModemap}{insertModemap} +\begin{chunk}{defun insertModemap} +(defun |insertModemap| (new mmList) + (if (null mmList) (list new) (cons new mmList))) -An angry JHD - August 15th., 1984 -\calls{compCase}{addDomain} -\calls{compCase}{compCase1} -\calls{compCase}{coerce} -\begin{chunk}{defun compCase} -(defun |compCase| (form mode env) - (let (mp td) - (setq mp (third form)) - (setq env (|addDomain| mp env)) - (when (setq td (|compCase1| (second form) mp env)) (|coerce| td mode)))) +\end{chunk} + +\defun{mergeModemap}{mergeModemap} +\calls{mergeModemap}{isSuperDomain} +\calls{mergeModemap}{TruthP} +\refsdollar{mergeModemap}{forceAdd} +\begin{chunk}{defun mergeModemap} +(defun |mergeModemap| (entry modemapList env) + (let (mc sig pred mcp sigp predp newmm mm) + (declare (special |$forceAdd|)) + ; break out the condition, signature, and predicate fields of the new entry + (setq mc (caar entry)) + (setq sig (cdar entry)) + (setq pred (caadr entry)) + (seq + ; walk across the successive tails of the modemap list + (do ((mmtail modemapList (cdr mmtail))) + ((atom mmtail) nil) + (setq mcp (caaar mmtail)) + (setq sigp (cdaar mmtail)) + (setq predp (caadar mmtail)) + (cond + ((or (equal mc mcp) (|isSuperDomain| mcp mc env)) + ; if this is a duplicate condition + (exit + (progn + (setq newmm nil) + (setq mm modemapList) + ; copy the unique modemap terms + (loop while (not (eq mm mmtail)) do + (setq newmm (cons (car mm) newmm)) + (setq mm (cdr mm))) + ; if the conditions and signatures are equal + (when (and (equal mc mcp) (equal sig sigp)) + ; we only need one of these unless the conditions are hairy + (cond + ((and (null |$forceAdd|) (|TruthP| predp)) + ; the new predicate buys us nothing + (setq entry nil) + (return modemapList)) + ((|TruthP| pred) + ; the thing we matched against is useless, by comparison + (setq mmtail (cdr mmtail))))) + (setq modemapList (nconc (nreverse newmm) (cons entry mmtail))) + (setq entry nil) + (return modemapList)))))) + ; if the entry is still defined, add it to the modemap + (if entry + (append modemapList (list entry)) + modemapList)))) \end{chunk} -\defun{compCase1}{compCase1} -\calls{compCase1}{comp} -\calls{compCase1}{getModemapList} -\calls{compCase1}{nreverse0} -\calls{compCase1}{modeEqual} -\usesdollar{compCase1}{Boolean} -\usesdollar{compCase1}{EmptyMode} -\begin{chunk}{defun compCase1} -(defun |compCase1| (form mode env) - (let (xp mp ep map tmp3 tmp5 tmp6 u fn) - (declare (special |$Boolean| |$EmptyMode|)) - (when (setq tmp3 (|comp| form |$EmptyMode| env)) - (setq xp (first tmp3)) - (setq mp (second tmp3)) - (setq ep (third tmp3)) - (when - (setq u - (dolist (modemap (|getModemapList| '|case| 2 ep) (nreverse0 tmp5)) - (setq map (first modemap)) - (when - (and (consp map) (consp (qrest map)) (consp (qcddr map)) - (consp (qcdddr map)) - (eq (qcddddr map) nil) - (|modeEqual| (fourth map) mode) - (|modeEqual| (third map) mp)) - (push (second modemap) tmp5)))) - (when - (setq fn - (dolist (onepair u tmp6) - (when (first onepair) (setq tmp6 (or tmp6 (second onepair)))))) - (list (list '|call| fn xp) |$Boolean| ep)))))) +\defun{TruthP}{TruthP} +\begin{chunk}{defun TruthP} +(defun |TruthP| (x) + (cond + ((null x) nil) + ((eq x t) t) + ((and (consp x) (eq (qfirst x) 'quote)) t) + (t nil))) \end{chunk} -\defplist{Record}{compCat plist} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get '|Record| 'special) '|compCat|)) +\defun{evalAndSub}{evalAndSub} +\calls{evalAndSub}{isCategory} +\calls{evalAndSub}{substNames} +\calls{evalAndSub}{contained} +\calls{evalAndSub}{put} +\calls{evalAndSub}{get} +\calls{evalAndSub}{getOperationAlist} +\defsdollar{evalAndSub}{lhsOfColon} +\begin{chunk}{defun evalAndSub} +(defun |evalAndSub| (domainName viewName functorForm form |$e|) + (declare (special |$e|)) + (let (|$lhsOfColon| opAlist substAlist) + (declare (special |$lhsOfColon|)) + (setq |$lhsOfColon| domainName) + (cond + ((|isCategory| form) + (list (|substNames| domainName viewName functorForm (elt form 1)) |$e|)) + (t + (when (contained '$$ form) + (setq |$e| (|put| '$$ '|mode| (|get| '$ '|mode| |$e|) |$e|))) + (setq opAlist (|getOperationAlist| domainName functorForm form)) + (setq substAlist (|substNames| domainName viewName functorForm opAlist)) + (list substAlist |$e|))))) \end{chunk} -\defplist{Mapping}{compCat plist} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get '|Mapping| 'special) '|compCat|)) +\defun{getOperationAlist}{getOperationAlist} +\calls{getOperationAlist}{getdatabase} +\calls{getOperationAlist}{isFunctor} +\calls{getOperationAlist}{systemError} +\calls{getOperationAlist}{compMakeCategoryObject} +\calls{getOperationAlist}{stackMessage} +\usesdollar{getOperationAlist}{e} +\usesdollar{getOperationAlist}{domainShell} +\usesdollar{getOperationAlist}{insideFunctorIfTrue} +\usesdollar{getOperationAlist}{functorForm} +\begin{chunk}{defun getOperationAlist} +(defun |getOperationAlist| (name functorForm form) + (let (u tt) + (declare (special |$e| |$domainShell| |$insideFunctorIfTrue| |$functorForm|)) + (when (and (atom name) (getdatabase name 'niladic)) + (setq functorform (list functorForm))) + (cond + ((and (setq u (|isFunctor| functorForm)) + (null (and |$insideFunctorIfTrue| + (equal (first functorForm) (first |$functorForm|))))) + u) + ((and |$insideFunctorIfTrue| (eq name '$)) + (if |$domainShell| + (elt |$domainShell| 1) + (|systemError| "$ has no shell now"))) + ((setq tt (|compMakeCategoryObject| form |$e|)) + (setq |$e| (third tt)) + (elt (first tt) 1)) + (t + (|stackMessage| (list '|not a category form: | form)))))) \end{chunk} -\defplist{Union}{compCat plist} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get '|Union| 'special) '|compCat|)) +\defdollar{FormalMapVariableList} +\begin{chunk}{initvars} +(defvar |$FormalMapVariableList| + '(\#1 \#2 \#3 \#4 \#5 \#6 \#7 \#8 \#9 \#10 \#11 \#12 \#13 \#14 \#15)) \end{chunk} -\defun{compCat}{compCat} -\calls{compCat}{getl} -\begin{chunk}{defun compCat} -(defun |compCat| (form mode env) - (declare (ignore mode)) - (let (functorName fn tmp1 tmp2 funList op sig catForm) - (setq functorName (first form)) - (when (setq fn (getl functorName '|makeFunctionList|)) - (setq tmp1 (funcall fn form form env)) - (setq funList (first tmp1)) - (setq env (second tmp1)) - (setq catForm - (list '|Join| '(|SetCategory|) - (cons 'category - (cons '|domain| - (dolist (item funList (nreverse0 tmp2)) - (setq op (first item)) - (setq sig (second item)) - (unless (eq op '=) (push (list 'signature op sig) tmp2))))))) - (list form catForm env)))) +\defun{substNames}{substNames} +\calls{substNames}{isCategoryPackageName} +\calls{substNames}{eqsubstlist} +\calls{substNames}{nreverse0} +\usesdollar{substNames}{FormalMapVariableList} +\begin{chunk}{defun substNames} +(defun |substNames| (domainName viewName functorForm opalist) + (let (nameForDollar sel pos modemapform tmp0 tmp1) + (declare (special |$FormalMapVariableList|)) + (setq functorForm (subst '$$ '$ functorForm)) + (setq nameForDollar + (if (|isCategoryPackageName| functorForm) + (second functorForm) + domainName)) +; following calls to SUBSTQ must copy to save RPLAC's in +; putInLocalDomainReferences + (dolist (term + (eqsubstlist (kdr functorForm) |$FormalMapVariableList| opalist) + (nreverse0 tmp0)) + (setq tmp1 (reverse term)) + (setq sel (caar tmp1)) + (setq pos (caddar tmp1)) + (setq modemapform (nreverse (cdr tmp1))) + (push + (append + (subst '$ '$$ (subst nameForDollar '$ modemapform)) + (list + (list sel viewName (if (eq domainName '$) pos (cadar modemapform))))) + tmp0)))) \end{chunk} -\defplist{category}{compCategory plist} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get 'category 'special) '|compCategory|)) +\defun{augModemapsFromCategoryRep}{augModemapsFromCategoryRep} +\calls{augModemapsFromCategoryRep}{evalAndSub} +\calls{augModemapsFromCategoryRep}{isCategory} +\calls{augModemapsFromCategoryRep}{compilerMessage} +\calls{augModemapsFromCategoryRep}{putDomainsInScope} +\calls{augModemapsFromCategoryRep}{assoc} +\calls{augModemapsFromCategoryRep}{addModemap} +\defsdollar{augModemapsFromCategoryRep}{base} +\begin{chunk}{defun augModemapsFromCategoryRep} +(defun |augModemapsFromCategoryRep| + (domainName repDefn functorBody categoryForm env) + (labels ( + (redefinedList (op z) + (let (result) + (dolist (u z result) + (setq result (or result (redefined op u)))))) + (redefined (opname u) + (let (op z result) + (when (consp u) + (setq op (qfirst u)) + (setq z (qrest u)) + (cond + ((eq op 'def) (equal opname (caar z))) + ((member op '(progn seq)) (redefinedList opname z)) + ((eq op 'cond) + (dolist (v z result) + (setq result (or result (redefinedList opname (cdr v))))))))))) + (let (fnAlist tmp1 repFnAlist catform lhs op sig cond fnsel u) + (declare (special |$base|)) + (setq tmp1 (|evalAndSub| domainName domainName domainName categoryForm env)) + (setq fnAlist (car tmp1)) + (setq env (cadr tmp1)) + (setq tmp1 (|evalAndSub| '|Rep| '|Rep| repDefn (|getmode| repDefn env) env)) + (setq repFnAlist (car tmp1)) + (setq env (cadr tmp1)) + (setq catform + (if (|isCategory| categoryForm) (elt categoryForm 0) categoryForm)) + (|compilerMessage| (list '|Adding | domainName '| modemaps|)) + (setq env (|putDomainsInScope| domainName env)) + (setq |$base| 4) + (dolist (term fnAlist) + (setq lhs (car term)) + (setq op (caar term)) + (setq sig (cadar term)) + (setq cond (cadr term)) + (setq fnsel (caddr term)) + (setq u (|assoc| (subst '|Rep| domainName lhs :test #'equal) repFnAlist)) + (if (and u (null (redefinedList op functorBody))) + (setq env (|addModemap| op domainName sig cond (caddr u) env)) + (setq env (|addModemap| op domainName sig cond fnsel env)))) + env))) \end{chunk} -\defun{compCategory}{compCategory} -\calls{compCategory}{resolve} -\calls{compCategory}{qcar} -\calls{compCategory}{qcdr} -\calls{compCategory}{compCategoryItem} -\calls{compCategory}{mkExplicitCategoryFunction} -\calls{compCategory}{systemErrorHere} -\defsdollar{compCategory}{sigList} -\defsdollar{compCategory}{atList} -\defsdollar{compCategory}{top-level} -\refsdollar{compCategory}{sigList} -\refsdollar{compCategory}{atList} -\begin{chunk}{defun compCategory} -(defun |compCategory| (form mode env) - (let ($top_level |$sigList| |$atList| domainOrPackage z rep) - (declare (special $top_level |$sigList| |$atList|)) - (setq $top_level t) - (cond - ((and - (equal (setq mode (|resolve| mode (list '|Category|))) - (list '|Category|)) - (consp form) - (eq (qfirst form) 'category) - (consp (qrest form))) - (setq domainOrPackage (second form)) - (setq z (qcddr form)) - (setq |$sigList| nil) - (setq |$atList| nil) - (dolist (x z) (|compCategoryItem| x nil)) - (setq rep - (|mkExplicitCategoryFunction| domainOrPackage |$sigList| |$atList|)) - (list rep mode env)) - (t - (|systemErrorHere| "compCategory"))))) +\section{Maintaining Modemaps} +\defun{addModemapKnown}{addModemapKnown} +\calls{addModemapKnown}{addModemap0} +\refsdollar{addModemapKnown}{e} +\refsdollar{CapsuleModemapFrame}{insideCapsuleFunctionIfTrue} +\defsdollar{addModemapKnown}{CapsuleModemapFrame} +\begin{chunk}{defun addModemapKnown} +(defun |addModemapKnown| (op mc sig pred fn |$e|) + (declare (special |$e| |$CapsuleModemapFrame| |$insideCapsuleFunctionIfTrue|)) + (if (eq |$insideCapsuleFunctionIfTrue| t) + (progn + (setq |$CapsuleModemapFrame| + (|addModemap0| op mc sig pred fn |$CapsuleModemapFrame|)) + |$e|) + (|addModemap0| op mc sig pred fn |$e|))) \end{chunk} -\defun{compCategoryItem}{compCategoryItem} -\calls{compCategoryItem}{qcar} -\calls{compCategoryItem}{qcdr} -\calls{compCategoryItem}{compCategoryItem} -\calls{compCategoryItem}{mkpf} -\refsdollar{compCategoryItem}{sigList} -\refsdollar{compCategoryItem}{atList} -\begin{chunk}{defun compCategoryItem} -(defun |compCategoryItem| (x predl) - (let (p e a b c predlp pred y z op sig) - (declare (special |$sigList| |$atList|)) - (cond - ((null x) nil) -; 1. if x is a conditional expression, recurse; otherwise, form the predicate - ((and (consp x) (eq (qfirst x) 'cond) - (consp (qrest x)) (eq (qcddr x) nil) - (consp (qsecond x)) - (consp (qcdadr x)) - (eq (qcddadr x) nil)) - (setq p (qcaadr x)) - (setq e (qcadadr x)) - (setq predlp (cons p predl)) - (cond - ((and (consp e) (eq (qfirst e) 'progn)) - (setq z (qrest e)) - (dolist (y z) (|compCategoryItem| y predlp))) - (t (|compCategoryItem| e predlp)))) - ((and (consp x) (eq (qfirst x) 'if) (consp (qrest x)) - (consp (qcddr x)) (consp (qcdddr x)) - (eq (qcddddr x) nil)) - (setq a (qsecond x)) - (setq b (qthird x)) - (setq c (qfourth x)) - (setq predlp (cons a predl)) - (unless (eq b '|noBranch|) - (cond - ((and (consp b) (eq (qfirst b) 'progn)) - (setq z (qrest b)) - (dolist (y z) (|compCategoryItem| y predlp))) - (t (|compCategoryItem| b predlp)))) +\defun{addModemap}{addModemap} +\calls{addModemap}{addModemap0} +\calls{addModemap}{knownInfo} +\refsdollar{addModemap}{e} +\refsdollar{addModemap}{InteractiveMode} +\refsdollar{addModemap}{insideCapsuleFunctionIfTrue} +\refsdollar{addModemap}{CapsuleModemapFrame} +\defsdollar{addModemap}{CapsuleModemapFrame} +\begin{chunk}{defun addModemap} +(defun |addModemap| (op mc sig pred fn |$e|) + (declare (special |$e| |$CapsuleModemapFrame| |$InteractiveMode| + |$insideCapsuleFunctionIfTrue|)) + (cond + (|$InteractiveMode| |$e|) + (t + (when (|knownInfo| pred) (setq pred t)) (cond - ((eq c '|noBranch|) nil) - (t - (setq predlp (cons (list '|not| a) predl)) - (cond - ((and (consp c) (eq (qfirst c) 'progn)) - (setq z (qrest c)) - (dolist (y z) (|compCategoryItem| y predlp))) - (t (|compCategoryItem| c predlp)))))) - (t - (setq pred (if predl (mkpf predl 'and) t)) - (cond -; 2. if attribute, push it and return - ((and (consp x) (eq (qfirst x) 'attribute) - (consp (qrest x)) (eq (qcddr x) nil)) - (setq y (qsecond x)) - (push (mkq (list y pred)) |$atList|)) -; 3. it may be a list, with PROGN as the CAR, and some information as the CDR - ((and (consp x) (eq (qfirst x) 'progn)) - (setq z (qrest x)) - (dolist (u z) (|compCategoryItem| u predl))) - (t -; 4. otherwise, x gives a signature for a single operator name or a list of -; names; if a list of names, recurse - (cond ((eq (car x) 'signature) (car x))) - (setq op (cadr x)) - (setq sig (cddr x)) - (cond - ((null (atom op)) - (dolist (y op) - (|compCategoryItem| (cons 'signature (cons y sig)) predl))) + ((eq |$insideCapsuleFunctionIfTrue| t) + (setq |$CapsuleModemapFrame| + (|addModemap0| op mc sig pred fn |$CapsuleModemapFrame|)) + |$e|) (t -; 5. branch on a single type or a signature %with source and target - (push (mkq (list (cdr x) pred)) |$sigList|))))))))) + (|addModemap0| op mc sig pred fn |$e|)))))) \end{chunk} -\defun{mkExplicitCategoryFunction}{mkExplicitCategoryFunction} -\calls{mkExplicitCategoryFunction}{mkq} -\calls{mkExplicitCategoryFunction}{union} -\calls{mkExplicitCategoryFunction}{mustInstantiate} -\calls{mkExplicitCategoryFunction}{remdup} -\calls{mkExplicitCategoryFunction}{identp} -\calls{mkExplicitCategoryFunction}{wrapDomainSub} -\begin{chunk}{defun mkExplicitCategoryFunction} -(defun |mkExplicitCategoryFunction| (domainOrPackage sigList atList) - (let (body sig parameters) - (setq body - (list '|mkCategory| (mkq domainOrPackage) - (cons 'list (reverse sigList)) - (cons 'list (reverse atList)) - (mkq - (let (result) - (loop for item in sigList - do - (setq sig (car (cdaadr item))) - (setq result - (|union| result - (loop for d in sig - when (|mustInstantiate| d) - collect d)))) - result)) - nil)) - (setq parameters - (remdup - (let (result) - (loop for item in sigList - do - (setq sig (car (cdaadr item))) - (setq result - (append result - (loop for x in sig - when (and (identp x) (not (eq x '$))) - collect x)))) - result))) - (|wrapDomainSub| parameters body))) +\defun{addModemap0}{addModemap0} +\calls{addModemap0}{addEltModemap} +\calls{addModemap0}{addModemap1} +\refsdollar{addModemap0}{functorForm} +\begin{chunk}{defun addModemap0} +(defun |addModemap0| (op mc sig pred fn env) + (declare (special |$functorForm|)) + (cond + ((and (consp |$functorForm|) + (eq (qfirst |$functorForm|) '|CategoryDefaults|) + (eq mc '$)) + env) + ((or (eq op '|elt|) (eq op '|setelt|)) + (|addEltModemap| op mc sig pred fn env)) + (t (|addModemap1| op mc sig pred fn env)))) \end{chunk} -\defun{mustInstantiate}{mustInstantiate} -\calls{mustInstantiate}{qcar} -\calls{mustInstantiate}{getl} -\refsdollar{mustInstantiate}{DummyFunctorNames} -\begin{chunk}{defun mustInstantiate} -(defun |mustInstantiate| (d) - (declare (special |$DummyFunctorNames|)) - (and (consp d) - (null (or (member (qfirst d) |$DummyFunctorNames|) - (getl (qfirst d) '|makeFunctionList|))))) +\defun{addModemap1}{addModemap1} +\calls{addModemap1}{getProplist} +\calls{addModemap1}{mkNewModemapList} +\calls{addModemap1}{lassoc} +\calls{addModemap1}{augProplist} +\calls{addModemap1}{unErrorRef} +\calls{addModemap1}{addBinding} +\begin{chunk}{defun addModemap1} +(defun |addModemap1| (op mc sig pred fn env) + (let (currentProplist newModemapList newProplist newProplistp) + (when (eq mc '|Rep|) (setq sig (subst '$ '|Rep| sig :test #'equal))) + (setq currentProplist (or (|getProplist| op env) nil)) + (setq newModemapList + (|mkNewModemapList| mc sig pred fn + (lassoc '|modemap| currentProplist) env nil)) + (setq newProplist (|augProplist| currentProplist '|modemap| newModemapList)) + (setq newProplistp (|augProplist| newProplist 'fluid t)) + (|unErrorRef| op) + (|addBinding| op newProplistp env))) \end{chunk} -\defun{wrapDomainSub}{wrapDomainSub} -\begin{chunk}{defun wrapDomainSub} -(defun |wrapDomainSub| (parameters x) - (list '|DomainSubstitutionMacro| parameters x)) -\end{chunk} +\section{Indirect called comp routines} +In the {\bf compExpression} function there is the code: +\begin{verbatim} + (if (and (atom (car x)) (setq fn (getl (car x) 'special))) + (funcall fn x m e) + (|compForm| x m e)))) +\end{verbatim} -\defplist{:}{compColon plist} + +\defplist{@}{compAdd plist} +We set up the {\tt compAdd} function to handle the {\tt add} keyword +by setting the {\tt special} keyword on the {\tt add} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) - (setf (get '|:| 'special) '|compColon|)) + (setf (get '|add| 'special) 'compAdd)) \end{chunk} -\defun{compColon}{compColon} -\calls{compColon}{compColonInside} -\calls{compColon}{assoc} -\calls{compColon}{getDomainsInScope} -\calls{compColon}{isDomainForm} -\seebook{compColon}{member}{5} -\calls{compColon}{addDomain} -\calls{compColon}{isCategoryForm} -\calls{compColon}{unknownTypeError} -\calls{compColon}{compColon} -\calls{compColon}{eqsubstlist} -\calls{compColon}{take} -\calls{compColon}{length} -\calls{compColon}{nreverse0} -\calls{compColon}{getmode} -\calls{compColon}{systemErrorHere} -\calls{compColon}{put} -\calls{compColon}{makeCategoryForm} -\calls{compColon}{genSomeVariable} -\usesdollar{compColon}{lhsOfColon} -\usesdollar{compColon}{noEnv} -\usesdollar{compColon}{insideFunctorIfTrue} -\usesdollar{compColon}{bootStrapMode} -\usesdollar{compColon}{FormalMapVariableList} -\usesdollar{compColon}{insideCategoryIfTrue} -\usesdollar{compColon}{insideExpressionIfTrue} -\begin{chunk}{defun compColon} -(defun |compColon| (form mode env) - (let (|$lhsOfColon| argf argt tprime mprime r td op argl newTarget a - signature tmp2 catform tmp3 g2 g5) - (declare (special |$lhsOfColon| |$noEnv| |$insideFunctorIfTrue| - |$bootStrapMode| |$FormalMapVariableList| - |$insideCategoryIfTrue| |$insideExpressionIfTrue|)) - (setq argf (second form)) - (setq argt (third form)) - (if |$insideExpressionIfTrue| - (|compColonInside| argf mode env argt) - (progn - (setq |$lhsOfColon| argf) - (setq argt - (cond - ((and (atom argt) - (setq tprime (|assoc| argt (|getDomainsInScope| env)))) - tprime) - ((and (|isDomainForm| argt env) (null |$insideCategoryIfTrue|)) - (unless (|member| argt (|getDomainsInScope| env)) - (setq env (|addDomain| argt env))) - argt) - ((or (|isDomainForm| argt env) (|isCategoryForm| argt env)) - argt) - ((and (consp argt) (eq (qfirst argt) '|Mapping|) - (progn - (setq tmp2 (qrest argt)) - (and (consp tmp2) - (progn - (setq mprime (qfirst tmp2)) - (setq r (qrest tmp2)) - t)))) - argt) - (t - (|unknownTypeError| argt) - argt))) - (cond - ((eq (car argf) 'listof) - (dolist (x (cdr argf) td) - (setq td (|compColon| (list '|:| x argt) mode env)) - (setq env (third td)))) - (t - (setq env - (cond - ((and (consp argf) - (progn - (setq op (qfirst argf)) - (setq argl (qrest argf)) - t) - (null (and (consp argt) (eq (qfirst argt) '|Mapping|)))) - (setq newTarget - (eqsubstlist (take (|#| argl) |$FormalMapVariableList|) - (dolist (x argl (nreverse0 g2)) - (setq g2 - (cons - (cond - ((and (consp x) (eq (qfirst x) '|:|) - (progn - (setq tmp2 (qrest x)) - (and (consp tmp2) - (progn - (setq a (qfirst tmp2)) - (setq tmp3 (qrest tmp2)) - (and (consp tmp3) - (eq (qrest tmp3) nil) - (progn - (setq mode (qfirst tmp3)) - t)))))) - a) - (t x)) - g2))) - argt)) - (setq signature - (cons '|Mapping| - (cons newTarget - (dolist (x argl (nreverse0 g5)) - (setq g5 - (cons - (cond - ((and (consp x) (eq (qfirst x) '|:|) - (progn - (setq tmp2 (qrest x)) - (and (consp tmp2) - (progn - (setq a (qfirst tmp2)) - (setq tmp3 (qrest tmp2)) - (and (consp tmp3) - (eq (qrest tmp3) nil) - (progn - (setq mode (qfirst tmp3)) - t)))))) - mode) - (t - (or (|getmode| x env) - (|systemErrorHere| "compColonOld")))) - g5)))))) - (|put| op '|mode| signature env)) - (t (|put| argf '|mode| argt env)))) - (cond - ((and (null |$bootStrapMode|) |$insideFunctorIfTrue| - (progn - (setq tmp2 (|makeCategoryForm| argt env)) - (and (consp tmp2) - (progn - (setq catform (qfirst tmp2)) - (setq tmp3 (qrest tmp2)) - (and (consp tmp3) - (eq (qrest tmp3) nil) - (progn - (setq env (qfirst tmp3)) - t)))))) - (setq env - (|put| argf '|value| (list (|genSomeVariable|) argt |$noEnv|) - env)))) - (list '|/throwAway| (|getmode| argf env) env ))))))) +\defun{compAdd}{compAdd} +The compAdd function expects three arguments: +\begin{enumerate} +\item the {\bf form} which is an |add| specifying the domain +to extend and a set of functions to be added +\item the {\bf mode} a |Join|, which is a set of categories and domains +\item the {\bf env} which is a list of functions and their modemaps +\end{enumerate} + +The bulk of the work is performed by a call to compOrCroak which +compiles the functions in the add form capsule. + +The compAdd function returns a triple, the result of a call to compCapsule. +\begin{enumerate} +\item the {\bf compiled capsule} which is a progn form which returns +the domain +\item the {\bf mode} from the input argument +\item the {\bf env} prepended with the signatures of the functions +in the body of the add. +\end{enumerate} +\calls{compAdd}{comp} +\calls{compAdd}{compSubDomain1} +\calls{compAdd}{nreverse0} +\calls{compAdd}{NRTgetLocalIndex} +\calls{compAdd}{compTuple2Record} +\calls{compAdd}{compOrCroak} +\calls{compAdd}{compCapsule} +\uses{compAdd}{/editfile} +\usesdollar{compAdd}{addForm} +\usesdollar{compAdd}{addFormLhs} +\usesdollar{compAdd}{EmptyMode} +\usesdollar{compAdd}{NRTaddForm} +\usesdollar{compAdd}{packagesUsed} +\usesdollar{compAdd}{functorForm} +\usesdollar{compAdd}{bootStrapMode} +\begin{chunk}{defun compAdd} +(defun compAdd (form mode env) + (let (|$addForm| |$addFormLhs| code domainForm predicate tmp3 tmp4) + (declare (special |$addForm| |$addFormLhs| |$EmptyMode| |$NRTaddForm| + |$packagesUsed| |$functorForm| |$bootStrapMode| /editfile)) + (setq |$addForm| (second form)) + (cond + ((eq |$bootStrapMode| t) + (cond + ((and (consp |$addForm|) (eq (qfirst |$addForm|) '|@Tuple|)) + (setq code nil)) + (t + (setq tmp3 (|comp| |$addForm| mode env)) + (setq code (first tmp3)) + (setq mode (second tmp3)) + (setq env (third tmp3)) tmp3)) + (list + (list 'cond + (list '|$bootStrapMode| code) + (list 't + (list '|systemError| + (list 'list ''|%b| (mkq (car |$functorForm|)) ''|%d| "from" + ''|%b| (mkq (|namestring| /editfile)) ''|%d| + "needs to be compiled")))) + mode env)) + (t + (setq |$addFormLhs| |$addForm|) + (cond + ((and (consp |$addForm|) (eq (qfirst |$addForm|) '|SubDomain|) + (consp (qrest |$addForm|)) (consp (qcddr |$addForm|)) + (eq (qcdddr |$addForm|) nil)) + (setq domainForm (second |$addForm|)) + (setq predicate (third |$addForm|)) + (setq |$packagesUsed| (cons domainForm |$packagesUsed|)) + (setq |$NRTaddForm| domainForm) + (|NRTgetLocalIndex| domainForm) + ; need to generate slot for add form since all $ go-get + ; slots will need to access it + (setq tmp3 (|compSubDomain1| domainForm predicate mode env)) + (setq |$addForm| (first tmp3)) + (setq env (third tmp3)) tmp3) + (t + (setq |$packagesUsed| + (if (and (consp |$addForm|) (eq (qfirst |$addForm|) '|@Tuple|)) + (append (qrest |$addForm|) |$packagesUsed|) + (cons |$addForm| |$packagesUsed|))) + (setq |$NRTaddForm| |$addForm|) + (setq tmp3 + (cond + ((and (consp |$addForm|) (eq (qfirst |$addForm|) '|@Tuple|)) + (setq |$NRTaddForm| + (cons '|@Tuple| + (dolist (x (cdr |$addForm|) (nreverse0 tmp4)) + (push (|NRTgetLocalIndex| x) tmp4)))) + (|compOrCroak| (|compTuple2Record| |$addForm|) |$EmptyMode| env)) + (t + (|compOrCroak| |$addForm| |$EmptyMode| env)))) + (setq |$addForm| (first tmp3)) + (setq env (third tmp3)) + tmp3)) + (|compCapsule| (third form) mode env))))) \end{chunk} -\defun{makeCategoryForm}{makeCategoryForm} -\calls{makeCategoryForm}{isCategoryForm} -\calls{makeCategoryForm}{compOrCroak} -\refsdollar{makeCategoryForm}{EmptyMode} -\begin{chunk}{defun makeCategoryForm} -(defun |makeCategoryForm| (c env) - (let (tmp1) - (declare (special |$EmptyMode|)) - (when (|isCategoryForm| c env) - (setq tmp1 (|compOrCroak| c |$EmptyMode| env)) - (list (first tmp1) (third tmp1))))) +\defun{compTuple2Record}{compTuple2Record} +\begin{chunk}{defun compTuple2Record} +(defun |compTuple2Record| (u) + (let ((i 0)) + (cons '|Record| + (loop for x in (rest u) + collect (list '|:| (incf i) x))))) \end{chunk} -\defplist{cons}{compCons plist} +\defplist{capsule}{compCapsule plist} +We set up the {\tt compCapsule} function to handle the {\tt capsule} keyword +by setting the {\tt special} keyword on the {\tt capsule} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) - (setf (get 'cons 'special) '|compCons|)) + (setf (get 'capsule 'special) '|compCapsule|)) + +\end{chunk} + +\defun{compCapsule}{compCapsule} +\calls{compCapsule}{bootStrapError} +\calls{compCapsule}{compCapsuleInner} +\calls{compCapsule}{addDomain} +\uses{compCapsule}{editfile} +\usesdollar{compCapsule}{insideExpressionIfTrue} +\usesdollar{compCapsule}{functorForm} +\usesdollar{compCapsule}{bootStrapMode} +\begin{chunk}{defun compCapsule} +(defun |compCapsule| (form mode env) + (let (|$insideExpressionIfTrue| itemList) + (declare (special |$insideExpressionIfTrue| |$functorForm| /editfile + |$bootStrapMode|)) + (setq itemList (cdr form)) + (cond + ((eq |$bootStrapMode| t) + (list (|bootStrapError| |$functorForm| /editfile) mode env)) + (t + (setq |$insideExpressionIfTrue| nil) + (|compCapsuleInner| itemList mode (|addDomain| '$ env)))))) + +\end{chunk} + +\defun{compCapsuleInner}{compCapsuleInner} +\calls{compCapsuleInner}{addInformation} +\calls{compCapsuleInner}{compCapsuleItems} +\calls{compCapsuleInner}{processFunctor} +\calls{compCapsuleInner}{mkpf} +\usesdollar{compCapsuleInner}{getDomainCode} +\usesdollar{compCapsuleInner}{signature} +\usesdollar{compCapsuleInner}{form} +\usesdollar{compCapsuleInner}{addForm} +\usesdollar{compCapsuleInner}{insideCategoryPackageIfTrue} +\usesdollar{compCapsuleInner}{insideCategoryIfTrue} +\usesdollar{compCapsuleInner}{functorLocalParameters} +\begin{chunk}{defun compCapsuleInner} +(defun |compCapsuleInner| (form mode env) + (let (localParList data code) + (declare (special |$getDomainCode| |$signature| |$form| |$addForm| + |$insideCategoryPackageIfTrue| |$insideCategoryIfTrue| + |$functorLocalParameters|)) + (setq env (|addInformation| mode env)) + (setq data (cons 'progn form)) + (setq env (|compCapsuleItems| form nil env)) + (setq localParList |$functorLocalParameters|) + (when |$addForm| (setq data (list '|add| |$addForm| data))) + (setq code + (if (and |$insideCategoryIfTrue| (null |$insideCategoryPackageIfTrue|)) + data + (|processFunctor| |$form| |$signature| data localParList env))) + (cons (mkpf (append |$getDomainCode| (list code)) 'progn) (list mode env)))) + +\end{chunk} + +\defun{processFunctor}{processFunctor} +\calls{processFunctor}{error} +\calls{processFunctor}{buildFunctor} +\begin{chunk}{defun processFunctor} +(defun |processFunctor| (form signature data localParList e) + (cond + ((and (consp form) (eq (qrest form) nil) + (eq (qfirst form) '|CategoryDefaults|)) + (|error| '|CategoryDefaults is a reserved name|)) + (t (|buildFunctor| form signature data localParList e)))) + +\end{chunk} + +\defun{compCapsuleItems}{compCapsuleItems} +The variable data appears to be unbound at runtime. Optimized +code won't check for this but interpreted code fails. We should +PROVE that data is unbound at runtime but have not done so yet. +Rather than remove the code entirely (since there MIGHT be a +path where it is used) we check for the runtime bound case and +assign \verb|$myFunctorBody| if data has a value. + +The compCapsuleInner function in this file LOOKS like it sets +data and expects code to manipulate the assigned data structure. +Since we can't be sure we take the least disruptive course of action. + +\calls{compCapsuleItems}{compSingleCapsuleItem} +\defsdollar{compCapsuleItems}{top-level} +\defsdollar{compCapsuleItems}{myFunctorBody} +\defsdollar{compCapsuleItems}{signatureOfForm} +\defsdollar{compCapsuleItems}{suffix} +\defsdollar{compCapsuleItems}{e} +\refsdollar{compCapsuleItems}{pred} +\refsdollar{compCapsuleItems}{e} +\begin{chunk}{defun compCapsuleItems} +(defun |compCapsuleItems| (itemlist |$predl| |$e|) + (declare (special |$predl| |$e|)) + (let ($top_level |$myFunctorBody| |$signatureOfForm| |$suffix|) + (declare (special $top_level |$myFunctorBody| |$signatureOfForm| |$suffix|)) + (setq $top_level nil) + (setq |$myFunctorBody| nil) + (when (boundp '|data|) (setq |$myFunctorBody| |data|)) + (setq |$signatureOfForm| nil) + (setq |$suffix| 0) + (loop for item in itemlist do + (setq |$e| (|compSingleCapsuleItem| item |$predl| |$e|))) + |$e|)) + +\end{chunk} + +\defun{compSingleCapsuleItem}{compSingleCapsuleItem} +\calls{compSingleCapsuleItem}{doit} +\refsdollar{compSingleCapsuleItem}{pred} +\refsdollar{compSingleCapsuleItem}{e} +\calls{compSingleCapsuleItem}{macroExpandInPlace} +\begin{chunk}{defun compSingleCapsuleItem} +(defun |compSingleCapsuleItem| (item |$predl| |$e|) + (declare (special |$predl| |$e|)) + (|doIt| (|macroExpandInPlace| item |$e|) |$predl|) + |$e|) + +\end{chunk} + +\defun{doIt}{doIt} +\calls{doIt}{lastnode} +\calls{doIt}{compSingleCapsuleItem} +\calls{doIt}{isDomainForm} +\calls{doIt}{stackWarning} +\calls{doIt}{doIt} +\calls{doIt}{compOrCroak} +\calls{doIt}{stackSemanticError} +\calls{doIt}{bright} +\calls{doIt}{member} +\calls{doIt}{kar} +\calls{doIt}{|isFunctor} +\calls{doIt}{insert} +\calls{doIt}{opOf} +\calls{doIt}{get} +\calls{doIt}{NRTgetLocalIndex} +\calls{doIt}{sublis} +\calls{doIt}{compOrCroak} +\calls{doIt}{sayBrightly} +\calls{doIt}{formatUnabbreviated} +\calls{doIt}{doItIf} +\calls{doIt}{isMacro} +\calls{doIt}{put} +\calls{doIt}{cannotDo} +\refsdollar{doIt}{predl} +\refsdollar{doIt}{e} +\refsdollar{doIt}{EmptyMode} +\refsdollar{doIt}{NonMentionableDomainNames} +\refsdollar{doIt}{functorLocalParameters} +\refsdollar{doIt}{functorsUsed} +\refsdollar{doIt}{packagesUsed} +\refsdollar{doIt}{NRTopt} +\refsdollar{doIt}{Representation} +\refsdollar{doIt}{LocalDomainAlist} +\refsdollar{doIt}{QuickCode} +\refsdollar{doIt}{signatureOfForm} +\defsdollar{doIt}{genno} +\defsdollar{doIt}{e} +\defsdollar{doIt}{functorLocalParameters} +\defsdollar{doIt}{functorsUsed} +\defsdollar{doIt}{packagesUsed} +\defsdollar{doIt}{Representation} +\defsdollar{doIt}{LocalDomainAlist} +\begin{chunk}{defun doIt} +(defun |doIt| (item |$predl|) + (declare (special |$predl|)) + (prog ($genno x rhs lhsp lhs rhsp rhsCode z tmp1 tmp2 tmp6 op body tt + functionPart u code) + (declare (special $genno |$e| |$EmptyMode| |$signatureOfForm| + |$QuickCode| |$LocalDomainAlist| |$Representation| + |$NRTopt| |$packagesUsed| |$functorsUsed| + |$functorLocalParameters| |$NonMentionableDomainNames|)) + (setq $genno 0) + (cond + ((and (consp item) (eq (qfirst item) 'seq) (consp (qrest item)) + (progn (setq tmp6 (reverse (qrest item))) t) + (consp tmp6) (consp (qfirst tmp6)) + (eq (qcaar tmp6) '|exit|) + (consp (qcdar tmp6)) + (equal (qcadar tmp6) 1) + (consp (qcddar tmp6)) + (eq (qcdddar tmp6) nil)) + (setq x (qcaddar tmp6)) + (setq z (qrest tmp6)) + (setq z (nreverse z)) + (rplaca item 'progn) + (rplaca (lastnode item) x) + (loop for it1 in (rest item) + do (setq |$e| (|compSingleCapsuleItem| it1 |$predl| |$e|)))) + ((|isDomainForm| item |$e|) + (setq u (list '|import| (cons (car item) (cdr item)))) + (|stackWarning| (list '|Use: import | (cons (car item) (cdr item)))) + (rplaca item (car u)) + (rplacd item (cdr u)) + (|doIt| item |$predl|)) + ((and (consp item) (eq (qfirst item) 'let) (consp (qrest item)) + (consp (qcddr item))) + (setq lhs (qsecond item)) + (setq rhs (qthird item)) + (cond + ((null (progn + (setq tmp2 (|compOrCroak| item |$EmptyMode| |$e|)) + (and (consp tmp2) + (progn + (setq code (qfirst tmp2)) + (and (consp (qrest tmp2)) + (progn + (and (consp (qcddr tmp2)) + (eq (qcdddr tmp2) nil) + (PROGN + (setq |$e| (qthird tmp2)) + t)))))))) + (|stackSemanticError| + (cons '|cannot compile assigned value to| (|bright| lhs)) + nil)) + ((null (and (consp code) (eq (qfirst code) 'let) + (progn + (and (consp (qrest code)) + (progn + (setq lhsp (qsecond code)) + (and (consp (qcddr code)))))) + (atom (qsecond code)))) + (cond + ((and (consp code) (eq (qfirst code) 'progn)) + (|stackSemanticError| + (list '|multiple assignment | item '| not allowed|) + nil)) + (t + (rplaca item (car code)) + (rplacd item (cdr code))))) + (t + (setq lhs lhsp) + (cond + ((and (null (|member| (kar rhs) |$NonMentionableDomainNames|)) + (null (member lhs |$functorLocalParameters|))) + (setq |$functorLocalParameters| + (append |$functorLocalParameters| (list lhs))))) + (cond + ((and (consp code) (eq (qfirst code) 'let) + (progn + (setq tmp2 (qrest code)) + (and (consp tmp2) + (progn + (setq tmp6 (qrest tmp2)) + (and (consp tmp6) + (progn + (setq rhsp (qfirst tmp6)) + t))))) + (|isDomainForm| rhsp |$e|)) + (cond + ((|isFunctor| rhsp) + (setq |$functorsUsed| (|insert| (|opOf| rhsp) |$functorsUsed|)) + (setq |$packagesUsed| (|insert| (list (|opOf| rhsp)) + |$packagesUsed|)))) + (cond + ((eq lhs '|Rep|) + (setq |$Representation| (elt (|get| '|Rep| '|value| |$e|) 0)) + (cond + ((eq |$NRTopt| t) + (|NRTgetLocalIndex| |$Representation|)) + (t nil)))) + (setq |$LocalDomainAlist| + (cons (cons lhs + (sublis |$LocalDomainAlist| (elt (|get| lhs '|value| |$e|) 0))) + |$LocalDomainAlist|)))) + (cond + ((and (consp code) (eq (qfirst code) 'let)) + (rplaca item (if |$QuickCode| 'qsetrefv 'setelt)) + (setq rhsCode rhsp) + (rplacd item (list '$ (|NRTgetLocalIndex| lhs) rhsCode))) + (t + (rplaca item (car code)) + (rplacd item (cdr code))))))) + ((and (consp item) (eq (qfirst item) '|:|) (consp (qrest item)) + (consp (qcddr item)) (eq (qcdddr item) nil)) + (setq tmp1 (|compOrCroak| item |$EmptyMode| |$e|)) + (setq |$e| (caddr tmp1)) + tmp1) + ((and (consp item) (eq (qfirst item) '|import|)) + (loop for dom in (qrest item) + do (|sayBrightly| (cons " importing " (|formatUnabbreviated| dom)))) + (setq tmp1 (|compOrCroak| item |$EmptyMode| |$e|)) + (setq |$e| (caddr tmp1)) + (rplaca item 'progn) + (rplacd item nil)) + ((and (consp item) (eq (qfirst item) 'if)) + (|doItIf| item |$predl| |$e|)) + ((and (consp item) (eq (qfirst item) '|where|) (consp (qrest item))) + (|compOrCroak| item |$EmptyMode| |$e|)) + ((and (consp item) (eq (qfirst item) 'mdef)) + (setq tmp1 (|compOrCroak| item |$EmptyMode| |$e|)) + (setq |$e| (caddr tmp1)) tmp1) + ((and (consp item) (eq (qfirst item) 'def) (consp (qrest item)) + (consp (qsecond item))) + (setq op (qcaadr item)) + (cond + ((setq body (|isMacro| item |$e|)) + (setq |$e| (|put| op '|macro| body |$e|))) + (t + (setq tt (|compOrCroak| item |$EmptyMode| |$e|)) + (setq |$e| (caddr tt)) + (rplaca item '|CodeDefine|) + (rplacd (cadr item) (list |$signatureOfForm|)) + (setq functionPart (list '|dispatchFunction| (car tt))) + (rplaca (cddr item) functionPart) + (rplacd (cddr item) nil)))) + ((setq u (|compOrCroak| item |$EmptyMode| |$e|)) + (setq code (car u)) + (setq |$e| (caddr u)) + (rplaca item (car code)) + (rplacd item (cdr code))) + (t (|cannotDo|))))) \end{chunk} -\defun{compCons}{compCons} -\calls{compCons}{compCons1} -\calls{compCons}{compForm} -\begin{chunk}{defun compCons} -(defun |compCons| (form mode env) - (or (|compCons1| form mode env) (|compForm| form mode env))) +\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|)) + (labels ( + (localExtras (oldFLP) + (let (oldFLPp flp1 gv ans nils n) + (declare (special |$functorLocalParameters| |$getDomainCode|)) + (unless (eq oldFLP |$functorLocalParameters|) + (setq flp1 |$functorLocalParameters|) + (setq oldFLPp oldFLP) + (setq n 0) + (loop while oldFLPp + do + (setq oldFLPp (cdr oldFLPp)) + (setq n (1+ n))) + (setq nils (setq ans nil)) + (loop for u in flp1 + do + (if (or (atom u) + (let (result) + (loop for v in |$getDomainCode| + do + (setq result (or result + (and (consp v) (consp (qrest v)) + (equal (qsecond v) u))))) + result)) + ; Now we have to add code to compile all the elements of + ; functorLocalParameters that were added during the conditional compilation + (setq nils (cons u nils)) + (progn + (setq gv (gensym)) + (setq ans (cons (list 'let gv u) ans)) + (setq nils (CONS gv nils)))) + (setq n (1+ n))) + (setq |$functorLocalParameters| (append oldFLP (nreverse nils))) + (nreverse ans))))) + (let (p x y olde tmp1 pp xp oldFLP yp) + (declare (special |$functorLocalParameters| |$Boolean|)) + (setq p (second item)) + (setq x (third item)) + (setq y (fourth item)) + (setq olde |$e|) + (setq tmp1 + (or (|comp| p |$Boolean| |$e|) + (|userError| (list "not a Boolean:" p)))) + (setq pp (first tmp1)) + (setq |$e| (third tmp1)) + (setq oldFLP |$functorLocalParameters|) + (unless (eq x '|noBranch|) + (|compSingleCapsuleItem| x |$predl| (|getSuccessEnvironment| p |$e|)) + (setq xp (localExtras oldFLP))) + (setq oldFLP |$functorLocalParameters|) + (unless (eq y '|noBranch|) + (|compSingleCapsuleItem| y |$predl| (|getInverseEnvironment| p olde)) + (setq yp (localExtras oldFLP))) + (rplaca item 'cond) + (rplacd item (list (cons pp (cons x xp)) (cons ''t (cons y yp))))))) \end{chunk} -\defun{compCons1}{compCons1} -\calls{compCons1}{comp} -\calls{compCons1}{convert} -\calls{compCons1}{qcar} -\calls{compCons1}{qcdr} -\usesdollar{compCons1}{EmptyMode} -\begin{chunk}{defun compCons1} -(defun |compCons1| (arg mode env) - (let (mx y my yt mp mr ytp tmp1 x td) - (declare (special |$EmptyMode|)) - (setq x (second arg)) - (setq y (third arg)) - (when (setq tmp1 (|comp| x |$EmptyMode| env)) - (setq x (first tmp1)) - (setq mx (second tmp1)) - (setq env (third tmp1)) - (cond - ((null y) - (|convert| (list (list 'list x) (list '|List| mx) env ) mode)) - (t - (when (setq yt (|comp| y |$EmptyMode| env)) - (setq y (first yt)) - (setq my (second yt)) - (setq env (third yt)) - (setq td - (cond - ((and (consp my) (eq (qfirst my) '|List|) (consp (qrest my))) - (setq mp (second my)) - (when (setq mr (list '|List| (|resolve| mp mx))) - (when (setq ytp (|convert| yt mr)) - (when (setq tmp1 (|convert| (list x mx (third ytp)) (second mr))) - (setq x (first tmp1)) - (setq env (third tmp1)) - (cond - ((and (consp (car ytp)) (eq (qfirst (car ytp)) 'list)) - (list (cons 'list (cons x (cdr (car ytp)))) mr env)) - (t - (list (list 'cons x (car ytp)) mr env))))))) - (t - (list (list 'cons x y) (list '|Pair| mx my) env )))) - (|convert| td mode))))))) +\defun{isMacro}{isMacro} +\calls{isMacro}{get} +\begin{chunk}{defun isMacro} +(defun |isMacro| (x env) + (let (op args signature body) + (when + (and (consp x) (eq (qfirst x) 'def) (consp (qrest x)) + (consp (qsecond x)) (consp (qcddr x)) + (consp (qcdddr x)) + (consp (qcddddr x)) + (eq (qrest (qcddddr x)) nil)) + (setq op (qcaadr x)) + (setq args (qcdadr x)) + (setq signature (qthird x)) + (setq body (qfirst (qcddddr x))) + (when + (and (null (|get| op '|modemap| env)) + (null args) + (null (|get| op '|mode| env)) + (consp signature) + (eq (qrest signature) nil) + (null (qfirst signature))) + body)))) \end{chunk} -\defplist{construct}{compConstruct plist} +\defplist{case}{compCase plist} +We set up the {\tt compCase} function to handle the {\tt case} keyword +by setting the {\tt special} keyword on the {\tt case} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) - (setf (get '|construct| 'special) '|compConstruct|)) + (setf (get '|case| 'special) '|compCase|)) \end{chunk} -\defun{compConstruct}{compConstruct} -\calls{compConstruct}{modeIsAggregateOf} -\calls{compConstruct}{compList} -\calls{compConstruct}{convert} -\calls{compConstruct}{compForm} -\calls{compConstruct}{compVector} -\calls{compConstruct}{getDomainsInScope} -\begin{chunk}{defun compConstruct} -(defun |compConstruct| (form mode env) - (let (z y td tp) - (setq z (cdr form)) - (cond - ((setq y (|modeIsAggregateOf| '|List| mode env)) - (if (setq td (|compList| z (list '|List| (cadr y)) env)) - (|convert| td mode) - (|compForm| form mode env))) - ((setq y (|modeIsAggregateOf| '|Vector| mode env)) - (if (setq td (|compVector| z (list '|Vector| (cadr y)) env)) - (|convert| td mode) - (|compForm| form mode env))) - ((setq td (|compForm| form mode env)) td) - (t - (dolist (d (|getDomainsInScope| env)) - (cond - ((and (setq y (|modeIsAggregateOf| '|List| d env)) - (setq td (|compList| z (list '|List| (cadr y)) env)) - (setq tp (|convert| td mode))) - (return tp)) - ((and (setq y (|modeIsAggregateOf| '|Vector| d env)) - (setq td (|compVector| z (list '|Vector| (cadr y)) env)) - (setq tp (|convert| td mode))) - (return tp)))))))) +\defun{compCase}{compCase} +Will the jerk who commented out these two functions please NOT do so +again. These functions ARE needed, and case can NOT be done by +modemap alone. The reason is that A case B requires to take A +evaluated, but B unevaluated. Therefore a special function is +required. You may have thought that you had tested this on ``failed'' +etc., but ``failed'' evaluates to it's own mode. Try it on x case \$ +next time. + +An angry JHD - August 15th., 1984 +\calls{compCase}{addDomain} +\calls{compCase}{compCase1} +\calls{compCase}{coerce} +\begin{chunk}{defun compCase} +(defun |compCase| (form mode env) + (let (mp td) + (setq mp (third form)) + (setq env (|addDomain| mp env)) + (when (setq td (|compCase1| (second form) mp env)) (|coerce| td mode)))) \end{chunk} -\defplist{ListCategory}{compConstructorCategory plist} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get '|ListCategory| 'special) '|compConstructorCategory|)) +\defun{compCase1}{compCase1} +\calls{compCase1}{comp} +\calls{compCase1}{getModemapList} +\calls{compCase1}{nreverse0} +\calls{compCase1}{modeEqual} +\usesdollar{compCase1}{Boolean} +\usesdollar{compCase1}{EmptyMode} +\begin{chunk}{defun compCase1} +(defun |compCase1| (form mode env) + (let (xp mp ep map tmp3 tmp5 tmp6 u fn) + (declare (special |$Boolean| |$EmptyMode|)) + (when (setq tmp3 (|comp| form |$EmptyMode| env)) + (setq xp (first tmp3)) + (setq mp (second tmp3)) + (setq ep (third tmp3)) + (when + (setq u + (dolist (modemap (|getModemapList| '|case| 2 ep) (nreverse0 tmp5)) + (setq map (first modemap)) + (when + (and (consp map) (consp (qrest map)) (consp (qcddr map)) + (consp (qcdddr map)) + (eq (qcddddr map) nil) + (|modeEqual| (fourth map) mode) + (|modeEqual| (third map) mp)) + (push (second modemap) tmp5)))) + (when + (setq fn + (dolist (onepair u tmp6) + (when (first onepair) (setq tmp6 (or tmp6 (second onepair)))))) + (list (list '|call| fn xp) |$Boolean| ep)))))) \end{chunk} -\defplist{RecordCategory}{compConstructorCategory plist} +\defplist{Record}{compCat plist} +We set up the {\tt compCat} function to handle the {\tt Record} keyword +by setting the {\tt special} keyword on the {\tt Record} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) - (setf (get '|RecordCategory| 'special) '|compConstructorCategory|)) + (setf (get '|Record| 'special) '|compCat|)) \end{chunk} -\defplist{UnionCategory}{compConstructorCategory plist} +\defplist{Mapping}{compCat plist} +We set up the {\tt compCat} function to handle the {\tt Mapping} keyword +by setting the {\tt special} keyword on the {\tt Mapping} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) - (setf (get '|UnionCategory| 'special) '|compConstructorCategory|)) + (setf (get '|Mapping| 'special) '|compCat|)) \end{chunk} -\defplist{VectorCategory}{compConstructorCategory plist} +\defplist{Union}{compCat plist} +We set up the {\tt compCat} function to handle the {\tt Union} keyword +by setting the {\tt special} keyword on the {\tt Union} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) - (setf (get '|VectorCategory| 'special) '|compConstructorCategory|)) + (setf (get '|Union| 'special) '|compCat|)) \end{chunk} -\defun{compConstructorCategory}{compConstructorCategory} -\calls{compConstructorCategory}{resolve} -\usesdollar{compConstructorCategory}{Category} -\begin{chunk}{defun compConstructorCategory} -(defun |compConstructorCategory| (form mode env) - (declare (special |$Category|)) - (list form (|resolve| |$Category| mode) env)) +\defun{compCat}{compCat} +\calls{compCat}{getl} +\begin{chunk}{defun compCat} +(defun |compCat| (form mode env) + (declare (ignore mode)) + (let (functorName fn tmp1 tmp2 funList op sig catForm) + (setq functorName (first form)) + (when (setq fn (getl functorName '|makeFunctionList|)) + (setq tmp1 (funcall fn form form env)) + (setq funList (first tmp1)) + (setq env (second tmp1)) + (setq catForm + (list '|Join| '(|SetCategory|) + (cons 'category + (cons '|domain| + (dolist (item funList (nreverse0 tmp2)) + (setq op (first item)) + (setq sig (second item)) + (unless (eq op '=) (push (list 'signature op sig) tmp2))))))) + (list form catForm env)))) \end{chunk} -\defplist{def}{compDefine plist} +\defplist{category}{compCategory plist} +We set up the {\tt compCategory} function to handle the {\tt category} keyword +by setting the {\tt special} keyword on the {\tt category} +symbol property list. \begin{chunk}{postvars} (eval-when (eval load) - (setf (get 'def 'special) '|compDefine|)) - -\end{chunk} - -\defun{compDefine}{compDefine} -\calls{compDefine}{compDefine1} -\usesdollar{compDefine}{tripleCache} -\usesdollar{compDefine}{tripleHits} -\usesdollar{compDefine}{macroIfTrue} -\usesdollar{compDefine}{packagesUsed} -\begin{chunk}{defun compDefine} -(defun |compDefine| (form mode env) - (let (|$tripleCache| |$tripleHits| |$macroIfTrue| |$packagesUsed|) - (declare (special |$tripleCache| |$tripleHits| |$macroIfTrue| - |$packagesUsed|)) - (setq |$tripleCache| nil) - (setq |$tripleHits| 0) - (setq |$macroIfTrue| nil) - (setq |$packagesUsed| nil) - (|compDefine1| form mode env))) + (setf (get 'category 'special) '|compCategory|)) \end{chunk} -\defun{compDefine1}{compDefine1} -\calls{compDefine1}{macroExpand} -\calls{compDefine1}{isMacro} -\calls{compDefine1}{getSignatureFromMode} -\calls{compDefine1}{compDefine1} -\calls{compDefine1}{compInternalFunction} -\calls{compDefine1}{compDefineAddSignature} -\calls{compDefine1}{compDefWhereClause} -\calls{compDefine1}{compDefineCategory} -\calls{compDefine1}{isDomainForm} -\calls{compDefine1}{getTargetFromRhs} -\calls{compDefine1}{giveFormalParametersValues} -\calls{compDefine1}{addEmptyCapsuleIfNecessary} -\calls{compDefine1}{compDefineFunctor} -\calls{compDefine1}{stackAndThrow} -\calls{compDefine1}{strconc} -\calls{compDefine1}{getAbbreviation} -\calls{compDefine1}{length} -\calls{compDefine1}{compDefineCapsuleFunction} -\usesdollar{compDefine1}{insideExpressionIfTrue} -\usesdollar{compDefine1}{formalArgList} -\usesdollar{compDefine1}{form} -\usesdollar{compDefine1}{op} -\usesdollar{compDefine1}{prefix} -\usesdollar{compDefine1}{insideFunctorIfTrue} -\usesdollar{compDefine1}{Category} -\usesdollar{compDefine1}{insideCategoryIfTrue} -\usesdollar{compDefine1}{insideCapsuleFunctionIfTrue} -\usesdollar{compDefine1}{ConstructorNames} -\usesdollar{compDefine1}{NoValueMode} -\usesdollar{compDefine1}{EmptyMode} -\usesdollar{compDefine1}{insideWhereIfTrue} -\usesdollar{compDefine1}{insideExpressionIfTrue} -\begin{chunk}{defun compDefine1} -(defun |compDefine1| (form mode env) - (let (|$insideExpressionIfTrue| lhs specialCases sig signature rhs newPrefix - (tmp1 t)) - (declare (special |$insideExpressionIfTrue| |$formalArgList| |$form| - |$op| |$prefix| |$insideFunctorIfTrue| |$Category| - |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| - |$ConstructorNames| |$NoValueMode| |$EmptyMode| - |$insideWhereIfTrue| |$insideExpressionIfTrue|)) - (setq |$insideExpressionIfTrue| nil) - (setq form (|macroExpand| form env)) - (setq lhs (second form)) - (setq signature (third form)) - (setq specialCases (fourth form)) - (setq rhs (fifth form)) +\defun{compCategory}{compCategory} +\calls{compCategory}{resolve} +\calls{compCategory}{compCategoryItem} +\calls{compCategory}{mkExplicitCategoryFunction} +\calls{compCategory}{systemErrorHere} +\defsdollar{compCategory}{sigList} +\defsdollar{compCategory}{atList} +\defsdollar{compCategory}{top-level} +\refsdollar{compCategory}{sigList} +\refsdollar{compCategory}{atList} +\begin{chunk}{defun compCategory} +(defun |compCategory| (form mode env) + (let ($top_level |$sigList| |$atList| domainOrPackage z rep) + (declare (special $top_level |$sigList| |$atList|)) + (setq $top_level t) (cond - ((and |$insideWhereIfTrue| - (|isMacro| form env) - (or (equal mode |$EmptyMode|) (equal mode |$NoValueMode|))) - (list lhs mode (|put| (car lhs) '|macro| rhs env))) - ((and (null (car signature)) (consp rhs) - (null (member (qfirst rhs) |$ConstructorNames|)) - (setq sig (|getSignatureFromMode| lhs env))) - (|compDefine1| - (list 'def lhs (cons (car sig) (cdr signature)) specialCases rhs) - mode env)) - (|$insideCapsuleFunctionIfTrue| (|compInternalFunction| form mode env)) - (t - (when (equal (car signature) |$Category|) (setq |$insideCategoryIfTrue| t)) - (setq env (|compDefineAddSignature| lhs signature env)) - (cond - ((null (dolist (x (rest signature) tmp1) (setq tmp1 (and tmp1 (null x))))) - (|compDefWhereClause| form mode env)) - ((equal (car signature) |$Category|) - (|compDefineCategory| form mode env nil |$formalArgList|)) - ((and (|isDomainForm| rhs env) (null |$insideFunctorIfTrue|)) - (when (null (car signature)) - (setq signature - (cons (|getTargetFromRhs| lhs rhs - (|giveFormalParametersValues| (cdr lhs) env)) - (cdr signature)))) - (setq rhs (|addEmptyCapsuleIfNecessary| (car signature) rhs)) - (|compDefineFunctor| - (list 'def lhs signature specialCases rhs) - mode env NIL |$formalArgList|)) - ((null |$form|) - (|stackAndThrow| (list "bad == form " form))) - (t - (setq newPrefix - (if |$prefix| - (intern (strconc (|encodeItem| |$prefix|) "," (|encodeItem| |$op|))) - (|getAbbreviation| |$op| (|#| (cdr |$form|))))) - (|compDefineCapsuleFunction| - form mode env newPrefix |$formalArgList|))))))) + ((and + (equal (setq mode (|resolve| mode (list '|Category|))) + (list '|Category|)) + (consp form) + (eq (qfirst form) 'category) + (consp (qrest form))) + (setq domainOrPackage (second form)) + (setq z (qcddr form)) + (setq |$sigList| nil) + (setq |$atList| nil) + (dolist (x z) (|compCategoryItem| x nil)) + (setq rep + (|mkExplicitCategoryFunction| domainOrPackage |$sigList| |$atList|)) + (list rep mode env)) + (t + (|systemErrorHere| "compCategory"))))) \end{chunk} -\defun{getAbbreviation}{getAbbreviation} -\calls{getAbbreviation}{constructor?} -\calls{getAbbreviation}{assq} -\calls{getAbbreviation}{mkAbbrev} -\calls{getAbbreviation}{rplac} -\refsdollar{getAbbreviation}{abbreviationTable} -\defsdollar{getAbbreviation}{abbreviationTable} -\begin{chunk}{defun getAbbreviation} -(defun |getAbbreviation| (name c) - (let (cname x n upc newAbbreviation) - (declare (special |$abbreviationTable|)) - (setq cname (|constructor?| name)) - (cond - ((setq x (assq cname |$abbreviationTable|)) - (cond - ((setq n (assq name (cdr x))) +\defun{compCategoryItem}{compCategoryItem} +\calls{compCategoryItem}{compCategoryItem} +\calls{compCategoryItem}{mkpf} +\refsdollar{compCategoryItem}{sigList} +\refsdollar{compCategoryItem}{atList} +\begin{chunk}{defun compCategoryItem} +(defun |compCategoryItem| (x predl) + (let (p e a b c predlp pred y z op sig) + (declare (special |$sigList| |$atList|)) + (cond + ((null x) nil) +; 1. if x is a conditional expression, recurse; otherwise, form the predicate + ((and (consp x) (eq (qfirst x) 'cond) + (consp (qrest x)) (eq (qcddr x) nil) + (consp (qsecond x)) + (consp (qcdadr x)) + (eq (qcddadr x) nil)) + (setq p (qcaadr x)) + (setq e (qcadadr x)) + (setq predlp (cons p predl)) + (cond + ((and (consp e) (eq (qfirst e) 'progn)) + (setq z (qrest e)) + (dolist (y z) (|compCategoryItem| y predlp))) + (t (|compCategoryItem| e predlp)))) + ((and (consp x) (eq (qfirst x) 'if) (consp (qrest x)) + (consp (qcddr x)) (consp (qcdddr x)) + (eq (qcddddr x) nil)) + (setq a (qsecond x)) + (setq b (qthird x)) + (setq c (qfourth x)) + (setq predlp (cons a predl)) + (unless (eq b '|noBranch|) (cond - ((setq upc (assq c (cdr n))) - (cdr upc)) - (t - (setq newAbbreviation (|mkAbbrev| x cname)) - (rplac (cdr n) (cons (cons c newAbbreviation) (cdr n))) - newAbbreviation))) + ((and (consp b) (eq (qfirst b) 'progn)) + (setq z (qrest b)) + (dolist (y z) (|compCategoryItem| y predlp))) + (t (|compCategoryItem| b predlp)))) + (cond + ((eq c '|noBranch|) nil) + (t + (setq predlp (cons (list '|not| a) predl)) + (cond + ((and (consp c) (eq (qfirst c) 'progn)) + (setq z (qrest c)) + (dolist (y z) (|compCategoryItem| y predlp))) + (t (|compCategoryItem| c predlp)))))) + (t + (setq pred (if predl (mkpf predl 'and) t)) + (cond +; 2. if attribute, push it and return + ((and (consp x) (eq (qfirst x) 'attribute) + (consp (qrest x)) (eq (qcddr x) nil)) + (setq y (qsecond x)) + (push (mkq (list y pred)) |$atList|)) +; 3. it may be a list, with PROGN as the CAR, and some information as the CDR + ((and (consp x) (eq (qfirst x) 'progn)) + (setq z (qrest x)) + (dolist (u z) (|compCategoryItem| u predl))) (t - (setq newAbbreviation (|mkAbbrev| x x)) - (rplac (cdr x) - (cons (cons name (list (cons c newAbbreviation))) (cdr x))) - newAbbreviation))) - (t - (setq |$abbreviationTable| - (cons (list cname (list name (cons c cname))) |$abbreviationTable|)) - cname)))) +; 4. otherwise, x gives a signature for a single operator name or a list of +; names; if a list of names, recurse + (cond ((eq (car x) 'signature) (car x))) + (setq op (cadr x)) + (setq sig (cddr x)) + (cond + ((null (atom op)) + (dolist (y op) + (|compCategoryItem| (cons 'signature (cons y sig)) predl))) + (t +; 5. branch on a single type or a signature %with source and target + (push (mkq (list (cdr x) pred)) |$sigList|))))))))) \end{chunk} -\defun{mkAbbrev}{mkAbbrev} -\calls{mkAbbrev}{addSuffix} -\calls{mkAbbrev}{alistSize} -\begin{chunk}{defun mkAbbrev} -(defun |mkAbbrev| (x z) - (|addSuffix| (|alistSize| (cdr x)) z)) +\defun{mkExplicitCategoryFunction}{mkExplicitCategoryFunction} +\calls{mkExplicitCategoryFunction}{mkq} +\calls{mkExplicitCategoryFunction}{union} +\calls{mkExplicitCategoryFunction}{mustInstantiate} +\calls{mkExplicitCategoryFunction}{remdup} +\calls{mkExplicitCategoryFunction}{identp} +\calls{mkExplicitCategoryFunction}{wrapDomainSub} +\begin{chunk}{defun mkExplicitCategoryFunction} +(defun |mkExplicitCategoryFunction| (domainOrPackage sigList atList) + (let (body sig parameters) + (setq body + (list '|mkCategory| (mkq domainOrPackage) + (cons 'list (reverse sigList)) + (cons 'list (reverse atList)) + (mkq + (let (result) + (loop for item in sigList + do + (setq sig (car (cdaadr item))) + (setq result + (|union| result + (loop for d in sig + when (|mustInstantiate| d) + collect d)))) + result)) + nil)) + (setq parameters + (remdup + (let (result) + (loop for item in sigList + do + (setq sig (car (cdaadr item))) + (setq result + (append result + (loop for x in sig + when (and (identp x) (not (eq x '$))) + collect x)))) + result))) + (|wrapDomainSub| parameters body))) \end{chunk} -\defun{addSuffix}{addSuffix} -\begin{chunk}{defun addSuffix} -(defun |addSuffix| (n u) - (let (s) - (if (alpha-char-p (elt (spadlet s (stringimage u)) (maxindex s))) - (intern (strconc s (stringimage n))) - (internl (strconc s (stringimage '|;|) (stringimage n)))))) +\defun{mustInstantiate}{mustInstantiate} +\calls{mustInstantiate}{getl} +\refsdollar{mustInstantiate}{DummyFunctorNames} +\begin{chunk}{defun mustInstantiate} +(defun |mustInstantiate| (d) + (declare (special |$DummyFunctorNames|)) + (and (consp d) + (null (or (member (qfirst d) |$DummyFunctorNames|) + (getl (qfirst d) '|makeFunctionList|))))) \end{chunk} -\defun{alistSize}{alistSize} -\begin{chunk}{defun alistSize} -(defun |alistSize| (c) - (labels ( - (count (x level) - (cond - ((eql level 2) (|#| x)) - ((null x) 0) - (+ (count (cdar x) (1+ level)) - (count (cdr x) level))))) - (count c 1))) +\defun{wrapDomainSub}{wrapDomainSub} +\begin{chunk}{defun wrapDomainSub} +(defun |wrapDomainSub| (parameters x) + (list '|DomainSubstitutionMacro| parameters x)) \end{chunk} -\defun{getSignatureFromMode}{getSignatureFromMode} -\calls{getSignatureFromMode}{getmode} -\calls{getSignatureFromMode}{opOf} -\calls{getSignatureFromMode}{qcar} -\calls{getSignatureFromMode}{qcdr} -\calls{getSignatureFromMode}{length} -\calls{getSignatureFromMode}{stackAndThrow} -\calls{getSignatureFromMode}{eqsubstlist} -\calls{getSignatureFromMode}{take} -\refsdollar{getSignatureFromMode}{FormalMapVariableList} -\begin{chunk}{defun getSignatureFromMode} -(defun |getSignatureFromMode| (form env) - (let (tmp1 signature) - (declare (special |$FormalMapVariableList|)) - (setq tmp1 (|getmode| (|opOf| form) env)) - (when (and (consp tmp1) (eq (qfirst tmp1) '|Mapping|)) - (setq signature (qrest tmp1)) - (if (not (eql (|#| form) (|#| signature))) - (|stackAndThrow| (list '|Wrong number of arguments: | form)) - (eqsubstlist (cdr form) - (take (|#| (cdr form)) |$FormalMapVariableList|) - signature))))) +\defplist{:}{compColon plist} +We set up the {\tt compColon} function to handle the \verb|:| keyword +by setting the {\tt special} keyword on the \verb|:| symbol property list. +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '|:| 'special) '|compColon|)) \end{chunk} -\defun{compInternalFunction}{compInternalFunction} -\calls{compInternalFunction}{identp} -\calls{compInternalFunction}{stackAndThrow} -\begin{chunk}{defun compInternalFunction} -(defun |compInternalFunction| (df m env) - (let (form signature specialCases body op argl nbody nf ress) - (setq form (second df)) - (setq signature (third df)) - (setq specialCases (fourth df)) - (setq body (fifth df)) - (setq op (first form)) - (setq argl (rest form)) - (cond - ((null (identp op)) - (|stackAndThrow| (list '|Bad name for internal function:| op))) - ((eql (|#| argl) 0) - (|stackAndThrow| - (list '|Argumentless internal functions unsupported:| op ))) - (t - (setq nbody (list '+-> argl body)) - (setq nf (list 'let (list '|:| op (cons '|Mapping| signature)) nbody)) - (setq ress (|comp| nf m env)) ress)))) +\defun{compColon}{compColon} +\calls{compColon}{compColonInside} +\calls{compColon}{assoc} +\calls{compColon}{getDomainsInScope} +\calls{compColon}{isDomainForm} +\seebook{compColon}{member}{5} +\calls{compColon}{addDomain} +\calls{compColon}{isCategoryForm} +\calls{compColon}{unknownTypeError} +\calls{compColon}{compColon} +\calls{compColon}{eqsubstlist} +\calls{compColon}{take} +\calls{compColon}{length} +\calls{compColon}{nreverse0} +\calls{compColon}{getmode} +\calls{compColon}{systemErrorHere} +\calls{compColon}{put} +\calls{compColon}{makeCategoryForm} +\calls{compColon}{genSomeVariable} +\usesdollar{compColon}{lhsOfColon} +\usesdollar{compColon}{noEnv} +\usesdollar{compColon}{insideFunctorIfTrue} +\usesdollar{compColon}{bootStrapMode} +\usesdollar{compColon}{FormalMapVariableList} +\usesdollar{compColon}{insideCategoryIfTrue} +\usesdollar{compColon}{insideExpressionIfTrue} +\begin{chunk}{defun compColon} +(defun |compColon| (form mode env) + (let (|$lhsOfColon| argf argt tprime mprime r td op argl newTarget a + signature tmp2 catform tmp3 g2 g5) + (declare (special |$lhsOfColon| |$noEnv| |$insideFunctorIfTrue| + |$bootStrapMode| |$FormalMapVariableList| + |$insideCategoryIfTrue| |$insideExpressionIfTrue|)) + (setq argf (second form)) + (setq argt (third form)) + (if |$insideExpressionIfTrue| + (|compColonInside| argf mode env argt) + (progn + (setq |$lhsOfColon| argf) + (setq argt + (cond + ((and (atom argt) + (setq tprime (|assoc| argt (|getDomainsInScope| env)))) + tprime) + ((and (|isDomainForm| argt env) (null |$insideCategoryIfTrue|)) + (unless (|member| argt (|getDomainsInScope| env)) + (setq env (|addDomain| argt env))) + argt) + ((or (|isDomainForm| argt env) (|isCategoryForm| argt env)) + argt) + ((and (consp argt) (eq (qfirst argt) '|Mapping|) + (progn + (setq tmp2 (qrest argt)) + (and (consp tmp2) + (progn + (setq mprime (qfirst tmp2)) + (setq r (qrest tmp2)) + t)))) + argt) + (t + (|unknownTypeError| argt) + argt))) + (cond + ((eq (car argf) 'listof) + (dolist (x (cdr argf) td) + (setq td (|compColon| (list '|:| x argt) mode env)) + (setq env (third td)))) + (t + (setq env + (cond + ((and (consp argf) + (progn + (setq op (qfirst argf)) + (setq argl (qrest argf)) + t) + (null (and (consp argt) (eq (qfirst argt) '|Mapping|)))) + (setq newTarget + (eqsubstlist (take (|#| argl) |$FormalMapVariableList|) + (dolist (x argl (nreverse0 g2)) + (setq g2 + (cons + (cond + ((and (consp x) (eq (qfirst x) '|:|) + (progn + (setq tmp2 (qrest x)) + (and (consp tmp2) + (progn + (setq a (qfirst tmp2)) + (setq tmp3 (qrest tmp2)) + (and (consp tmp3) + (eq (qrest tmp3) nil) + (progn + (setq mode (qfirst tmp3)) + t)))))) + a) + (t x)) + g2))) + argt)) + (setq signature + (cons '|Mapping| + (cons newTarget + (dolist (x argl (nreverse0 g5)) + (setq g5 + (cons + (cond + ((and (consp x) (eq (qfirst x) '|:|) + (progn + (setq tmp2 (qrest x)) + (and (consp tmp2) + (progn + (setq a (qfirst tmp2)) + (setq tmp3 (qrest tmp2)) + (and (consp tmp3) + (eq (qrest tmp3) nil) + (progn + (setq mode (qfirst tmp3)) + t)))))) + mode) + (t + (or (|getmode| x env) + (|systemErrorHere| "compColonOld")))) + g5)))))) + (|put| op '|mode| signature env)) + (t (|put| argf '|mode| argt env)))) + (cond + ((and (null |$bootStrapMode|) |$insideFunctorIfTrue| + (progn + (setq tmp2 (|makeCategoryForm| argt env)) + (and (consp tmp2) + (progn + (setq catform (qfirst tmp2)) + (setq tmp3 (qrest tmp2)) + (and (consp tmp3) + (eq (qrest tmp3) nil) + (progn + (setq env (qfirst tmp3)) + t)))))) + (setq env + (|put| argf '|value| (list (|genSomeVariable|) argt |$noEnv|) + env)))) + (list '|/throwAway| (|getmode| argf env) env ))))))) \end{chunk} -\defun{compDefineCapsuleFunction}{compDefineCapsuleFunction} -\calls{compDefineCapsuleFunction}{length} -\calls{compDefineCapsuleFunction}{get} -\calls{compDefineCapsuleFunction}{profileRecord} -\calls{compDefineCapsuleFunction}{compArgumentConditions} -\calls{compDefineCapsuleFunction}{addDomain} -\calls{compDefineCapsuleFunction}{giveFormalParametersValues} -\calls{compDefineCapsuleFunction}{getSignature} -\calls{compDefineCapsuleFunction}{put} -\calls{compDefineCapsuleFunction}{stripOffSubdomainConditions} -\calls{compDefineCapsuleFunction}{getArgumentModeOrMoan} -\calls{compDefineCapsuleFunction}{checkAndDeclare} -\calls{compDefineCapsuleFunction}{hasSigInTargetCategory} -\calls{compDefineCapsuleFunction}{stripOffArgumentConditions} -\calls{compDefineCapsuleFunction}{resolve} -\calls{compDefineCapsuleFunction}{member} -\calls{compDefineCapsuleFunction}{getmode} -\calls{compDefineCapsuleFunction}{formatUnabbreviated} -\calls{compDefineCapsuleFunction}{sayBrightly} -\calls{compDefineCapsuleFunction}{compOrCroak} -\calls{compDefineCapsuleFunction}{NRTassignCapsuleFunctionSlot} -\calls{compDefineCapsuleFunction}{mkq} -\calls{compDefineCapsuleFunction}{replaceExitEtc} -\calls{compDefineCapsuleFunction}{addArgumentConditions} -\calls{compDefineCapsuleFunction}{compileCases} -\calls{compDefineCapsuleFunction}{addStats} -\refsdollar{compDefineCapsuleFunction}{semanticErrorStack} -\refsdollar{compDefineCapsuleFunction}{DomainsInScope} -\refsdollar{compDefineCapsuleFunction}{op} -\refsdollar{compDefineCapsuleFunction}{formalArgList} -\refsdollar{compDefineCapsuleFunction}{signatureOfForm} -\refsdollar{compDefineCapsuleFunction}{functionLocations} -\refsdollar{compDefineCapsuleFunction}{profileCompiler} -\refsdollar{compDefineCapsuleFunction}{compileOnlyCertainItems} -\refsdollar{compDefineCapsuleFunction}{returnMode} -\refsdollar{compDefineCapsuleFunction}{functorStats} -\refsdollar{compDefineCapsuleFunction}{functionStats} -\defsdollar{compDefineCapsuleFunction}{form} -\defsdollar{compDefineCapsuleFunction}{functionStats} -\defsdollar{compDefineCapsuleFunction}{argumentConditionList} -\defsdollar{compDefineCapsuleFunction}{finalEnv} -\defsdollar{compDefineCapsuleFunction}{initCapsuleErrorCount} -\defsdollar{compDefineCapsuleFunction}{insideCapsuleFunctionIfTrue} -\defsdollar{compDefineCapsuleFunction}{CapsuleModemapFrame} -\defsdollar{compDefineCapsuleFunction}{CapsuleDomainsInScope} -\defsdollar{compDefineCapsuleFunction}{insideExpressionIfTrue} -\defsdollar{compDefineCapsuleFunction}{returnMode} -\defsdollar{compDefineCapsuleFunction}{op} -\defsdollar{compDefineCapsuleFunction}{formalArgList} -\defsdollar{compDefineCapsuleFunction}{signatureOfForm} -\defsdollar{compDefineCapsuleFunction}{functionLocations} -\begin{chunk}{defun compDefineCapsuleFunction} -(defun |compDefineCapsuleFunction| (df m oldE |$prefix| |$formalArgList|) - (declare (special |$prefix| |$formalArgList|)) - (let (|$form| |$op| |$functionStats| |$argumentConditionList| |$finalEnv| - |$initCapsuleErrorCount| |$insideCapsuleFunctionIfTrue| - |$CapsuleModemapFrame| |$CapsuleDomainsInScope| - |$insideExpressionIfTrue| form signature body tmp1 lineNumber - specialCases argl identSig argModeList signaturep e rettype tmp2 - localOrExported formattedSig tt catchTag bodyp finalBody fun val) - (declare (special |$form| |$op| |$functionStats| |$functorStats| - |$argumentConditionList| |$finalEnv| |$returnMode| - |$initCapsuleErrorCount| |$newCompCompare| |$NoValueMode| - |$insideCapsuleFunctionIfTrue| - |$CapsuleModemapFrame| |$CapsuleDomainsInScope| - |$insideExpressionIfTrue| |$compileOnlyCertainItems| - |$profileCompiler| |$functionLocations| |$finalEnv| - |$signatureOfForm| |$semanticErrorStack|)) - (setq form (second df)) - (setq signature (third df)) - (setq specialCases (fourth df)) - (setq body (fifth df)) - (setq tmp1 specialCases) - (setq lineNumber (first tmp1)) - (setq specialCases (rest tmp1)) - (setq e oldE) -;-1. bind global variables - (setq |$form| nil) - (setq |$op| nil) - (setq |$functionStats| (list 0 0)) - (setq |$argumentConditionList| nil) - (setq |$finalEnv| nil) -; used by ReplaceExitEtc to get a common environment - (setq |$initCapsuleErrorCount| (|#| |$semanticErrorStack|)) - (setq |$insideCapsuleFunctionIfTrue| t) - (setq |$CapsuleModemapFrame| e) - (setq |$CapsuleDomainsInScope| (|get| '|$DomainsInScope| 'special e)) - (setq |$insideExpressionIfTrue| t) - (setq |$returnMode| m) - (setq |$op| (first form)) - (setq argl (rest form)) - (setq |$form| (cons |$op| argl)) - (setq argl (|stripOffArgumentConditions| argl)) - (setq |$formalArgList| (append argl |$formalArgList|)) -; let target and local signatures help determine modes of arguments - (setq argModeList - (cond - ((setq identSig (|hasSigInTargetCategory| argl form (car signature) e)) - (setq e (|checkAndDeclare| argl form identSig e)) - (cdr identSig)) - (t - (loop for a in argl - collect (|getArgumentModeOrMoan| a form e))))) - (setq argModeList (|stripOffSubdomainConditions| argModeList argl)) - (setq signaturep (cons (car signature) argModeList)) - (unless identSig - (setq oldE (|put| |$op| '|mode| (cons '|Mapping| signaturep) oldE))) -; obtain target type if not given - (cond - ((null (car signaturep)) - (setq signaturep - (cond - (identSig identSig) - (t (|getSignature| |$op| (cdr signaturep) e)))))) - (when signaturep - (setq e (|giveFormalParametersValues| argl e)) - (setq |$signatureOfForm| signaturep) - (setq |$functionLocations| - (cons (cons (list |$op| |$signatureOfForm|) lineNumber) - |$functionLocations|)) - (setq e (|addDomain| (car signaturep) e)) - (setq e (|compArgumentConditions| e)) - (when |$profileCompiler| - (loop for x in argl for y in signaturep - do (|profileRecord| '|arguments| x y))) -; 4. introduce needed domains into extendedEnv - (loop for domain in signaturep - do (setq e (|addDomain| domain e))) -; 6. compile body in environment with extended environment - (setq rettype (|resolve| (car signaturep) |$returnMode|)) - (setq localOrExported - (cond - ((and (null (|member| |$op| |$formalArgList|)) - (progn - (setq tmp2 (|getmode| |$op| e)) - (and (consp tmp2) (eq (qfirst tmp2) '|Mapping|)))) - '|local|) - (t '|exported|))) -; 6a skip if compiling only certain items but not this one -; could be moved closer to the top - (setq formattedSig (|formatUnabbreviated| (cons '|Mapping| signaturep))) +\defun{makeCategoryForm}{makeCategoryForm} +\calls{makeCategoryForm}{isCategoryForm} +\calls{makeCategoryForm}{compOrCroak} +\refsdollar{makeCategoryForm}{EmptyMode} +\begin{chunk}{defun makeCategoryForm} +(defun |makeCategoryForm| (c env) + (let (tmp1) + (declare (special |$EmptyMode|)) + (when (|isCategoryForm| c env) + (setq tmp1 (|compOrCroak| c |$EmptyMode| env)) + (list (first tmp1) (third tmp1))))) + +\end{chunk} + +\defplist{cons}{compCons plist} +We set up the {\tt compCons} function to handle the {\tt cons} keyword +by setting the {\tt special} keyword on the {\tt cons} symbol property list. +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'cons 'special) '|compCons|)) + +\end{chunk} + +\defun{compCons}{compCons} +\calls{compCons}{compCons1} +\calls{compCons}{compForm} +\begin{chunk}{defun compCons} +(defun |compCons| (form mode env) + (or (|compCons1| form mode env) (|compForm| form mode env))) + +\end{chunk} + +\defun{compCons1}{compCons1} +\calls{compCons1}{comp} +\calls{compCons1}{convert} +\usesdollar{compCons1}{EmptyMode} +\begin{chunk}{defun compCons1} +(defun |compCons1| (arg mode env) + (let (mx y my yt mp mr ytp tmp1 x td) + (declare (special |$EmptyMode|)) + (setq x (second arg)) + (setq y (third arg)) + (when (setq tmp1 (|comp| x |$EmptyMode| env)) + (setq x (first tmp1)) + (setq mx (second tmp1)) + (setq env (third tmp1)) (cond - ((and |$compileOnlyCertainItems| - (null (|member| |$op| |$compileOnlyCertainItems|))) - (|sayBrightly| - (cons " skipping " (cons localOrExported (|bright| |$op|)))) - (list nil (cons '|Mapping| signaturep) oldE)) + ((null y) + (|convert| (list (list 'list x) (list '|List| mx) env ) mode)) (t - (|sayBrightly| - (cons " compiling " (cons localOrExported (append (|bright| |$op|) - (cons ": " formattedSig))))) - (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 - (setq catchTag (mkq (gensym))) - (setq fun - (progn - (setq bodyp - (|replaceExitEtc| (car tt) catchTag '|TAGGEDreturn| |$returnMode|)) - (setq bodyp (|addArgumentConditions| bodyp |$op|)) - (setq finalBody (list 'catch catchTag bodyp)) - (|compileCases| - (list |$op| (list 'lam (append argl (list '$)) finalBody)) - oldE))) - (setq |$functorStats| (|addStats| |$functorStats| |$functionStats|)) -; 7. give operator a 'value property - (setq val (list fun signaturep e)) - (list fun (list '|Mapping| signaturep) oldE)))))) + (when (setq yt (|comp| y |$EmptyMode| env)) + (setq y (first yt)) + (setq my (second yt)) + (setq env (third yt)) + (setq td + (cond + ((and (consp my) (eq (qfirst my) '|List|) (consp (qrest my))) + (setq mp (second my)) + (when (setq mr (list '|List| (|resolve| mp mx))) + (when (setq ytp (|convert| yt mr)) + (when (setq tmp1 (|convert| (list x mx (third ytp)) (second mr))) + (setq x (first tmp1)) + (setq env (third tmp1)) + (cond + ((and (consp (car ytp)) (eq (qfirst (car ytp)) 'list)) + (list (cons 'list (cons x (cdr (car ytp)))) mr env)) + (t + (list (list 'cons x (car ytp)) mr env))))))) + (t + (list (list 'cons x y) (list '|Pair| mx my) env )))) + (|convert| td mode))))))) \end{chunk} -\defun{compileCases}{compileCases} -\calls{compileCases}{eval} -\calls{compileCases}{qcar} -\calls{compileCases}{qcdr} -\calls{compileCases}{compile} -\calls{compileCases}{getSpecialCaseAssoc} -\calls{compileCases}{get} -\calls{compileCases}{assocleft} -\calls{compileCases}{outerProduct} -\calls{compileCases}{assocright} -\calls{compileCases}{mkpf} -\refsdollar{compileCases}{getDomainCode} -\refsdollar{compileCases}{insideFunctorIfTrue} -\defsdollar{compileCases}{specialCaseKeyList} -\begin{chunk}{defun compileCases} -(defun |compileCases| (x |$e|) - (declare (special |$e|)) - (labels ( - (isEltArgumentIn (Rlist x) - (cond - ((atom x) nil) - ((and (consp x) (eq (qfirst x) 'elt) (consp (qrest x)) - (consp (qcddr x)) (eq (qcdddr x) nil)) - (or (member (second x) Rlist) - (isEltArgumentIn Rlist (cdr x)))) - ((and (consp x) (eq (qfirst x) 'qrefelt) (consp (qrest x)) - (consp (qcddr x)) (eq (qcdddr x) nil)) - (or (member (second x) Rlist) - (isEltArgumentIn Rlist (cdr x)))) - (t - (or (isEltArgumentIn Rlist (car x)) - (isEltArgumentIn Rlist (CDR x)))))) - (FindNamesFor (r rp) - (let (v u) - (declare (special |$getDomainCode|)) - (cons r - (loop for item in |$getDomainCode| - do - (setq v (second item)) - (setq u (third item)) - when (and (equal (second u) r) (|eval| (subst rp r u :test #'equal))) - collect v))))) - (let (|$specialCaseKeyList| specialCaseAssoc listOfDomains listOfAllCases cl) - (declare (special |$specialCaseKeyList| |$true| |$insideFunctorIfTrue|)) - (setq |$specialCaseKeyList| nil) +\defplist{construct}{compConstruct plist} +We set up the {\tt compConstruct} function to handle the {\tt construct} +keyword by setting the {\tt special} keyword on the {\tt construct} +symbol property list. +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '|construct| 'special) '|compConstruct|)) + +\end{chunk} + +\defun{compConstruct}{compConstruct} +\calls{compConstruct}{modeIsAggregateOf} +\calls{compConstruct}{compList} +\calls{compConstruct}{convert} +\calls{compConstruct}{compForm} +\calls{compConstruct}{compVector} +\calls{compConstruct}{getDomainsInScope} +\begin{chunk}{defun compConstruct} +(defun |compConstruct| (form mode env) + (let (z y td tp) + (setq z (cdr form)) (cond - ((null (eq |$insideFunctorIfTrue| t)) (|compile| x)) + ((setq y (|modeIsAggregateOf| '|List| mode env)) + (if (setq td (|compList| z (list '|List| (cadr y)) env)) + (|convert| td mode) + (|compForm| form mode env))) + ((setq y (|modeIsAggregateOf| '|Vector| mode env)) + (if (setq td (|compVector| z (list '|Vector| (cadr y)) env)) + (|convert| td mode) + (|compForm| form mode env))) + ((setq td (|compForm| form mode env)) td) (t - (setq specialCaseAssoc - (loop for y in (|getSpecialCaseAssoc|) - when (and (null (|get| (first y) '|specialCase| |$e|)) - (isEltArgumentIn (FindNamesFor (first y) (second y)) x)) - collect y)) + (dolist (d (|getDomainsInScope| env)) + (cond + ((and (setq y (|modeIsAggregateOf| '|List| d env)) + (setq td (|compList| z (list '|List| (cadr y)) env)) + (setq tp (|convert| td mode))) + (return tp)) + ((and (setq y (|modeIsAggregateOf| '|Vector| d env)) + (setq td (|compVector| z (list '|Vector| (cadr y)) env)) + (setq tp (|convert| td mode))) + (return tp)))))))) + +\end{chunk} + +\defplist{ListCategory}{compConstructorCategory plist} +We set up the {\tt compConstructorCategory} function to handle the +{\tt ListCategory} keyword by setting the {\tt special} keyword on the +{\tt ListCategory} symbol property list. +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '|ListCategory| 'special) '|compConstructorCategory|)) + +\end{chunk} + +\defplist{RecordCategory}{compConstructorCategory plist} +We set up the +{\tt compConstructorCategory} function to handle the +{\tt RecordCategory} keyword by setting the {\tt special} keyword on the +{\tt RecordCategory} symbol property list. +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '|RecordCategory| 'special) '|compConstructorCategory|)) + +\end{chunk} + +\defplist{UnionCategory}{compConstructorCategory plist} +We set up the +{\tt compConstructorCategory} function to handle the +{\tt UnionCategory} keyword by setting the {\tt special} keyword on the +{\tt UnionCategory} symbol property list. +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '|UnionCategory| 'special) '|compConstructorCategory|)) + +\end{chunk} + +\defplist{VectorCategory}{compConstructorCategory plist} +We set up the +{\tt compConstructorCategory} function to handle the +{\tt VectorCategory} keyword by setting the {\tt special} keyword on the +{\tt VectorCategory} symbol property list. +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get '|VectorCategory| 'special) '|compConstructorCategory|)) + +\end{chunk} + +\defun{compConstructorCategory}{compConstructorCategory} +\calls{compConstructorCategory}{resolve} +\usesdollar{compConstructorCategory}{Category} +\begin{chunk}{defun compConstructorCategory} +(defun |compConstructorCategory| (form mode env) + (declare (special |$Category|)) + (list form (|resolve| |$Category| mode) env)) + +\end{chunk} + +\defun{getAbbreviation}{getAbbreviation} +\calls{getAbbreviation}{constructor?} +\calls{getAbbreviation}{assq} +\calls{getAbbreviation}{mkAbbrev} +\calls{getAbbreviation}{rplac} +\refsdollar{getAbbreviation}{abbreviationTable} +\defsdollar{getAbbreviation}{abbreviationTable} +\begin{chunk}{defun getAbbreviation} +(defun |getAbbreviation| (name c) + (let (cname x n upc newAbbreviation) + (declare (special |$abbreviationTable|)) + (setq cname (|constructor?| name)) + (cond + ((setq x (assq cname |$abbreviationTable|)) + (cond + ((setq n (assq name (cdr x))) (cond - ((null specialCaseAssoc) (|compile| x)) + ((setq upc (assq c (cdr n))) + (cdr upc)) (t - (setq listOfDomains (assocleft specialCaseAssoc)) - (setq listOfAllCases (|outerProduct| (assocright specialCaseAssoc))) - (setq cl - (loop for z in listOfAllCases - collect - (progn - (setq |$specialCaseKeyList| - (loop for d in listOfDomains for c in z - collect (cons d c))) - (cons - (mkpf - (loop for d in listOfDomains for c in z - collect (list 'equal d c)) - 'and) - (list (|compile| (copy x))))))) - (setq |$specialCaseKeyList| nil) - (cons 'cond (append cl (list (list |$true| (|compile| x)))))))))))) + (setq newAbbreviation (|mkAbbrev| x cname)) + (rplac (cdr n) (cons (cons c newAbbreviation) (cdr n))) + newAbbreviation))) + (t + (setq newAbbreviation (|mkAbbrev| x x)) + (rplac (cdr x) + (cons (cons name (list (cons c newAbbreviation))) (cdr x))) + newAbbreviation))) + (t + (setq |$abbreviationTable| + (cons (list cname (list name (cons c cname))) |$abbreviationTable|)) + cname)))) + +\end{chunk} + +\defun{mkAbbrev}{mkAbbrev} +\calls{mkAbbrev}{addSuffix} +\calls{mkAbbrev}{alistSize} +\begin{chunk}{defun mkAbbrev} +(defun |mkAbbrev| (x z) + (|addSuffix| (|alistSize| (cdr x)) z)) + +\end{chunk} + +\defun{addSuffix}{addSuffix} +\begin{chunk}{defun addSuffix} +(defun |addSuffix| (n u) + (let (s) + (if (alpha-char-p (elt (spadlet s (stringimage u)) (maxindex s))) + (intern (strconc s (stringimage n))) + (internl (strconc s (stringimage '|;|) (stringimage n)))))) + +\end{chunk} + +\defun{alistSize}{alistSize} +\begin{chunk}{defun alistSize} +(defun |alistSize| (c) + (labels ( + (count (x level) + (cond + ((eql level 2) (|#| x)) + ((null x) 0) + (+ (count (cdar x) (1+ level)) + (count (cdr x) level))))) + (count c 1))) + +\end{chunk} + +\defun{getSignatureFromMode}{getSignatureFromMode} +\calls{getSignatureFromMode}{getmode} +\calls{getSignatureFromMode}{opOf} +\calls{getSignatureFromMode}{length} +\calls{getSignatureFromMode}{stackAndThrow} +\calls{getSignatureFromMode}{eqsubstlist} +\calls{getSignatureFromMode}{take} +\refsdollar{getSignatureFromMode}{FormalMapVariableList} +\begin{chunk}{defun getSignatureFromMode} +(defun |getSignatureFromMode| (form env) + (let (tmp1 signature) + (declare (special |$FormalMapVariableList|)) + (setq tmp1 (|getmode| (|opOf| form) env)) + (when (and (consp tmp1) (eq (qfirst tmp1) '|Mapping|)) + (setq signature (qrest tmp1)) + (if (not (eql (|#| form) (|#| signature))) + (|stackAndThrow| (list '|Wrong number of arguments: | form)) + (eqsubstlist (cdr form) + (take (|#| (cdr form)) |$FormalMapVariableList|) + signature))))) \end{chunk} @@ -12788,8 +12908,6 @@ An angry JHD - August 15th., 1984 \end{chunk} \defun{addArgumentConditions}{addArgumentConditions} -\calls{addArgumentConditions}{qcar} -\calls{addArgumentConditions}{qcdr} \calls{addArgumentConditions}{mkq} \calls{addArgumentConditions}{systemErrorHere} \refsdollar{addArgumentConditions}{true} @@ -12824,33 +12942,7 @@ An angry JHD - August 15th., 1984 \end{chunk} -\defun{compArgumentConditions}{compArgumentConditions} -\calls{compArgumentConditions}{compOrCroak} -\refsdollar{compArgumentConditions}{Boolean} -\refsdollar{compArgumentConditions}{argumentConditionList} -\defsdollar{compArgumentConditions}{argumentConditionList} -\begin{chunk}{defun compArgumentConditions} -(defun |compArgumentConditions| (env) - (let (n a x y tmp1) - (declare (special |$Boolean| |$argumentConditionList|)) - (setq |$argumentConditionList| - (loop for item in |$argumentConditionList| - do - (setq n (first item)) - (setq a (second item)) - (setq x (third item)) - (setq y (subst a '|#1| x :test #'equal)) - (setq tmp1 (|compOrCroak| y |$Boolean| env)) - (setq env (third tmp1)) - collect - (list n x (first tmp1)))) - env)) - -\end{chunk} - \defun{stripOffSubdomainConditions}{stripOffSubdomainConditions} -\calls{stripOffSubdomainConditions}{qcar} -\calls{stripOffSubdomainConditions}{qcdr} \calls{stripOffSubdomainConditions}{assoc} \calls{stripOffSubdomainConditions}{mkpf} \refsdollar{stripOffSubdomainConditions}{argumentConditionList} @@ -12878,8 +12970,6 @@ An angry JHD - August 15th., 1984 \end{chunk} \defun{stripOffArgumentConditions}{stripOffArgumentConditions} -\calls{stripOffArgumentConditions}{qcar} -\calls{stripOffArgumentConditions}{qcdr} \refsdollar{stripOffArgumentConditions}{argumentConditionList} \defsdollar{stripOffArgumentConditions}{argumentConditionList} \begin{chunk}{defun stripOffArgumentConditions} @@ -12909,8 +12999,6 @@ is still more than one complain else return the only signature. \calls{getSignature}{remdup} \calls{getSignature}{knownInfo} \calls{getSignature}{getmode} -\calls{getSignature}{qcar} -\calls{getSignature}{qcdr} \calls{getSignature}{say} \calls{getSignature}{printSignature} \calls{getSignature}{SourceLevelSubsume} @@ -13052,6 +13140,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{elt}{compElt plist} +We set up the +{\tt compElt} function to handle the +{\tt elt} keyword by setting the {\tt special} keyword on the +{\tt elt} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|elt| 'special) '|compElt|)) @@ -13120,6 +13212,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{exit}{compExit plist} +We set up the +{\tt compExit} function to handle the +{\tt exit} keyword by setting the {\tt special} keyword on the +{\tt exit} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|exit| 'special) '|compExit|)) @@ -13154,6 +13250,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{has}{compHas plist} +We set up the +{\tt compHas} function to handle the +{\tt has} keyword by setting the {\tt special} keyword on the +{\tt has} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|has| 'special) '|compHas|)) @@ -13184,8 +13284,6 @@ is still more than one complain else return the only signature. \calls{compHasFormat}{length} \calls{compHasFormat}{sublislis} \calls{compHasFormat}{comp} -\calls{compHasFormat}{qcar} -\calls{compHasFormat}{qcdr} \calls{compHasFormat}{mkList} \calls{compHasFormat}{mkDomainConstructor} \calls{compHasFormat}{isDomainForm} @@ -13236,6 +13334,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{if}{compIf plist} +We set up the +{\tt compIf} function to handle the +{\tt if} keyword by setting the {\tt special} keyword on the +{\tt if} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get 'if 'special) '|compIf|)) @@ -13297,8 +13399,6 @@ is still more than one complain else return the only signature. \defun{canReturn}{canReturn} \calls{canReturn}{say} -\calls{canReturn}{qcar} -\calls{canReturn}{qcdr} \calls{canReturn}{canReturn} \calls{canReturn}{systemErrorHere} \begin{chunk}{defun canReturn} @@ -13414,8 +13514,6 @@ is still more than one complain else return the only signature. \end{chunk} \defun{getSuccessEnvironment}{getSuccessEnvironment} -\calls{getSuccessEnvironment}{qcar} -\calls{getSuccessEnvironment}{qcdr} \calls{getSuccessEnvironment}{isDomainForm} \calls{getSuccessEnvironment}{put} \calls{getSuccessEnvironment}{identp} @@ -13465,8 +13563,6 @@ is still more than one complain else return the only signature. \end{chunk} \defun{getInverseEnvironment}{getInverseEnvironment} -\calls{getInverseEnvironment}{qcar} -\calls{getInverseEnvironment}{qcdr} \calls{getInverseEnvironment}{identp} \calls{getInverseEnvironment}{isDomainForm} \calls{getInverseEnvironment}{put} @@ -13551,6 +13647,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{import}{compImport plist} +We set up the +{\tt compImport} function to handle the +{\tt import} keyword by setting the {\tt special} keyword on the +{\tt import} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|import| 'special) '|compImport|)) @@ -13570,6 +13670,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{is}{compIs plist} +We set up the +{\tt compIs} function to handle the +{\tt is} keyword by setting the {\tt special} keyword on the +{\tt is} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|is| 'special) '|compIs|)) @@ -13601,6 +13705,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{Join}{compJoin plist} +We set up the +{\tt compJoin} function to handle the +{\tt Join} keyword by setting the {\tt special} keyword on the +{\tt Join} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|Join| 'special) '|compJoin|)) @@ -13615,8 +13723,6 @@ is still more than one complain else return the only signature. \calls{compJoin}{isCategoryForm} \calls{compJoin}{union} \calls{compJoin}{compJoin,getParms} -\calls{compJoin}{qcar} -\calls{compJoin}{qcdr} \calls{compJoin}{wrapDomainSub} \calls{compJoin}{convert} \usesdollar{compJoin}{Category} @@ -13687,6 +13793,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{$+->$}{compLambda plist} +We set up the +{\tt compLambda} function to handle the +\verb|+->| keyword by setting the {\tt special} keyword on the +\verb|+->| symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|+->| 'special) '|compLambda|)) @@ -13694,8 +13804,6 @@ is still more than one complain else return the only signature. \end{chunk} \defun{compLambda}{compLambda} -\calls{compLambda}{qcar} -\calls{compLambda}{qcdr} \calls{compLambda}{argsToSig} \calls{compLambda}{compAtSign} \calls{compLambda}{stackAndThrow} @@ -13739,6 +13847,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{leave}{compLeave plist} +We set up the +{\tt compLeave} function to handle the +{\tt leave} keyword by setting the {\tt special} keyword on the +{\tt leave} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|leave| 'special) '|compLeave|)) @@ -13765,6 +13877,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{mdef}{compMacro plist} +We set up the +{\tt compMacro} function to handle the +{\tt MDEF} keyword by setting the {\tt special} keyword on the +{\tt MDEF} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get 'mdef 'special) '|compMacro|)) @@ -13772,7 +13888,6 @@ is still more than one complain else return the only signature. \end{chunk} \defun{compMacro}{compMacro} -\calls{compMacro}{qcar} \calls{compMacro}{formatUnabbreviated} \calls{compMacro}{sayBrightly} \calls{compMacro}{put} @@ -13813,6 +13928,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{pretend}{compPretend plist} +We set up the +{\tt compPretend} function to handle the +{\tt pretend} keyword by setting the {\tt special} keyword on the +{\tt pretend} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|pretend| 'special) '|compPretend|)) @@ -13853,6 +13972,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{quote}{compQuote plist} +We set up the +{\tt compQuote} function to handle the +{\tt QUOTE} keyword by setting the {\tt special} keyword on the +{\tt QUOTE} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get 'quote 'special) '|compQuote|)) @@ -13867,6 +13990,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{reduce}{compReduce plist} +We set up the +{\tt compReduce} function to handle the +{\tt REDUCE} keyword by setting the {\tt special} keyword on the +{\tt REDUCE} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get 'reduce 'special) '|compReduce|)) @@ -13968,6 +14095,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{collect}{compRepeatOrCollect plist} +We set up the +{\tt compRepeatOrCollect} function to handle the +{\tt COLLECT} keyword by setting the {\tt special} keyword on the +{\tt COLLECT} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get 'collect 'special) '|compRepeatOrCollect|)) @@ -13975,6 +14106,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{repeat}{compRepeatOrCollect plist} +We set up the +{\tt compRepeatOrCollect} function to handle the +{\tt REPEAT} keyword by setting the {\tt special} keyword on the +{\tt REPEAT} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get 'repeat 'special) '|compRepeatOrCollect|)) @@ -14073,6 +14208,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{return}{compReturn plist} +We set up the +{\tt compReturn} function to handle the +{\tt return} keyword by setting the {\tt special} keyword on the +{\tt return} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|return| 'special) '|compReturn|)) @@ -14117,6 +14256,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{seq}{compSeq plist} +We set up the +{\tt compSeq} function to handle the +{\tt SEQ} keyword by setting the {\tt special} keyword on the +{\tt SEQ} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get 'seq 'special) '|compSeq|)) @@ -14166,8 +14309,6 @@ is still more than one complain else return the only signature. \end{chunk} \defun{replaceExitEtc}{replaceExitEtc} -\calls{replaceExitEtc}{qcar} -\calls{replaceExitEtc}{qcdr} \calls{replaceExitEtc}{rplac} \calls{replaceExitEtc}{replaceExitEtc} \calls{replaceExitEtc}{intersectionEnvironment} @@ -14230,6 +14371,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{let}{compSetq plist} +We set up the +{\tt compSetq} function to handle the +{\tt LET} keyword by setting the {\tt special} keyword on the +{\tt LET} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get 'let 'special) '|compSetq|)) @@ -14237,6 +14382,10 @@ is still more than one complain else return the only signature. \end{chunk} \defplist{setq}{compSetq plist} +We set up the +{\tt compSetq} function to handle the +{\tt SETQ} keyword by setting the {\tt special} keyword on the +{\tt SETQ} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get 'setq 'special) '|compSetq|)) @@ -14256,8 +14405,6 @@ is still more than one complain else return the only signature. \seebook{compSetq1}{identp}{5} \calls{compSetq1}{compMakeDeclaration} \calls{compSetq1}{compSetq} -\calls{compSetq1}{qcar} -\calls{compSetq1}{qcdr} \calls{compSetq1}{setqMultiple} \calls{compSetq1}{setqSetelt} \usesdollar{compSetq1}{EmptyMode} @@ -14297,8 +14444,6 @@ is still more than one complain else return the only signature. \defun{setqMultiple}{setqMultiple} \calls{setqMultiple}{nreverse0} -\calls{setqMultiple}{qcar} -\calls{setqMultiple}{qcdr} \calls{setqMultiple}{stackMessage} \calls{setqMultiple}{setqMultipleExplicit} \calls{setqMultiple}{genVariable} @@ -14578,8 +14723,6 @@ This function returns the index of domain entry x in the association list \defun{outputComp}{outputComp} \calls{outputComp}{comp} -\calls{outputComp}{qcar} -\calls{outputComp}{qcdr} \calls{outputComp}{nreverse0} \calls{outputComp}{outputComp} \calls{outputComp}{get} @@ -14625,8 +14768,6 @@ This function returns the index of domain entry x in the association list \defun{isDomainForm}{isDomainForm} \calls{isDomainForm}{kar} -\calls{isDomainForm}{qcar} -\calls{isDomainForm}{qcdr} \calls{isDomainForm}{isFunctor} \calls{isDomainForm}{isCategoryForm} \calls{isDomainForm}{isDomainConstructorForm} @@ -14646,8 +14787,6 @@ This function returns the index of domain entry x in the association list \end{chunk} \defun{isDomainConstructorForm}{isDomainConstructorForm} -\calls{isDomainConstructorForm}{qcar} -\calls{isDomainConstructorForm}{qcdr} \calls{isDomainConstructorForm}{isCategoryForm} \calls{isDomainConstructorForm}{eqsubstlist} \refsdollar{isDomainConstructorForm}{FormalMapVariableList} @@ -14669,6 +14808,10 @@ This function returns the index of domain entry x in the association list \end{chunk} \defplist{String}{compString plist} +We set up the +{\tt compString} function to handle the +{\tt String} keyword by setting the {\tt special} keyword on the +{\tt String} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|String| 'special) '|compString|)) @@ -14686,6 +14829,10 @@ This function returns the index of domain entry x in the association list \end{chunk} \defplist{SubDomain}{compSubDomain plist} +We set up the +{\tt compSubDomain} function to handle the +{\tt SubDomain} keyword by setting the {\tt special} keyword on the +{\tt SubDomain} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|SubDomain| 'special) '|compSubDomain|)) @@ -14765,6 +14912,10 @@ This function returns the index of domain entry x in the association list \end{chunk} \defplist{SubsetCategory}{compSubsetCategory plist} +We set up the +{\tt compSubsetCategory} function to handle the +{\tt SubsetCategory} keyword by setting the {\tt special} keyword on the +{\tt SubsetCategory} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|SubsetCategory| 'special) '|compSubsetCategory|)) @@ -14798,6 +14949,10 @@ This function returns the index of domain entry x in the association list \end{chunk} \defplist{|}{compSuchthat plist} +We set up the +{\tt compSuchthat} function to handle the +\verb?|? keyword by setting the {\tt special} keyword on the +\verb?|? symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '\| 'special) '|compSuchthat|)) @@ -14827,6 +14982,10 @@ This function returns the index of domain entry x in the association list \end{chunk} \defplist{vector}{compVector plist} +We set up the +{\tt compVector} function to handle the +{\tt VECTOR} keyword by setting the {\tt special} keyword on the +{\tt VECTOR} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get 'vector 'special) '|compVector|)) @@ -14866,6 +15025,10 @@ This function returns the index of domain entry x in the association list \end{chunk} \defplist{where}{compWhere plist} +We set up the +{\tt compWhere} function to handle the +{\tt where} keyword by setting the {\tt special} keyword on the +{\tt where} symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|where| 'special) '|compWhere|)) @@ -15064,8 +15227,6 @@ of basic objects may not be the same. \defun{coerceExtraHard}{coerceExtraHard} \calls{coerceExtraHard}{autoCoerceByModemap} \calls{coerceExtraHard}{isUnionMode} -\calls{coerceExtraHard}{qcar} -\calls{coerceExtraHard}{qcdr} \calls{coerceExtraHard}{hasType} \calls{coerceExtraHard}{member} \calls{coerceExtraHard}{autoCoerceByModemap} @@ -15151,6 +15312,10 @@ of basic objects may not be the same. \end{chunk} \defplist{@}{compAtSign plist} +We set up the +{\tt compAtSign} function to handle the +\verb|@| keyword by setting the {\tt special} keyword on the +\verb|@| symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|@| 'special) 'compAtSign)) @@ -15170,6 +15335,10 @@ of basic objects may not be the same. \end{chunk} \defplist{::}{compCoerce plist} +We set up the +{\tt compCoerce} function to handle the +\verb|::| keyword by setting the {\tt special} keyword on the +\verb|::| symbol property list. \begin{chunk}{postvars} (eval-when (eval load) (setf (get '|::| 'special) '|compCoerce|)) @@ -15233,8 +15402,6 @@ of basic objects may not be the same. \end{chunk} \defun{coerceByModemap}{coerceByModemap} -\calls{coerceByModemap}{qcar} -\calls{coerceByModemap}{qcdr} \calls{coerceByModemap}{modeEqual} \calls{coerceByModemap}{isSubset} \calls{coerceByModemap}{genDeltaEntry} @@ -15264,8 +15431,6 @@ of basic objects may not be the same. \end{chunk} \defun{autoCoerceByModemap}{autoCoerceByModemap} -\calls{autoCoerceByModemap}{qcar} -\calls{autoCoerceByModemap}{qcdr} \calls{autoCoerceByModemap}{getModemapList} \calls{autoCoerceByModemap}{modeEqual} \calls{autoCoerceByModemap}{member} @@ -15345,8 +15510,6 @@ of basic objects may not be the same. \end{chunk} \defun{mkUnion}{mkUnion} -\calls{mkUnion}{qcar} -\calls{mkUnion}{qcdr} \calls{mkUnion}{union} \refsdollar{mkUnion}{Rep} \begin{chunk}{defun mkUnion} @@ -15417,29 +15580,6 @@ This orders Unions \end{chunk} -\subsection{compilerDoitWithScreenedLisplib}{compilerDoitWithScreenedLisplib} -\calls{compilerDoitWithScreenedLisplib}{embed} -\calls{compilerDoitWithScreenedLisplib}{rwrite} -\calls{compilerDoitWithScreenedLisplib}{compilerDoit} -\calls{compilerDoitWithScreenedLisplib}{unembed} -\refsdollar{compilerDoitWithScreenedLisplib}{saveableItems} -\refsdollar{compilerDoitWithScreenedLisplib}{libFile} -\begin{chunk}{defun compilerDoitWithScreenedLisplib} -(defun |compilerDoitWithScreenedLisplib| (constructor fun) - (declare (special |$saveableItems| |$libFile|)) - (embed 'rwrite - '(lambda (key value stream) - (cond - ((and (eq stream |$libFile|) - (not (member key |$saveableItems|))) - value) - ((not nil) (rwrite key value stream))))) - (unwind-protect - (|compilerDoit| constructor fun) - (unembed 'rwrite))) - -\end{chunk} - \chapter{Post Transformers} \section{Direct called postparse routines} \defun{postTransform}{postTransform} @@ -15935,8 +16075,6 @@ of the symbol being parsed. The original list read: \end{chunk} \defun{postCollect,finish}{postCollect,finish} -\calls{postCollect,finish}{qcar} -\calls{postCollect,finish}{qcdr} \calls{postCollect,finish}{postMakeCons} \calls{postCollect,finish}{tuple2List} \calls{postCollect,finish}{postTranList} @@ -21894,8 +22032,6 @@ Since it has no side effects we define it to return nil. \end{chunk} \defun{parseTranCheckForRecord}{parseTranCheckForRecord} -\calls{parseTranCheckForRecord}{qcar} -\calls{parseTranCheckForRecord}{qcdr} \calls{parseTranCheckForRecord}{postError} \calls{parseTranCheckForRecord}{parseTran} \begin{chunk}{defun parseTranCheckForRecord} @@ -22160,694 +22296,1243 @@ Since it has no side effects we define it to return nil. \end{chunk} -\defun{blankp}{blankp} -\begin{chunk}{defun blankp} -(defun blankp (char) - (or (eq char #\Space) (eq char #\tab))) +\defun{blankp}{blankp} +\begin{chunk}{defun blankp} +(defun blankp (char) + (or (eq char #\Space) (eq char #\tab))) + +\end{chunk} + +\defun{drop}{drop} +Return a pointer to the Nth cons of X, counting 0 as the first cons. +\calls{drop}{drop} +\calls{drop}{take} +\calls{drop}{croak} +\begin{chunk}{defun drop} +(defun drop (n x &aux m) + (cond + ((eql n 0) x) + ((> n 0) (drop (1- n) (cdr x))) + ((>= (setq m (+ (length x) n)) 0) (take m x)) + ((croak (list "Bad args to DROP" n x))))) + +\end{chunk} + +\defun{escaped}{escaped} +\begin{chunk}{defun escaped} +(defun escaped (str n) + (and (> n 0) (eq (char str (1- n)) #\_))) + +\end{chunk} + +\defdollar{comblocklist} +\begin{chunk}{initvars} +(defvar $comblocklist nil "a dynamic lists of comments for this block") + +\end{chunk} + +\defun{fincomblock}{fincomblock} +\begin{itemize} +\item NUM is the line number of the current line +\item OLDNUMS is the list of line numbers of previous lines +\item OLDLOCS is the list of previous indentation locations +\item NCBLOCK is the current comment block +\end{itemize} +\calls{fincomblock}{preparse-echo} +\usesdollar{fincomblock}{comblocklist} +\usesdollar{fincomblock}{EchoLineStack} +\begin{chunk}{defun fincomblock} +(defun fincomblock (num oldnums oldlocs ncblock linelist) + (declare (special $EchoLineStack $comblocklist)) + (push + (cond + ((eql (car ncblock) 0) (cons (1- num) (reverse (cdr ncblock)))) + ;; comment for constructor itself paired with 1st line -1 + (t + (when $EchoLineStack + (setq num (pop $EchoLineStack)) + (preparse-echo linelist) + (setq $EchoLineStack (list num))) + (cons ;; scan backwards for line to left of current + (do ((onums oldnums (cdr onums)) + (olocs oldlocs (cdr olocs)) + (sloc (car ncblock))) + ((null onums) nil) + (when (and (numberp (car olocs)) (<= (car olocs) sloc)) + (return (car onums)))) + (reverse (cdr ncblock))))) + $comblocklist)) + +\end{chunk} + +\defun{indent-pos}{indent-pos} +\calls{indent-pos}{next-tab-loc} +\begin{chunk}{defun indent-pos} +(defun indent-pos (str) + (do ((i 0 (1+ i)) (pos 0)) + ((>= i (length str)) nil) + (case (char str i) + (#\space (incf pos)) + (#\tab (setq pos (next-tab-loc pos))) + (otherwise (return pos))))) + +\end{chunk} + +\defun{infixtok}{infixtok} +\calls{infixtok}{string2id-n} +\begin{chunk}{defun infixtok} +(defun infixtok (s) + (member (string2id-n s 1) '(|then| |else|) :test #'eq)) + +\end{chunk} + +\defun{is-console}{is-console} +\calls{is-console}{fp-output-stream} +\uses{is-console}{*terminal-io*} +\begin{chunk}{defun is-console} +(defun is-console (stream) + (and (streamp stream) (output-stream-p stream) + (eq (system:fp-output-stream stream) + (system:fp-output-stream *terminal-io*)))) + +\end{chunk} + +\defun{next-tab-loc}{next-tab-loc} +\begin{chunk}{defun next-tab-loc} +(defun next-tab-loc (i) + (* (1+ (truncate i 8)) 8)) + +\end{chunk} + +\defun{nonblankloc}{nonblankloc} +\calls{nonblankloc}{blankp} +\begin{chunk}{defun nonblankloc} +(defun nonblankloc (str) + (position-if-not #'blankp str)) + +\end{chunk} + +\defun{parseprint}{parseprint} +\begin{chunk}{defun parseprint} +(defun parseprint (l) + (when l + (format t "~&~% *** PREPARSE ***~%~%") + (dolist (x l) (format t "~5d. ~a~%" (car x) (cdr x))) + (format t "~%"))) + +\end{chunk} + +\defun{skip-to-endif}{skip-to-endif} +\calls{skip-to-endif}{initial-substring} +\calls{skip-to-endif}{preparseReadLine} +\calls{skip-to-endif}{preparseReadLine1} +\calls{skip-to-endif}{skip-to-endif} +\begin{chunk}{defun skip-to-endif} +(defun skip-to-endif (x) + (let (line ind tmp1) + (setq tmp1 (preparseReadLine1)) + (setq ind (car tmp1)) + (setq line (cdr tmp1)) + (cond + ((not (stringp line)) (cons ind line)) + ((initial-substring line ")endif") (preparseReadLine x)) + ((initial-substring line ")fin") (cons ind nil)) + (t (skip-to-endif x))))) + +\end{chunk} + +\chapter{The Compiler} + +\defdollar{newConlist} +A list of new constructors discovered during compile. +These are used in a call to {\tt extendLocalLibdb} when a user +compiles new local code. +\begin{chunk}{initvars} +(defvar |$newConlist| nil + "A list of new constructors discovered during compile ") \end{chunk} -\defun{drop}{drop} -Return a pointer to the Nth cons of X, counting 0 as the first cons. -\calls{drop}{drop} -\calls{drop}{take} -\calls{drop}{croak} -\begin{chunk}{defun drop} -(defun drop (n x &aux m) - (cond - ((eql n 0) x) - ((> n 0) (drop (1- n) (cdr x))) - ((>= (setq m (+ (length x) n)) 0) (take m x)) - ((croak (list "Bad args to DROP" n x))))) +\section{Compiling EQ.spad} +Given the top level command: +\begin{verbatim} +)co EQ +\end{verbatim} +The default call chain looks like: +\begin{verbatim} +1> (|compiler| ...) + 2> (|compileSpad2Cmd| ...) + Compiling AXIOM source code from file /tmp/A.spad using old system + compiler. + 3> (|compilerDoit| ...) + 4> (|/RQ,LIB|) + 5> (/RF-1 ...) + 6> (SPAD ...) + AXSERV abbreviates package AxiomServer + 7> (S-PROCESS ...) + 8> (|compTopLevel| ...) + 9> (|compOrCroak| ...) + 10> (|compOrCroak1| ...) + 11> (|comp| ...) + 12> (|compNoStacking| ...) + 13> (|comp2| ...) + 14> (|comp3| ...) + 15> (|compExpression| ...) +* 16> (|compWhere| ...) + 17> (|comp| ...) + 18> (|compNoStacking| ...) + 19> (|comp2| ...) + 20> (|comp3| ...) + 21> (|compExpression| ...) + 22> (|compSeq| ...) + 23> (|compSeq1| ...) + 24> (|compSeqItem| ...) + 25> (|comp| ...) + 26> (|compNoStacking| ...) + 27> (|comp2| ...) + 28> (|comp3| ...) + 29> (|compExpression| ...) + <29 (|compExpression| ...) + <28 (|comp3| ...) + <27 (|comp2| ...) + <26 (|compNoStacking| ...) + <25 (|comp| ...) + <24 (|compSeqItem| ...) + 24> (|compSeqItem| ...) + 25> (|comp| ...) + 26> (|compNoStacking| ...) + 27> (|comp2| ...) + 28> (|comp3| ...) + 29> (|compExpression| ...) + 30> (|compExit| ...) + 31> (|comp| ...) + 32> (|compNoStacking| ...) + 33> (|comp2| ...) + 34> (|comp3| ...) + 35> (|compExpression| ...) + <35 (|compExpression| ...) + <34 (|comp3| ...) + <33 (|comp2| ...) + <32 (|compNoStacking| ...) + <31 (|comp| ...) + 31> (|modifyModeStack| ...) + <31 (|modifyModeStack| ...) + <30 (|compExit| ...) + <29 (|compExpression| ...) + <28 (|comp3| ...) + <27 (|comp2| ...) + <26 (|compNoStacking| ...) + <25 (|comp| ...) + <24 (|compSeqItem| ...) + 24> (|replaceExitEtc| ...) + 25> (|replaceExitEtc,fn| ...) + 26> (|replaceExitEtc| ...) + 27> (|replaceExitEtc,fn| ...) + 28> (|replaceExitEtc| ...) + 29> (|replaceExitEtc,fn| ...) + <29 (|replaceExitEtc,fn| ...) + <28 (|replaceExitEtc| ...) + 28> (|replaceExitEtc| ...) + 29> (|replaceExitEtc,fn| ...) + <29 (|replaceExitEtc,fn| ...) + <28 (|replaceExitEtc| ...) + <27 (|replaceExitEtc,fn| ...) + <26 (|replaceExitEtc| ...) + 26> (|replaceExitEtc| ...) + 27> (|replaceExitEtc,fn| ...) + 28> (|replaceExitEtc| ...) + 29> (|replaceExitEtc,fn| ...) + 30> (|replaceExitEtc| ...) + 31> (|replaceExitEtc,fn| ...) + 32> (|replaceExitEtc| ...) + 33> (|replaceExitEtc,fn| ...) + <33 (|replaceExitEtc,fn| ...) + <32 (|replaceExitEtc| ...) + 32> (|replaceExitEtc| ...) + 33> (|replaceExitEtc,fn| ...) + <33 (|replaceExitEtc,fn| ...) + <32 (|replaceExitEtc| ...) + <31 (|replaceExitEtc,fn| ...) + <30 (|replaceExitEtc| ...) + 30> (|convertOrCroak| ...) + 31> (|convert| ...) + <31 (|convert| ...) + <30 (|convertOrCroak| ...) + <29 (|replaceExitEtc,fn| ...) + <28 (|replaceExitEtc| ...) + 28> (|replaceExitEtc| ...) + 29> (|replaceExitEtc,fn| ...) + <29 (|replaceExitEtc,fn| ...) + <28 (|replaceExitEtc| ...) + <27 (|replaceExitEtc,fn| ...) + <26 (|replaceExitEtc| ...) + <25 (|replaceExitEtc,fn| ...) + <24 (|replaceExitEtc| ...) + <23 (|compSeq1| ...) + <22 (|compSeq| ...) + <21 (|compExpression| ...) + <20 (|comp3| ...) + <19 (|comp2| ...) + <18 (|compNoStacking| ...) + <17 (|comp| ...) + 17> (|comp| ...) + 18> (|compNoStacking| ...) + 19> (|comp2| ...) + 20> (|comp3| ...) + 21> (|compExpression| ...) + 22> (|comp| ...) + 23> (|compNoStacking| ...) + 24> (|comp2| ...) + 25> (|comp3| ...) + 26> (|compColon| ...) + <26 (|compColon| ...) + <25 (|comp3| ...) + <24 (|comp2| ...) + <23 (|compNoStacking| ...) + <22 (|comp| ...) +\end{verbatim} -\end{chunk} - -\defun{escaped}{escaped} -\begin{chunk}{defun escaped} -(defun escaped (str n) - (and (> n 0) (eq (char str (1- n)) #\_))) +In order to explain the compiler we will walk through the compilation of +EQ.spad, which handles equations as mathematical objects. We start the +system. Most of the structure in Axiom are circular so we have to the +\verb|*print-cycle*| to true. +\begin{verbatim} +root@spiff:/tmp# axiom -nox -\end{chunk} +(1) -> )lisp (setq *print-circle* t) -\defdollar{comblocklist} -\begin{chunk}{initvars} -(defvar $comblocklist nil "a dynamic lists of comments for this block") +Value = T +\end{verbatim} + +We trace the function we find interesting: +\begin{verbatim} +(1) -> )lisp (trace |compiler|) + +Value = (|compiler|) +\end{verbatim} + +\section{The top level compiler command} +This is the graph of the functions used for compDefine. +The syntax is a graphviz dot file. +To generate this graph as a JPEG file, type: +\begin{verbatim} +tangle v9compDefine.dot bookvol9.pamphlet >v9compdefine.dot +dot -Tjpg v9compiler.dot >v9compiler.jpg +\end{verbatim} +\begin{chunk}{v9compiler.dot} +digraph pic { + fontsize=10; + bgcolor="#ECEA81"; + node [shape=box, color=white, style=filled]; + +"compiler" [color="#ECEA81"] +"compileSpad2Cmd" [color="#ECEA81"] +"compileSpad2LispCmd" [color="#ECEA81"] +"compilerDoitWithScreenedLisplib" [color="#ECEA81"] +"compilerDoit" [color="#ECEA81"] +"/rq" [color="#ECEA81"] +"/rf" [color="#ECEA81"] +"/rf-1" [color="#ECEA81"] +"/rq,lib" [color="#ECEA81"] +"spad" [color="#ECEA81"] +"s-process" [color="#ECEA81"] +"compTopLevel" [color="#ECEA81"] +"compOrCroak" [color="#FFFFFF"] + +"compiler" -> "compileSpad2Cmd" +"compiler" -> "compileSpad2LispCmd" +"compileSpad2Cmd" -> "compilerDoitWithScreenedLisplib" +"compileSpad2Cmd" -> "compilerDoit" +"compilerDoitWithScreenedLisplib" -> "compilerDoit" +"compilerDoit" -> "/rq" +"compilerDoit" -> "/rf" +"compilerDoit" -> "/rq,lib" +"/rq" -> "/rf-1" +"/rf" -> "/rf-1" +"/rq,lib" -> "/rf-1" +"/rf-1" -> "spad" +"spad" -> "s-process" +"s-process" -> "compTopLevel" +"compTopLevel" -> "compOrCroak" +} \end{chunk} - -\defun{fincomblock}{fincomblock} -\begin{itemize} -\item NUM is the line number of the current line -\item OLDNUMS is the list of line numbers of previous lines -\item OLDLOCS is the list of previous indentation locations -\item NCBLOCK is the current comment block -\end{itemize} -\calls{fincomblock}{preparse-echo} -\usesdollar{fincomblock}{comblocklist} -\usesdollar{fincomblock}{EchoLineStack} -\begin{chunk}{defun fincomblock} -(defun fincomblock (num oldnums oldlocs ncblock linelist) - (declare (special $EchoLineStack $comblocklist)) - (push - (cond - ((eql (car ncblock) 0) (cons (1- num) (reverse (cdr ncblock)))) - ;; comment for constructor itself paired with 1st line -1 - (t - (when $EchoLineStack - (setq num (pop $EchoLineStack)) - (preparse-echo linelist) - (setq $EchoLineStack (list num))) - (cons ;; scan backwards for line to left of current - (do ((onums oldnums (cdr onums)) - (olocs oldlocs (cdr olocs)) - (sloc (car ncblock))) - ((null onums) nil) - (when (and (numberp (car olocs)) (<= (car olocs) sloc)) - (return (car onums)))) - (reverse (cdr ncblock))))) - $comblocklist)) +\includegraphics[scale=0.5]{ps/v9compiler.eps} + +\defun{compiler}{compiler} +We compile the spad file. We can see that the {\bf compiler} function gets +a list +\begin{verbatim} +(1) -> )co EQ + + 1> (|compiler| (EQ)) +\end{verbatim} +In order to find this file, the {\bf pathname} and {\bf pathnameType} +functions are used to find the location and pathname to the file. They +{\bf pathnameType} function eventually returns the fact that this is +a spad source file. Once that is known we call the {\bf compileSpad2Cmd} +function with a list containing the full pathname as a string. +\begin{verbatim} + 1> (|compiler| (EQ)) + 2> (|pathname| (EQ)) + <2 (|pathname| #p"EQ") + 2> (|pathnameType| #p"EQ") + 3> (|pathname| #p"EQ") + <3 (|pathname| #p"EQ") + <2 (|pathnameType| NIL) + 2> (|pathnameType| "/tmp/EQ.spad") + 3> (|pathname| "/tmp/EQ.spad") + <3 (|pathname| #p"/tmp/EQ.spad") + <2 (|pathnameType| "spad") + 2> (|pathnameType| "/tmp/EQ.spad") + 3> (|pathname| "/tmp/EQ.spad") + <3 (|pathname| #p"/tmp/EQ.spad") + <2 (|pathnameType| "spad") + 2> (|pathnameType| "/tmp/EQ.spad") + 3> (|pathname| "/tmp/EQ.spad") + <3 (|pathname| #p"/tmp/EQ.spad") + <2 (|pathnameType| "spad") + 2> (|compileSpad2Cmd| ("/tmp/EQ.spad")) +\end{verbatim} -\end{chunk} - -\defun{indent-pos}{indent-pos} -\calls{indent-pos}{next-tab-loc} -\begin{chunk}{defun indent-pos} -(defun indent-pos (str) - (do ((i 0 (1+ i)) (pos 0)) - ((>= i (length str)) nil) - (case (char str i) - (#\space (incf pos)) - (#\tab (setq pos (next-tab-loc pos))) - (otherwise (return pos))))) +\seebook{compiler}{helpSpad2Cmd}{5} +\seebook{compiler}{selectOptionLC}{5} +\seebook{compiler}{pathname}{5} +\seebook{compiler}{mergePathnames}{5} +\seebook{compiler}{pathnameType}{5} +\seebook{compiler}{namestring}{5} +\calls{compiler}{throwKeyedMsg} +\calls{compiler}{findfile} +\calls{compiler}{compileSpad2Cmd} +\calls{compiler}{compileSpadLispCmd} +\usesdollar{compiler}{newConlist} +\usesdollar{compiler}{options} +\uses{compiler}{/editfile} +\begin{chunk}{defun compiler} +(defun |compiler| (args) + "The top level compiler command" + (let (|$newConlist| optlist optname optargs havenew haveold ef af1 + pathname pathtype) + (declare (special |$newConlist| |$options| /editfile)) + (setq |$newConlist| nil) + (cond + ((and (null args) (null |$options|) (null /editfile)) + (|helpSpad2Cmd| '(|compiler|))) + (t + (cond ((null args) (setq args (cons /editfile nil)))) + (setq optlist '(|new| |old| |translate| |constructor|)) + (setq havenew nil) + (setq haveold nil) + (do ((t0 |$options| (cdr t0)) (opt nil)) + ((or (atom t0) + (progn (setq opt (car t0)) nil) + (null (null (and havenew haveold)))) + nil) + (setq optname (car opt)) + (setq optargs (cdr opt)) + (case (|selectOptionLC| optname optlist nil) + (|new| (setq havenew t)) + (|translate| (setq haveold t)) + (|constructor| (setq haveold t)) + (|old| (setq haveold t)))) + (cond + ((and havenew haveold) (|throwKeyedMsg| 's2iz0081 nil)) + (t + (setq pathname (|pathname| args)) + (setq pathtype (|pathnameType| pathname)) + (cond + ((or haveold (string= pathtype "spad")) + (if (null (setq af1 ($findfile pathname '(|spad|)))) + (|throwKeyedMsg| 's2il0003 (cons (namestring pathname) nil)) + (|compileSpad2Cmd| (list af1)))) + ((string= pathtype "nrlib") + (if (null (setq af1 ($findfile pathname '(|nrlib|)))) + (|throwKeyedMsg| 'S2IL0003 (cons (namestring pathname) nil)) + (|compileSpadLispCmd| (list af1)))) + (t + (setq af1 ($findfile pathname '(|spad|))) + (cond + ((and af1 (string= (|pathnameType| af1) "spad")) + (|compileSpad2Cmd| (list af1))) + (t + (setq ef (|pathname| /editfile)) + (setq ef (|mergePathnames| pathname ef)) + (cond + ((equal ef pathname) (|throwKeyedMsg| 's2iz0039 nil)) + (t + (setq pathname ef) + (cond + ((string= (|pathnameType| pathname) "spad") + (|compileSpad2Cmd| args)) + (t + (setq af1 ($findfile pathname '(|spad|))) + (cond + ((and af1 (string= (|pathnameType| af1) "spad")) + (|compileSpad2Cmd| (cons af1 nil))) + (t (|throwKeyedMsg| 's2iz0039 nil))))))))))))))))) \end{chunk} -\defun{infixtok}{infixtok} -\calls{infixtok}{string2id-n} -\begin{chunk}{defun infixtok} -(defun infixtok (s) - (member (string2id-n s 1) '(|then| |else|) :test #'eq)) - -\end{chunk} - -\defun{is-console}{is-console} -\calls{is-console}{fp-output-stream} -\uses{is-console}{*terminal-io*} -\begin{chunk}{defun is-console} -(defun is-console (stream) - (and (streamp stream) (output-stream-p stream) - (eq (system:fp-output-stream stream) - (system:fp-output-stream *terminal-io*)))) +\defun{compileSpad2Cmd}{compileSpad2Cmd} +The argument to this function, as noted above, is a list containing +the string pathname to the file. +\begin{verbatim} + 2> (|compileSpad2Cmd| ("/tmp/EQ.spad")) +\end{verbatim} +There is a fair bit of redundant work to find the full filename and pathname +of the file. This needs to be eliminated. -\end{chunk} +The trace of the functions in this routines is: +\begin{verbatim} + 1> (|selectOptionLC| "compiler" (|abbreviations| |boot| |browse| |cd| |clear| |close| |compiler| |copyright| |credits| |describe| |display| |edit| |fin| |frame| |help| |history| |lisp| |library| |load| |ltrace| |pquit| |quit| |read| |savesystem| |set| |show| |spool| |summary| |synonym| |system| |trace| |trademark| |undo| |what| |with| |workfiles| |zsystemdevelopment|) |commandErrorIfAmbiguous|) + <1 (|selectOptionLC| |compiler|) + 1> (|selectOptionLC| |compiler| (|abbreviations| |boot| |browse| |cd| |clear| |close| |compiler| |copyright| |credits| |describe| |display| |edit| |fin| |frame| |help| |history| |lisp| |library| |load| |ltrace| |pquit| |quit| |read| |savesystem| |set| |show| |spool| |summary| |synonym| |system| |trace| |trademark| |undo| |what| |with| |workfiles| |zsystemdevelopment|) |commandError|) + <1 (|selectOptionLC| |compiler|) + 1> (|pathname| (EQ)) + <1 (|pathname| #p"EQ") + 1> (|pathnameType| #p"EQ") + 2> (|pathname| #p"EQ") + <2 (|pathname| #p"EQ") + <1 (|pathnameType| NIL) + 1> (|pathnameType| "/tmp/EQ.spad") + 2> (|pathname| "/tmp/EQ.spad") + <2 (|pathname| #p"/tmp/EQ.spad") + <1 (|pathnameType| "spad") + 1> (|pathnameType| "/tmp/EQ.spad") + 2> (|pathname| "/tmp/EQ.spad") + <2 (|pathname| #p"/tmp/EQ.spad") + <1 (|pathnameType| "spad") + 1> (|pathnameType| "/tmp/EQ.spad") + 2> (|pathname| "/tmp/EQ.spad") + <2 (|pathname| #p"/tmp/EQ.spad") + <1 (|pathnameType| "spad") + 1> (|compileSpad2Cmd| ("/tmp/EQ.spad")) + 2> (|pathname| ("/tmp/EQ.spad")) + <2 (|pathname| #p"/tmp/EQ.spad") + 2> (|pathnameType| #p"/tmp/EQ.spad") + 3> (|pathname| #p"/tmp/EQ.spad") + <3 (|pathname| #p"/tmp/EQ.spad") + <2 (|pathnameType| "spad") + 2> (|updateSourceFiles| #p"/tmp/EQ.spad") + 3> (|pathname| #p"/tmp/EQ.spad") + <3 (|pathname| #p"/tmp/EQ.spad") + 3> (|pathname| #p"/tmp/EQ.spad") + <3 (|pathname| #p"/tmp/EQ.spad") + 3> (|pathnameType| #p"/tmp/EQ.spad") + 4> (|pathname| #p"/tmp/EQ.spad") + <4 (|pathname| #p"/tmp/EQ.spad") + <3 (|pathnameType| "spad") + 3> (|pathname| ("EQ" "spad" "*")) + <3 (|pathname| #p"EQ.spad") + 3> (|pathnameType| #p"EQ.spad") + 4> (|pathname| #p"EQ.spad") + <4 (|pathname| #p"EQ.spad") + <3 (|pathnameType| "spad") + <2 (|updateSourceFiles| #p"EQ.spad") + 2> (|namestring| ("/tmp/EQ.spad")) + 3> (|pathname| ("/tmp/EQ.spad")) + <3 (|pathname| #p"/tmp/EQ.spad") + <2 (|namestring| "/tmp/EQ.spad") + Compiling AXIOM source code from file /tmp/EQ.spad using old system + compiler. +\end{verbatim} -\defun{next-tab-loc}{next-tab-loc} -\begin{chunk}{defun next-tab-loc} -(defun next-tab-loc (i) - (* (1+ (truncate i 8)) 8)) +Again we find a lot of redundant work. We finally end up calling +{\bf compilerDoit} with a constructed argument list: +\begin{verbatim} + 2> (|compilerDoit| NIL (|rq| |lib|)) +\end{verbatim} -\end{chunk} -\defun{nonblankloc}{nonblankloc} -\calls{nonblankloc}{blankp} -\begin{chunk}{defun nonblankloc} -(defun nonblankloc (str) - (position-if-not #'blankp str)) +\seebook{compileSpad2Cmd}{pathname}{5} +\seebook{compileSpad2Cmd}{pathnameType}{5} +\seebook{compileSpad2Cmd}{namestring}{5} +\seebook{compileSpad2Cmd}{updateSourceFiles}{5} +\seebook{compileSpad2Cmd}{selectOptionLC}{5} +\seebook{compileSpad2Cmd}{terminateSystemCommand}{5} +\calls{compileSpad2Cmd}{throwKeyedMsg} +\seebook{compileSpad2Cmd}{sayKeyedMsg}{5} +\calls{compileSpad2Cmd}{error} +\calls{compileSpad2Cmd}{strconc} +\calls{compileSpad2Cmd}{object2String} +\calls{compileSpad2Cmd}{browserAutoloadOnceTrigger} +\calls{compileSpad2Cmd}{spad2AsTranslatorAutoloadOnceTrigger} +\calls{compileSpad2Cmd}{compilerDoitWithScreenedLisplib} +\calls{compileSpad2Cmd}{compilerDoit} +\calls{compileSpad2Cmd}{extendLocalLibdb} +\calls{compileSpad2Cmd}{spadPrompt} +\usesdollar{compileSpad2Cmd}{newComp} +\usesdollar{compileSpad2Cmd}{scanIfTrue} +\usesdollar{compileSpad2Cmd}{compileOnlyCertainItems} +\usesdollar{compileSpad2Cmd}{f} +\usesdollar{compileSpad2Cmd}{m} +\usesdollar{compileSpad2Cmd}{QuickLet} +\usesdollar{compileSpad2Cmd}{QuickCode} +\usesdollar{compileSpad2Cmd}{sourceFileTypes} +\usesdollar{compileSpad2Cmd}{InteractiveMode} +\usesdollar{compileSpad2Cmd}{options} +\usesdollar{compileSpad2Cmd}{newConlist} +\uses{compileSpad2Cmd}{/editfile} +\begin{chunk}{defun compileSpad2Cmd} +(defun |compileSpad2Cmd| (args) + (let (|$newComp| |$scanIfTrue| + |$compileOnlyCertainItems| |$f| |$m| |$QuickLet| |$QuickCode| + |$sourceFileTypes| |$InteractiveMode| path optlist fun optname + optargs fullopt constructor) + (declare (special |$newComp| |$scanIfTrue| + |$compileOnlyCertainItems| |$f| |$m| |$QuickLet| |$QuickCode| + |$sourceFileTypes| |$InteractiveMode| /editfile |$options| + |$newConlist|)) + (setq path (|pathname| args)) + (cond + ((not (string= (|pathnameType| path) "spad")) + (|throwKeyedMsg| 's2iz0082 nil)) + ((null (probe-file path)) + (|throwKeyedMsg| 's2il0003 (cons (|namestring| args) nil))) + (t + (setq /editfile path) + (|updateSourceFiles| path) + (|sayKeyedMsg| 's2iz0038 (list (|namestring| args))) + (setq optlist '(|break| |constructor| |functions| |library| |lisp| + |new| |old| |nobreak| |nolibrary| |noquiet| |vartrace| |quiet| + |translate|)) + (setq |$QuickLet| t) + (setq |$QuickCode| t) + (setq fun '(|rq| |lib|)) + (setq |$sourceFileTypes| '("SPAD")) + (dolist (opt |$options|) + (setq optname (car opt)) + (setq optargs (cdr opt)) + (setq fullopt (|selectOptionLC| optname optlist nil)) + (case fullopt + (|old| nil) + (|library| (setelt fun 1 '|lib|)) + (|nolibrary| (setelt fun 1 '|nolib|)) + (|quiet| (when (not (eq (elt fun 0) '|c|)) (setelt fun 0 '|rq|))) + (|noquiet| (when (not (eq (elt fun 0) '|c|)) (setelt fun 0 '|rf|))) + (|nobreak| (setq |$scanIfTrue| t)) + (|break| (setq |$scanIfTrue| nil)) + (|vartrace| (setq |$QuickLet| nil)) + (|lisp| (|throwKeyedMsg| 's2iz0036 (list ")lisp"))) + (|functions| + (if (null optargs) + (|throwKeyedMsg| 's2iz0037 (list ")functions")) + (setq |$compileOnlyCertainItems| optargs))) + (|constructor| + (if (null optargs) + (|throwKeyedMsg| 's2iz0037 (list ")constructor")) + (progn + (setelt fun 0 '|c|) + (setq constructor (mapcar #'|unabbrev| optargs))))) + (t + (|throwKeyedMsg| 's2iz0036 + (list (strconc ")" (|object2String| optname))))))) + (setq |$InteractiveMode| nil) + (cond + (|$compileOnlyCertainItems| + (if (null constructor) + (|sayKeyedMsg| 's2iz0040 nil) + (|compilerDoitWithScreenedLisplib| constructor fun))) + (t (|compilerDoit| constructor fun))) + (|extendLocalLibdb| |$newConlist|) + (|terminateSystemCommand|) + (|spadPrompt|))))) \end{chunk} - -\defun{parseprint}{parseprint} -\begin{chunk}{defun parseprint} -(defun parseprint (l) - (when l - (format t "~&~% *** PREPARSE ***~%~%") - (dolist (x l) (format t "~5d. ~a~%" (car x) (cdr x))) - (format t "~%"))) - -\end{chunk} -\defun{skip-to-endif}{skip-to-endif} -\calls{skip-to-endif}{initial-substring} -\calls{skip-to-endif}{preparseReadLine} -\calls{skip-to-endif}{preparseReadLine1} -\calls{skip-to-endif}{skip-to-endif} -\begin{chunk}{defun skip-to-endif} -(defun skip-to-endif (x) - (let (line ind tmp1) - (setq tmp1 (preparseReadLine1)) - (setq ind (car tmp1)) - (setq line (cdr tmp1)) +\defun{compileSpadLispCmd}{compileSpadLispCmd} +\seebook{compileSpadLispCmd}{pathname}{5} +\seebook{compileSpadLispCmd}{pathnameType}{5} +\seebook{compileSpadLispCmd}{selectOptionLC}{5} +\seebook{compileSpadLispCmd}{namestring}{5} +\seebook{compileSpadLispCmd}{terminateSystemCommand}{5} +\seebook{compileSpadLispCmd}{fnameMake}{5} +\seebook{compileSpadLispCmd}{pathnameDirectory}{5} +\seebook{compileSpadLispCmd}{pathnameName}{5} +\seebook{compileSpadLispCmd}{fnameReadable?}{5} +\seebook{compileSpadLispCmd}{localdatabase}{5} +\calls{compileSpadLispCmd}{throwKeyedMsg} +\calls{compileSpadLispCmd}{object2String} +\seebook{compileSpadLispCmd}{sayKeyedMsg}{5} +\calls{compileSpadLispCmd}{recompile-lib-file-if-necessary} +\calls{compileSpadLispCmd}{spadPrompt} +\usesdollar{compileSpadLispCmd}{options} +\begin{chunk}{defun compileSpadLispCmd} +(defun |compileSpadLispCmd| (args) + (let (path optlist optname optargs beQuiet dolibrary lsp) + (declare (special |$options|)) + (setq path (|pathname| (|fnameMake| (car args) "code" "lsp"))) (cond - ((not (stringp line)) (cons ind line)) - ((initial-substring line ")endif") (preparseReadLine x)) - ((initial-substring line ")fin") (cons ind nil)) - (t (skip-to-endif x))))) + ((null (probe-file path)) + (|throwKeyedMsg| 's2il0003 (cons (|namestring| args) nil))) + (t + (setq optlist '(|quiet| |noquiet| |library| |nolibrary|)) + (setq beQuiet nil) + (setq dolibrary t) + (dolist (opt |$options|) + (setq optname (car opt)) + (setq optargs (cdr opt)) + (case (|selectOptionLC| optname optlist nil) + (|quiet| (setq beQuiet t)) + (|noquiet| (setq beQuiet nil)) + (|library| (setq dolibrary t)) + (|nolibrary| (setq dolibrary nil)) + (t + (|throwKeyedMsg| 's2iz0036 + (list (strconc ")" (|object2String| optname))))))) + (setq lsp + (|fnameMake| + (|pathnameDirectory| path) + (|pathnameName| path) + (|pathnameType| path))) + (cond + ((|fnameReadable?| lsp) + (unless beQuiet (|sayKeyedMsg| 's2iz0089 (list (|namestring| lsp)))) + (recompile-lib-file-if-necessary lsp)) + (t + (|sayKeyedMsg| 's2il0003 (list (|namestring| lsp))))) + (cond + (dolibrary + (unless beQuiet (|sayKeyedMsg| 's2iz0090 (list (|pathnameName| path)))) + (localdatabase (list (|pathnameName| (car args))) nil)) + ((null beQuiet) (|sayKeyedMsg| 's2iz0084 nil)) + (t nil)) + (|terminateSystemCommand|) + (|spadPrompt|))))) \end{chunk} - -\chapter{The Compiler} -\section{Compiling EQ.spad} -Given the top level command: -\begin{verbatim} -)co EQ -\end{verbatim} -The default call chain looks like: -\begin{verbatim} -1> (|compiler| ...) - 2> (|compileSpad2Cmd| ...) - Compiling AXIOM source code from file /tmp/A.spad using old system - compiler. - 3> (|compilerDoit| ...) - 4> (|/RQ,LIB|) - 5> (/RF-1 ...) - 6> (SPAD ...) - AXSERV abbreviates package AxiomServer - 7> (S-PROCESS ...) - 8> (|compTopLevel| ...) - 9> (|compOrCroak| ...) - 10> (|compOrCroak1| ...) - 11> (|comp| ...) - 12> (|compNoStacking| ...) - 13> (|comp2| ...) - 14> (|comp3| ...) - 15> (|compExpression| ...) -* 16> (|compWhere| ...) - 17> (|comp| ...) - 18> (|compNoStacking| ...) - 19> (|comp2| ...) - 20> (|comp3| ...) - 21> (|compExpression| ...) - 22> (|compSeq| ...) - 23> (|compSeq1| ...) - 24> (|compSeqItem| ...) - 25> (|comp| ...) - 26> (|compNoStacking| ...) - 27> (|comp2| ...) - 28> (|comp3| ...) - 29> (|compExpression| ...) - <29 (|compExpression| ...) - <28 (|comp3| ...) - <27 (|comp2| ...) - <26 (|compNoStacking| ...) - <25 (|comp| ...) - <24 (|compSeqItem| ...) - 24> (|compSeqItem| ...) - 25> (|comp| ...) - 26> (|compNoStacking| ...) - 27> (|comp2| ...) - 28> (|comp3| ...) - 29> (|compExpression| ...) - 30> (|compExit| ...) - 31> (|comp| ...) - 32> (|compNoStacking| ...) - 33> (|comp2| ...) - 34> (|comp3| ...) - 35> (|compExpression| ...) - <35 (|compExpression| ...) - <34 (|comp3| ...) - <33 (|comp2| ...) - <32 (|compNoStacking| ...) - <31 (|comp| ...) - 31> (|modifyModeStack| ...) - <31 (|modifyModeStack| ...) - <30 (|compExit| ...) - <29 (|compExpression| ...) - <28 (|comp3| ...) - <27 (|comp2| ...) - <26 (|compNoStacking| ...) - <25 (|comp| ...) - <24 (|compSeqItem| ...) - 24> (|replaceExitEtc| ...) - 25> (|replaceExitEtc,fn| ...) - 26> (|replaceExitEtc| ...) - 27> (|replaceExitEtc,fn| ...) - 28> (|replaceExitEtc| ...) - 29> (|replaceExitEtc,fn| ...) - <29 (|replaceExitEtc,fn| ...) - <28 (|replaceExitEtc| ...) - 28> (|replaceExitEtc| ...) - 29> (|replaceExitEtc,fn| ...) - <29 (|replaceExitEtc,fn| ...) - <28 (|replaceExitEtc| ...) - <27 (|replaceExitEtc,fn| ...) - <26 (|replaceExitEtc| ...) - 26> (|replaceExitEtc| ...) - 27> (|replaceExitEtc,fn| ...) - 28> (|replaceExitEtc| ...) - 29> (|replaceExitEtc,fn| ...) - 30> (|replaceExitEtc| ...) - 31> (|replaceExitEtc,fn| ...) - 32> (|replaceExitEtc| ...) - 33> (|replaceExitEtc,fn| ...) - <33 (|replaceExitEtc,fn| ...) - <32 (|replaceExitEtc| ...) - 32> (|replaceExitEtc| ...) - 33> (|replaceExitEtc,fn| ...) - <33 (|replaceExitEtc,fn| ...) - <32 (|replaceExitEtc| ...) - <31 (|replaceExitEtc,fn| ...) - <30 (|replaceExitEtc| ...) - 30> (|convertOrCroak| ...) - 31> (|convert| ...) - <31 (|convert| ...) - <30 (|convertOrCroak| ...) - <29 (|replaceExitEtc,fn| ...) - <28 (|replaceExitEtc| ...) - 28> (|replaceExitEtc| ...) - 29> (|replaceExitEtc,fn| ...) - <29 (|replaceExitEtc,fn| ...) - <28 (|replaceExitEtc| ...) - <27 (|replaceExitEtc,fn| ...) - <26 (|replaceExitEtc| ...) - <25 (|replaceExitEtc,fn| ...) - <24 (|replaceExitEtc| ...) - <23 (|compSeq1| ...) - <22 (|compSeq| ...) - <21 (|compExpression| ...) - <20 (|comp3| ...) - <19 (|comp2| ...) - <18 (|compNoStacking| ...) - <17 (|comp| ...) - 17> (|comp| ...) - 18> (|compNoStacking| ...) - 19> (|comp2| ...) - 20> (|comp3| ...) - 21> (|compExpression| ...) - 22> (|comp| ...) - 23> (|compNoStacking| ...) - 24> (|comp2| ...) - 25> (|comp3| ...) - 26> (|compColon| ...) - <26 (|compColon| ...) - <25 (|comp3| ...) - <24 (|comp2| ...) - <23 (|compNoStacking| ...) - <22 (|comp| ...) -\end{verbatim} +\subsection{compilerDoitWithScreenedLisplib}{compilerDoitWithScreenedLisplib} +\calls{compilerDoitWithScreenedLisplib}{embed} +\calls{compilerDoitWithScreenedLisplib}{rwrite} +\calls{compilerDoitWithScreenedLisplib}{compilerDoit} +\calls{compilerDoitWithScreenedLisplib}{unembed} +\refsdollar{compilerDoitWithScreenedLisplib}{saveableItems} +\refsdollar{compilerDoitWithScreenedLisplib}{libFile} +\begin{chunk}{defun compilerDoitWithScreenedLisplib} +(defun |compilerDoitWithScreenedLisplib| (constructor fun) + (declare (special |$saveableItems| |$libFile|)) + (embed 'rwrite + '(lambda (key value stream) + (cond + ((and (eq stream |$libFile|) + (not (member key |$saveableItems|))) + value) + ((not nil) (rwrite key value stream))))) + (unwind-protect + (|compilerDoit| constructor fun) + (unembed 'rwrite))) -In order to explain the compiler we will walk through the compilation of -EQ.spad, which handles equations as mathematical objects. We start the -system. Most of the structure in Axiom are circular so we have to the -\verb|*print-cycle*| to true. +\end{chunk} + +\defun{compilerDoit}{compilerDoit} +This trivial function cases on the second argument to decide which +combination of operations was requested. For this case we see: \begin{verbatim} -root@spiff:/tmp# axiom -nox +(1) -> )co EQ + Compiling AXIOM source code from file /tmp/EQ.spad using old system + compiler. + 1> (|compilerDoit| NIL (|rq| |lib|)) + 2> (|/RQ,LIB|) -(1) -> )lisp (setq *print-circle* t) +... [snip]... -Value = T + <2 (|/RQ,LIB| T) + <1 (|compilerDoit| T) +(1) -> \end{verbatim} +\seebook{compilerDoit}{/rq}{5} +\seebook{compilerDoit}{/rf}{5} +\seebook{compilerDoit}{member}{5} +\calls{compilerDoit}{sayBrightly} +\calls{compilerDoit}{opOf} +\calls{compilerDoit}{/RQ,LIB} +\usesdollar{compilerDoit}{byConstructors} +\usesdollar{compilerDoit}{constructorsSeen} +\begin{chunk}{defun compilerDoit} +(defun |compilerDoit| (constructor fun) + (let (|$byConstructors| |$constructorsSeen|) + (declare (special |$byConstructors| |$constructorsSeen|)) + (cond + ((equal fun '(|rf| |lib|)) (|/RQ,LIB|)) ; Ignore "noquiet" + ((equal fun '(|rf| |nolib|)) (/rf)) + ((equal fun '(|rq| |lib|)) (|/RQ,LIB|)) + ((equal fun '(|rq| |nolib|)) (/rq)) + ((equal fun '(|c| |lib|)) + (setq |$byConstructors| (loop for x in constructor collect (|opOf| x))) + (|/RQ,LIB|) + (dolist (x |$byConstructors|) + (unless (|member| x |$constructorsSeen|) + (|sayBrightly| `(">>> Warning " |%b| ,x |%d| " was not found")))))))) -We trace the function we find interesting: -\begin{verbatim} -(1) -> )lisp (trace |compiler|) - -Value = (|compiler|) -\end{verbatim} +\end{chunk} -\defunsec{compiler}{The top level compiler command} -We compile the spad file. We can see that the {\bf compiler} function gets -a list -\begin{verbatim} -(1) -> )co EQ +\defun{/rq}{/rq} +Compile with quiet output +\calls{/rq}{/rf-1} +\uses{/rq}{echo-meta} +\begin{chunk}{defun /rq} +(defun /rq (&rest foo &aux (echo-meta nil)) + (declare (special Echo-Meta) (ignore foo)) + (/rf-1 nil)) - 1> (|compiler| (EQ)) -\end{verbatim} -In order to find this file, the {\bf pathname} and {\bf pathnameType} -functions are used to find the location and pathname to the file. They -{\bf pathnameType} function eventually returns the fact that this is -a spad source file. Once that is known we call the {\bf compileSpad2Cmd} -function with a list containing the full pathname as a string. -\begin{verbatim} - 1> (|compiler| (EQ)) - 2> (|pathname| (EQ)) - <2 (|pathname| #p"EQ") - 2> (|pathnameType| #p"EQ") - 3> (|pathname| #p"EQ") - <3 (|pathname| #p"EQ") - <2 (|pathnameType| NIL) - 2> (|pathnameType| "/tmp/EQ.spad") - 3> (|pathname| "/tmp/EQ.spad") - <3 (|pathname| #p"/tmp/EQ.spad") - <2 (|pathnameType| "spad") - 2> (|pathnameType| "/tmp/EQ.spad") - 3> (|pathname| "/tmp/EQ.spad") - <3 (|pathname| #p"/tmp/EQ.spad") - <2 (|pathnameType| "spad") - 2> (|pathnameType| "/tmp/EQ.spad") - 3> (|pathname| "/tmp/EQ.spad") - <3 (|pathname| #p"/tmp/EQ.spad") - <2 (|pathnameType| "spad") - 2> (|compileSpad2Cmd| ("/tmp/EQ.spad")) -\end{verbatim} +\end{chunk} -\seebook{compiler}{helpSpad2Cmd}{5} -\seebook{compiler}{selectOptionLC}{5} -\seebook{compiler}{pathname}{5} -\seebook{compiler}{mergePathnames}{5} -\seebook{compiler}{pathnameType}{5} -\seebook{compiler}{namestring}{5} -\calls{compiler}{throwKeyedMsg} -\calls{compiler}{findfile} -\calls{compiler}{compileSpad2Cmd} -\calls{compiler}{compileSpadLispCmd} -\usesdollar{compiler}{newConlist} -\usesdollar{compiler}{options} -\uses{compiler}{/editfile} -\begin{chunk}{defun compiler} -(defun |compiler| (args) - "The top level compiler command" - (let (|$newConlist| optlist optname optargs havenew haveold aft ef af af1) - (declare (special |$newConlist| |$options| /editfile)) - (setq |$newConlist| nil) - (cond - ((and (null args) (null |$options|) (null /editfile)) - (|helpSpad2Cmd| '(|compiler|))) - (t - (cond ((null args) (setq args (cons /editfile nil)))) - (setq optlist '(|new| |old| |translate| |constructor|)) - (setq havenew nil) - (setq haveold nil) - (do ((t0 |$options| (cdr t0)) (opt nil)) - ((or (atom t0) - (progn (setq opt (car t0)) nil) - (null (null (and havenew haveold)))) - nil) - (setq optname (car opt)) - (setq optargs (cdr opt)) - (case (|selectOptionLC| optname optlist nil) - (|new| (setq havenew t)) - (|translate| (setq haveold t)) - (|constructor| (setq haveold t)) - (|old| (setq haveold t)))) - (cond - ((and havenew haveold) (|throwKeyedMsg| 's2iz0081 nil)) - (t - (setq af (|pathname| args)) - (setq aft (|pathnameType| af)) - (cond - ((or haveold (string= aft "spad")) - (if (null (setq af1 ($findfile af '(|spad|)))) - (|throwKeyedMsg| 's2il0003 (cons (namestring af) nil)) - (|compileSpad2Cmd| (cons af1 nil)))) - ((string= aft "nrlib") - (if (null (setq af1 ($findfile af '(|nrlib|)))) - (|throwKeyedMsg| 'S2IL0003 (cons (namestring af) nil)) - (|compileSpadLispCmd| (cons af1 nil)))) - (t - (setq af1 ($findfile af '(|spad|))) - (cond - ((and af1 (string= (|pathnameType| af1) "spad")) - (|compileSpad2Cmd| (cons af1 nil))) - (t - (setq ef (|pathname| /editfile)) - (setq ef (|mergePathnames| af ef)) - (cond - ((boot-equal ef af) (|throwKeyedMsg| 's2iz0039 nil)) - (t - (setq af ef) - (cond - ((string= (|pathnameType| af) "spad") - (|compileSpad2Cmd| args)) - (t - (setq af1 ($findfile af '(|spad|))) - (cond - ((and af1 (string= (|pathnameType| af1) "spad")) - (|compileSpad2Cmd| (cons af1 nil))) - (t (|throwKeyedMsg| 's2iz0039 nil))))))))))))))))) +\defun{/rf}{/rf} +Compile with noisy output +\calls{/rf}{/rf-1} +\uses{/rf}{echo-meta} +\begin{chunk}{defun /rf} +(defun /rf (&rest foo &aux (echo-meta t)) + (declare (special echo-meta) (ignore foo)) + (/rf-1 nil)) \end{chunk} -\defunsec{compileSpad2Cmd}{The Spad compiler top level function} -The argument to this function, as noted above, is a list containing -the string pathname to the file. +\defun{/RQ,LIB}{/RQ,LIB} +This function simply calls {\bf \verb|/rf-1|}. \begin{verbatim} - 2> (|compileSpad2Cmd| ("/tmp/EQ.spad")) +(2) -> )co EQ + Compiling AXIOM source code from file /tmp/EQ.spad using old system + compiler. + 1> (|compilerDoit| NIL (|rq| |lib|)) + 2> (|/RQ,LIB|) + 3> (/RF-1 NIL) +...[snip]... + <3 (/RF-1 T) + <2 (|/RQ,LIB| T) + <1 (|compilerDoit| T) \end{verbatim} -There is a fair bit of redundant work to find the full filename and pathname -of the file. This needs to be eliminated. +\calls{/RQ,LIB}{/rf-1} +\seebook{/RQ,LIB}{echo-meta}{5} +\usesdollar{/RQ,LIB}{lisplib} +\begin{chunk}{defun /RQ,LIB} +(defun |/RQ,LIB| (&rest foo &aux (echo-meta nil) ($lisplib t)) + (declare (special echo-meta $lisplib) (ignore foo)) + (/rf-1 nil)) -The trace of the functions in this routines is: +\end{chunk} + +\defun{/rf-1}{/rf-1} +Since this function is called with nil we fall directly into the +call to the function {\bf spad}: \begin{verbatim} - 1> (|selectOptionLC| "compiler" (|abbreviations| |boot| |browse| |cd| |clear| |close| |compiler| |copyright| |credits| |describe| |display| |edit| |fin| |frame| |help| |history| |lisp| |library| |load| |ltrace| |pquit| |quit| |read| |savesystem| |set| |show| |spool| |summary| |synonym| |system| |trace| |trademark| |undo| |what| |with| |workfiles| |zsystemdevelopment|) |commandErrorIfAmbiguous|) - <1 (|selectOptionLC| |compiler|) - 1> (|selectOptionLC| |compiler| (|abbreviations| |boot| |browse| |cd| |clear| |close| |compiler| |copyright| |credits| |describe| |display| |edit| |fin| |frame| |help| |history| |lisp| |library| |load| |ltrace| |pquit| |quit| |read| |savesystem| |set| |show| |spool| |summary| |synonym| |system| |trace| |trademark| |undo| |what| |with| |workfiles| |zsystemdevelopment|) |commandError|) - <1 (|selectOptionLC| |compiler|) - 1> (|pathname| (EQ)) - <1 (|pathname| #p"EQ") - 1> (|pathnameType| #p"EQ") - 2> (|pathname| #p"EQ") - <2 (|pathname| #p"EQ") - <1 (|pathnameType| NIL) - 1> (|pathnameType| "/tmp/EQ.spad") - 2> (|pathname| "/tmp/EQ.spad") - <2 (|pathname| #p"/tmp/EQ.spad") - <1 (|pathnameType| "spad") - 1> (|pathnameType| "/tmp/EQ.spad") - 2> (|pathname| "/tmp/EQ.spad") - <2 (|pathname| #p"/tmp/EQ.spad") - <1 (|pathnameType| "spad") - 1> (|pathnameType| "/tmp/EQ.spad") - 2> (|pathname| "/tmp/EQ.spad") - <2 (|pathname| #p"/tmp/EQ.spad") - <1 (|pathnameType| "spad") - 1> (|compileSpad2Cmd| ("/tmp/EQ.spad")) - 2> (|pathname| ("/tmp/EQ.spad")) - <2 (|pathname| #p"/tmp/EQ.spad") - 2> (|pathnameType| #p"/tmp/EQ.spad") - 3> (|pathname| #p"/tmp/EQ.spad") - <3 (|pathname| #p"/tmp/EQ.spad") - <2 (|pathnameType| "spad") - 2> (|updateSourceFiles| #p"/tmp/EQ.spad") - 3> (|pathname| #p"/tmp/EQ.spad") - <3 (|pathname| #p"/tmp/EQ.spad") - 3> (|pathname| #p"/tmp/EQ.spad") - <3 (|pathname| #p"/tmp/EQ.spad") - 3> (|pathnameType| #p"/tmp/EQ.spad") - 4> (|pathname| #p"/tmp/EQ.spad") - <4 (|pathname| #p"/tmp/EQ.spad") - <3 (|pathnameType| "spad") - 3> (|pathname| ("EQ" "spad" "*")) - <3 (|pathname| #p"EQ.spad") - 3> (|pathnameType| #p"EQ.spad") - 4> (|pathname| #p"EQ.spad") - <4 (|pathname| #p"EQ.spad") - <3 (|pathnameType| "spad") - <2 (|updateSourceFiles| #p"EQ.spad") - 2> (|namestring| ("/tmp/EQ.spad")) - 3> (|pathname| ("/tmp/EQ.spad")) - <3 (|pathname| #p"/tmp/EQ.spad") - <2 (|namestring| "/tmp/EQ.spad") +(2) -> )co EQ Compiling AXIOM source code from file /tmp/EQ.spad using old system compiler. + 1> (|compilerDoit| NIL (|rq| |lib|)) + 2> (|/RQ,LIB|) + 3> (/RF-1 NIL) + 4> (SPAD "/tmp/EQ.spad") +...[snip]... + <4 (SPAD T) + <3 (/RF-1 T) + <2 (|/RQ,LIB| T) + <1 (|compilerDoit| T) \end{verbatim} +\seebook{/rf-1}{makeInputFilename}{5} +\calls{/rf-1}{ncINTERPFILE} +calls{/rf-1}{spad} +\uses{/rf-1}{/editfile} +\uses{/rf-1}{echo-meta} +\begin{chunk}{defun /rf-1} +(defun /rf-1 (ignore) + (declare (ignore ignore)) + (let* ((input-file (makeInputFilename /editfile)) + (type (pathname-type input-file))) + (declare (special echo-meta /editfile)) + (cond + ((string= type "lisp") (load input-file)) + ((string= type "input") (|ncINTERPFILE| input-file echo-meta)) + (t (spad input-file))))) -Again we find a lot of redundant work. We finally end up calling -{\bf compilerDoit} with a constructed argument list: -\begin{verbatim} - 2> (|compilerDoit| NIL (|rq| |lib|)) -\end{verbatim} +\end{chunk} + +\defun{spad}{spad} +\catches{spad}{spad-reader} +\seebook{spad}{addBinding}{5} +\seebook{spad}{makeInitialModemapFrame}{5} +\seebook{spad}{init-boot/spad-reader}{5} +\calls{spad}{initialize-preparse} +\calls{spad}{preparse} +\calls{spad}{PARSE-NewExpr} +\calls{spad}{pop-stack-1} +\calls{spad}{s-process} +\calls{spad}{ioclear} +\seebook{spad}{shut}{5} +\usesdollar{spad}{noSubsumption} +\usesdollar{spad}{InteractiveFrame} +\usesdollar{spad}{InitialDomainsInScope} +\usesdollar{spad}{InteractiveMode} +\usesdollar{spad}{spad} +\usesdollar{spad}{boot} +\uses{spad}{curoutstream} +\uses{spad}{*fileactq-apply*} +\uses{spad}{line} +\uses{spad}{optionlist} +\uses{spad}{echo-meta} +\uses{spad}{/editfile} +\uses{spad}{*comp370-apply*} +\uses{spad}{*eof*} +\uses{spad}{file-closed} +\uses{spad}{boot-line-stack} +\catches{spad}{spad-reader} +\begin{chunk}{defun spad} +(defun spad (&optional (*spad-input-file* nil) (*spad-output-file* nil) + &aux (*comp370-apply* #'print-defun) + (*fileactq-apply* #'print-defun) + ($spad t) ($boot nil) (optionlist nil) (*eof* nil) + (file-closed nil) (/editfile *spad-input-file*) + (|$noSubsumption| |$noSubsumption|) in-stream out-stream) + (declare (special echo-meta /editfile *comp370-apply* *eof* curoutstream + file-closed |$noSubsumption| |$InteractiveFrame| + |$InteractiveMode| optionlist + boot-line-stack *fileactq-apply* $spad $boot)) + ;; only rebind |$InteractiveFrame| if compiling + (progv (if (not |$InteractiveMode|) '(|$InteractiveFrame|)) + (if (not |$InteractiveMode|) + (list (|addBinding| '|$DomainsInScope| + `((fluid . |true|)) + (|addBinding| '|$Information| nil + (|makeInitialModemapFrame|))))) + (init-boot/spad-reader) + (unwind-protect + (progn + (setq in-stream (if *spad-input-file* + (open *spad-input-file* :direction :input) + *standard-input*)) + (initialize-preparse in-stream) + (setq out-stream (if *spad-output-file* + (open *spad-output-file* :direction :output) + *standard-output*)) + (when *spad-output-file* + (format out-stream "~&;;; -*- Mode:Lisp; Package:Boot -*-~%~%") + (print-package "BOOT")) + (setq curoutstream out-stream) + (loop + (if (or *eof* file-closed) (return nil)) + (catch 'spad_reader + (if (setq boot-line-stack (preparse in-stream)) + (let ((line (cdar boot-line-stack))) + (declare (special line)) + (|PARSE-NewExpr|) + (let ((parseout (pop-stack-1)) ) + (when parseout + (let ((*standard-output* out-stream)) + (s-process parseout)) + (format out-stream "~&"))) + ))) + (ioclear in-stream out-stream))) + (if *spad-input-file* (shut in-stream)) + (if *spad-output-file* (shut out-stream))) + t)) +\end{chunk} -\seebook{compileSpad2Cmd}{pathname}{5} -\seebook{compileSpad2Cmd}{pathnameType}{5} -\seebook{compileSpad2Cmd}{namestring}{5} -\seebook{compileSpad2Cmd}{updateSourceFiles}{5} -\seebook{compileSpad2Cmd}{selectOptionLC}{5} -\seebook{compileSpad2Cmd}{terminateSystemCommand}{5} -\calls{compileSpad2Cmd}{throwKeyedMsg} -\seebook{compileSpad2Cmd}{sayKeyedMsg}{5} -\calls{compileSpad2Cmd}{error} -\calls{compileSpad2Cmd}{strconc} -\calls{compileSpad2Cmd}{object2String} -\calls{compileSpad2Cmd}{browserAutoloadOnceTrigger} -\calls{compileSpad2Cmd}{spad2AsTranslatorAutoloadOnceTrigger} -\calls{compileSpad2Cmd}{compilerDoitWithScreenedLisplib} -\calls{compileSpad2Cmd}{compilerDoit} -\calls{compileSpad2Cmd}{extendLocalLibdb} -\calls{compileSpad2Cmd}{spadPrompt} -\usesdollar{compileSpad2Cmd}{newComp} -\usesdollar{compileSpad2Cmd}{scanIfTrue} -\usesdollar{compileSpad2Cmd}{compileOnlyCertainItems} -\usesdollar{compileSpad2Cmd}{f} -\usesdollar{compileSpad2Cmd}{m} -\usesdollar{compileSpad2Cmd}{QuickLet} -\usesdollar{compileSpad2Cmd}{QuickCode} -\usesdollar{compileSpad2Cmd}{sourceFileTypes} -\usesdollar{compileSpad2Cmd}{InteractiveMode} -\usesdollar{compileSpad2Cmd}{options} -\usesdollar{compileSpad2Cmd}{newConlist} -\uses{compileSpad2Cmd}{/editfile} -\begin{chunk}{defun compileSpad2Cmd} -(defun |compileSpad2Cmd| (args) - (let (|$newComp| |$scanIfTrue| - |$compileOnlyCertainItems| |$f| |$m| |$QuickLet| |$QuickCode| - |$sourceFileTypes| |$InteractiveMode| path optlist fun optname - optargs fullopt constructor) - (declare (special |$newComp| |$scanIfTrue| - |$compileOnlyCertainItems| |$f| |$m| |$QuickLet| |$QuickCode| - |$sourceFileTypes| |$InteractiveMode| /editfile |$options| - |$newConlist|)) - (setq path (|pathname| args)) - (cond - ((not (string= (|pathnameType| path) "spad")) - (|throwKeyedMsg| 's2iz0082 nil)) - ((null (probe-file path)) - (|throwKeyedMsg| 's2il0003 (cons (|namestring| args) nil))) - (t - (setq /editfile path) - (|updateSourceFiles| path) - (|sayKeyedMsg| 's2iz0038 (list (|namestring| args))) - (setq optlist '(|break| |constructor| |functions| |library| |lisp| - |new| |old| |nobreak| |nolibrary| |noquiet| |vartrace| |quiet| - |translate|)) - (setq |$QuickLet| t) - (setq |$QuickCode| t) - (setq fun '(|rq| |lib|)) - (setq |$sourceFileTypes| '("SPAD")) - (dolist (opt |$options|) - (setq optname (car opt)) - (setq optargs (cdr opt)) - (setq fullopt (|selectOptionLC| optname optlist nil)) - (case fullopt - (|old| nil) - (|library| (setelt fun 1 '|lib|)) - (|nolibrary| (setelt fun 1 '|nolib|)) - (|quiet| (when (not (eq (elt fun 0) '|c|)) (setelt fun 0 '|rq|))) - (|noquiet| (when (not (eq (elt fun 0) '|c|)) (setelt fun 0 '|rf|))) - (|nobreak| (setq |$scanIfTrue| t)) - (|break| (setq |$scanIfTrue| nil)) - (|vartrace| (setq |$QuickLet| nil)) - (|lisp| (|throwKeyedMsg| 's2iz0036 (list ")lisp"))) - (|functions| - (if (null optargs) - (|throwKeyedMsg| 's2iz0037 (list ")functions")) - (setq |$compileOnlyCertainItems| optargs))) - (|constructor| - (if (null optargs) - (|throwKeyedMsg| 's2iz0037 (list ")constructor")) - (progn - (setelt fun 0 '|c|) - (setq constructor (mapcar #'|unabbrev| optargs))))) - (t - (|throwKeyedMsg| 's2iz0036 - (list (strconc ")" (|object2String| optname))))))) - (setq |$InteractiveMode| nil) - (cond - (|$compileOnlyCertainItems| - (if (null constructor) - (|sayKeyedMsg| 's2iz0040 nil) - (|compilerDoitWithScreenedLisplib| constructor fun))) - (t (|compilerDoit| constructor fun))) - (|extendLocalLibdb| |$newConlist|) - (|terminateSystemCommand|) - (|spadPrompt|))))) +\defun{s-process}{Interpreter interface to the compiler} +\calls{s-process}{curstrm} +\calls{s-process}{def-rename} +\calls{s-process}{new2OldLisp} +\calls{s-process}{parseTransform} +\calls{s-process}{postTransform} +\calls{s-process}{displayPreCompilationErrors} +\calls{s-process}{prettyprint} +\seebook{s-process}{processInteractive}{5} +\calls{s-process}{compTopLevel} +\calls{s-process}{def-process} +\calls{s-process}{displaySemanticErrors} +\calls{s-process}{terpri} +\calls{s-process}{get-internal-run-time} +\usesdollar{s-process}{Index} +\usesdollar{s-process}{macroassoc} +\usesdollar{s-process}{newspad} +\usesdollar{s-process}{PolyMode} +\usesdollar{s-process}{EmptyMode} +\usesdollar{s-process}{compUniquelyIfTrue} +\usesdollar{s-process}{currentFunction} +\usesdollar{s-process}{postStack} +\usesdollar{s-process}{topOp} +\usesdollar{s-process}{semanticErrorStack} +\usesdollar{s-process}{warningStack} +\usesdollar{s-process}{exitMode} +\usesdollar{s-process}{exitModeStack} +\usesdollar{s-process}{returnMode} +\usesdollar{s-process}{leaveMode} +\usesdollar{s-process}{leaveLevelStack} +\usesdollar{s-process}{top-level} +\usesdollar{s-process}{insideFunctorIfTrue} +\usesdollar{s-process}{insideExpressionIfTrue} +\usesdollar{s-process}{insideCoerceInteractiveHardIfTrue} +\usesdollar{s-process}{insideWhereIfTrue} +\usesdollar{s-process}{insideCategoryIfTrue} +\usesdollar{s-process}{insideCapsuleFunctionIfTrue} +\usesdollar{s-process}{form} +\usesdollar{s-process}{DomainFrame} +\usesdollar{s-process}{e} +\usesdollar{s-process}{EmptyEnvironment} +\usesdollar{s-process}{genFVar} +\usesdollar{s-process}{genSDVar} +\usesdollar{s-process}{VariableCount} +\usesdollar{s-process}{previousTime} +\usesdollar{s-process}{LocalFrame} +\usesdollar{s-process}{Translation} +\usesdollar{s-process}{TranslateOnly} +\usesdollar{s-process}{PrintOnly} +\usesdollar{s-process}{currentLine} +\usesdollar{s-process}{InteractiveFrame} +\uses{s-process}{curoutstream} +\begin{chunk}{defun s-process} +(defun s-process (x) + (prog ((|$Index| 0) + ($macroassoc ()) + ($newspad t) + (|$PolyMode| |$EmptyMode|) + (|$compUniquelyIfTrue| nil) + |$currentFunction| + (|$postStack| nil) + |$topOp| + (|$semanticErrorStack| ()) + (|$warningStack| ()) + (|$exitMode| |$EmptyMode|) + (|$exitModeStack| ()) + (|$returnMode| |$EmptyMode|) + (|$leaveMode| |$EmptyMode|) + (|$leaveLevelStack| ()) + $top_level |$insideFunctorIfTrue| |$insideExpressionIfTrue| + |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| + |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| + (|$DomainFrame| '((NIL))) + (|$e| |$EmptyEnvironment|) + (|$genFVar| 0) + (|$genSDVar| 0) + (|$VariableCount| 0) + (|$previousTime| (get-internal-run-time)) + (|$LocalFrame| '((NIL))) + (curstrm curoutstream) |$s| |$x| |$m| u) + (declare (special |$Index| $macroassoc $newspad |$PolyMode| |$EmptyMode| + |$compUniquelyIfTrue| |$currentFunction| |$postStack| |$topOp| + |$semanticErrorStack| |$warningStack| |$exitMode| |$exitModeStack| + |$returnMode| |$leaveMode| |$leaveLevelStack| $top_level + |$insideFunctorIfTrue| |$insideExpressionIfTrue| + |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| + |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| + |$DomainFrame| |$e| |$EmptyEnvironment| |$genFVar| |$genSDVar| + |$VariableCount| |$previousTime| |$LocalFrame| + curstrm |$s| |$x| |$m| curoutstream $traceflag |$Translation| + |$TranslateOnly| |$PrintOnly| |$currentLine| |$InteractiveFrame|)) + (setq $traceflag t) + (if (not x) (return nil)) + (if $boot + (setq x (def-rename (new2OldLisp x))) + (setq x (|parseTransform| (postTransform x)))) + (when |$TranslateOnly| (return (setq |$Translation| x))) + (when |$postStack| (|displayPreCompilationErrors|) (return nil)) + (when |$PrintOnly| + (format t "~S =====>~%" |$currentLine|) + (return (prettyprint x))) + (if (not $boot) + (if |$InteractiveMode| + (|processInteractive| x nil) + (when (setq u (|compTopLevel| x |$EmptyMode| |$InteractiveFrame|)) + (setq |$InteractiveFrame| (third u)))) + (def-process x)) + (when |$semanticErrorStack| (|displaySemanticErrors|)) + (terpri))) \end{chunk} -This trivial function cases on the second argument to decide which -combination of operations was requested. For this case we see: -\begin{verbatim} -(1) -> )co EQ - Compiling AXIOM source code from file /tmp/EQ.spad using old system - compiler. - 1> (|compilerDoit| NIL (|rq| |lib|)) - 2> (|/RQ,LIB|) - -... [snip]... +\defun{compTopLevel}{compTopLevel} +\calls{compTopLevel}{compOrCroak} +\usesdollar{compTopLevel}{NRTderivedTargetIfTrue} +\usesdollar{compTopLevel}{killOptimizeIfTrue} +\usesdollar{compTopLevel}{forceAdd} +\usesdollar{compTopLevel}{compTimeSum} +\usesdollar{compTopLevel}{resolveTimeSum} +\usesdollar{compTopLevel}{packagesUsed} +\usesdollar{compTopLevel}{envHashTable} +\begin{chunk}{defun compTopLevel} +(defun |compTopLevel| (form mode env) + (let (|$NRTderivedTargetIfTrue| |$killOptimizeIfTrue| |$forceAdd| + |$compTimeSum| |$resolveTimeSum| |$packagesUsed| |$envHashTable| + t1 t2 t3 val newmode) + (declare (special |$NRTderivedTargetIfTrue| |$killOptimizeIfTrue| + |$forceAdd| |$compTimeSum| |$resolveTimeSum| + |$packagesUsed| |$envHashTable| )) + (setq |$NRTderivedTargetIfTrue| nil) + (setq |$killOptimizeIfTrue| nil) + (setq |$forceAdd| nil) + (setq |$compTimeSum| 0) + (setq |$resolveTimeSum| 0) + (setq |$packagesUsed| NIL) + (setq |$envHashTable| (make-hashtable 'equal)) + (dolist (u (car (car env))) + (dolist (v (cdr u)) + (hput |$envHashTable| (cons (car u) (cons (car v) nil)) t))) + (cond + ((or (and (consp form) (eq (qfirst form) 'def)) + (and (consp form) (eq (qfirst form) '|where|) + (progn + (setq t1 (qrest form)) + (and (consp t1) + (progn + (setq t2 (qfirst t1)) + (and (consp t2) (eq (qfirst t2) 'def))))))) + (setq t3 (|compOrCroak| form mode env)) + (setq val (car t3)) + (setq newmode (second t3)) + (cons val (cons newmode (cons env nil)))) + (t (|compOrCroak| form mode env))))) - <2 (|/RQ,LIB| T) - <1 (|compilerDoit| T) -(1) -> -\end{verbatim} +\end{chunk} -\defun{compilerDoit}{compilerDoit} -\seebook{compilerDoit}{/rq}{5} -\seebook{compilerDoit}{/rf}{5} -\seebook{compilerDoit}{member}{5} -\calls{compilerDoit}{sayBrightly} -\calls{compilerDoit}{opOf} -\calls{compilerDoit}{/RQ,LIB} -\usesdollar{compilerDoit}{byConstructors} -\usesdollar{compilerDoit}{constructorsSeen} -\begin{chunk}{defun compilerDoit} -(defun |compilerDoit| (constructor fun) - (let (|$byConstructors| |$constructorsSeen|) - (declare (special |$byConstructors| |$constructorsSeen|)) +\defun{extendLocalLibdb}{extendLocalLibdb} +\calls{extendLocalLibdb}{buildLibdb} +\calls{extendLocalLibdb}{union} +\calls{extendLocalLibdb}{purgeNewConstructorLines} +\calls{extendLocalLibdb}{dbReadLines} +\calls{extendLocalLibdb}{dbWriteLines} +\calls{extendLocalLibdb}{deleteFile} +\calls{extendLocalLibdb}{msort} +\refsdollar{extendLocalLibdb}{createLocalLibDb} +\refsdollar{extendLocalLibdb}{newConstructorList} +\defsdollar{extendLocalLibdb}{newConstructorList} +\begin{chunk}{defun extendLocalLibdb} +(defun |extendLocalLibdb| (conlist) + (let (localLibdb oldlines newlines) + (declare (special |$createLocalLibDb| |$newConstructorList|)) (cond - ((equal fun '(|rf| |lib|)) (|/RQ,LIB|)) ; Ignore "noquiet" - ((equal fun '(|rf| |nolib|)) (/rf)) - ((equal fun '(|rq| |lib|)) (|/RQ,LIB|)) - ((equal fun '(|rq| |nolib|)) (/rq)) - ((equal fun '(|c| |lib|)) - (setq |$byConstructors| (loop for x in constructor collect (|opOf| x))) - (|/RQ,LIB|) - (dolist (x |$byConstructors|) - (unless (|member| x |$constructorsSeen|) - (|sayBrightly| `(">>> Warning " |%b| ,x |%d| " was not found")))))))) + ((null |$createLocalLibDb|) nil) + ((null conlist) nil) + (t + (|buildLibdb| conlist) + (setq |$newConstructorList| (|union| conlist |$newConstructorList|)) + (setq localLibdb "libdb.text") + (cond + ((null (probe-file "libdb.text")) + (rename-file "temp.text" "libdb.text")) + (t + (setq oldlines + (|purgeNewConstructorLines| (|dbReadLines| localLibdb) conlist)) + (setq newlines (|dbReadLines| "temp.text")) + (|dbWriteLines| (msort (|union| oldlines newlines)) "libdb.text") + (|deleteFile| "temp.text"))))))) \end{chunk} -This function simply calls {\bf \verb|/rf-1|}. +\defun{buildLibdb}{buildLibdb} +This function appears to have two use cases, one in which the domainList +variable is undefined, in which case it writes out all of the constructors, +and the other case where it writes out a single constructor. +Formal for libdb.text: \begin{verbatim} -(2) -> )co EQ - Compiling AXIOM source code from file /tmp/EQ.spad using old system - compiler. - 1> (|compilerDoit| NIL (|rq| |lib|)) - 2> (|/RQ,LIB|) - 3> (/RF-1 NIL) -...[snip]... - <3 (/RF-1 T) - <2 (|/RQ,LIB| T) - <1 (|compilerDoit| T) + constructors Cname\#\I\sig \args \abb \comments (C is C, D, P, X) + operations Op \#\E\sig \conname\pred\comments (E is one of U/E) + attributes Aname\#\E\args\conname\pred\comments + I = \end{verbatim} - -\defun{/RQ,LIB}{/RQ,LIB} -\calls{/RQ,LIB}{/rf-1} -\seebook{/RQ,LIB}{echo-meta}{5} -\usesdollar{/RQ,LIB}{lisplib} -\begin{chunk}{defun /RQ,LIB} -(defun |/RQ,LIB| (&rest foo &aux (echo-meta nil) ($lisplib t)) - (declare (special echo-meta $lisplib) (ignore foo)) - (/rf-1 nil)) +\calls{buildLibdb}{dsetq} +\calls{buildLibdb}{ifcar} +\calls{buildLibdb}{deleteFile} +\calls{buildLibdb}{make-outstream} +\calls{buildLibdb}{writedb} +\calls{buildLibdb}{buildLibdbString} +\calls{buildLibdb}{allConstructors} +\calls{buildLibdb}{buildLibdbConEntry} +\calls{buildLibdb}{getConstructorExports} +\calls{buildLibdb}{buildLibOps} +\calls{buildLibdb}{buildLibAttrs} +\calls{buildLibdb}{shut} +\calls{buildLibdb}{obey} +\calls{buildLibdb}{deleteFile} +\refsdollar{buildLibdb}{outStream} +\refsdollar{buildLibdb}{conform} +\defsdollar{buildLibdb}{kind} +\defsdollar{buildLibdb}{doc} +\defsdollar{buildLibdb}{exposed?} +\defsdollar{buildLibdb}{conform} +\defsdollar{buildLibdb}{conname} +\defsdollar{buildLibdb}{outStream} +\defsdollar{buildLibdb}{DefLst} +\defsdollar{buildLibdb}{PakLst} +\defsdollar{buildLibdb}{catLst} +\defsdollar{buildLibdb}{DomLst} +\defsdollar{buildLibdb}{AttrLst} +\defsdollar{buildLibdb}{OpLst} +\begin{chunk}{defun buildLibdb} +(defun |buildLibdb| (&rest G168131 &AUX options) + (dsetq options G168131) + (let (|$OpLst| |$AttrLst| |$DomLst| |$CatLst| |$PakLst| |$DefLst| + |$outStream| |$conname| |$conform| |$exposed?| |$doc| + |$kind| domainList comments constructorList tmp1 attrlist oplist) + (declare (special |$OpLst| |$AttrLst| |$DomLst| |$CatLst| |$PakLst| + |$DefLst| |$outStream| |$conname| |$conform| + |$exposed?| |$doc| |$kind|)) + (setq domainList (ifcar options)) + (setq |$OpLst| nil) + (setq |$AttrLst| nil) + (setq |$DomLst| nil) + (setq |$CatLst| nil) + (setq |$PakLst| nil) + (setq |$DefLst| nil) + (|deleteFile| "temp.text") + (setq |$outStream| (make-outstream "temp.text")) + (unless domainList + (setq comments + (concatenate 'string + "\\spad{Union(A,B,...,C)} is a primitive type in AXIOM used to " + "represent objects of type \\spad{A} or of type \\spad{B} or...or " + "of type \\spad{C}.")) + (|writedb| + (|buildLibdbString| + (list "dUnion" 1 "x" "special" "(A,B,...,C)" 'UNION comments))) + (setq comments + (concatenate 'string + "\\spad{Record(a:A,b:B,...,c:C)} is a primitive type in AXIOM used " + "to represent composite objects made up of objects of type " + "\\spad{A}, \\spad{B},..., \\spad{C} which are indexed by \"keys\"" + " (identifiers) \\spad{a},\\spad{b},...,\\spad{c}.")) + (|writedb| + (|buildLibdbString| + (list "dRecord" 1 "x" "special" "(a:A,b:B,...,c:C)" 'RECORD comments))) + (setq comments + (concatenate 'string + "\\spad{Mapping(T,S)} is a primitive type in AXIOM used to represent" + " mappings from source type \\spad{S} to target type \\spad{T}. " + "Similarly, \\spad{Mapping(T,A,B)} denotes a mapping from source " + "type \\spad{(A,B)} to target type \\spad{T}.")) + (|writedb| + (|buildLibdbString| + (list "dMapping" 1 "x" "special" "(T,S)" 'MAPPING comments))) + (setq comments + (concatenate 'string + "\\spad{Enumeration(a,b,...,c)} is a primitive type in AXIOM used to " + "represent the object composed of the symbols \\spad{a},\\spad{b}," + "..., and \\spad{c}.")) + (|writedb| + (|buildLibdbString| + (list "dEnumeration" 1 "x" "special" "(a,b,...,c)" 'ENUM comments)))) + (setq |$conname| nil) + (setq |$conform| nil) + (setq |$exposed?| nil) + (setq |$doc| nil) + (setq |$kind| nil) + (setq constructorList (or domainList (|allConstructors|))) + (loop for con in constructorList do + (|writedb| (|buildLibdbConEntry| con)) + (setq tmp1 (|getConstructorExports| |$conform|)) + (setq attrlist (car tmp1)) + (setq oplist (cdr tmp1)) + (|buildLibOps| oplist) + (|buildLibAttrs| attrlist)) + (shut |$outStream|) + (unless domainList + (obey "sort \"temp.text\" > \"libdb.text\"") + (rename-file "libdb.text" "olibdb.text") + (|deleteFile| "temp.text")))) \end{chunk} - -Since this function is called with nil we fall directly into the -call to the function {\bf spad}: -\begin{verbatim} -(2) -> )co EQ - Compiling AXIOM source code from file /tmp/EQ.spad using old system - compiler. - 1> (|compilerDoit| NIL (|rq| |lib|)) - 2> (|/RQ,LIB|) - 3> (/RF-1 NIL) - 4> (SPAD "/tmp/EQ.spad") -...[snip]... - <4 (SPAD T) - <3 (/RF-1 T) - <2 (|/RQ,LIB| T) - <1 (|compilerDoit| T) -\end{verbatim} -\defun{/rf-1}{/rf-1} -\seebook{/rf-1}{makeInputFilename}{5} -\calls{/rf-1}{ncINTERPFILE} -\seebook{/rf-1}{spad}{5} -\uses{/rf-1}{/editfile} -\uses{/rf-1}{echo-meta} -\begin{chunk}{defun /rf-1} -(defun /rf-1 (ignore) - (declare (ignore ignore)) - (let* ((input-file (makeInputFilename /editfile)) - (type (pathname-type input-file))) - (declare (special echo-meta /editfile)) - (cond - ((string= type "lisp") (load input-file)) - ((string= type "input") (|ncINTERPFILE| input-file echo-meta)) - (t (spad input-file))))) -\end{chunk} Here we begin the actual compilation process. \begin{verbatim} @@ -23114,354 +23799,161 @@ And the {\bf s-process} function which returns a parsed version of the input. (|:| (|coerce| (|:| |eqn| $)) |Boolean|) (= (|eqn| |lhs|) (|eqn| |rhs|)))) NIL)) - (|if| (|has| S |AbelianSemiGroup|) - (|;| - (|;| - (== - (+ |eq1| |eq2|) - (= - (+ (|eq1| |lhs|) (|eq2| |lhs|)) - (+ (|eq1| |rhs|) (|eq2| |rhs|)))) - (== (+ |s| |eq2|) (+ (|construct| (|,| |s| |s|)) |eq2|))) - (== (+ |eq1| |s|) (+ |eq1| (|construct| (|,| |s| |s|))))) - NIL)) - (|if| (|has| S |AbelianGroup|) - (|;| - (|;| - (|;| - (|;| - (|;| - (|;| - (== (- |eq|) (= (- (|lhs| |eq|)) (- (|rhs| |eq|)))) - (== (- |s| |eq2|) (- (|construct| (|,| |s| |s|)) |eq2|))) - (== (- |eq1| |s|) (- |eq1| (|construct| (|,| |s| |s|))))) - (== (|leftZero| |eq|) (= 0 (- (|rhs| |eq|) (|lhs| |eq|))))) - (== (|rightZero| |eq|) (= (- (|lhs| |eq|) (|rhs| |eq|)) 0))) - (== 0 (|equation| (|,| (|elt| S 0) (|elt| S 0))))) - (== - (- |eq1| |eq2|) - (= - (- (|eq1| |lhs|) (|eq2| |lhs|)) - (- (|eq1| |rhs|) (|eq2| |rhs|))))) - NIL)) - (|if| (|has| S |SemiGroup|) - (|;| - (|;| - (|;| - (== - (* (|:| |eq1| $) (|:| |eq2| $)) - (= - (* (|eq1| |lhs|) (|eq2| |lhs|)) - (* (|eq1| |rhs|) (|eq2| |rhs|)))) - (== - (* (|:| |l| S) (|:| |eqn| $)) - (= (* |l| (|eqn| |lhs|)) (* |l| (|eqn| |rhs|))))) - (== - (* (|:| |l| S) (|:| |eqn| $)) - (= (* |l| (|eqn| |lhs|)) (* |l| (|eqn| |rhs|))))) - (== - (* (|:| |eqn| $) (|:| |l| S)) - (= (* (|eqn| |lhs|) |l|) (* (|eqn| |rhs|) |l|)))) - NIL)) - (|if| (|has| S |Monoid|) - (|;| - (|;| - (|;| - (== 1 (|equation| (|,| (|elt| S 1) (|elt| S 1)))) - (== - (|recip| |eq|) - (|;| - (|;| - (=> (|case| (|:=| |lh| (|recip| (|lhs| |eq|))) "failed") - "failed") - (=> (|case| (|:=| |rh| (|recip| (|rhs| |eq|))) "failed") - "failed")) - (|construct| (|,| (|::| |lh| S) (|::| |rh| S)))))) - (== - (|leftOne| |eq|) - (|;| - (=> (|case| (|:=| |re| (|recip| (|lhs| |eq|))) "failed") - "failed") - (= 1 (* (|rhs| |eq|) |re|))))) - (== - (|rightOne| |eq|) - (|;| - (=> (|case| (|:=| |re| (|recip| (|rhs| |eq|))) "failed") - "failed") - (= (* (|lhs| |eq|) |re|) 1)))) - NIL)) - (|if| (|has| S |Group|) - (|;| - (|;| - (== - (|inv| |eq|) - (|construct| (|,| (|inv| (|lhs| |eq|)) (|inv| (|rhs| |eq|))))) - (== (|leftOne| |eq|) (= 1 (* (|rhs| |eq|) (|inv| (|rhs| |eq|)))))) - (== (|rightOne| |eq|) (= (* (|lhs| |eq|) (|inv| (|rhs| |eq|))) 1))) - NIL)) - (|if| (|has| S |Ring|) - (|;| - (== - (|characteristic| (|@Tuple|)) - ((|elt| S |characteristic|) (|@Tuple|))) - (== (* (|:| |i| |Integer|) (|:| |eq| $)) (* (|::| |i| S) |eq|))) - NIL)) - (|if| (|has| S |IntegralDomain|) - (== - (|factorAndSplit| |eq|) - (|;| - (|;| - (=> - (|has| S (|:| |factor| (-> S (|Factored| S)))) - (|;| - (|:=| |eq0| (|rightZero| |eq|)) - (COLLECT - (IN |rcf| (|factors| (|factor| (|lhs| |eq0|)))) - (|construct| (|equation| (|,| (|rcf| |factor|) 0)))))) - (=> - (|has| S (|Polynomial| |Integer|)) - (|;| + (|if| (|has| S |AbelianSemiGroup|) + (|;| + (|;| + (== + (+ |eq1| |eq2|) + (= + (+ (|eq1| |lhs|) (|eq2| |lhs|)) + (+ (|eq1| |rhs|) (|eq2| |rhs|)))) + (== (+ |s| |eq2|) (+ (|construct| (|,| |s| |s|)) |eq2|))) + (== (+ |eq1| |s|) (+ |eq1| (|construct| (|,| |s| |s|))))) + NIL)) + (|if| (|has| S |AbelianGroup|) (|;| (|;| - (|:=| |eq0| (|rightZero| |eq|)) - (==> MF - (|MultivariateFactorize| - (|,| - (|,| (|,| |Symbol| (|IndexedExponents| |Symbol|)) |Integer|) - (|Polynomial| |Integer|))))) - (|:=| - (|:| |p| (|Polynomial| |Integer|)) - (|pretend| (|lhs| |eq0|) (|Polynomial| |Integer|)))) - (COLLECT - (IN |rcf| (|factors| ((|elt| MF |factor|) |p|))) - (|construct| - (|equation| (|,| (|pretend| (|rcf| |factor|) S) 0))))))) - (|construct| |eq|))) - NIL)) - (|if| (|has| S (|PartialDifferentialRing| |Symbol|)) - (== - (|:| (|differentiate| (|,| (|:| |eq| $) (|:| |sym| |Symbol|))) $) - (|construct| - (|,| - (|differentiate| (|,| (|lhs| |eq|) |sym|)) - (|differentiate| (|,| (|rhs| |eq|) |sym|))))) - NIL)) - (|if| (|has| S |Field|) - (|;| - (|;| - (== (|dimension| (|@Tuple|)) (|::| 2 |CardinalNumber|)) - (== - (/ (|:| |eq1| $) (|:| |eq2| $)) - (= (/ (|eq1| |lhs|) (|eq2| |lhs|)) (/ (|eq1| |rhs|) (|eq2| |rhs|))))) - (== - (|inv| |eq|) - (|construct| (|,| (|inv| (|lhs| |eq|)) (|inv| (|rhs| |eq|)))))) - NIL)) - (|if| (|has| S |ExpressionSpace|) - (== - (|subst| (|,| |eq1| |eq2|)) - (|;| - (|:=| |eq3| (|pretend| |eq2| (|Equation| S))) - (|construct| - (|,| - (|subst| (|,| (|lhs| |eq1|) |eq3|)) - (|subst| (|,| (|rhs| |eq1|) |eq3|)))))) - NIL))))))) - -\end{verbatim} - -\defun{spad}{spad} -\catches{spad}{spad-reader} -\seebook{spad}{addBinding}{5} -\seebook{spad}{makeInitialModemapFrame}{5} -\seebook{spad}{init-boot/spad-reader}{5} -\calls{spad}{initialize-preparse} -\calls{spad}{preparse} -\calls{spad}{PARSE-NewExpr} -\calls{spad}{pop-stack-1} -\calls{spad}{s-process} -\calls{spad}{ioclear} -\seebook{spad}{shut}{5} -\usesdollar{spad}{noSubsumption} -\usesdollar{spad}{InteractiveFrame} -\usesdollar{spad}{InitialDomainsInScope} -\usesdollar{spad}{InteractiveMode} -\usesdollar{spad}{spad} -\usesdollar{spad}{boot} -\uses{spad}{curoutstream} -\uses{spad}{*fileactq-apply*} -\uses{spad}{line} -\uses{spad}{optionlist} -\uses{spad}{echo-meta} -\uses{spad}{/editfile} -\uses{spad}{*comp370-apply*} -\uses{spad}{*eof*} -\uses{spad}{file-closed} -\uses{spad}{boot-line-stack} -\catches{spad}{spad-reader} -\begin{chunk}{defun spad} -(defun spad (&optional (*spad-input-file* nil) (*spad-output-file* nil) - &aux (*comp370-apply* #'print-defun) - (*fileactq-apply* #'print-defun) - ($spad t) ($boot nil) (optionlist nil) (*eof* nil) - (file-closed nil) (/editfile *spad-input-file*) - (|$noSubsumption| |$noSubsumption|) in-stream out-stream) - (declare (special echo-meta /editfile *comp370-apply* *eof* curoutstream - file-closed |$noSubsumption| |$InteractiveFrame| - |$InteractiveMode| optionlist - boot-line-stack *fileactq-apply* $spad $boot)) - ;; only rebind |$InteractiveFrame| if compiling - (progv (if (not |$InteractiveMode|) '(|$InteractiveFrame|)) - (if (not |$InteractiveMode|) - (list (|addBinding| '|$DomainsInScope| - `((fluid . |true|)) - (|addBinding| '|$Information| nil - (|makeInitialModemapFrame|))))) - (init-boot/spad-reader) - (unwind-protect - (progn - (setq in-stream (if *spad-input-file* - (open *spad-input-file* :direction :input) - *standard-input*)) - (initialize-preparse in-stream) - (setq out-stream (if *spad-output-file* - (open *spad-output-file* :direction :output) - *standard-output*)) - (when *spad-output-file* - (format out-stream "~&;;; -*- Mode:Lisp; Package:Boot -*-~%~%") - (print-package "BOOT")) - (setq curoutstream out-stream) - (loop - (if (or *eof* file-closed) (return nil)) - (catch 'spad_reader - (if (setq boot-line-stack (preparse in-stream)) - (let ((line (cdar boot-line-stack))) - (declare (special line)) - (|PARSE-NewExpr|) - (let ((parseout (pop-stack-1)) ) - (when parseout - (let ((*standard-output* out-stream)) - (s-process parseout)) - (format out-stream "~&"))) - ))) - (ioclear in-stream out-stream))) - (if *spad-input-file* (shut in-stream)) - (if *spad-output-file* (shut out-stream))) - t)) - -\end{chunk} - -\defun{s-process}{Interpreter interface to the compiler} -\calls{s-process}{curstrm} -\calls{s-process}{def-rename} -\calls{s-process}{new2OldLisp} -\calls{s-process}{parseTransform} -\calls{s-process}{postTransform} -\calls{s-process}{displayPreCompilationErrors} -\calls{s-process}{prettyprint} -\seebook{s-process}{processInteractive}{5} -\calls{s-process}{compTopLevel} -\calls{s-process}{def-process} -\calls{s-process}{displaySemanticErrors} -\calls{s-process}{terpri} -\calls{s-process}{get-internal-run-time} -\usesdollar{s-process}{Index} -\usesdollar{s-process}{macroassoc} -\usesdollar{s-process}{newspad} -\usesdollar{s-process}{PolyMode} -\usesdollar{s-process}{EmptyMode} -\usesdollar{s-process}{compUniquelyIfTrue} -\usesdollar{s-process}{currentFunction} -\usesdollar{s-process}{postStack} -\usesdollar{s-process}{topOp} -\usesdollar{s-process}{semanticErrorStack} -\usesdollar{s-process}{warningStack} -\usesdollar{s-process}{exitMode} -\usesdollar{s-process}{exitModeStack} -\usesdollar{s-process}{returnMode} -\usesdollar{s-process}{leaveMode} -\usesdollar{s-process}{leaveLevelStack} -\usesdollar{s-process}{top-level} -\usesdollar{s-process}{insideFunctorIfTrue} -\usesdollar{s-process}{insideExpressionIfTrue} -\usesdollar{s-process}{insideCoerceInteractiveHardIfTrue} -\usesdollar{s-process}{insideWhereIfTrue} -\usesdollar{s-process}{insideCategoryIfTrue} -\usesdollar{s-process}{insideCapsuleFunctionIfTrue} -\usesdollar{s-process}{form} -\usesdollar{s-process}{DomainFrame} -\usesdollar{s-process}{e} -\usesdollar{s-process}{EmptyEnvironment} -\usesdollar{s-process}{genFVar} -\usesdollar{s-process}{genSDVar} -\usesdollar{s-process}{VariableCount} -\usesdollar{s-process}{previousTime} -\usesdollar{s-process}{LocalFrame} -\usesdollar{s-process}{Translation} -\usesdollar{s-process}{TranslateOnly} -\usesdollar{s-process}{PrintOnly} -\usesdollar{s-process}{currentLine} -\usesdollar{s-process}{InteractiveFrame} -\uses{s-process}{curoutstream} -\begin{chunk}{defun s-process} -(defun s-process (x) - (prog ((|$Index| 0) - ($macroassoc ()) - ($newspad t) - (|$PolyMode| |$EmptyMode|) - (|$compUniquelyIfTrue| nil) - |$currentFunction| - (|$postStack| nil) - |$topOp| - (|$semanticErrorStack| ()) - (|$warningStack| ()) - (|$exitMode| |$EmptyMode|) - (|$exitModeStack| ()) - (|$returnMode| |$EmptyMode|) - (|$leaveMode| |$EmptyMode|) - (|$leaveLevelStack| ()) - $top_level |$insideFunctorIfTrue| |$insideExpressionIfTrue| - |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| - |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| - (|$DomainFrame| '((NIL))) - (|$e| |$EmptyEnvironment|) - (|$genFVar| 0) - (|$genSDVar| 0) - (|$VariableCount| 0) - (|$previousTime| (get-internal-run-time)) - (|$LocalFrame| '((NIL))) - (curstrm curoutstream) |$s| |$x| |$m| u) - (declare (special |$Index| $macroassoc $newspad |$PolyMode| |$EmptyMode| - |$compUniquelyIfTrue| |$currentFunction| |$postStack| |$topOp| - |$semanticErrorStack| |$warningStack| |$exitMode| |$exitModeStack| - |$returnMode| |$leaveMode| |$leaveLevelStack| $top_level - |$insideFunctorIfTrue| |$insideExpressionIfTrue| - |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| - |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| - |$DomainFrame| |$e| |$EmptyEnvironment| |$genFVar| |$genSDVar| - |$VariableCount| |$previousTime| |$LocalFrame| - curstrm |$s| |$x| |$m| curoutstream $traceflag |$Translation| - |$TranslateOnly| |$PrintOnly| |$currentLine| |$InteractiveFrame|)) - (setq $traceflag t) - (if (not x) (return nil)) - (if $boot - (setq x (def-rename (new2OldLisp x))) - (setq x (|parseTransform| (postTransform x)))) - (when |$TranslateOnly| (return (setq |$Translation| x))) - (when |$postStack| (|displayPreCompilationErrors|) (return nil)) - (when |$PrintOnly| - (format t "~S =====>~%" |$currentLine|) - (return (prettyprint x))) - (if (not $boot) - (if |$InteractiveMode| - (|processInteractive| x nil) - (when (setq u (|compTopLevel| x |$EmptyMode| |$InteractiveFrame|)) - (setq |$InteractiveFrame| (third u)))) - (def-process x)) - (when |$semanticErrorStack| (|displaySemanticErrors|)) - (terpri))) + (|;| + (|;| + (|;| + (|;| + (== (- |eq|) (= (- (|lhs| |eq|)) (- (|rhs| |eq|)))) + (== (- |s| |eq2|) (- (|construct| (|,| |s| |s|)) |eq2|))) + (== (- |eq1| |s|) (- |eq1| (|construct| (|,| |s| |s|))))) + (== (|leftZero| |eq|) (= 0 (- (|rhs| |eq|) (|lhs| |eq|))))) + (== (|rightZero| |eq|) (= (- (|lhs| |eq|) (|rhs| |eq|)) 0))) + (== 0 (|equation| (|,| (|elt| S 0) (|elt| S 0))))) + (== + (- |eq1| |eq2|) + (= + (- (|eq1| |lhs|) (|eq2| |lhs|)) + (- (|eq1| |rhs|) (|eq2| |rhs|))))) + NIL)) + (|if| (|has| S |SemiGroup|) + (|;| + (|;| + (|;| + (== + (* (|:| |eq1| $) (|:| |eq2| $)) + (= + (* (|eq1| |lhs|) (|eq2| |lhs|)) + (* (|eq1| |rhs|) (|eq2| |rhs|)))) + (== + (* (|:| |l| S) (|:| |eqn| $)) + (= (* |l| (|eqn| |lhs|)) (* |l| (|eqn| |rhs|))))) + (== + (* (|:| |l| S) (|:| |eqn| $)) + (= (* |l| (|eqn| |lhs|)) (* |l| (|eqn| |rhs|))))) + (== + (* (|:| |eqn| $) (|:| |l| S)) + (= (* (|eqn| |lhs|) |l|) (* (|eqn| |rhs|) |l|)))) + NIL)) + (|if| (|has| S |Monoid|) + (|;| + (|;| + (|;| + (== 1 (|equation| (|,| (|elt| S 1) (|elt| S 1)))) + (== + (|recip| |eq|) + (|;| + (|;| + (=> (|case| (|:=| |lh| (|recip| (|lhs| |eq|))) "failed") + "failed") + (=> (|case| (|:=| |rh| (|recip| (|rhs| |eq|))) "failed") + "failed")) + (|construct| (|,| (|::| |lh| S) (|::| |rh| S)))))) + (== + (|leftOne| |eq|) + (|;| + (=> (|case| (|:=| |re| (|recip| (|lhs| |eq|))) "failed") + "failed") + (= 1 (* (|rhs| |eq|) |re|))))) + (== + (|rightOne| |eq|) + (|;| + (=> (|case| (|:=| |re| (|recip| (|rhs| |eq|))) "failed") + "failed") + (= (* (|lhs| |eq|) |re|) 1)))) + NIL)) + (|if| (|has| S |Group|) + (|;| + (|;| + (== + (|inv| |eq|) + (|construct| (|,| (|inv| (|lhs| |eq|)) (|inv| (|rhs| |eq|))))) + (== (|leftOne| |eq|) (= 1 (* (|rhs| |eq|) (|inv| (|rhs| |eq|)))))) + (== (|rightOne| |eq|) (= (* (|lhs| |eq|) (|inv| (|rhs| |eq|))) 1))) + NIL)) + (|if| (|has| S |Ring|) + (|;| + (== + (|characteristic| (|@Tuple|)) + ((|elt| S |characteristic|) (|@Tuple|))) + (== (* (|:| |i| |Integer|) (|:| |eq| $)) (* (|::| |i| S) |eq|))) + NIL)) + (|if| (|has| S |IntegralDomain|) + (== + (|factorAndSplit| |eq|) + (|;| + (|;| + (=> + (|has| S (|:| |factor| (-> S (|Factored| S)))) + (|;| + (|:=| |eq0| (|rightZero| |eq|)) + (COLLECT + (IN |rcf| (|factors| (|factor| (|lhs| |eq0|)))) + (|construct| (|equation| (|,| (|rcf| |factor|) 0)))))) + (=> + (|has| S (|Polynomial| |Integer|)) + (|;| + (|;| + (|;| + (|:=| |eq0| (|rightZero| |eq|)) + (==> MF + (|MultivariateFactorize| + (|,| + (|,| (|,| |Symbol| (|IndexedExponents| |Symbol|)) |Integer|) + (|Polynomial| |Integer|))))) + (|:=| + (|:| |p| (|Polynomial| |Integer|)) + (|pretend| (|lhs| |eq0|) (|Polynomial| |Integer|)))) + (COLLECT + (IN |rcf| (|factors| ((|elt| MF |factor|) |p|))) + (|construct| + (|equation| (|,| (|pretend| (|rcf| |factor|) S) 0))))))) + (|construct| |eq|))) + NIL)) + (|if| (|has| S (|PartialDifferentialRing| |Symbol|)) + (== + (|:| (|differentiate| (|,| (|:| |eq| $) (|:| |sym| |Symbol|))) $) + (|construct| + (|,| + (|differentiate| (|,| (|lhs| |eq|) |sym|)) + (|differentiate| (|,| (|rhs| |eq|) |sym|))))) + NIL)) + (|if| (|has| S |Field|) + (|;| + (|;| + (== (|dimension| (|@Tuple|)) (|::| 2 |CardinalNumber|)) + (== + (/ (|:| |eq1| $) (|:| |eq2| $)) + (= (/ (|eq1| |lhs|) (|eq2| |lhs|)) (/ (|eq1| |rhs|) (|eq2| |rhs|))))) + (== + (|inv| |eq|) + (|construct| (|,| (|inv| (|lhs| |eq|)) (|inv| (|rhs| |eq|)))))) + NIL)) + (|if| (|has| S |ExpressionSpace|) + (== + (|subst| (|,| |eq1| |eq2|)) + (|;| + (|:=| |eq3| (|pretend| |eq2| (|Equation| S))) + (|construct| + (|,| + (|subst| (|,| (|lhs| |eq1|) |eq3|)) + (|subst| (|,| (|rhs| |eq1|) |eq3|)))))) + NIL))))))) -\end{chunk} +\end{verbatim} \defun{print-defun}{print-defun} \calls{print-defun}{is-console} @@ -23496,50 +23988,6 @@ And the {\bf s-process} function which returns a parsed version of the input. \end{chunk} -\defun{compTopLevel}{compTopLevel} -\calls{compTopLevel}{newComp} -\calls{compTopLevel}{compOrCroak} -\usesdollar{compTopLevel}{NRTderivedTargetIfTrue} -\usesdollar{compTopLevel}{killOptimizeIfTrue} -\usesdollar{compTopLevel}{forceAdd} -\usesdollar{compTopLevel}{compTimeSum} -\usesdollar{compTopLevel}{resolveTimeSum} -\usesdollar{compTopLevel}{packagesUsed} -\usesdollar{compTopLevel}{envHashTable} -\begin{chunk}{defun compTopLevel} -(defun |compTopLevel| (form mode env) - (let (|$NRTderivedTargetIfTrue| |$killOptimizeIfTrue| |$forceAdd| - |$compTimeSum| |$resolveTimeSum| |$packagesUsed| |$envHashTable| - t1 t2 t3 val newmode) - (declare (special |$NRTderivedTargetIfTrue| |$killOptimizeIfTrue| - |$forceAdd| |$compTimeSum| |$resolveTimeSum| - |$packagesUsed| |$envHashTable| )) - (setq |$NRTderivedTargetIfTrue| nil) - (setq |$killOptimizeIfTrue| nil) - (setq |$forceAdd| nil) - (setq |$compTimeSum| 0) - (setq |$resolveTimeSum| 0) - (setq |$packagesUsed| NIL) - (setq |$envHashTable| (make-hashtable 'equal)) - (dolist (u (car (car env))) - (dolist (v (cdr u)) - (hput |$envHashTable| (cons (car u) (cons (car v) nil)) t))) - (cond - ((or (and (consp form) (eq (qfirst form) 'def)) - (and (consp form) (eq (qfirst form) '|where|) - (progn - (setq t1 (qrest form)) - (and (consp t1) - (progn - (setq t2 (qfirst t1)) - (and (consp t2) (eq (qfirst t2) 'def))))))) - (setq t3 (|compOrCroak| form mode env)) - (setq val (car t3)) - (setq newmode (second t3)) - (cons val (cons newmode (cons env nil)))) - (t (|compOrCroak| form mode env))))) - -\end{chunk} Given: \begin{verbatim} CohenCategory(): Category == SetCategory with @@ -24100,7 +24548,9 @@ preferred to the underlying representation -- RDJ 9/12/83 (t nil))) \end{chunk} + \defun{compSymbol}{compSymbol} +\calls{compSymbol}{isFluid} \calls{compSymbol}{getmode} \calls{compSymbol}{get} \calls{compSymbol}{NRTgetLocalIndex} @@ -24182,21 +24632,6 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} -\defun{compExpression}{compExpression} -\calls{compExpression}{getl} -\calls{compExpression}{compForm} -\usesdollar{compExpression}{insideExpressionIfTrue} -\begin{chunk}{defun compExpression} -(defun |compExpression| (form mode env) - (let (|$insideExpressionIfTrue| fn) - (declare (special |$insideExpressionIfTrue|)) - (setq |$insideExpressionIfTrue| t) - (if (and (atom (car form)) (setq fn (getl (car form) 'special))) - (funcall fn form mode env) - (|compForm| form mode env)))) - -\end{chunk} - \defun{compForm}{compForm} \calls{compForm}{compForm1} \calls{compForm}{compArgumentsAndTryAgain} @@ -24211,6 +24646,8 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} \defun{compForm1}{compForm1} +This function is called if a keyword is found in a compile form +but there is no handler listed for the form (See \ref{handlers}). \calls{compForm1}{length} \calls{compForm1}{outputComp} \calls{compForm1}{compOrCroak} @@ -24398,8 +24835,6 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} \defun{getFormModemaps}{getFormModemaps} -\calls{getFormModemaps}{qcar} -\calls{getFormModemaps}{qcdr} \calls{getFormModemaps}{getFormModemaps} \calls{getFormModemaps}{nreverse0} \calls{getFormModemaps}{get} @@ -24448,8 +24883,6 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} \defun{eltModemapFilter}{eltModemapFilter} -\calls{eltModemapFilter}{qcar} -\calls{eltModemapFilter}{qcdr} \calls{eltModemapFilter}{isConstantId} \calls{eltModemapFilter}{stackMessage} \begin{chunk}{defun eltModemapFilter} @@ -24846,8 +25279,6 @@ preferred to the underlying representation -- RDJ 9/12/83 \defun{compWithMappingMode1}{compWithMappingMode1} \calls{compWithMappingMode1}{isFunctor} \calls{compWithMappingMode1}{get} -\calls{compWithMappingMode1}{qcar} -\calls{compWithMappingMode1}{qcdr} \calls{compWithMappingMode1}{extendsCategoryForm} \calls{compWithMappingMode1}{compLambda} \calls{compWithMappingMode1}{stackAndThrow} @@ -25286,68 +25717,6 @@ symbol in the free list are represented by the alist (symbol . count) \end{chunk} -\defun{compileSpadLispCmd}{compileSpadLispCmd} -\seebook{compileSpadLispCmd}{pathname}{5} -\seebook{compileSpadLispCmd}{pathnameType}{5} -\seebook{compileSpadLispCmd}{selectOptionLC}{5} -\seebook{compileSpadLispCmd}{namestring}{5} -\seebook{compileSpadLispCmd}{terminateSystemCommand}{5} -\seebook{compileSpadLispCmd}{fnameMake}{5} -\seebook{compileSpadLispCmd}{pathnameDirectory}{5} -\seebook{compileSpadLispCmd}{pathnameName}{5} -\seebook{compileSpadLispCmd}{fnameReadable?}{5} -\seebook{compileSpadLispCmd}{localdatabase}{5} -\calls{compileSpadLispCmd}{throwKeyedMsg} -\calls{compileSpadLispCmd}{object2String} -\seebook{compileSpadLispCmd}{sayKeyedMsg}{5} -\calls{compileSpadLispCmd}{recompile-lib-file-if-necessary} -\calls{compileSpadLispCmd}{spadPrompt} -\usesdollar{compileSpadLispCmd}{options} -\begin{chunk}{defun compileSpadLispCmd} -(defun |compileSpadLispCmd| (args) - (let (path optlist optname optargs beQuiet dolibrary lsp) - (declare (special |$options|)) - (setq path (|pathname| (|fnameMake| (car args) "code" "lsp"))) - (cond - ((null (probe-file path)) - (|throwKeyedMsg| 's2il0003 (cons (|namestring| args) nil))) - (t - (setq optlist '(|quiet| |noquiet| |library| |nolibrary|)) - (setq beQuiet nil) - (setq dolibrary t) - (dolist (opt |$options|) - (setq optname (car opt)) - (setq optargs (cdr opt)) - (case (|selectOptionLC| optname optlist nil) - (|quiet| (setq beQuiet t)) - (|noquiet| (setq beQuiet nil)) - (|library| (setq dolibrary t)) - (|nolibrary| (setq dolibrary nil)) - (t - (|throwKeyedMsg| 's2iz0036 - (list (strconc ")" (|object2String| optname))))))) - (setq lsp - (|fnameMake| - (|pathnameDirectory| path) - (|pathnameName| path) - (|pathnameType| path))) - (cond - ((|fnameReadable?| lsp) - (unless beQuiet (|sayKeyedMsg| 's2iz0089 (list (|namestring| lsp)))) - (recompile-lib-file-if-necessary lsp)) - (t - (|sayKeyedMsg| 's2il0003 (list (|namestring| lsp))))) - (cond - (dolibrary - (unless beQuiet (|sayKeyedMsg| 's2iz0090 (list (|pathnameName| path)))) - (localdatabase (list (|pathnameName| (car args))) nil)) - ((null beQuiet) (|sayKeyedMsg| 's2iz0084 nil)) - (t nil)) - (|terminateSystemCommand|) - (|spadPrompt|))))) - -\end{chunk} - \defun{recompile-lib-file-if-necessary}{recompile-lib-file-if-necessary} \calls{recompile-lib-file-if-necessary}{compile-lib-file} \uses{recompile-lib-file-if-necessary}{*lisp-bin-filetype*} @@ -25693,6 +26062,7 @@ The current input line. \getchunk{defun blankp} \getchunk{defun bootStrapError} +\getchunk{defun buildLibdb} \getchunk{defun bumperrorcount} \getchunk{defun canReturn} @@ -25730,7 +26100,6 @@ The current input line. \getchunk{defun checkLookForLeftBrace} \getchunk{defun checkLookForRightBrace} \getchunk{defun checkNumOfArgs} -\getchunk{defun checkTexht} \getchunk{defun checkRecordHash} \getchunk{defun checkRemoveComments} \getchunk{defun checkRewrite} @@ -25908,6 +26277,7 @@ The current input line. \getchunk{defun evalAndRwriteLispForm} \getchunk{defun evalAndSub} \getchunk{defun expand-tabs} +\getchunk{defun extendLocalLibdb} \getchunk{defun extractCodeAndConstructTriple} \getchunk{defun flattenSignatureList} @@ -26296,6 +26666,8 @@ The current input line. \getchunk{defun replaceVars} \getchunk{defun resolve} \getchunk{defun reportOnFunctorCompilation} +\getchunk{defun /rf} +\getchunk{defun /rq} \getchunk{defun /rf-1} \getchunk{defun /RQ,LIB} \getchunk{defun rwriteLispForm} diff --git a/books/ps/v9compdefine.eps b/books/ps/v9compdefine.eps new file mode 100644 index 0000000..cee9425 --- /dev/null +++ b/books/ps/v9compdefine.eps @@ -0,0 +1,1076 @@ +%!PS-Adobe-3.0 EPSF-3.0 +%%Creator: graphviz version 2.26.3 (20100126.1600) +%%Title: pic +%%Pages: 1 +%%BoundingBox: 36 36 1204 440 +%%EndComments +save +%%BeginProlog +/DotDict 200 dict def +DotDict begin + +/setupLatin1 { +mark +/EncodingVector 256 array def + EncodingVector 0 + +ISOLatin1Encoding 0 255 getinterval putinterval +EncodingVector 45 /hyphen put + +% Set up ISO Latin 1 character encoding +/starnetISO { + dup dup findfont dup length dict begin + { 1 index /FID ne { def }{ pop pop } ifelse + } forall + /Encoding EncodingVector def + currentdict end definefont +} def +/Times-Roman starnetISO def +/Times-Italic starnetISO def +/Times-Bold starnetISO def +/Times-BoldItalic starnetISO def +/Helvetica starnetISO def +/Helvetica-Oblique starnetISO def +/Helvetica-Bold starnetISO def +/Helvetica-BoldOblique starnetISO def +/Courier starnetISO def +/Courier-Oblique starnetISO def +/Courier-Bold starnetISO def +/Courier-BoldOblique starnetISO def +cleartomark +} bind def + +%%BeginResource: procset graphviz 0 0 +/coord-font-family /Times-Roman def +/default-font-family /Times-Roman def +/coordfont coord-font-family findfont 8 scalefont def + +/InvScaleFactor 1.0 def +/set_scale { + dup 1 exch div /InvScaleFactor exch def + scale +} bind def + +% styles +/solid { [] 0 setdash } bind def +/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def +/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def +/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def +/bold { 2 setlinewidth } bind def +/filled { } bind def +/unfilled { } bind def +/rounded { } bind def +/diagonals { } bind def + +% hooks for setting color +/nodecolor { sethsbcolor } bind def +/edgecolor { sethsbcolor } bind def +/graphcolor { sethsbcolor } bind def +/nopcolor {pop pop pop} bind def + +/beginpage { % i j npages + /npages exch def + /j exch def + /i exch def + /str 10 string def + npages 1 gt { + gsave + coordfont setfont + 0 0 moveto + (\() show i str cvs show (,) show j str cvs show (\)) show + grestore + } if +} bind def + +/set_font { + findfont exch + scalefont setfont +} def + +% draw text fitted to its expected width +/alignedtext { % width text + /text exch def + /width exch def + gsave + width 0 gt { + [] 0 setdash + text stringwidth pop width exch sub text length div 0 text ashow + } if + grestore +} def + +/boxprim { % xcorner ycorner xsize ysize + 4 2 roll + moveto + 2 copy + exch 0 rlineto + 0 exch rlineto + pop neg 0 rlineto + closepath +} bind def + +/ellipse_path { + /ry exch def + /rx exch def + /y exch def + /x exch def + matrix currentmatrix + newpath + x y translate + rx ry scale + 0 0 1 0 360 arc + setmatrix +} bind def + +/endpage { showpage } bind def +/showpage { } def + +/layercolorseq + [ % layer color sequence - darkest to lightest + [0 0 0] + [.2 .8 .8] + [.4 .8 .8] + [.6 .8 .8] + [.8 .8 .8] + ] +def + +/layerlen layercolorseq length def + +/setlayer {/maxlayer exch def /curlayer exch def + layercolorseq curlayer 1 sub layerlen mod get + aload pop sethsbcolor + /nodecolor {nopcolor} def + /edgecolor {nopcolor} def + /graphcolor {nopcolor} def +} bind def + +/onlayer { curlayer ne {invis} if } def + +/onlayers { + /myupper exch def + /mylower exch def + curlayer mylower lt + curlayer myupper gt + or + {invis} if +} def + +/curlayer 0 def + +%%EndResource +%%EndProlog +%%BeginSetup +14 default-font-family set_font +1 setmiterlimit +% /arrowlength 10 def +% /arrowwidth 5 def + +% make sure pdfmark is harmless for PS-interpreters other than Distiller +/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse +% make '<<' and '>>' safe on PS Level 1 devices +/languagelevel where {pop languagelevel}{1} ifelse +2 lt { + userdict (<<) cvn ([) cvn load put + userdict (>>) cvn ([) cvn load put +} if + +%%EndSetup +setupLatin1 +%%Page: 1 1 +%%PageBoundingBox: 36 36 1204 440 +%%PageOrientation: Portrait +0 0 1 beginpage +gsave +36 36 1168 404 boxprim clip newpath +1 1 set_scale 0 rotate 40 41 translate +0.16355 0.45339 0.92549 graphcolor +newpath -4 -5 moveto +-4 400 lineto +1164.67 400 lineto +1164.67 -5 lineto +closepath fill +1 setlinewidth +0.16355 0.45339 0.92549 graphcolor +newpath -4 -5 moveto +-4 400 lineto +1164.67 400 lineto +1164.67 -5 lineto +closepath stroke +% compArgumentConditions +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 561 108 moveto +367 108 lineto +367 72 lineto +561 72 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 561 108 moveto +367 108 lineto +367 72 lineto +561 72 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +375 86.4 moveto 178 (compArgumentConditions) alignedtext +grestore +% compDefWhereClause +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 584 180 moveto +416 180 lineto +416 144 lineto +584 144 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 584 180 moveto +416 180 lineto +416 144 lineto +584 144 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +423.5 158.4 moveto 153 (compDefWhereClause) alignedtext +grestore +% compDefine +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 726 324 moveto +628 324 lineto +628 288 lineto +726 288 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 726 324 moveto +628 324 lineto +628 288 lineto +726 288 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +636 302.4 moveto 82 (compDefine) alignedtext +grestore +% compDefine1 +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 730 252 moveto +624 252 lineto +624 216 lineto +730 216 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 730 252 moveto +624 252 lineto +624 216 lineto +730 216 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +631.5 230.4 moveto 91 (compDefine1) alignedtext +grestore +% compDefine->compDefine1 +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 677 287.83 moveto +677 280.13 677 270.97 677 262.42 curveto +stroke +0 0 0 edgecolor +newpath 680.5 262.41 moveto +677 252.41 lineto +673.5 262.41 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 680.5 262.41 moveto +677 252.41 lineto +673.5 262.41 lineto +closepath stroke +grestore +% compDefine1->compDefWhereClause +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 632.34 215.83 moveto +608.45 206.12 578.87 194.08 553.74 183.86 curveto +stroke +0 0 0 edgecolor +newpath 554.93 180.56 moveto +544.34 180.04 lineto +552.29 187.05 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 554.93 180.56 moveto +544.34 180.04 lineto +552.29 187.05 lineto +closepath stroke +grestore +% compDefineAddSignature +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 960 180 moveto +770 180 lineto +770 144 lineto +960 144 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 960 180 moveto +770 180 lineto +770 144 lineto +960 144 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +777.5 158.4 moveto 175 (compDefineAddSignature) alignedtext +grestore +% compDefine1->compDefineAddSignature +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 724.44 215.83 moveto +749.92 206.07 781.5 193.98 808.28 183.72 curveto +stroke +0 0 0 edgecolor +newpath 809.81 186.88 moveto +817.9 180.04 lineto +807.31 180.35 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 809.81 186.88 moveto +817.9 180.04 lineto +807.31 180.35 lineto +closepath stroke +grestore +% compDefineCapsuleFunction +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 398 180 moveto +188 180 lineto +188 144 lineto +398 144 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 398 180 moveto +188 180 lineto +188 144 lineto +398 144 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +195.5 158.4 moveto 195 (compDefineCapsuleFunction) alignedtext +grestore +% compDefine1->compDefineCapsuleFunction +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 623.61 223.99 moveto +565.84 213.16 472.23 195.61 399.34 181.94 curveto +stroke +0 0 0 edgecolor +newpath 399.67 178.44 moveto +389.19 180.04 lineto +398.38 185.32 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 399.67 178.44 moveto +389.19 180.04 lineto +398.38 185.32 lineto +closepath stroke +grestore +% compDefineCategory +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 834 396 moveto +674 396 lineto +674 360 lineto +834 360 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 834 396 moveto +674 396 lineto +674 360 lineto +834 360 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +681.5 374.4 moveto 145 (compDefineCategory) alignedtext +grestore +% compDefine1->compDefineCategory +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 702.72 252.08 moveto +714.28 261.5 727.08 273.99 735 288 curveto +745.71 306.94 750.4 331.22 752.45 349.78 curveto +stroke +0 0 0 edgecolor +newpath 748.98 350.33 moveto +753.37 359.97 lineto +755.95 349.69 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 748.98 350.33 moveto +753.37 359.97 lineto +755.95 349.69 lineto +closepath stroke +grestore +% compDefineFunctor +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 752 180 moveto +602 180 lineto +602 144 lineto +752 144 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 752 180 moveto +602 180 lineto +602 144 lineto +752 144 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +610 158.4 moveto 134 (compDefineFunctor) alignedtext +grestore +% compDefine1->compDefineFunctor +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 677 215.83 moveto +677 208.13 677 198.97 677 190.42 curveto +stroke +0 0 0 edgecolor +newpath 680.5 190.41 moveto +677 180.41 lineto +673.5 190.41 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 680.5 190.41 moveto +677 180.41 lineto +673.5 190.41 lineto +closepath stroke +grestore +% compInternalFunction +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 1144 180 moveto +978 180 lineto +978 144 lineto +1144 144 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 1144 180 moveto +978 180 lineto +978 144 lineto +1144 144 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +985.5 158.4 moveto 151 (compInternalFunction) alignedtext +grestore +% compDefine1->compInternalFunction +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 730.05 224.36 moveto +786.47 214.07 878.6 197.15 967.75 180.23 curveto +stroke +0 0 0 edgecolor +newpath 968.59 183.63 moveto +977.76 178.33 lineto +967.28 176.75 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 968.59 183.63 moveto +977.76 178.33 lineto +967.28 176.75 lineto +closepath stroke +grestore +% compDefineCapsuleFunction->compArgumentConditions +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 336.15 143.83 moveto +359.12 134.16 387.55 122.19 411.76 111.99 curveto +stroke +0 0 0 edgecolor +newpath 413.3 115.14 moveto +421.16 108.04 lineto +410.59 108.69 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 413.3 115.14 moveto +421.16 108.04 lineto +410.59 108.69 lineto +closepath stroke +grestore +% compOrCroak +gsave +0 0 1 nodecolor +newpath 223 108 moveto +113 108 lineto +113 72 lineto +223 72 lineto +closepath fill +1 setlinewidth +filled +0 0 1 nodecolor +newpath 223 108 moveto +113 108 lineto +113 72 lineto +223 72 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +121 86.4 moveto 94 (compOrCroak) alignedtext +grestore +% compDefineCapsuleFunction->compOrCroak +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 261.46 143.83 moveto +245.32 134.54 225.5 123.12 208.27 113.2 curveto +stroke +0 0 0 edgecolor +newpath 209.94 110.12 moveto +199.53 108.16 lineto +206.45 116.19 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 209.94 110.12 moveto +199.53 108.16 lineto +206.45 116.19 lineto +closepath stroke +grestore +% compileCases +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 349 108 moveto +241 108 lineto +241 72 lineto +349 72 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 349 108 moveto +241 108 lineto +241 72 lineto +349 72 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +249 86.4 moveto 92 (compileCases) alignedtext +grestore +% compDefineCapsuleFunction->compileCases +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 293.5 143.83 moveto +293.72 136.13 293.97 126.97 294.21 118.42 curveto +stroke +0 0 0 edgecolor +newpath 297.71 118.51 moveto +294.49 108.41 lineto +290.71 118.31 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 297.71 118.51 moveto +294.49 108.41 lineto +290.71 118.31 lineto +closepath stroke +grestore +% compDefineCategory1 +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 610 324 moveto +440 324 lineto +440 288 lineto +610 288 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 610 324 moveto +440 324 lineto +440 288 lineto +610 288 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +448 302.4 moveto 154 (compDefineCategory1) alignedtext +grestore +% compDefineCategory->compDefineCategory1 +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 696.51 359.92 moveto +664.8 349.95 625.25 337.52 592.12 327.1 curveto +stroke +0 0 0 edgecolor +newpath 593.1 323.74 moveto +582.51 324.08 lineto +591 330.42 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 593.1 323.74 moveto +582.51 324.08 lineto +591 330.42 lineto +closepath stroke +grestore +% compDefineLisplib +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 1072 108 moveto +932 108 lineto +932 72 lineto +1072 72 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 1072 108 moveto +932 108 lineto +932 72 lineto +1072 72 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +940 86.4 moveto 124 (compDefineLisplib) alignedtext +grestore +% compDefineCategory->compDefineLisplib +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 834.12 364.09 moveto +929.15 342.82 1083.41 292.22 1153 180 curveto +1161.43 166.4 1162.21 157.08 1153 144 curveto +1143.92 131.11 1113.31 119.05 1082 109.62 curveto +stroke +0 0 0 edgecolor +newpath 1082.86 106.22 moveto +1072.28 106.77 lineto +1080.9 112.94 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 1082.86 106.22 moveto +1072.28 106.77 lineto +1080.9 112.94 lineto +closepath stroke +grestore +% compDefineCategory1->compDefine1 +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 563.36 287.83 moveto +583.5 278.29 608.38 266.51 629.71 256.4 curveto +stroke +0 0 0 edgecolor +newpath 631.38 259.48 moveto +638.92 252.04 lineto +628.38 253.16 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 631.38 259.48 moveto +638.92 252.04 lineto +628.38 253.16 lineto +closepath stroke +grestore +% compDefineCategory2 +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 170 180 moveto +0 180 lineto +0 144 lineto +170 144 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 170 180 moveto +0 180 lineto +0 144 lineto +170 144 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +8 158.4 moveto 154 (compDefineCategory2) alignedtext +grestore +% compDefineCategory1->compDefineCategory2 +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 469.72 287.91 moveto +388.27 261.25 236.33 211.53 149.76 183.2 curveto +stroke +0 0 0 edgecolor +newpath 150.65 179.8 moveto +140.05 180.02 lineto +148.47 186.45 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 150.65 179.8 moveto +140.05 180.02 lineto +148.47 186.45 lineto +closepath stroke +grestore +% compMakeDeclaration +gsave +0 0 1 nodecolor +newpath 187 36 moveto +19 36 lineto +19 0 lineto +187 0 lineto +closepath fill +1 setlinewidth +filled +0 0 1 nodecolor +newpath 187 36 moveto +19 36 lineto +19 0 lineto +187 0 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +27 14.4 moveto 152 (compMakeDeclaration) alignedtext +grestore +% compDefineCategory2->compMakeDeclaration +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 77.75 143.82 moveto +71.45 125.46 64.31 96.4 71 72 curveto +73.58 62.58 78.27 53.14 83.29 44.85 curveto +stroke +0 0 0 edgecolor +newpath 86.29 46.66 moveto +88.76 36.36 lineto +80.4 42.86 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 86.29 46.66 moveto +88.76 36.36 lineto +80.4 42.86 lineto +closepath stroke +grestore +% compDefineCategory2->compOrCroak +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 105.94 143.83 moveto +116.07 135.05 128.38 124.37 139.35 114.85 curveto +stroke +0 0 0 edgecolor +newpath 141.8 117.36 moveto +147.06 108.16 lineto +137.21 112.07 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 141.8 117.36 moveto +147.06 108.16 lineto +137.21 112.07 lineto +closepath stroke +grestore +% compile +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 329 36 moveto +261 36 lineto +261 0 lineto +329 0 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 329 36 moveto +261 36 lineto +261 0 lineto +329 0 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +269 14.4 moveto 52 (compile) alignedtext +grestore +% compDefineCategory2->compile +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 83.69 143.99 moveto +83.25 123.85 85.79 91.48 104 72 curveto +123.92 50.69 201.06 33.94 251 25.05 curveto +stroke +0 0 0 edgecolor +newpath 251.66 28.49 moveto +260.91 23.32 lineto +250.46 21.59 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 251.66 28.49 moveto +260.91 23.32 lineto +250.46 21.59 lineto +closepath stroke +grestore +% compDefineFunctor1 +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 737 108 moveto +579 108 lineto +579 72 lineto +737 72 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 737 108 moveto +579 108 lineto +579 72 lineto +737 72 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +586.5 86.4 moveto 143 (compDefineFunctor1) alignedtext +grestore +% compDefineFunctor->compDefineFunctor1 +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 672.21 143.83 moveto +670.15 136.05 667.7 126.77 665.42 118.13 curveto +stroke +0 0 0 edgecolor +newpath 668.79 117.19 moveto +662.86 108.41 lineto +662.03 118.98 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 668.79 117.19 moveto +662.86 108.41 lineto +662.03 118.98 lineto +closepath stroke +grestore +% compDefineFunctor->compDefineLisplib +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 752.38 145.3 moveto +803.2 134.04 870.17 119.21 921.94 107.74 curveto +stroke +0 0 0 edgecolor +newpath 922.75 111.14 moveto +931.76 105.56 lineto +921.23 104.31 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 922.75 111.14 moveto +931.76 105.56 lineto +921.23 104.31 lineto +closepath stroke +grestore +% compDefineFunctor1->compMakeDeclaration +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 578.91 73.48 moveto +575.9 72.96 572.93 72.46 570 72 curveto +429.52 49.73 393.27 52.53 252 36 curveto +234.31 33.93 215.45 31.68 197.3 29.5 curveto +stroke +0 0 0 edgecolor +newpath 197.65 26.02 moveto +187.3 28.3 lineto +196.81 32.97 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 197.65 26.02 moveto +187.3 28.3 lineto +196.81 32.97 lineto +closepath stroke +grestore +% compFunctorBody +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 728 36 moveto +588 36 lineto +588 0 lineto +728 0 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 728 36 moveto +588 36 lineto +588 0 lineto +728 0 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +596 14.4 moveto 124 (compFunctorBody) alignedtext +grestore +% compDefineFunctor1->compFunctorBody +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 658 71.83 moveto +658 64.13 658 54.97 658 46.42 curveto +stroke +0 0 0 edgecolor +newpath 661.5 46.41 moveto +658 36.41 lineto +654.5 46.41 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 661.5 46.41 moveto +658 36.41 lineto +654.5 46.41 lineto +closepath stroke +grestore +% compDefineFunctor1->compile +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 578.85 73.78 moveto +575.86 73.18 572.91 72.58 570 72 curveto +488.66 55.69 393.67 37.15 339.31 26.59 curveto +stroke +0 0 0 edgecolor +newpath 339.8 23.12 moveto +329.32 24.65 lineto +338.46 29.99 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 339.8 23.12 moveto +329.32 24.65 lineto +338.46 29.99 lineto +closepath stroke +grestore +% compileDocumentation +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 1089 36 moveto +915 36 lineto +915 0 lineto +1089 0 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 1089 36 moveto +915 36 lineto +915 0 lineto +1089 0 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +922.5 14.4 moveto 159 (compileDocumentation) alignedtext +grestore +% compDefineLisplib->compileDocumentation +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 1002 71.83 moveto +1002 64.13 1002 54.97 1002 46.42 curveto +stroke +0 0 0 edgecolor +newpath 1005.5 46.41 moveto +1002 36.41 lineto +998.5 46.41 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 1005.5 46.41 moveto +1002 36.41 lineto +998.5 46.41 lineto +closepath stroke +grestore +% compileCases->compile +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 295 71.83 moveto +295 64.13 295 54.97 295 46.42 curveto +stroke +0 0 0 edgecolor +newpath 298.5 46.41 moveto +295 36.41 lineto +291.5 46.41 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 298.5 46.41 moveto +295 36.41 lineto +291.5 46.41 lineto +closepath stroke +grestore +endpage +showpage +grestore +%%PageTrailer +%%EndPage: 1 +%%Trailer +end +restore +%%EOF diff --git a/books/ps/v9compiler.eps b/books/ps/v9compiler.eps new file mode 100644 index 0000000..6d9f48b --- /dev/null +++ b/books/ps/v9compiler.eps @@ -0,0 +1,770 @@ +%!PS-Adobe-3.0 EPSF-3.0 +%%Creator: graphviz version 2.26.3 (20100126.1600) +%%Title: pic +%%Pages: 1 +%%BoundingBox: 36 36 498 728 +%%EndComments +save +%%BeginProlog +/DotDict 200 dict def +DotDict begin + +/setupLatin1 { +mark +/EncodingVector 256 array def + EncodingVector 0 + +ISOLatin1Encoding 0 255 getinterval putinterval +EncodingVector 45 /hyphen put + +% Set up ISO Latin 1 character encoding +/starnetISO { + dup dup findfont dup length dict begin + { 1 index /FID ne { def }{ pop pop } ifelse + } forall + /Encoding EncodingVector def + currentdict end definefont +} def +/Times-Roman starnetISO def +/Times-Italic starnetISO def +/Times-Bold starnetISO def +/Times-BoldItalic starnetISO def +/Helvetica starnetISO def +/Helvetica-Oblique starnetISO def +/Helvetica-Bold starnetISO def +/Helvetica-BoldOblique starnetISO def +/Courier starnetISO def +/Courier-Oblique starnetISO def +/Courier-Bold starnetISO def +/Courier-BoldOblique starnetISO def +cleartomark +} bind def + +%%BeginResource: procset graphviz 0 0 +/coord-font-family /Times-Roman def +/default-font-family /Times-Roman def +/coordfont coord-font-family findfont 8 scalefont def + +/InvScaleFactor 1.0 def +/set_scale { + dup 1 exch div /InvScaleFactor exch def + scale +} bind def + +% styles +/solid { [] 0 setdash } bind def +/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def +/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def +/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def +/bold { 2 setlinewidth } bind def +/filled { } bind def +/unfilled { } bind def +/rounded { } bind def +/diagonals { } bind def + +% hooks for setting color +/nodecolor { sethsbcolor } bind def +/edgecolor { sethsbcolor } bind def +/graphcolor { sethsbcolor } bind def +/nopcolor {pop pop pop} bind def + +/beginpage { % i j npages + /npages exch def + /j exch def + /i exch def + /str 10 string def + npages 1 gt { + gsave + coordfont setfont + 0 0 moveto + (\() show i str cvs show (,) show j str cvs show (\)) show + grestore + } if +} bind def + +/set_font { + findfont exch + scalefont setfont +} def + +% draw text fitted to its expected width +/alignedtext { % width text + /text exch def + /width exch def + gsave + width 0 gt { + [] 0 setdash + text stringwidth pop width exch sub text length div 0 text ashow + } if + grestore +} def + +/boxprim { % xcorner ycorner xsize ysize + 4 2 roll + moveto + 2 copy + exch 0 rlineto + 0 exch rlineto + pop neg 0 rlineto + closepath +} bind def + +/ellipse_path { + /ry exch def + /rx exch def + /y exch def + /x exch def + matrix currentmatrix + newpath + x y translate + rx ry scale + 0 0 1 0 360 arc + setmatrix +} bind def + +/endpage { showpage } bind def +/showpage { } def + +/layercolorseq + [ % layer color sequence - darkest to lightest + [0 0 0] + [.2 .8 .8] + [.4 .8 .8] + [.6 .8 .8] + [.8 .8 .8] + ] +def + +/layerlen layercolorseq length def + +/setlayer {/maxlayer exch def /curlayer exch def + layercolorseq curlayer 1 sub layerlen mod get + aload pop sethsbcolor + /nodecolor {nopcolor} def + /edgecolor {nopcolor} def + /graphcolor {nopcolor} def +} bind def + +/onlayer { curlayer ne {invis} if } def + +/onlayers { + /myupper exch def + /mylower exch def + curlayer mylower lt + curlayer myupper gt + or + {invis} if +} def + +/curlayer 0 def + +%%EndResource +%%EndProlog +%%BeginSetup +14 default-font-family set_font +1 setmiterlimit +% /arrowlength 10 def +% /arrowwidth 5 def + +% make sure pdfmark is harmless for PS-interpreters other than Distiller +/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse +% make '<<' and '>>' safe on PS Level 1 devices +/languagelevel where {pop languagelevel}{1} ifelse +2 lt { + userdict (<<) cvn ([) cvn load put + userdict (>>) cvn ([) cvn load put +} if + +%%EndSetup +setupLatin1 +%%Page: 1 1 +%%PageBoundingBox: 36 36 498 728 +%%PageOrientation: Portrait +0 0 1 beginpage +gsave +36 36 462 692 boxprim clip newpath +1 1 set_scale 0 rotate 40 41 translate +0.16355 0.45339 0.92549 graphcolor +newpath -4 -5 moveto +-4 688 lineto +459 688 lineto +459 -5 lineto +closepath fill +1 setlinewidth +0.16355 0.45339 0.92549 graphcolor +newpath -4 -5 moveto +-4 688 lineto +459 688 lineto +459 -5 lineto +closepath stroke +% compiler +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 320 684 moveto +246 684 lineto +246 648 lineto +320 648 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 320 684 moveto +246 684 lineto +246 648 lineto +320 648 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +254 662.4 moveto 58 (compiler) alignedtext +grestore +% compileSpad2Cmd +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 268 612 moveto +126 612 lineto +126 576 lineto +268 576 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 268 612 moveto +126 612 lineto +126 576 lineto +268 576 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +134 590.4 moveto 126 (compileSpad2Cmd) alignedtext +grestore +% compiler->compileSpad2Cmd +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 261.3 647.83 moveto +250.81 639.05 238.05 628.37 226.68 618.85 curveto +stroke +0 0 0 edgecolor +newpath 228.61 615.9 moveto +218.69 612.16 lineto +224.12 621.27 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 228.61 615.9 moveto +218.69 612.16 lineto +224.12 621.27 lineto +closepath stroke +grestore +% compileSpad2LispCmd +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 454 612 moveto +286 612 lineto +286 576 lineto +454 576 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 454 612 moveto +286 612 lineto +286 576 lineto +454 576 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +293.5 590.4 moveto 153 (compileSpad2LispCmd) alignedtext +grestore +% compiler->compileSpad2LispCmd +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 304.95 647.83 moveto +315.67 638.96 328.72 628.16 340.31 618.57 curveto +stroke +0 0 0 edgecolor +newpath 342.58 621.23 moveto +348.05 612.16 lineto +338.12 615.84 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 342.58 621.23 moveto +348.05 612.16 lineto +338.12 615.84 lineto +closepath stroke +grestore +% compilerDoitWithScreenedLisplib +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 244 540 moveto +0 540 lineto +0 504 lineto +244 504 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 244 540 moveto +0 540 lineto +0 504 lineto +244 504 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +8 518.4 moveto 228 (compilerDoitWithScreenedLisplib) alignedtext +grestore +% compileSpad2Cmd->compilerDoitWithScreenedLisplib +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 178.07 575.83 moveto +169.01 567.13 158.02 556.58 148.17 547.13 curveto +stroke +0 0 0 edgecolor +newpath 150.56 544.56 moveto +140.92 540.16 lineto +145.71 549.61 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 150.56 544.56 moveto +140.92 540.16 lineto +145.71 549.61 lineto +closepath stroke +grestore +% compilerDoit +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 249 468 moveto +145 468 lineto +145 432 lineto +249 432 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 249 468 moveto +145 468 lineto +145 432 lineto +249 432 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +153 446.4 moveto 88 (compilerDoit) alignedtext +grestore +% compileSpad2Cmd->compilerDoit +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 223.72 575.91 moveto +235.01 566.64 246.93 554.29 253 540 curveto +259.26 525.27 259.26 518.73 253 504 curveto +248.3 492.94 240.11 483.05 231.42 474.85 curveto +stroke +0 0 0 edgecolor +newpath 233.55 472.06 moveto +223.72 468.09 lineto +228.92 477.32 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 233.55 472.06 moveto +223.72 468.09 lineto +228.92 477.32 lineto +closepath stroke +grestore +% compilerDoitWithScreenedLisplib->compilerDoit +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 140.93 503.83 moveto +149.99 495.13 160.98 484.58 170.83 475.13 curveto +stroke +0 0 0 edgecolor +newpath 173.29 477.61 moveto +178.08 468.16 lineto +168.44 472.56 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 173.29 477.61 moveto +178.08 468.16 lineto +168.44 472.56 lineto +closepath stroke +grestore +% /rq +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 152 396 moveto +98 396 lineto +98 360 lineto +152 360 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 152 396 moveto +98 396 lineto +98 360 lineto +152 360 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +115.5 374.4 moveto 19 (/rq) alignedtext +grestore +% compilerDoit->/rq +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 178.83 431.83 moveto +170.28 423.28 159.94 412.94 150.62 403.62 curveto +stroke +0 0 0 edgecolor +newpath 152.96 401.01 moveto +143.41 396.41 lineto +148.01 405.96 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 152.96 401.01 moveto +143.41 396.41 lineto +148.01 405.96 lineto +closepath stroke +grestore +% /rf +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 224 396 moveto +170 396 lineto +170 360 lineto +224 360 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 224 396 moveto +170 396 lineto +170 360 lineto +224 360 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +189 374.4 moveto 16 (/rf) alignedtext +grestore +% compilerDoit->/rf +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 197 431.83 moveto +197 424.13 197 414.97 197 406.42 curveto +stroke +0 0 0 edgecolor +newpath 200.5 406.41 moveto +197 396.41 lineto +193.5 406.41 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 200.5 406.41 moveto +197 396.41 lineto +193.5 406.41 lineto +closepath stroke +grestore +% /rq,lib +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 298 396 moveto +242 396 lineto +242 360 lineto +298 360 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 298 396 moveto +242 396 lineto +242 360 lineto +298 360 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +250 374.4 moveto 40 (/rq,lib) alignedtext +grestore +% compilerDoit->/rq,lib +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 215.42 431.83 moveto +224.15 423.22 234.73 412.79 244.24 403.4 curveto +stroke +0 0 0 edgecolor +newpath 246.92 405.68 moveto +251.58 396.16 lineto +242.01 400.69 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 246.92 405.68 moveto +251.58 396.16 lineto +242.01 400.69 lineto +closepath stroke +grestore +% /rf-1 +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 224 324 moveto +170 324 lineto +170 288 lineto +224 288 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 224 324 moveto +170 324 lineto +170 288 lineto +224 288 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +182.5 302.4 moveto 29 (/rf-1) alignedtext +grestore +% /rq->/rf-1 +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 143.17 359.83 moveto +151.72 351.28 162.06 340.94 171.38 331.62 curveto +stroke +0 0 0 edgecolor +newpath 173.99 333.96 moveto +178.59 324.41 lineto +169.04 329.01 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 173.99 333.96 moveto +178.59 324.41 lineto +169.04 329.01 lineto +closepath stroke +grestore +% /rf->/rf-1 +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 197 359.83 moveto +197 352.13 197 342.97 197 334.42 curveto +stroke +0 0 0 edgecolor +newpath 200.5 334.41 moveto +197 324.41 lineto +193.5 334.41 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 200.5 334.41 moveto +197 324.41 lineto +193.5 334.41 lineto +closepath stroke +grestore +% spad +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 224 252 moveto +170 252 lineto +170 216 lineto +224 216 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 224 252 moveto +170 252 lineto +170 216 lineto +224 216 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +181 230.4 moveto 32 (spad) alignedtext +grestore +% /rf-1->spad +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 197 287.83 moveto +197 280.13 197 270.97 197 262.42 curveto +stroke +0 0 0 edgecolor +newpath 200.5 262.41 moveto +197 252.41 lineto +193.5 262.41 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 200.5 262.41 moveto +197 252.41 lineto +193.5 262.41 lineto +closepath stroke +grestore +% /rq,lib->/rf-1 +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 251.58 359.83 moveto +242.85 351.22 232.27 340.79 222.76 331.4 curveto +stroke +0 0 0 edgecolor +newpath 224.99 328.69 moveto +215.42 324.16 lineto +220.08 333.68 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 224.99 328.69 moveto +215.42 324.16 lineto +220.08 333.68 lineto +closepath stroke +grestore +% s-process +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 237 180 moveto +157 180 lineto +157 144 lineto +237 144 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 237 180 moveto +157 180 lineto +157 144 lineto +237 144 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +165 158.4 moveto 64 (s-process) alignedtext +grestore +% spad->s-process +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 197 215.83 moveto +197 208.13 197 198.97 197 190.42 curveto +stroke +0 0 0 edgecolor +newpath 200.5 190.41 moveto +197 180.41 lineto +193.5 190.41 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 200.5 190.41 moveto +197 180.41 lineto +193.5 190.41 lineto +closepath stroke +grestore +% compTopLevel +gsave +0.16355 0.45339 0.92549 nodecolor +newpath 253 108 moveto +141 108 lineto +141 72 lineto +253 72 lineto +closepath fill +1 setlinewidth +filled +0.16355 0.45339 0.92549 nodecolor +newpath 253 108 moveto +141 108 lineto +141 72 lineto +253 72 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +148.5 86.4 moveto 97 (compTopLevel) alignedtext +grestore +% s-process->compTopLevel +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 197 143.83 moveto +197 136.13 197 126.97 197 118.42 curveto +stroke +0 0 0 edgecolor +newpath 200.5 118.41 moveto +197 108.41 lineto +193.5 118.41 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 200.5 118.41 moveto +197 108.41 lineto +193.5 118.41 lineto +closepath stroke +grestore +% compOrCroak +gsave +0 0 1 nodecolor +newpath 252 36 moveto +142 36 lineto +142 0 lineto +252 0 lineto +closepath fill +1 setlinewidth +filled +0 0 1 nodecolor +newpath 252 36 moveto +142 36 lineto +142 0 lineto +252 0 lineto +closepath stroke +0 0 0 nodecolor +14 /Times-Roman set_font +150 14.4 moveto 94 (compOrCroak) alignedtext +grestore +% compTopLevel->compOrCroak +gsave +1 setlinewidth +0 0 0 edgecolor +newpath 197 71.83 moveto +197 64.13 197 54.97 197 46.42 curveto +stroke +0 0 0 edgecolor +newpath 200.5 46.41 moveto +197 36.41 lineto +193.5 46.41 lineto +closepath fill +1 setlinewidth +solid +0 0 0 edgecolor +newpath 200.5 46.41 moveto +197 36.41 lineto +193.5 46.41 lineto +closepath stroke +grestore +endpage +showpage +grestore +%%PageTrailer +%%EndPage: 1 +%%Trailer +end +restore +%%EOF diff --git a/changelog b/changelog index 3227712..023ab16 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,11 @@ +20111230 tpd src/axiom-website/patches.html 20111230.01.tpd.patch +20111230 tpd books/bookvol5 treeshake compiler +20111230 tpd books/ps/v9compiler.eps document compiler +20111230 tpd books/ps/v9comdefine.eps document compiler +20111230 tpd src/interp/util.lisp treeshake compiler +20111230 tpd src/interp/vmlisp.lisp treeshake compiler +20111230 tpd src/interp/br-con.lisp treeshake compiler +20111230 tpd books/bookvol9 treeshake and document compiler 20111227 tpd src/axiom-website/patches.html 20111227.02.tpd.patch 20111227 mxa src/axiom-website/litprog.html note HTML escape code flaw 20111227 mxa readme add Michael Albaugh diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index f623e8c..456dee6 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3747,5 +3747,7 @@ books/bookvol9 localize function names
src/axiom-website/litprog.html fix argument count
20111227.02.tpd.patch src/axiom-website/litprog.html note HTML escape code flaw
+20111230.01.tpd.patch +books/bookvol9 treeshake and document compiler
diff --git a/src/interp/br-con.lisp.pamphlet b/src/interp/br-con.lisp.pamphlet index 73acdda..3fe1a4a 100644 --- a/src/interp/br-con.lisp.pamphlet +++ b/src/interp/br-con.lisp.pamphlet @@ -4533,163 +4533,6 @@ ;--============================================================================ ;-- Build Library Database (libdb.text,...) ;--============================================================================ -;--Formal for libdb.text: -;-- constructors Cname\#\I\sig \args \abb \comments (C is C, D, P, X) -;-- operations Op \#\E\sig \conname\pred\comments (E is one of U/E) -;-- attributes Aname\#\E\args\conname\pred\comments -;-- I = -;buildLibdb(:options) == --called by make-databases (daase.lisp.pamphlet) -; domainList := IFCAR options --build local libdb if list of domains is given -; $OpLst: local := nil -; $AttrLst: local := nil -; $DomLst : local := nil -; $CatLst : local := nil -; $PakLst : local := nil -; $DefLst : local := nil -; deleteFile '"temp.text" -; $outStream: local := MAKE_-OUTSTREAM '"temp.text" -; if null domainList then -; comments := -; '"\spad{Union(A,B,...,C)} is a primitive type in AXIOM used to represent objects of type \spad{A} or of type \spad{B} or...or of type \spad{C}." -; writedb -; buildLibdbString ['"dUnion",1,'"x",'"special",'"(A,B,...,C)",'UNION,comments] -; comments := -; '"\spad{Record(a:A,b:B,...,c:C)} is a primitive type in AXIOM used to represent composite objects made up of objects of type \spad{A}, \spad{B},..., \spad{C} which are indexed by _"keys_" (identifiers) \spad{a},\spad{b},...,\spad{c}." -; writedb -; buildLibdbString ['"dRecord",1,'"x",'"special",'"(a:A,b:B,...,c:C)",'RECORD,comments] -; comments := -; '"\spad{Mapping(T,S)} is a primitive type in AXIOM used to represent mappings from source type \spad{S} to target type \spad{T}. Similarly, \spad{Mapping(T,A,B)} denotes a mapping from source type \spad{(A,B)} to target type \spad{T}." -; writedb -; buildLibdbString ['"dMapping",1,'"x",'"special",'"(T,S)",'MAPPING,comments] -; comments := -; '"\spad{Enumeration(a,b,...,c)} is a primitive type in AXIOM used to represent the object composed of the symbols \spad{a},\spad{b},..., and \spad{c}." -; writedb -; buildLibdbString ['"dEnumeration",1,'"x",'"special",'"(a,b,...,c)",'ENUM,comments] -; $conname: local := nil -; $conform: local := nil -; $exposed?:local := nil -; $doc: local := nil -; $kind: local := nil -; constructorList := domainList or allConstructors() -; for con in constructorList repeat -; writedb buildLibdbConEntry con -; [attrlist,:oplist] := getConstructorExports $conform -; buildLibOps oplist -; buildLibAttrs attrlist -; SHUT $outStream -; domainList => 'done --leave new database in temp.text -; OBEY -; $machineType = 'RIOS => '"sort -f -T /tmp -y200 _"temp.text_" > _"libdb.text_"" -; $machineType = 'SPARC => '"sort -f _"temp.text_" > _"libdb.text_"" -; '"sort _"temp.text_" > _"libdb.text_"" -; --OBEY '"mv libdb.text olibdb.text" -; RENAME_-FILE('"libdb.text", '"olibdb.text") -; deleteFile '"temp.text" - -(DEFUN |buildLibdb| (&REST G168131 &AUX |options|) - (DSETQ |options| G168131) - (PROG (|$OpLst| |$AttrLst| |$DomLst| |$CatLst| |$PakLst| |$DefLst| - |$outStream| |$conname| |$conform| |$exposed?| |$doc| - |$kind| |domainList| |comments| |constructorList| - |LETTMP#1| |attrlist| |oplist|) - (DECLARE (SPECIAL |$OpLst| |$AttrLst| |$DomLst| |$CatLst| |$PakLst| - |$DefLst| |$outStream| |$conname| |$conform| - |$exposed?| |$doc| |$kind| |$machineType|)) - (RETURN - (SEQ (PROGN - (SPADLET |domainList| (IFCAR |options|)) - (SPADLET |$OpLst| NIL) - (SPADLET |$AttrLst| NIL) - (SPADLET |$DomLst| NIL) - (SPADLET |$CatLst| NIL) - (SPADLET |$PakLst| NIL) - (SPADLET |$DefLst| NIL) - (|deleteFile| "temp.text") - (SPADLET |$outStream| - (MAKE-OUTSTREAM "temp.text")) - (COND - ((NULL |domainList|) - (SPADLET |comments| - "\\spad{Union(A,B,...,C)} is a primitive type in AXIOM used to represent objects of type \\spad{A} or of type \\spad{B} or...or of type \\spad{C}.") - (|writedb| - (|buildLibdbString| - (CONS "dUnion" - (CONS 1 - (CONS "x" - (CONS "special" - (CONS "(A,B,...,C)" - (CONS 'UNION - (CONS |comments| NIL))))))))) - (SPADLET |comments| - "\\spad{Record(a:A,b:B,...,c:C)} is a primitive type in AXIOM used to represent composite objects made up of objects of type \\spad{A}, \\spad{B},..., \\spad{C} which are indexed by \"keys\" (identifiers) \\spad{a},\\spad{b},...,\\spad{c}.") - (|writedb| - (|buildLibdbString| - (CONS "dRecord" - (CONS 1 - (CONS "x" - (CONS "special" - (CONS - "(a:A,b:B,...,c:C)" - (CONS 'RECORD - (CONS |comments| NIL))))))))) - (SPADLET |comments| - "\\spad{Mapping(T,S)} is a primitive type in AXIOM used to represent mappings from source type \\spad{S} to target type \\spad{T}. Similarly, \\spad{Mapping(T,A,B)} denotes a mapping from source type \\spad{(A,B)} to target type \\spad{T}.") - (|writedb| - (|buildLibdbString| - (CONS "dMapping" - (CONS 1 - (CONS "x" - (CONS "special" - (CONS "(T,S)" - (CONS 'MAPPING - (CONS |comments| NIL))))))))) - (SPADLET |comments| - "\\spad{Enumeration(a,b,...,c)} is a primitive type in AXIOM used to represent the object composed of the symbols \\spad{a},\\spad{b},..., and \\spad{c}.") - (|writedb| - (|buildLibdbString| - (CONS "dEnumeration" - (CONS 1 - (CONS "x" - (CONS "special" - (CONS "(a,b,...,c)" - (CONS 'ENUM - (CONS |comments| NIL))))))))))) - (SPADLET |$conname| NIL) - (SPADLET |$conform| NIL) - (SPADLET |$exposed?| NIL) - (SPADLET |$doc| NIL) - (SPADLET |$kind| NIL) - (SPADLET |constructorList| - (OR |domainList| (|allConstructors|))) - (DO ((G168077 |constructorList| (CDR G168077)) - (|con| NIL)) - ((OR (ATOM G168077) - (PROGN (SETQ |con| (CAR G168077)) NIL)) - NIL) - (SEQ (EXIT (PROGN - (|writedb| (|buildLibdbConEntry| |con|)) - (SPADLET |LETTMP#1| - (|getConstructorExports| - |$conform|)) - (SPADLET |attrlist| (CAR |LETTMP#1|)) - (SPADLET |oplist| (CDR |LETTMP#1|)) - (|buildLibOps| |oplist|) - (|buildLibAttrs| |attrlist|))))) - (SHUT |$outStream|) - (COND - (|domainList| '|done|) - ('T - (OBEY (COND - ((BOOT-EQUAL |$machineType| 'RIOS) - "sort -f -T /tmp -y200 \"temp.text\" > \"libdb.text\"") - ((BOOT-EQUAL |$machineType| 'SPARC) - "sort -f \"temp.text\" > \"libdb.text\"") - ('T - "sort \"temp.text\" > \"libdb.text\""))) - (RENAME-FILE "libdb.text" - "olibdb.text") - (|deleteFile| "temp.text")))))))) - ;buildLibdbConEntry conname == ; NULL GETDATABASE(conname, 'CONSTRUCTORMODEMAP) => nil ; abb:=GETDATABASE(conname,'ABBREVIATION) @@ -7331,31 +7174,6 @@ ; dbWriteLines(MSORT UNION(oldlines,newlines), '"libdb.text") ; deleteFile '"temp.text" -(DEFUN |extendLocalLibdb| (|conlist|) - (PROG (|localLibdb| |oldlines| |newlines|) - (declare (special |$createLocalLibDb| |$newConstructorList|)) - (RETURN - (COND - ((NULL |$createLocalLibDb|) NIL) - ((NULL |conlist|) NIL) - ('T (|buildLibdb| |conlist|) - (SPADLET |$newConstructorList| - (|union| |conlist| |$newConstructorList|)) - (SPADLET |localLibdb| "libdb.text") - (COND - ((NULL (PROBE-FILE "libdb.text")) - (RENAME-FILE "temp.text" - "libdb.text")) - ('T - (SPADLET |oldlines| - (|purgeNewConstructorLines| - (|dbReadLines| |localLibdb|) |conlist|)) - (SPADLET |newlines| - (|dbReadLines| "temp.text")) - (|dbWriteLines| (MSORT (|union| |oldlines| |newlines|)) - "libdb.text") - (|deleteFile| "temp.text")))))))) - ;$returnNowhereFromGoGet := false (SPADLET |$returnNowhereFromGoGet| NIL) @@ -27176,15 +26994,6 @@ $dbKindAlist := ;--======================================================================= ;-- Code for Private Libdbs ;--======================================================================= -;--extendLocalLibdb conlist == --called by function "compiler"(see above) -;-- buildLibdb conlist --> puts datafile into temp.text -;-- $newConstructorList := UNION(conlist, $newConstructorList) -;-- localLibdb := '"libdb.text" -;-- not isExistingFile '"libdb.text" => RENAME_-FILE('"temp.text",'"libdb.text") -;-- oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist) -;-- newlines := dbReadLines '"temp.text" -;-- dbWriteLines(MSORT UNION(oldlines,newlines), '"libdb.text") -;-- deleteFile '"temp.text" ;purgeNewConstructorLines(lines, conlist) == ; [x for x in lines | not screenLocalLine(x, conlist)] diff --git a/src/interp/util.lisp.pamphlet b/src/interp/util.lisp.pamphlet index b089d80..238d3e5 100644 --- a/src/interp/util.lisp.pamphlet +++ b/src/interp/util.lisp.pamphlet @@ -508,7 +508,6 @@ if you use the browse function of the {\bf hypertex} system. |parentsOf| ;interop.boot |getParentsFor| ;old compiler |folks| ;for astran - |extendLocalLibdb| ;)lib needs this |oSearch| |aokSearch| |kSearch| @@ -526,7 +525,6 @@ if you use the browse function of the {\bf hypertex} system. |dbGetOrigin| |dbComments| |grepConstruct| - |buildLibdb| |bcDefiniteIntegrate| |bcDifferentiate| |bcDraw| @@ -542,7 +540,6 @@ if you use the browse function of the {\bf hypertex} system. |conPage| |dbName| |dbPart| - |extendLocalLibdb| |form2HtString| |htGloss| |htGreekSearch| diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index 39c3057..4bde94e 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -5521,7 +5521,6 @@ now the function is defined but does nothing. ;; For the browser, used for building local databases when a user compiles ;; their own code. (SETQ |$newConstructorList| nil) -(SETQ |$newConlist| nil) (SETQ |$createLocalLibDb| 't) ;; These are duplicates of definitions in bookvol9