diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index b78a285..3cbf73a 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -5290,6 +5290,123 @@ of the symbol being parsed. The original list read: \end{chunk} +\defun{loadIfNecessary}{loadIfNecessary} +\calls{loadIfNecessary}{loadLibIfNecessary} +\begin{chunk}{defun loadIfNecessary} +(defun |loadIfNecessary| (u) + (|loadLibIfNecessary| u t)) + +\end{chunk} + +\defun{loadLibIfNecessary}{loadLibIfNecessary} +\calls{loadLibIfNecessary}{loadLibIfNecessary} +\calls{loadLibIfNecessary}{functionp} +\calls{loadLibIfNecessary}{macrop} +\calls{loadLibIfNecessary}{getl} +\calls{loadLibIfNecessary}{loadLib} +\calls{loadLibIfNecessary}{lassoc} +\calls{loadLibIfNecessary}{getProplist} +\calls{loadLibIfNecessary}{getdatabase} +\calls{loadLibIfNecessary}{updateCategoryFrameForCategory} +\calls{loadLibIfNecessary}{updateCategoryFrameForConstructor} +\calls{loadLibIfNecessary}{throwKeyedMsg} +\refsdollar{loadLibIfNecessary}{CategoryFrame} +\refsdollar{loadLibIfNecessary}{InteractiveMode} +\begin{chunk}{defun loadLibIfNecessary} +(defun |loadLibIfNecessary| (u mustExist) + (let (value y) + (declare (special |$CategoryFrame| |$InteractiveMode|)) + (cond + ((eq u '|$EmptyMode|) u) + ((null (atom u)) (|loadLibIfNecessary| (car u) mustExist)) + (t + (setq value + (cond + ((or (|functionp| u) (|macrop| u)) u) + ((getl u 'loaded) u) + ((|loadLib| u) u))) + (cond + ((and (null |$InteractiveMode|) + (or (null (setq y (|getProplist| u |$CategoryFrame|))) + (and (null (lassoc '|isFunctor| y)) + (null (lassoc '|isCategory| y))))) + (if (setq y (getdatabase u 'constructorkind)) + (if (eq y '|category|) + (|updateCategoryFrameForCategory| u) + (|updateCategoryFrameForConstructor| u)) + (|throwKeyedMsg| 's2il0005 (list u)))) + (t value)))))) + +\end{chunk} + +\defun{updateCategoryFrameForConstructor}{updateCategoryFrameForConstructor} +\calls{updateCategoryFrameForConstructor}{getdatabase} +\calls{updateCategoryFrameForConstructor}{put} +\calls{updateCategoryFrameForConstructor}{convertOpAlist2compilerInfo} +\calls{updateCategoryFrameForConstructor}{addModemap} +\refsdollar{updateCategoryFrameForConstructor}{CategoryFrame} +\defsdollar{updateCategoryFrameForConstructor}{CategoryFrame} +\begin{chunk}{defun updateCategoryFrameForConstructor} +(defun |updateCategoryFrameForConstructor| (constructor) + (let (opAlist tmp1 dc sig pred impl) + (declare (special |$CategoryFrame|)) + (setq opalist (getdatabase constructor 'operationalist)) + (setq tmp1 (getdatabase constructor 'constructormodemap)) + (setq dc (caar tmp1)) + (setq sig (cdar tmp1)) + (setq pred (caadr tmp1)) + (setq impl (cadadr tmp1)) + (setq |$CategoryFrame| + (|put| constructor '|isFunctor| + (|convertOpAlist2compilerInfo| opAlist) + (|addModemap| constructor dc sig pred impl + (|put| constructor '|mode| (cons '|Mapping| sig) |$CategoryFrame|)))))) + +\end{chunk} + +\defun{updateCategoryFrameForCategory}{updateCategoryFrameForCategory} +\calls{updateCategoryFrameForCategory}{getdatabase} +\calls{updateCategoryFrameForCategory}{put} +\calls{updateCategoryFrameForCategory}{addModemap} +\refsdollar{updateCategoryFrameForCategory}{CategoryFrame} +\defsdollar{updateCategoryFrameForCategory}{CategoryFrame} +\begin{chunk}{defun updateCategoryFrameForCategory} +(defun |updateCategoryFrameForCategory| (category) + (let (tmp1 dc sig pred impl) + (declare (special |$CategoryFrame|)) + (setq tmp1 (getdatabase category 'constructormodemap)) + (setq dc (caar tmp1)) + (setq sig (cdar tmp1)) + (setq pred (caadr tmp1)) + (setq impl (cadadr tmp1)) + (setq |$CategoryFrame| + (|put| category '|isCategory| t + (|addModemap| category dc sig pred impl |$CategoryFrame|))))) + +\end{chunk} + +\defplist{if}{parseIf} +\begin{chunk}{postvars} +(eval-when (eval load) + (setf (get 'if '|parseTran|) '|parseIf|)) + +\end{chunk} + +\defun{parseIf}{parseIf} +\calls{parseIf}{parseIf,ifTran} +\calls{parseIf}{parseTran} +\begin{chunk}{defun parseIf} +(defun |parseIf| (arg) + (if (null (and (pairp arg) (pairp (qcdr arg)) + (pairp (qcdr (qcdr arg))) (eq (qcdr (qcdr (qcdr arg))) nil))) + arg + (|parseIf,ifTran| + (|parseTran| (first arg)) + (|parseTran| (second arg)) + (|parseTran| (third arg))))) + +\end{chunk} + \defun{parseIf,ifTran}{parseIf,ifTran} \calls{parseIf,ifTran}{parseIf,ifTran} \calls{parseIf,ifTran}{incExitLevel} @@ -5388,28 +5505,6 @@ of the symbol being parsed. The original list read: \end{chunk} -\defplist{if}{parseIf} -\begin{chunk}{postvars} -(eval-when (eval load) - (setf (get 'if '|parseTran|) '|parseIf|)) - -\end{chunk} - -\defun{parseIf}{parseIf} -\calls{parseIf}{parseIf,ifTran} -\calls{parseIf}{parseTran} -\begin{chunk}{defun parseIf} -(defun |parseIf| (arg) - (if (null (and (pairp arg) (pairp (qcdr arg)) - (pairp (qcdr (qcdr arg))) (eq (qcdr (qcdr (qcdr arg))) nil))) - arg - (|parseIf,ifTran| - (|parseTran| (first arg)) - (|parseTran| (second arg)) - (|parseTran| (third arg))))) - -\end{chunk} - \defplist{implies}{parseImplies} \begin{chunk}{postvars} (eval-when (eval load) @@ -6225,6 +6320,61 @@ $\rightarrow$ \end{chunk} +\defun{mkEvalableCategoryForm}{mkEvalableCategoryForm} +\calls{mkEvalableCategoryForm}{pairp} +\calls{mkEvalableCategoryForm}{qcar} +\calls{mkEvalableCategoryForm}{qcdr} +\calls{mkEvalableCategoryForm}{mkEvalableCategoryForm} +\calls{mkEvalableCategoryForm}{compOrCroak} +\calls{mkEvalableCategoryForm}{getdatabase} +\calls{mkEvalableCategoryForm}{get} +\calls{mkEvalableCategoryForm}{quotifyCategoryArgument} +\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 (pairp c) + (progn + (setq op (qcar c)) + (setq argl (qcdr 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 (|quotifyCategoryArgument| 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} @@ -6386,6 +6536,28 @@ $\rightarrow$ \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} @@ -6524,13 +6696,51 @@ $\rightarrow$ (|unloadOneConstructor| op libname) (localdatabase (list (getdatabase op 'abbreviation)) nil) (setq |$newConlist| (cons op |$newConlist|)) - (cond (eq |$lisplibKind| '|category|) + (when (eq |$lisplibKind| '|category|) (|updateCategoryFrameForCategory| op) (|updateCategoryFrameForConstructor| op)) res)))) \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} @@ -6560,7 +6770,7 @@ $\rightarrow$ |$lisplibModemap| |$lisplibKind| |$lisplibModemapAlist| |$lisplibAbbreviation| |$lisplibAncestors| |$lisplibOpAlist| |$lisplibOperationAlist| - |$lisplibSuperDomain| |$lisplibVariableAlist| + |$lisplibSuperDomain| |$lisplibVariableAlist| errors |$lisplibSignatureAlist| /editfile /major-version errors)) ($erase libName 'errorlib 'a) (setq errors 0) @@ -6582,6 +6792,271 @@ $\rightarrow$ \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}{makeprop} +\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|))) + (makeprop (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 tmp1 tmp2 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 (pairp implementation) (pairp (qcdr implementation)) + (pairp (qcdr (qcdr implementation))) + (eq (qcdr (qcdr (qcdr implementation))) nil) + (progn (setq n (qcar (qcdr (qcdr implementation)))) t) + (|member| (setq eltEtc (qcar implementation)) '(const elt))) + eltEtc) + ((pairp implementation) + (setq impOp (qcar 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{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} @@ -7565,7 +8040,7 @@ The way XLAMs work: \refsdollar{augModemapsFromDomain}{DummyFunctorNames} \begin{chunk}{defun augModemapsFromDomain} (defun |augModemapsFromDomain| (name functorForm env) - (let (curDomainsInScope u innerDom dl) + (let (curDomainsInScope u innerDom) (declare (special |$Category| |$DummyFunctorNames|)) (cond ((|member| (or (kar name) name) |$DummyFunctorNames|) @@ -7586,6 +8061,88 @@ The way XLAMs work: \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) + (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)) + (t + (|stackMessage| (list functorForm '| is an unknown mode|)) + env)))) + +\end{chunk} + +\defun{substituteCategoryArguments}{substituteCategoryArguments} +\calls{substituteCategoryArguments}{msubst} +\calls{substituteCategoryArguments}{internl} +\calls{substituteCategoryArguments}{stringimage} +\calls{substituteCategoryArguments}{sublis} +\begin{chunk}{defun substituteCategoryArguments} +(defun |substituteCategoryArguments| (argl catform) + (let (arglAssoc (i 0)) + (setq argl (msubst '$$ '$ argl)) + (setq arglAssoc + (loop for a in argl + collect (cons (internl '|#| (stringimage (incf i))) a))) + (sublis arglAssoc catform))) + +\end{chunk} + +\defun{addConstructorModemaps}{addConstructorModemaps} +\calls{addConstructorModemaps}{putDomainsInScope} +\calls{addConstructorModemaps}{getl} +\calls{addConstructorModemaps}{msubst} +\calls{addConstructorModemaps}{pairp} +\calls{addConstructorModemaps}{qcar} +\calls{addConstructorModemaps}{qcdr} +\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 (pairp opcode) (pairp (qcdr opcode)) + (pairp (qcdr (qcdr opcode))) + (eq (qcdr (qcdr (qcdr opcode))) nil) + (eq (qcar opcode) 'elt)) + (setq nsig (msubst '$$$ name sig)) + (setq nsig (msubst '$ '$$$ (msubst '$$ '$ nsig))) + (setq opcode (list (first opcode) (second opcode) nsig))) + (setq env (|addModemap| op name sig t opcode env))) + env)) + +\end{chunk} + \defun{getModemap}{getModemap} \calls{getModemap}{get} \calls{getModemap}{compApplyModemap} @@ -9831,6 +10388,52 @@ An angry JHD - August 15th., 1984 \end{chunk} +\defun{isDomainForm}{isDomainForm} +\calls{isDomainForm}{kar} +\calls{isDomainForm}{pairp} +\calls{isDomainForm}{qcar} +\calls{isDomainForm}{qcdr} +\calls{isDomainForm}{isFunctor} +\calls{isDomainForm}{isCategoryForm} +\calls{isDomainForm}{isDomainConstructorForm} +\refsdollar{isDomainForm}{SpecialDomainNames} +\begin{chunk}{defun isDomainForm} +(defun |isDomainForm| (d env) + (declare (special |$SpecialDomainNames|)) + (or (member (kar d) |$SpecialDomainNames|) (|isFunctor| d) + (and (progn + (setq tmp1 (|getmode| d env)) + (and (pairp tmp1) (eq (qcar tmp1) '|Mapping|) (pairp (qcdr tmp1)))) + (|isCategoryForm| (qcar (qcdr tmp1)) env)) + (|isCategoryForm| (|getmode| d env) env) + (|isDomainConstructorForm| d env))) + +\end{chunk} + +\defun{isDomainConstructorForm}{isDomainConstructorForm} +\calls{isDomainConstructorForm}{pairp} +\calls{isDomainConstructorForm}{qcar} +\calls{isDomainConstructorForm}{qcdr} +\calls{isDomainConstructorForm}{isCategoryForm} +\calls{isDomainConstructorForm}{eqsubstlist} +\refsdollar{isDomainConstructorForm}{FormalMapVariableList} +\begin{chunk}{defun isDomainConstructorForm} +(defun |isDomainConstructorForm| (d env) + (let (u) + (declare (special |$FormalMapVariableList|)) + (when + (and (pairp d) + (setq u (|get| (qcar d) '|value| env)) + (pairp u) + (pairp (qcdr u)) + (pairp (qcar (qcdr u))) + (eq (qcar (qcar (qcdr u))) '|Mapping|) + (pairp (qcdr (qcar (qcdr u))))) + (|isCategoryForm| + (eqsubstlist (rest d) |$FormalMapVariableList| (cadadr u)) env)))) + +\end{chunk} + \defplist{String}{compString plist} \begin{chunk}{postvars} (eval-when (eval load) @@ -17151,6 +17754,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun action} \getchunk{defun addclose} +\getchunk{defun addConstructorModemaps} \getchunk{defun addDomain} \getchunk{defun addEltModemap} \getchunk{defun addEmptyCapsuleIfNecessary} @@ -17168,6 +17772,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun augModemapsFromCategory} \getchunk{defun augModemapsFromCategoryRep} \getchunk{defun augModemapsFromDomain} +\getchunk{defun augModemapsFromDomain1} \getchunk{defun blankp} \getchunk{defun bumperrorcount} @@ -17219,6 +17824,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun compileFileQuietly} \getchunk{defun compile-lib-file} \getchunk{defun compiler} +\getchunk{defun compileDocumentation} \getchunk{defun compilerDoit} \getchunk{defun compileSpad2Cmd} \getchunk{defun compileSpadLispCmd} @@ -17280,20 +17886,27 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun errhuh} \getchunk{defun escape-keywords} \getchunk{defun escaped} +\getchunk{defun evalAndRwriteLispForm} \getchunk{defun evalAndSub} \getchunk{defun extractCodeAndConstructTriple} +\getchunk{defun finalizeLisplib} \getchunk{defun fincomblock} \getchunk{defun floatexpid} \getchunk{defun freelist} \getchunk{defun get-a-line} +\getchunk{defun getCategoryOpsAndAtts} +\getchunk{defun getConstructorOpsAndAtts} \getchunk{defun getDomainsInScope} +\getchunk{defun getFunctorOpsAndAtts} \getchunk{defun getModemap} \getchunk{defun getModemapList} \getchunk{defun getModemapListFromDomain} \getchunk{defun getOperationAlist} \getchunk{defun getScriptName} +\getchunk{defun getSlotFromCategoryForm} +\getchunk{defun getSlotFromFunctor} \getchunk{defun getTargetFromRhs} \getchunk{defun get-token} \getchunk{defun getToken} @@ -17318,6 +17931,8 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun initial-substring-p} \getchunk{defun initializeLisplib} \getchunk{defun is-console} +\getchunk{defun isDomainConstructorForm} +\getchunk{defun isDomainForm} \getchunk{defun isListConstructor} \getchunk{defun isSuperDomain} \getchunk{defun isTokenDelimiter} @@ -17331,6 +17946,10 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun line-past-end-p} \getchunk{defun line-print} \getchunk{defun line-new-line} +\getchunk{defun lisplibDoRename} +\getchunk{defun lisplibWrite} +\getchunk{defun loadIfNecessary} +\getchunk{defun loadLibIfNecessary} \getchunk{defun macroExpand} \getchunk{defun macroExpandInPlace} @@ -17346,9 +17965,11 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun match-string} \getchunk{defun match-token} \getchunk{defun mergeModemap} +\getchunk{defun mergeSignatureAndLocalVarAlists} \getchunk{defun meta-syntax-error} \getchunk{defun mkCategoryPackage} \getchunk{defun mkConstructor} +\getchunk{defun mkEvalableCategoryForm} \getchunk{defun mkNewModemapList} \getchunk{defun mkOpVec} \getchunk{defun modifyModeStack} @@ -17564,6 +18185,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun removeSuperfluousMapping} \getchunk{defun reportOnFunctorCompilation} \getchunk{defun /RQ,LIB} +\getchunk{defun rwriteLispForm} \getchunk{defun setDefOp} \getchunk{defun skip-blanks} @@ -17576,12 +18198,14 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun stack-pop} \getchunk{defun stack-push} \getchunk{defun storeblanks} +\getchunk{defun substituteCategoryArguments} \getchunk{defun substNames} \getchunk{defun s-process} \getchunk{defun token-install} \getchunk{defun token-lookahead-type} \getchunk{defun token-print} +\getchunk{defun transformOperationAlist} \getchunk{defun transIs} \getchunk{defun transIs1} \getchunk{defun translabel} @@ -17592,6 +18216,10 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun underscore} \getchunk{defun unget-tokens} \getchunk{defun unTuple} +\getchunk{defun updateCategoryFrameForCategory} +\getchunk{defun updateCategoryFrameForConstructor} + +\getchunk{defun writeLib1} \getchunk{postvars} diff --git a/changelog b/changelog index 231027e..33460c7 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20110721 tpd src/axiom-website/patches.html 20110721.01.tpd.patch +20110721 tpd src/interp/vmlisp.lisp treeshake compiler +20110721 tpd src/interp/lisplib.lisp treeshake compiler +20110721 tpd books/bookvol9 treeshake compiler 20110716 tpd src/axiom-website/patches.html 20110716.01.tpd.patch 20110716 tpd src/interp/lisplib.lisp treeshake compiler 20110716 tpd books/bookvol9 treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 58aee9d..718f3c0 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3548,5 +3548,7 @@ src/interp/Makefile add (si::reset-sys-paths) per Camm
books/bookvol5 treeshake interpreter
20110716.01.tpd.patch books/bookvol9 treeshake compiler
+20110721.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/lisplib.lisp.pamphlet b/src/interp/lisplib.lisp.pamphlet index 49a44f5..32cb445 100644 --- a/src/interp/lisplib.lisp.pamphlet +++ b/src/interp/lisplib.lisp.pamphlet @@ -32,47 +32,6 @@ (DEFUN |readLibPathFast| (|p|) (RDEFIOSTREAM (CONS (CONS 'FILE |p|) (CONS '(MODE . INPUT) NIL)) NIL)) -;writeLib1(fn,ft,fm) == RDEFIOSTREAM [['FILE,fn,ft,fm],'(MODE . OUTPUT)] - -(DEFUN |writeLib1| (|fn| |ft| |fm|) - (RDEFIOSTREAM - (CONS (CONS 'FILE (CONS |fn| (CONS |ft| (CONS |fm| NIL)))) - (CONS '(MODE . OUTPUT) NIL)))) - -;lisplibWrite(prop,val,filename) == -; -- this may someday not write NIL keys, but it will now -; if $LISPLIB then -; rwrite128(prop,val,filename) - -(DEFUN |lisplibWrite| (|prop| |val| |filename|) - (declare (special $LISPLIB)) - (COND ($LISPLIB (|rwrite128| |prop| |val| |filename|)) ('T NIL))) - -;rwrite128(key,value,stream) == -; rwrite(key,value,stream) - -(DEFUN |rwrite128| (|key| |value| |stream|) - (|rwrite| |key| |value| |stream|)) - -;evalAndRwriteLispForm(key,form) == -; eval form -; rwriteLispForm(key,form) - -(DEFUN |evalAndRwriteLispForm| (|key| |form|) - (PROGN (|eval| |form|) (|rwriteLispForm| |key| |form|))) - -;rwriteLispForm(key,form) == -; if $LISPLIB then -; rwrite( key,form,$libFile) -; LAM_,FILEACTQ(key,form) - -(DEFUN |rwriteLispForm| (|key| |form|) - (declare (special |$libFile| $LISPLIB)) - (COND - ($LISPLIB (|rwrite| |key| |form| |$libFile|) - (|LAM,FILEACTQ| |key| |form|)) - ('T NIL))) - ;getFileProperty(fn,ft,id,cache) == ; fn in '(DOMAIN SUBDOM MODE) => nil ; p := pathname [fn,ft,'"*"] @@ -218,56 +177,6 @@ ((GETL |libName| 'LOADED) NIL) ('T (|loadLib| |libName|)))) -;loadIfNecessary u == loadLibIfNecessary(u,true) - -(DEFUN |loadIfNecessary| (|u|) (|loadLibIfNecessary| |u| 'T)) - -;loadLibIfNecessary(u,mustExist) == -; u = '$EmptyMode => u -; null atom u => loadLibIfNecessary(first u,mustExist) -; value:= -; functionp(u) or macrop(u) => u -; GET(u,'LOADED) => u -; loadLib u => u -; null $InteractiveMode and ((null (y:= getProplist(u,$CategoryFrame))) -; or (null LASSOC('isFunctor,y)) and (null LASSOC('isCategory,y))) => -; y:= GETDATABASE(u,'CONSTRUCTORKIND) => -; y = 'category => -; updateCategoryFrameForCategory u -; updateCategoryFrameForConstructor u -; throwKeyedMsg("S2IL0005",[u]) -; value - -(DEFUN |loadLibIfNecessary| (|u| |mustExist|) - (PROG (|value| |y|) - (declare (special |$CategoryFrame| |$InteractiveMode|)) - (RETURN - (COND - ((BOOT-EQUAL |u| '|$EmptyMode|) |u|) - ((NULL (ATOM |u|)) - (|loadLibIfNecessary| (CAR |u|) |mustExist|)) - ('T - (SPADLET |value| - (COND - ((OR (|functionp| |u|) (|macrop| |u|)) |u|) - ((GETL |u| 'LOADED) |u|) - ((|loadLib| |u|) |u|))) - (COND - ((AND (NULL |$InteractiveMode|) - (OR (NULL (SPADLET |y| - (|getProplist| |u| - |$CategoryFrame|))) - (AND (NULL (LASSOC '|isFunctor| |y|)) - (NULL (LASSOC '|isCategory| |y|))))) - (COND - ((SPADLET |y| (GETDATABASE |u| 'CONSTRUCTORKIND)) - (COND - ((BOOT-EQUAL |y| '|category|) - (|updateCategoryFrameForCategory| |u|)) - ('T (|updateCategoryFrameForConstructor| |u|)))) - ('T (|throwKeyedMsg| 'S2IL0005 (CONS |u| NIL))))) - ('T |value|))))))) - ;convertOpAlist2compilerInfo(opalist) == ; "append"/[[formatSig(op,sig) for sig in siglist] ; for [op,:siglist] in opalist] where @@ -335,57 +244,6 @@ |op| |sig|) G166289)))))))))))))))))) -;updateCategoryFrameForConstructor(constructor) == -; opAlist := GETDATABASE(constructor, 'OPERATIONALIST) -; [[dc,:sig],[pred,impl]] := GETDATABASE(constructor, 'CONSTRUCTORMODEMAP) -; $CategoryFrame := put(constructor,'isFunctor, -; convertOpAlist2compilerInfo(opAlist), -; addModemap(constructor, dc, sig, pred, impl, -; put(constructor, 'mode, ['Mapping,:sig], $CategoryFrame))) - -(DEFUN |updateCategoryFrameForConstructor| (|constructor|) - (PROG (|opAlist| |LETTMP#1| |dc| |sig| |pred| |impl|) - (declare (special |$CategoryFrame|)) - (RETURN - (PROGN - (SPADLET |opAlist| (GETDATABASE |constructor| 'OPERATIONALIST)) - (SPADLET |LETTMP#1| - (GETDATABASE |constructor| 'CONSTRUCTORMODEMAP)) - (SPADLET |dc| (CAAR |LETTMP#1|)) - (SPADLET |sig| (CDAR |LETTMP#1|)) - (SPADLET |pred| (CAADR |LETTMP#1|)) - (SPADLET |impl| (CADADR |LETTMP#1|)) - (SPADLET |$CategoryFrame| - (|put| |constructor| '|isFunctor| - (|convertOpAlist2compilerInfo| |opAlist|) - (|addModemap| |constructor| |dc| |sig| |pred| - |impl| - (|put| |constructor| '|mode| - (CONS '|Mapping| |sig|) - |$CategoryFrame|)))))))) - -;updateCategoryFrameForCategory(category) == -; [[dc,:sig],[pred,impl]] := GETDATABASE(category, 'CONSTRUCTORMODEMAP) -; $CategoryFrame := -; put(category, 'isCategory, 'T, -; addModemap(category, dc, sig, pred, impl, $CategoryFrame)) - -(DEFUN |updateCategoryFrameForCategory| (|category|) - (PROG (|LETTMP#1| |dc| |sig| |pred| |impl|) - (declare (special |$CategoryFrame|)) - (RETURN - (PROGN - (SPADLET |LETTMP#1| - (GETDATABASE |category| 'CONSTRUCTORMODEMAP)) - (SPADLET |dc| (CAAR |LETTMP#1|)) - (SPADLET |sig| (CDAR |LETTMP#1|)) - (SPADLET |pred| (CAADR |LETTMP#1|)) - (SPADLET |impl| (CADADR |LETTMP#1|)) - (SPADLET |$CategoryFrame| - (|put| |category| '|isCategory| 'T - (|addModemap| |category| |dc| |sig| |pred| - |impl| |$CategoryFrame|))))))) - ;makeConstructorsAutoLoad() == ; for cnam in allConstructors() repeat ; REMPROP(cnam,'LOADED) @@ -744,188 +602,6 @@ |editFlag| |traceFlag|)) |val|)))) -;compileDocumentation libName == -; filename := MAKE_-INPUT_-FILENAME(libName,$spadLibFT) -; $FCOPY(filename,[libName,'DOCLB]) -; stream := RDEFIOSTREAM [['FILE,libName,'DOCLB],['MODE, :'O]] -; lisplibWrite('"documentation",finalizeDocumentation(),stream) -;-- if $lisplibRelatedDomains then -;-- lisplibWrite('"relatedDomains",$lisplibRelatedDomains,stream) -; RSHUT(stream) -; RPACKFILE([libName,'DOCLB]) -; $REPLACE([libName,$spadLibFT],[libName,'DOCLB]) -; ['dummy, $EmptyMode, $e] - -(DEFUN |compileDocumentation| (|libName|) - (PROG (|filename| |stream|) - (declare (special |$e| |$EmptyMode| |$spadLibFT| $FCOPY)) - (RETURN - (PROGN - (SPADLET |filename| - (MAKE-INPUT-FILENAME |libName| |$spadLibFT|)) - ($FCOPY |filename| (CONS |libName| (CONS 'DOCLB NIL))) - (SPADLET |stream| - (RDEFIOSTREAM - (CONS (CONS 'FILE - (CONS |libName| (CONS 'DOCLB NIL))) - (CONS (CONS 'MODE 'O) NIL)))) - (|lisplibWrite| "documentation" - (|finalizeDocumentation|) |stream|) - (RSHUT |stream|) - (RPACKFILE (CONS |libName| (CONS 'DOCLB NIL))) - (replaceFile (CONS |libName| (CONS |$spadLibFT| NIL)) - (CONS |libName| (CONS 'DOCLB NIL))) - (CONS '|dummy| (CONS |$EmptyMode| (CONS |$e| NIL))))))) - -;finalizeLisplib libName == -; lisplibWrite('"constructorForm",removeZeroOne $lisplibForm,$libFile) -; lisplibWrite('"constructorKind",kind:=removeZeroOne $lisplibKind,$libFile) -; lisplibWrite('"constructorModemap",removeZeroOne $lisplibModemap,$libFile) -; $lisplibCategory:= $lisplibCategory or $lisplibModemap.mmTarget -; -- set to target of modemap for package/domain constructors; -; -- to the right-hand sides (the definition) for category constructors -; lisplibWrite('"constructorCategory",$lisplibCategory,$libFile) -; lisplibWrite('"sourceFile",namestring _/EDITFILE,$libFile) -; lisplibWrite('"modemaps",removeZeroOne $lisplibModemapAlist,$libFile) -; opsAndAtts:= getConstructorOpsAndAtts( -; $lisplibForm,kind,$lisplibModemap) -; lisplibWrite('"operationAlist",removeZeroOne CAR opsAndAtts,$libFile) -; --lisplibWrite('"attributes",CDR opsAndAtts,$libFile) -; --if kind='category then NRTgenInitialAttributeAlist CDR opsAndAtts -; if kind='category then -; $pairlis : local := [[a,:v] for a in rest $lisplibForm -; for v in $FormalMapVariableList] -; $NRTslot1PredicateList : local := [] -; 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) -; if $profileCompiler then profileWrite() -; if $lisplibForm and null CDR $lisplibForm then -; MAKEPROP(CAR $lisplibForm,'NILADIC,'T) -; ERRORS ^=0 => -- ERRORS is a fluid variable for the compiler -; sayMSG ['" Errors in processing ",kind,'" ",:bright libName,'":"] -; sayMSG ['" not replacing ",$spadLibFT,'" for",:bright libName] - -(DEFUN |finalizeLisplib| (|libName|) - (PROG (|$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|)) - (RETURN - (SEQ (PROGN - (|lisplibWrite| "constructorForm" - (|removeZeroOne| |$lisplibForm|) |$libFile|) - (|lisplibWrite| "constructorKind" - (SPADLET |kind| (|removeZeroOne| |$lisplibKind|)) - |$libFile|) - (|lisplibWrite| "constructorModemap" - (|removeZeroOne| |$lisplibModemap|) |$libFile|) - (SPADLET |$lisplibCategory| - (OR |$lisplibCategory| (CADAR |$lisplibModemap|))) - (|lisplibWrite| "constructorCategory" - |$lisplibCategory| |$libFile|) - (|lisplibWrite| "sourceFile" - (|namestring| /EDITFILE) |$libFile|) - (|lisplibWrite| "modemaps" - (|removeZeroOne| |$lisplibModemapAlist|) |$libFile|) - (SPADLET |opsAndAtts| - (|getConstructorOpsAndAtts| |$lisplibForm| |kind| - |$lisplibModemap|)) - (|lisplibWrite| "operationAlist" - (|removeZeroOne| (CAR |opsAndAtts|)) |$libFile|) - (COND - ((BOOT-EQUAL |kind| '|category|) - (SPADLET |$pairlis| - (PROG (G166609) - (SPADLET G166609 NIL) - (RETURN - (DO ((G166615 (CDR |$lisplibForm|) - (CDR G166615)) - (|a| NIL) - (G166616 |$FormalMapVariableList| - (CDR G166616)) - (|v| NIL)) - ((OR (ATOM G166615) - (PROGN - (SETQ |a| (CAR G166615)) - NIL) - (ATOM G166616) - (PROGN - (SETQ |v| (CAR G166616)) - NIL)) - (NREVERSE0 G166609)) - (SEQ (EXIT - (SETQ G166609 - (CONS (CONS |a| |v|) G166609)))))))) - (SPADLET |$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|) - (COND (|$profileCompiler| (|profileWrite|))) - (COND - ((AND |$lisplibForm| (NULL (CDR |$lisplibForm|))) - (MAKEPROP (CAR |$lisplibForm|) 'NILADIC 'T))) - (COND - ((NEQUAL ERRORS 0) - (PROGN - (|sayMSG| - (CONS " Errors in processing " - (CONS |kind| - (CONS " " - (APPEND (|bright| |libName|) - (CONS ":" NIL)))))) - (|sayMSG| - (CONS " not replacing " - (CONS |$spadLibFT| - (CONS " for" - (|bright| |libName|))))))))))))) - -;lisplibDoRename(libName) == -; _$REPLACE([libName,$spadLibFT,'a], -; [libName,'ERRORLIB,'a]) - -(DEFUN |lisplibDoRename| (|libName|) - (declare (special |$spadLibFT|)) - (replaceFile - (CONS |libName| - (CONS |$spadLibFT| (CONS 'a NIL))) - (CONS |libName| (CONS 'ERRORLIB (CONS 'a NIL))))) - ;lisplibError(cname,fname,type,cn,fn,typ,error) == ; sayMSG bright ['" Illegal ",$spadLibFT] ; error in '(duplicateAbb wrongType) => @@ -965,38 +641,6 @@ ((SPADLET |s| (|getConstructorSignature| |c|)) (CDR |s|)) ('T (|throwEvalTypeMsg| 'S2IL0015 (CONS |c| NIL))))))) -;mergeSignatureAndLocalVarAlists(signatureAlist, localVarAlist) == -; -- this function makes a single Alist for both signatures -; -- and local variable types, to be stored in the LISPLIB -; -- for the function being compiled -; [[funcName,:[signature,:LASSOC(funcName,localVarAlist)]] for -; [funcName, :signature] in signatureAlist] - -(DEFUN |mergeSignatureAndLocalVarAlists| - (|signatureAlist| |localVarAlist|) - (PROG (|funcName| |signature|) - (RETURN - (SEQ (PROG (G166659) - (SPADLET G166659 NIL) - (RETURN - (DO ((G166665 |signatureAlist| (CDR G166665)) - (G166650 NIL)) - ((OR (ATOM G166665) - (PROGN (SETQ G166650 (CAR G166665)) NIL) - (PROGN - (PROGN - (SPADLET |funcName| (CAR G166650)) - (SPADLET |signature| (CDR G166650)) - G166650) - NIL)) - (NREVERSE0 G166659)) - (SEQ (EXIT (SETQ G166659 - (CONS (CONS |funcName| - (CONS |signature| - (LASSOC |funcName| - |localVarAlist|))) - G166659))))))))))) - ;Operators u == ; ATOM u => [] ; ATOM first u => @@ -1040,58 +684,6 @@ (|union| G166691 (|Operators| |v|)))))))))))))) -;getConstructorOpsAndAtts(form,kind,modemap) == -; kind is 'category => getCategoryOpsAndAtts(form) -; getFunctorOpsAndAtts(form,modemap) - -(DEFUN |getConstructorOpsAndAtts| (|form| |kind| |modemap|) - (COND - ((EQ |kind| '|category|) (|getCategoryOpsAndAtts| |form|)) - ('T (|getFunctorOpsAndAtts| |form| |modemap|)))) - -;getCategoryOpsAndAtts(catForm) == -; -- returns [operations,:attributes] of CAR catForm -; [transformOperationAlist getSlotFromCategoryForm(catForm,1), -; :getSlotFromCategoryForm(catForm,2)] - -(DEFUN |getCategoryOpsAndAtts| (|catForm|) - (CONS (|transformOperationAlist| - (|getSlotFromCategoryForm| |catForm| 1)) - (|getSlotFromCategoryForm| |catForm| 2))) - -;getFunctorOpsAndAtts(form,modemap) == -; [transformOperationAlist getSlotFromFunctor(form,1,modemap), -; :getSlotFromFunctor(form,2,modemap)] - -(DEFUN |getFunctorOpsAndAtts| (|form| |modemap|) - (CONS (|transformOperationAlist| - (|getSlotFromFunctor| |form| 1 |modemap|)) - (|getSlotFromFunctor| |form| 2 |modemap|))) - -;getSlotFromFunctor([name,:args],slot,[[.,target,:argMml],:.]) == -; slot = 1 => $lisplibOperationAlist -; t := compMakeCategoryObject(target,$e) or -; systemErrorHere '"getSlotFromFunctor" -; t.expr.slot - -(DEFUN |getSlotFromFunctor| (G166719 |slot| G166728) - (PROG (|target| |argMml| |name| |args| |t|) - (declare (special |$e| |$lisplibOperationAlist|)) - (RETURN - (PROGN - (SPADLET |target| (CADAR G166728)) - (SPADLET |argMml| (CDDAR G166728)) - (SPADLET |name| (CAR G166719)) - (SPADLET |args| (CDR G166719)) - (COND - ((EQL |slot| 1) |$lisplibOperationAlist|) - ('T - (SPADLET |t| - (OR (|compMakeCategoryObject| |target| |$e|) - (|systemErrorHere| - "getSlotFromFunctor"))) - (ELT (CAR |t|) |slot|))))))) - ;getSlot1 domainName == ; $e: local:= $CategoryFrame ; fn:= getLisplibName domainName @@ -1115,9 +707,9 @@ |$CategoryFrame|)) (RETURN (SEQ (PROGN - (SPADLET |$e| |$CategoryFrame|) - (SPADLET |fn| (|getLisplibName| |domainName|)) - (SPADLET |p| + (setq |$e| |$CategoryFrame|) + (setq |fn| (|getLisplibName| |domainName|)) + (setq |p| (|pathname| (CONS |fn| (CONS |$spadLibFT| @@ -1126,10 +718,10 @@ ((NULL (|isExistingFile| |p|)) (|sayKeyedMsg| 'S2IL0003 (CONS (|namestring| |p|) NIL)) NIL) - ((SPADLET |sig| + ((setq |sig| (|getConstructorSignature| |domainName|)) - (SPADLET |target| (CADR |sig|)) - (SPADLET |argMml| (CDDR |sig|)) + (setq |target| (CADR |sig|)) + (setq |argMml| (CDDR |sig|)) (DO ((G166759 |$FormalMapVariableList| (CDR G166759)) (|a| NIL) (G166760 |argMml| (CDR G166760)) @@ -1139,9 +731,9 @@ (ATOM G166760) (PROGN (SETQ |m| (CAR G166760)) NIL)) NIL) - (SEQ (EXIT (SPADLET |$e| + (SEQ (EXIT (setq |$e| (|put| |a| '|mode| |m| |$e|))))) - (SPADLET |t| + (setq |t| (OR (|compMakeCategoryObject| |target| |$e|) (|systemErrorHere| "getSlot1"))) @@ -1152,135 +744,6 @@ (CONS "constructor modemap" NIL))) NIL))))))) -;transformOperationAlist operationAlist == -; -- this transforms the operationAlist which is written out onto LISPLIBs. -; -- The original form of this list is a list of items of the form: -; -- (( ) ( (ELT $ n))) -; -- The new form is an op-Alist which has entries ( . signature-Alist) -; -- where signature-Alist has entries ( . item) -; -- where item has form ( ) -; -- where = -; -- NIL => function -; -- CONST => constant ... and others -; newAlist:= nil -; for [[op,sig,:.],condition,implementation] in operationAlist repeat -; kind:= -; implementation is [eltEtc,.,n] and eltEtc in '(CONST ELT) => eltEtc -; implementation is [impOp,:.] => -; impOp = 'XLAM => implementation -; impOp in '(CONST Subsumed) => impOp -; keyedSystemError("S2IL0025",[impOp]) -; implementation = 'mkRecord => 'mkRecord -; keyedSystemError("S2IL0025",[implementation]) -; signatureItem:= -; if u:= ASSOC([op,sig],$functionLocations) then n := [n,:rest u] -; kind = 'ELT => -; condition = 'T => [sig,n] -; [sig,n,condition] -; [sig,n,condition,kind] -; itemList:= [signatureItem,:LASSQ(op,newAlist)] -; newAlist:= insertAlist(op,itemList,newAlist) -; newAlist - -(DEFUN |transformOperationAlist| (|operationAlist|) - (PROG (|op| |sig| |condition| |implementation| |eltEtc| |ISTMP#1| - |ISTMP#2| |impOp| |kind| |u| |n| |signatureItem| - |itemList| |newAlist|) - (declare (special |$functionLocations|)) - (RETURN - (SEQ (PROGN - (SPADLET |newAlist| NIL) - (DO ((G166830 |operationAlist| (CDR G166830)) - (G166804 NIL)) - ((OR (ATOM G166830) - (PROGN (SETQ G166804 (CAR G166830)) NIL) - (PROGN - (PROGN - (SPADLET |op| (CAAR G166804)) - (SPADLET |sig| (CADAR G166804)) - (SPADLET |condition| (CADR G166804)) - (SPADLET |implementation| (CADDR G166804)) - G166804) - NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |kind| - (COND - ((AND (PAIRP |implementation|) - (PROGN - (SPADLET |eltEtc| - (QCAR |implementation|)) - (SPADLET |ISTMP#1| - (QCDR |implementation|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (SPADLET |n| - (QCAR |ISTMP#2|)) - 'T))))) - (|member| |eltEtc| - '(CONST ELT))) - |eltEtc|) - ((AND (PAIRP |implementation|) - (PROGN - (SPADLET |impOp| - (QCAR |implementation|)) - 'T)) - (COND - ((BOOT-EQUAL |impOp| 'XLAM) - |implementation|) - ((|member| |impOp| - '(CONST |Subsumed|)) - |impOp|) - ('T - (|keyedSystemError| - 'S2IL0025 - (CONS |impOp| NIL))))) - ((BOOT-EQUAL |implementation| - '|mkRecord|) - '|mkRecord|) - ('T - (|keyedSystemError| 'S2IL0025 - (CONS |implementation| NIL))))) - (SPADLET |signatureItem| - (PROGN - (COND - ((SPADLET |u| - (|assoc| - (CONS |op| - (CONS |sig| NIL)) - |$functionLocations|)) - (SPADLET |n| - (CONS |n| (CDR |u|))))) - (COND - ((BOOT-EQUAL |kind| 'ELT) - (COND - ((BOOT-EQUAL |condition| - 'T) - (CONS |sig| - (CONS |n| NIL))) - ('T - (CONS |sig| - (CONS |n| - (CONS |condition| NIL)))))) - ('T - (CONS |sig| - (CONS |n| - (CONS |condition| - (CONS |kind| NIL)))))))) - (SPADLET |itemList| - (CONS |signatureItem| - (LASSQ |op| |newAlist|))) - (SPADLET |newAlist| - (|insertAlist| |op| |itemList| - |newAlist|)))))) - |newAlist|))))) - ;sayNonUnique x == ; sayBrightlyNT '"Non-unique:" ; pp x @@ -1311,21 +774,21 @@ (PROG (|sig| |domain| |n| |slot|) (RETURN (PROGN - (SPADLET |oldSig| (|removeOPT| |oldSig|)) - (SPADLET |dom| (|removeOPT| |dom|)) - (SPADLET |sig| (MSUBST '$ |dom| |oldSig|)) + (setq |oldSig| (|removeOPT| |oldSig|)) + (setq |dom| (|removeOPT| |dom|)) + (setq |sig| (MSUBST '$ |dom| |oldSig|)) (|loadIfNecessary| (CAR |dom|)) (COND ((|isPackageForm| |dom|) (|getSlotFromPackage| |dom| |op| |oldSig|)) - ('T (SPADLET |domain| (|evalDomain| |dom|)) + ('T (setq |domain| (|evalDomain| |dom|)) (COND - ((SPADLET |n| + ((setq |n| (|findConstructorSlotNumber| |dom| |domain| |op| |sig|)) (COND ((BOOT-EQUAL - (ELT (SPADLET |slot| (ELT |domain| |n|)) 0) + (ELT (setq |slot| (ELT |domain| |n|)) 0) |Undef|) (|throwKeyedMsg| 'S2IL0023A (CONS |op| @@ -1364,11 +827,11 @@ (|sayMSG| (CONS " using slot 1 of " (CONS |domainForm| NIL))) - (SPADLET |constructorArglist| (CDR |domainForm|)) - (SPADLET |nsig| (|#| |sig|)) - (SPADLET |tail| + (setq |constructorArglist| (CDR |domainForm|)) + (setq |nsig| (|#| |sig|)) + (setq |tail| (PROG (G166911) - (SPADLET G166911 NIL) + (setq G166911 NIL) (RETURN (DO ((G166919 NIL G166911) (G166920 (ELT |domain| 1) @@ -1380,11 +843,11 @@ NIL) (PROGN (PROGN - (SPADLET |op1| + (setq |op1| (CAAR G166872)) - (SPADLET |sig1| + (setq |sig1| (CADAR G166872)) - (SPADLET |r| (CDR G166872)) + (setq |r| (CDR G166872)) G166872) NIL)) G166911) @@ -1393,7 +856,7 @@ (BOOT-EQUAL |nsig| (|#| |sig1|)) (PROG (G166928) - (SPADLET G166928 'T) + (setq G166928 'T) (RETURN (DO ((G166935 NIL @@ -1442,24 +905,24 @@ (COND ((AND (PAIRP |tail|) (PROGN - (SPADLET |ISTMP#1| (QCDR |tail|)) + (setq |ISTMP#1| (QCDR |tail|)) (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCAR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (EQ (QCAR |ISTMP#2|) 'ELT) (PROGN - (SPADLET |ISTMP#3| + (setq |ISTMP#3| (QCDR |ISTMP#2|)) (AND (PAIRP |ISTMP#3|) (PROGN - (SPADLET |ISTMP#4| + (setq |ISTMP#4| (QCDR |ISTMP#3|)) (AND (PAIRP |ISTMP#4|) (EQ (QCDR |ISTMP#4|) NIL) (PROGN - (SPADLET |n| + (setq |n| (QCAR |ISTMP#4|)) 'T)))))))))) |n|) @@ -1475,14 +938,14 @@ (COND ((AND (PAIRP |d|) (EQ (QCAR |d|) '|Union|) (PROGN - (SPADLET |ISTMP#1| (QCDR |d|)) + (setq |ISTMP#1| (QCDR |d|)) (AND (PAIRP |ISTMP#1|) (PROGN - (SPADLET |domain| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (setq |domain| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) (PROGN - (SPADLET |utype| (QCAR |ISTMP#2|)) + (setq |utype| (QCAR |ISTMP#2|)) 'T))))) (BOOT-EQUAL |utype| "failed")) |domain|) @@ -1504,19 +967,19 @@ |entryList| |sig1| |r| |tail|) (RETURN (SEQ (PROGN - (SPADLET |constructorName| (CAR |domainForm|)) - (SPADLET |constructorArglist| (CDR |domainForm|)) - (SPADLET |operationAlist| + (setq |constructorName| (CAR |domainForm|)) + (setq |constructorArglist| (CDR |domainForm|)) + (setq |operationAlist| (OR (GETDATABASE |constructorName| 'OPERATIONALIST) (|keyedSystemError| 'S2IL0026 (CONS |constructorName| NIL)))) - (SPADLET |entryList| + (setq |entryList| (OR (QLASSQ |op| |operationAlist|) (RETURN NIL))) (COND - ((SPADLET |tail| + ((setq |tail| (PROG (G166992) - (SPADLET G166992 NIL) + (setq G166992 NIL) (RETURN (DO ((G167000 NIL G166992) (G167001 |entryList| @@ -1529,9 +992,9 @@ NIL) (PROGN (PROGN - (SPADLET |sig1| + (setq |sig1| (CAR G166987)) - (SPADLET |r| (CDR G166987)) + (setq |r| (CDR G166987)) G166987) NIL)) G166992) @@ -1564,11 +1027,11 @@ (SEQ (PROGN (DO () ((NULL (AND |sig| |sig1|)) NIL) (SEQ (EXIT (PROGN - (SPADLET |partsMatch| + (setq |partsMatch| (COND ((BOOT-EQUAL - (SPADLET |item| (CAR |sig|)) - (SPADLET |item1| (CAR |sig1|))) + (setq |item| (CAR |sig|)) + (setq |item1| (CAR |sig1|))) 'T) ((integerp |item1|) (BOOT-EQUAL |item| @@ -1580,8 +1043,8 @@ |$CategoryFrame|)))) (COND ((NULL |partsMatch|) (RETURN NIL)) - ('T (SPADLET |sig| (CDR |sig|)) - (SPADLET |sig1| (CDR |sig1|)))))))) + ('T (setq |sig| (CDR |sig|)) + (setq |sig1| (CDR |sig1|)))))))) (COND ((OR |sig| |sig1|) NIL) ('T 'T))))))) ;findDomainSlotNumber(domain,op,sig) == --using slot 1 of the domain @@ -1598,10 +1061,10 @@ (declare (special |$CategoryFrame|)) (RETURN (SEQ (PROGN - (SPADLET |nsig| (|#| |sig|)) - (SPADLET |tail| + (setq |nsig| (|#| |sig|)) + (setq |tail| (PROG (G167073) - (SPADLET G167073 NIL) + (setq G167073 NIL) (RETURN (DO ((G167081 NIL G167073) (G167082 (ELT |domain| 1) @@ -1613,10 +1076,10 @@ NIL) (PROGN (PROGN - (SPADLET |op1| (CAAR G167039)) - (SPADLET |sig1| + (setq |op1| (CAAR G167039)) + (setq |sig1| (CADAR G167039)) - (SPADLET |r| (CDR G167039)) + (setq |r| (CDR G167039)) G167039) NIL)) G167073) @@ -1625,7 +1088,7 @@ (BOOT-EQUAL |nsig| (|#| |sig1|)) (PROG (G167090) - (SPADLET G167090 'T) + (setq G167090 'T) (RETURN (DO ((G167097 NIL @@ -1666,23 +1129,23 @@ (COND ((AND (PAIRP |tail|) (PROGN - (SPADLET |ISTMP#1| (QCDR |tail|)) + (setq |ISTMP#1| (QCDR |tail|)) (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCAR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (EQ (QCAR |ISTMP#2|) 'ELT) (PROGN - (SPADLET |ISTMP#3| + (setq |ISTMP#3| (QCDR |ISTMP#2|)) (AND (PAIRP |ISTMP#3|) (PROGN - (SPADLET |ISTMP#4| + (setq |ISTMP#4| (QCDR |ISTMP#3|)) (AND (PAIRP |ISTMP#4|) (EQ (QCDR |ISTMP#4|) NIL) (PROGN - (SPADLET |n| + (setq |n| (QCAR |ISTMP#4|)) 'T)))))))))) |n|) @@ -1705,325 +1168,11 @@ (PROG (|mm| |sig|) (RETURN (COND - ((SPADLET |mm| + ((setq |mm| (GETDATABASE (|opOf| |form|) 'CONSTRUCTORMODEMAP)) - (SPADLET |sig| (CDAR |mm|)) |sig|) + (setq |sig| (CDAR |mm|)) |sig|) ('T NIL))))) -;--% from MODEMAP BOOT -; -;augModemapsFromDomain1(name,functorForm,e) == -; GET(KAR functorForm,"makeFunctionList") => -; addConstructorModemaps(name,functorForm,e) -; atom functorForm and (catform:= getmode(functorForm,e)) => -; augModemapsFromCategory(name,name,functorForm,catform,e) -; mappingForm:= getmodeOrMapping(KAR functorForm,e) => -; ["Mapping",categoryForm,:functArgTypes]:= mappingForm -; catform:= substituteCategoryArguments(rest functorForm,categoryForm) -; augModemapsFromCategory(name,name,functorForm,catform,e) -; stackMessage [functorForm," is an unknown mode"] -; e - -(DEFUN |augModemapsFromDomain1| (|name| |functorForm| |e|) - (PROG (|mappingForm| |categoryForm| |functArgTypes| |catform|) - (RETURN - (COND - ((GETL (KAR |functorForm|) '|makeFunctionList|) - (|addConstructorModemaps| |name| |functorForm| |e|)) - ((AND (ATOM |functorForm|) - (SPADLET |catform| (|getmode| |functorForm| |e|))) - (|augModemapsFromCategory| |name| |functorForm| |catform| |e|)) - ((SPADLET |mappingForm| - (|getmodeOrMapping| (KAR |functorForm|) |e|)) - (COND - ((EQ (CAR |mappingForm|) '|Mapping|) (CAR |mappingForm|))) - (SPADLET |categoryForm| (CADR |mappingForm|)) - (SPADLET |functArgTypes| (CDDR |mappingForm|)) - (SPADLET |catform| - (|substituteCategoryArguments| (CDR |functorForm|) - |categoryForm|)) - (|augModemapsFromCategory| |name| |functorForm| |catform| |e|)) - ('T - (|stackMessage| - (CONS |functorForm| (CONS '| is an unknown mode| NIL))) - |e|))))) - - -;addConstructorModemaps(name,form is [functorName,:.],e) == -; $InteractiveMode: local:= nil -; e:= putDomainsInScope(name,e) --frame -; fn := GET(functorName,"makeFunctionList") -; [funList,e]:= FUNCALL(fn,name,form,e) -; for [op,sig,opcode] in funList repeat -; if opcode is [sel,dc,n] and sel='ELT then -; nsig := substitute("$$$",name,sig) -; nsig := substitute('$,"$$$",substitute("$$",'$,nsig)) -; opcode := [sel,dc,nsig] -; e:= addModemap(op,name,sig,true,opcode,e) -; e - -(DEFUN |addConstructorModemaps| (|name| |form| |e|) - (PROG (|$InteractiveMode| |functorName| |fn| |LETTMP#1| |funList| - |op| |sig| |sel| |ISTMP#1| |dc| |ISTMP#2| |n| |nsig| - |opcode|) - (DECLARE (SPECIAL |$InteractiveMode|)) - (RETURN - (SEQ (PROGN - (SPADLET |functorName| (CAR |form|)) - (SPADLET |$InteractiveMode| NIL) - (SPADLET |e| (|putDomainsInScope| |name| |e|)) - (SPADLET |fn| (GETL |functorName| '|makeFunctionList|)) - (SPADLET |LETTMP#1| (FUNCALL |fn| |name| |form| |e|)) - (SPADLET |funList| (CAR |LETTMP#1|)) - (SPADLET |e| (CADR |LETTMP#1|)) - (DO ((G166774 |funList| (CDR G166774)) - (G166732 NIL)) - ((OR (ATOM G166774) - (PROGN (SETQ G166732 (CAR G166774)) NIL) - (PROGN - (PROGN - (SPADLET |op| (CAR G166732)) - (SPADLET |sig| (CADR G166732)) - (SPADLET |opcode| (CADDR G166732)) - G166732) - NIL)) - NIL) - (SEQ (EXIT (PROGN - (COND - ((AND (PAIRP |opcode|) - (PROGN - (SPADLET |sel| (QCAR |opcode|)) - (SPADLET |ISTMP#1| - (QCDR |opcode|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |dc| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |n| - (QCAR |ISTMP#2|)) - 'T))))) - (BOOT-EQUAL |sel| 'ELT)) - (SPADLET |nsig| - (MSUBST '$$$ |name| |sig|)) - (SPADLET |nsig| - (MSUBST '$ '$$$ - (MSUBST '$$ '$ |nsig|))) - (SPADLET |opcode| - (CONS |sel| - (CONS |dc| (CONS |nsig| NIL)))))) - (SPADLET |e| - (|addModemap| |op| |name| |sig| 'T - |opcode| |e|)))))) - |e|))))) - - -;substituteCategoryArguments(argl,catform) == -; argl:= substitute("$$","$",argl) -; arglAssoc:= [[INTERNL("#",STRINGIMAGE i),:a] for i in 1.. for a in argl] -; SUBLIS(arglAssoc,catform) - -(DEFUN |substituteCategoryArguments| (|argl| |catform|) - (PROG (|arglAssoc|) - (RETURN - (SEQ (PROGN - (SPADLET |argl| (MSUBST '$$ '$ |argl|)) - (SPADLET |arglAssoc| - (PROG (G166422) - (SPADLET G166422 NIL) - (RETURN - (DO ((|i| 1 (QSADD1 |i|)) - (G166428 |argl| (CDR G166428)) - (|a| NIL)) - ((OR (ATOM G166428) - (PROGN - (SETQ |a| (CAR G166428)) - NIL)) - (NREVERSE0 G166422)) - (SEQ (EXIT (SETQ G166422 - (CONS - (CONS - (INTERNL '|#| - (STRINGIMAGE |i|)) - |a|) - G166422)))))))) - (SUBLIS |arglAssoc| |catform|)))))) - -;getSlotFromCategoryForm ([op,:argl],index) == -; u:= eval [op,:MAPCAR('MKQ,TAKE(#argl,$FormalMapVariableList))] -; null VECP u => -; systemErrorHere '"getSlotFromCategoryForm" -; u . index - -(DEFUN |getSlotFromCategoryForm| (G167151 |index|) - (PROG (|op| |argl| |u|) - (declare (special |$FormalMapVariableList|)) - (RETURN - (PROGN - (SPADLET |op| (CAR G167151)) - (SPADLET |argl| (CDR G167151)) - (SPADLET |u| - (|eval| (CONS |op| - (MAPCAR 'MKQ - (TAKE (|#| |argl|) - |$FormalMapVariableList|))))) - (COND - ((NULL (VECP |u|)) - (|systemErrorHere| "getSlotFromCategoryForm")) - ('T (ELT |u| |index|))))))) - -;--% constructor evaluation -;-- The following functions are used by the compiler but are modified -;-- here for use with new LISPLIB scheme -; -;mkEvalableCategoryForm c == --from DEFINE -; c is [op,:argl] => -; op="Join" => ["Join",:[mkEvalableCategoryForm x for x in argl]] -; op is "DomainSubstitutionMacro" => -; --$extraParms :local -; --catobj := EVAL c -- DomainSubstitutionFunction makes $extraParms -; --mkEvalableCategoryForm sublisV($extraParms, catobj) -; mkEvalableCategoryForm CADR argl -; op is "mkCategory" => c -; MEMQ(op,$CategoryNames) => -; ([x,m,$e]:= compOrCroak(c,$EmptyMode,$e); m=$Category => x) -; --loadIfNecessary op -; GETDATABASE(op,'CONSTRUCTORKIND) = 'category or -; get(op,"isCategory",$CategoryFrame) => -; [op,:[quotifyCategoryArgument x for x in argl]] -; [x,m,$e]:= compOrCroak(c,$EmptyMode,$e) -; m=$Category => x -; MKQ c - -(DEFUN |mkEvalableCategoryForm| (|c|) - (PROG (|op| |argl| |LETTMP#1| |x| |m|) - (declare (special |$Category| |$e| |$EmptyMode| |$CategoryFrame| - |$CategoryNames|)) - (RETURN - (SEQ (COND - ((AND (PAIRP |c|) - (PROGN - (SPADLET |op| (QCAR |c|)) - (SPADLET |argl| (QCDR |c|)) - 'T)) - (COND - ((BOOT-EQUAL |op| '|Join|) - (CONS '|Join| - (PROG (G167194) - (SPADLET G167194 NIL) - (RETURN - (DO ((G167199 |argl| (CDR G167199)) - (|x| NIL)) - ((OR (ATOM G167199) - (PROGN - (SETQ |x| (CAR G167199)) - NIL)) - (NREVERSE0 G167194)) - (SEQ (EXIT (SETQ G167194 - (CONS - (|mkEvalableCategoryForm| - |x|) - G167194))))))))) - ((EQ |op| '|DomainSubstitutionMacro|) - (|mkEvalableCategoryForm| (CADR |argl|))) - ((EQ |op| '|mkCategory|) |c|) - ((member |op| |$CategoryNames|) - (SPADLET |LETTMP#1| - (|compOrCroak| |c| |$EmptyMode| |$e|)) - (SPADLET |x| (CAR |LETTMP#1|)) - (SPADLET |m| (CADR |LETTMP#1|)) - (SPADLET |$e| (CADDR |LETTMP#1|)) - (COND ((BOOT-EQUAL |m| |$Category|) |x|))) - ((OR (BOOT-EQUAL (GETDATABASE |op| 'CONSTRUCTORKIND) - '|category|) - (|get| |op| '|isCategory| |$CategoryFrame|)) - (CONS |op| - (PROG (G167209) - (SPADLET G167209 NIL) - (RETURN - (DO ((G167214 |argl| (CDR G167214)) - (|x| NIL)) - ((OR (ATOM G167214) - (PROGN - (SETQ |x| (CAR G167214)) - NIL)) - (NREVERSE0 G167209)) - (SEQ (EXIT (SETQ G167209 - (CONS - (|quotifyCategoryArgument| - |x|) - G167209))))))))) - ('T - (SPADLET |LETTMP#1| - (|compOrCroak| |c| |$EmptyMode| |$e|)) - (SPADLET |x| (CAR |LETTMP#1|)) - (SPADLET |m| (CADR |LETTMP#1|)) - (SPADLET |$e| (CADDR |LETTMP#1|)) - (COND ((BOOT-EQUAL |m| |$Category|) |x|))))) - ('T (MKQ |c|))))))) - -;isDomainForm(D,e) == -; --added for MPOLY 3/83 by RDJ -; MEMQ(KAR D,$SpecialDomainNames) or isFunctor D or -; -- ((D is ['Mapping,target,:.]) and isCategoryForm(target,e)) or -; ((getmode(D,e) is ['Mapping,target,:.]) and isCategoryForm(target,e)) or -; isCategoryForm(getmode(D,e),e) or isDomainConstructorForm(D,e) - -(DEFUN |isDomainForm| (D |e|) - (PROG (|ISTMP#1| |ISTMP#2| |target|) - (declare (special |$SpecialDomainNames|)) - (RETURN - (OR (member (KAR D) |$SpecialDomainNames|) (|isFunctor| D) - (AND (PROGN - (SPADLET |ISTMP#1| (|getmode| D |e|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|Mapping|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |target| (QCAR |ISTMP#2|)) - 'T))))) - (|isCategoryForm| |target| |e|)) - (|isCategoryForm| (|getmode| D |e|) |e|) - (|isDomainConstructorForm| D |e|))))) - -;isDomainConstructorForm(D,e) == -; D is [op,:argl] and (u:= get(op,"value",e)) and -; u is [.,["Mapping",target,:.],:.] and -; isCategoryForm(EQSUBSTLIST(argl,$FormalMapVariableList,target),e) - -(DEFUN |isDomainConstructorForm| (D |e|) - (PROG (|op| |argl| |u| |ISTMP#1| |ISTMP#2| |ISTMP#3| |target|) - (declare (special |$FormalMapVariableList|)) - (RETURN - (AND (PAIRP D) - (PROGN - (SPADLET |op| (QCAR D)) - (SPADLET |argl| (QCDR D)) - 'T) - (SPADLET |u| (|get| |op| '|value| |e|)) (PAIRP |u|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) '|Mapping|) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |target| (QCAR |ISTMP#3|)) - 'T))))))) - (|isCategoryForm| - (EQSUBSTLIST |argl| |$FormalMapVariableList| |target|) - |e|))))) - ;isFunctor x == ; op:= opOf x ; not IDENTP op => false @@ -2048,7 +1197,7 @@ (declare (special |$CategoryFrame| |$InteractiveMode|)) (RETURN (PROGN - (SPADLET |op| (|opOf| |x|)) + (setq |op| (|opOf| |x|)) (COND ((NULL (IDENTP |op|)) NIL) (|$InteractiveMode| @@ -2058,13 +1207,13 @@ ('T (member (GETDATABASE |op| 'CONSTRUCTORKIND) '(|domain| |package|))))) - ((SPADLET |u| + ((setq |u| (OR (|get| |op| '|isFunctor| |$CategoryFrame|) (member |op| '(|SubDomain| |Union| |Record|)))) |u|) ((|constructor?| |op|) (COND - ((SPADLET |prop| + ((setq |prop| (|get| |op| '|isFunctor| |$CategoryFrame|)) |prop|) ('T diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index 7f1cc8f..7f7118a 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -5422,7 +5422,6 @@ now the function is defined but does nothing. ;;; Common Block (defvar |$UserLevel| '|development|) -(defvar |$preserveSystemLisplib| t "if nil finalizeLisplib does MA REP") (defvar |$incrementalLisplibFlag| nil "checked in compDefineLisplib") (defvar |$reportInstantiations| nil) (defvar |$reportEachInstantiation| nil)