diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 80d0d0f..e3fd333 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -7074,30 +7074,6 @@ $\rightarrow$ \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{genDomainOps}{genDomainOps} \calls{genDomainOps}{getOperationAlist} \calls{genDomainOps}{substNames} @@ -7301,6 +7277,234 @@ $\rightarrow$ \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}{pairp} +\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 tmp2 target) + (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 (pairp tmp1) (eq (qcar tmp1) '|Mapping|) + (pairp (qcdr 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{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{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} + +\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} + +\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{substNames}{substNames} +\calls{substNames}{substq} +\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 (substq '$$ '$ 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 + (substq '$ '$$ (substq nameForDollar '$ modemapform)) + (list + (list sel viewName (if (eq domainName '$) pos (cadar modemapform))))) + tmp0)))) + +\end{chunk} + +\defun{augModemapsFromCategoryRep}{augModemapsFromCategoryRep} +\calls{augModemapsFromCategoryRep}{evalAndSub} +\calls{augModemapsFromCategoryRep}{isCategory} +\calls{augModemapsFromCategoryRep}{compilerMessage} +\calls{augModemapsFromCategoryRep}{putDomainsInScope} +\calls{augModemapsFromCategoryRep}{assoc} +\calls{augModemapsFromCategoryRep}{msubst} +\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 (pairp u) + (setq op (qcar u)) + (setq z (qcdr 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| (msubst '|Rep| domainName lhs) 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} + \section{Indirect called comp routines} In the {\bf compExpression} function there is the code: \begin{verbatim} @@ -16408,6 +16612,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun action} \getchunk{defun addclose} +\getchunk{defun addDomain} \getchunk{defun addEmptyCapsuleIfNecessary} \getchunk{defun add-parens-and-semis-to-line} \getchunk{defun Advance-Char} @@ -16417,6 +16622,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun aplTranList} \getchunk{defun argsToSig} \getchunk{defun augModemapsFromCategory} +\getchunk{defun augModemapsFromCategoryRep} \getchunk{defun blankp} \getchunk{defun bumperrorcount} @@ -16527,6 +16733,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun errhuh} \getchunk{defun escape-keywords} \getchunk{defun escaped} +\getchunk{defun evalAndSub} \getchunk{defun extractCodeAndConstructTriple} \getchunk{defun fincomblock} @@ -16534,6 +16741,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun freelist} \getchunk{defun get-a-line} +\getchunk{defun getOperationAlist} \getchunk{defun getScriptName} \getchunk{defun getTargetFromRhs} \getchunk{defun get-token} @@ -16810,6 +17018,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun stack-pop} \getchunk{defun stack-push} \getchunk{defun storeblanks} +\getchunk{defun substNames} \getchunk{defun s-process} \getchunk{defun token-install} diff --git a/changelog b/changelog index 51606c9..1691b5b 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20110708 tpd src/axiom-website/patches.html 20110708.01.tpd.patch +20110708 tpd src/interp/vmlisp.lisp treehake compiler +20110708 tpd src/interp/modemap.lisp treeshake compiler +20110708 tpd books/bookvol9 treeshake compiler 20110707 tpd src/axiom-website/patches.html 20110707.01.tpd.patch 20110707 tpd src/interp/interp-proclaims.lisp change function arity 20110707 tpd src/interp/modemap.lisp treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index a5aa0c8..df34d98 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3530,5 +3530,7 @@ books/bookvol5 remove dewriteify,s inner function
books/bookvol9 use \defsdollar and \refsdollar
20110707.01.tpd.patch books/bookvol9 treeshake compiler
+20110708.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/modemap.lisp.pamphlet b/src/interp/modemap.lisp.pamphlet index 915fad2..8eee908 100644 --- a/src/interp/modemap.lisp.pamphlet +++ b/src/interp/modemap.lisp.pamphlet @@ -18,65 +18,6 @@ ;--These functions are called from outside this file to add a domain ;-- or to get the current domains in scope; ; -;addDomain(domain,e) == -; atom domain => -; EQ(domain,"$EmptyMode") => e -; EQ(domain,"$NoValueMode") => e -; not IDENTP domain or 2<#(s:= STRINGIMAGE domain) and -; EQ(char "#",s.(0)) and EQ(char "#",s.(1)) => e -; MEMQ(domain,getDomainsInScope e) => e -; isLiteral(domain,e) => e -; addNewDomain(domain,e) -; (name:= first domain)='Category => e -; domainMember(domain,getDomainsInScope e) => e -; getmode(name,e) is ["Mapping",target,:.] and isCategoryForm(target,e)=> -; addNewDomain(domain,e) -; -- constructor? test needed for domains compiled with $bootStrapMode=true -; isFunctor name or constructor? name => addNewDomain(domain,e) -; if not isCategoryForm(domain,e) and -; not MEMBER(name,'(Mapping CATEGORY)) then -; unknownTypeError name -; e --is not a functor - -(DEFUN |addDomain| (|domain| |e|) - (PROG (|s| |name| |ISTMP#1| |ISTMP#2| |target|) - (RETURN - (COND - ((ATOM |domain|) - (COND - ((EQ |domain| '|$EmptyMode|) |e|) - ((EQ |domain| '|$NoValueMode|) |e|) - ((OR (NULL (IDENTP |domain|)) - (AND (QSLESSP 2 - (|#| (SPADLET |s| (STRINGIMAGE |domain|)))) - (EQ (|char| '|#|) (ELT |s| 0)) - (EQ (|char| '|#|) (ELT |s| 1)))) - |e|) - ((member |domain| (|getDomainsInScope| |e|)) |e|) - ((|isLiteral| |domain| |e|) |e|) - ('T (|addNewDomain| |domain| |e|)))) - ((BOOT-EQUAL (SPADLET |name| (CAR |domain|)) '|Category|) |e|) - ((|domainMember| |domain| (|getDomainsInScope| |e|)) |e|) - ((AND (PROGN - (SPADLET |ISTMP#1| (|getmode| |name| |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|)) - (|addNewDomain| |domain| |e|)) - ((OR (|isFunctor| |name|) (|constructor?| |name|)) - (|addNewDomain| |domain| |e|)) - ('T - (COND - ((AND (NULL (|isCategoryForm| |domain| |e|)) - (NULL (|member| |name| '(|Mapping| CATEGORY)))) - (|unknownTypeError| |name|))) - |e|))))) - ;domainMember(dom,domList) == or/[modeEqual(dom,d) for d in domList] (DEFUN |domainMember| (|dom| |domList|) @@ -656,275 +597,6 @@ G166422)))))))) (SUBLIS |arglAssoc| |catform|)))))) -; --Called, by compDefineFunctor, to add modemaps for $ that may -; --be equivalent to those of Rep. We must check that these -; --operations are not being redefined. -;augModemapsFromCategoryRep(domainName,repDefn,functorBody,categoryForm,e) == -; [fnAlist,e]:= evalAndSub(domainName,domainName,domainName,categoryForm,e) -; [repFnAlist,e]:= evalAndSub('Rep,'Rep,repDefn,getmode(repDefn,e),e) -; catform:= (isCategory categoryForm => categoryForm.(0); categoryForm) -; compilerMessage ["Adding ",domainName," modemaps"] -; e:= putDomainsInScope(domainName,e) -; $base:= 4 -; for [lhs:=[op,sig,:.],cond,fnsel] in fnAlist repeat -; u:=ASSOC(SUBST('Rep,domainName,lhs),repFnAlist) -; u and not AMFCR_,redefinedList(op,functorBody) => -; fnsel':=CADDR u -; e:= addModemap(op,domainName,sig,cond,fnsel',e) -; e:= addModemap(op,domainName,sig,cond,fnsel,e) -; e -(DEFUN |augModemapsFromCategoryRep| - (|domainName| |repDefn| |functorBody| |categoryForm| |e|) - (PROG (|fnAlist| |LETTMP#1| |repFnAlist| |catform| |lhs| |op| |sig| - |cond| |fnsel| |u| |fnsel'|) - (declare (special |$base|)) - (RETURN - (SEQ (PROGN - (SPADLET |LETTMP#1| - (|evalAndSub| |domainName| |domainName| - |domainName| |categoryForm| |e|)) - (SPADLET |fnAlist| (CAR |LETTMP#1|)) - (SPADLET |e| (CADR |LETTMP#1|)) - (SPADLET |LETTMP#1| - (|evalAndSub| '|Rep| '|Rep| |repDefn| - (|getmode| |repDefn| |e|) |e|)) - (SPADLET |repFnAlist| (CAR |LETTMP#1|)) - (SPADLET |e| (CADR |LETTMP#1|)) - (SPADLET |catform| - (COND - ((|isCategory| |categoryForm|) - (ELT |categoryForm| 0)) - ('T |categoryForm|))) - (|compilerMessage| - (CONS '|Adding | - (CONS |domainName| (CONS '| modemaps| NIL)))) - (SPADLET |e| (|putDomainsInScope| |domainName| |e|)) - (SPADLET |$base| 4) - (DO ((G166471 |fnAlist| (CDR G166471)) - (G166457 NIL)) - ((OR (ATOM G166471) - (PROGN (SETQ G166457 (CAR G166471)) NIL) - (PROGN - (PROGN - (SPADLET |lhs| (CAR G166457)) - (SPADLET |op| (CAAR G166457)) - (SPADLET |sig| (CADAR G166457)) - (SPADLET |cond| (CADR G166457)) - (SPADLET |fnsel| (CADDR G166457)) - G166457) - NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |u| - (|assoc| - (MSUBST '|Rep| |domainName| - |lhs|) - |repFnAlist|)) - (COND - ((AND |u| - (NULL - (|AMFCR,redefinedList| |op| - |functorBody|))) - (SPADLET |fnsel'| (CADDR |u|)) - (SPADLET |e| - (|addModemap| |op| |domainName| - |sig| |cond| |fnsel'| |e|))) - ('T - (SPADLET |e| - (|addModemap| |op| |domainName| - |sig| |cond| |fnsel| |e|)))))))) - |e|))))) - -;AMFCR_,redefinedList(op,l) == "OR"/[AMFCR_,redefined(op,u) for u in l] - -(DEFUN |AMFCR,redefinedList| (|op| |l|) - (PROG () - (RETURN - (SEQ (PROG (G166499) - (SPADLET G166499 NIL) - (RETURN - (DO ((G166505 NIL G166499) - (G166506 |l| (CDR G166506)) (|u| NIL)) - ((OR G166505 (ATOM G166506) - (PROGN (SETQ |u| (CAR G166506)) NIL)) - G166499) - (SEQ (EXIT (SETQ G166499 - (OR G166499 - (|AMFCR,redefined| |op| |u|)))))))))))) - -;AMFCR_,redefined(opname,u) == -; not(u is [op,:l]) => nil -; op = 'DEF => opname = CAAR l -; MEMQ(op,'(PROGN SEQ)) => AMFCR_,redefinedList(opname,l) -; op = 'COND => "OR"/[AMFCR_,redefinedList(opname,CDR u) for u in l] - -(DEFUN |AMFCR,redefined| (|opname| |u|) - (PROG (|op| |l|) - (RETURN - (SEQ (COND - ((NULL (AND (PAIRP |u|) - (PROGN - (SPADLET |op| (QCAR |u|)) - (SPADLET |l| (QCDR |u|)) - 'T))) - NIL) - ((BOOT-EQUAL |op| 'DEF) (BOOT-EQUAL |opname| (CAAR |l|))) - ((member |op| '(PROGN SEQ)) - (|AMFCR,redefinedList| |opname| |l|)) - ((BOOT-EQUAL |op| 'COND) - (PROG (G166521) - (SPADLET G166521 NIL) - (RETURN - (DO ((G166527 NIL G166521) - (G166528 |l| (CDR G166528)) (|u| NIL)) - ((OR G166527 (ATOM G166528) - (PROGN (SETQ |u| (CAR G166528)) NIL)) - G166521) - (SEQ (EXIT (SETQ G166521 - (OR G166521 - (|AMFCR,redefinedList| |opname| - (CDR |u|))))))))))))))) - -;--subCatParametersInto(domainForm,catForm,e) == -;-- -- JHD 08/08/84 perhaps we are fortunate that it is not used -;-- --this is particularly dirty and should be cleaned up, say, by wrapping -;-- -- an appropriate lambda expression around mapping forms -;-- domainForm is [op,:l] and l => -;-- get(op,'modemap,e) is [[[mc,:.],:.]] => SUBLIS(PAIR(rest mc,l),catForm) -;-- catForm -; -;evalAndSub(domainName,viewName,functorForm,form,$e) == -; $lhsOfColon: local:= domainName -; isCategory form => [substNames(domainName,viewName,functorForm,form.(1)),$e] -; --next lines necessary-- see MPOLY for which $ is actual arg. --- RDJ 3/83 -; if CONTAINED("$$",form) then $e:= put("$$","mode",get("$","mode",$e),$e) -; opAlist:= getOperationAlist(domainName,functorForm,form) -; substAlist:= substNames(domainName,viewName,functorForm,opAlist) -; [substAlist,$e] - -(DEFUN |evalAndSub| (|domainName| |viewName| |functorForm| |form| |$e|) - (DECLARE (SPECIAL |$e|)) - (PROG (|$lhsOfColon| |opAlist| |substAlist|) - (DECLARE (SPECIAL |$lhsOfColon|)) - (RETURN - (PROGN - (SPADLET |$lhsOfColon| |domainName|) - (COND - ((|isCategory| |form|) - (CONS (|substNames| |domainName| |viewName| |functorForm| - (ELT |form| 1)) - (CONS |$e| NIL))) - ('T - (COND - ((CONTAINED '$$ |form|) - (SPADLET |$e| - (|put| '$$ '|mode| (|get| '$ '|mode| |$e|) |$e|)))) - (SPADLET |opAlist| - (|getOperationAlist| |domainName| |functorForm| - |form|)) - (SPADLET |substAlist| - (|substNames| |domainName| |viewName| |functorForm| - |opAlist|)) - (CONS |substAlist| (CONS |$e| NIL)))))))) - -;getOperationAlist(name,functorForm,form) == -; if atom name and GETDATABASE(name,'NILADIC) then functorForm:= [functorForm] -;-- (null isConstructorForm functorForm) and (u:= isFunctor functorForm) -; (u:= isFunctor functorForm) and not -; ($insideFunctorIfTrue and first functorForm=first $functorForm) => u -; $insideFunctorIfTrue and name="$" => -; ($domainShell => $domainShell.(1); systemError '"$ has no shell now") -; T:= compMakeCategoryObject(form,$e) => ([.,.,$e]:= T; T.expr.(1)) -; stackMessage ["not a category form: ",form] - -(DEFUN |getOperationAlist| (|name| |functorForm| |form|) - (PROG (|u| T$) - (declare (special |$e| |$domainShell| |$insideFunctorIfTrue| - |$functorForm|)) - (RETURN - (PROGN - (COND - ((AND (ATOM |name|) (GETDATABASE |name| 'NILADIC)) - (SPADLET |functorForm| (CONS |functorForm| NIL)))) - (COND - ((AND (SPADLET |u| (|isFunctor| |functorForm|)) - (NULL (AND |$insideFunctorIfTrue| - (BOOT-EQUAL (CAR |functorForm|) - (CAR |$functorForm|))))) - |u|) - ((AND |$insideFunctorIfTrue| (BOOT-EQUAL |name| '$)) - (COND - (|$domainShell| (ELT |$domainShell| 1)) - ('T (|systemError| "$ has no shell now")))) - ((SPADLET T$ (|compMakeCategoryObject| |form| |$e|)) - (SPADLET |$e| (CADDR T$)) (ELT (CAR T$) 1)) - ('T - (|stackMessage| - (CONS '|not a category form: | (CONS |form| NIL))))))))) - -;substNames(domainName,viewName,functorForm,opalist) == -; functorForm := SUBSTQ("$$","$", functorForm) -; nameForDollar := -; isCategoryPackageName functorForm => CADR functorForm -; domainName -; -- following calls to SUBSTQ must copy to save RPLAC's in -; -- putInLocalDomainReferences -; [[:SUBSTQ("$","$$",SUBSTQ(nameForDollar,"$",modemapform)), -; [sel, viewName,if domainName = "$" then pos else -; CADAR modemapform]] -; for [:modemapform,[sel,"$",pos]] in -; EQSUBSTLIST(KDR functorForm,$FormalMapVariableList, opalist)] - -(DEFUN |substNames| (|domainName| |viewName| |functorForm| |opalist|) - (PROG (|nameForDollar| |LETTMP#1| |sel| |pos| |modemapform|) - (declare (special |$FormalMapVariableList|)) - (RETURN - (SEQ (PROGN - (SPADLET |functorForm| (SUBSTQ '$$ '$ |functorForm|)) - (SPADLET |nameForDollar| - (COND - ((|isCategoryPackageName| |functorForm|) - (CADR |functorForm|)) - ('T |domainName|))) - (PROG (G166616) - (SPADLET G166616 NIL) - (RETURN - (DO ((G166622 - (EQSUBSTLIST (KDR |functorForm|) - |$FormalMapVariableList| |opalist|) - (CDR G166622)) - (G166604 NIL)) - ((OR (ATOM G166622) - (PROGN (SETQ G166604 (CAR G166622)) NIL) - (PROGN - (PROGN - (SPADLET |LETTMP#1| (REVERSE G166604)) - (SPADLET |sel| (CAAR |LETTMP#1|)) - (SPADLET |pos| (CADDAR |LETTMP#1|)) - (SPADLET |modemapform| - (NREVERSE (CDR |LETTMP#1|))) - G166604) - NIL)) - (NREVERSE0 G166616)) - (SEQ (EXIT (SETQ G166616 - (CONS - (APPEND - (SUBSTQ '$ '$$ - (SUBSTQ |nameForDollar| '$ - |modemapform|)) - (CONS - (CONS |sel| - (CONS |viewName| - (CONS - (COND - ((BOOT-EQUAL |domainName| - '$) - |pos|) - ('T (CADAR |modemapform|))) - NIL))) - NIL)) - G166616)))))))))))) - ;addConstructorModemaps(name,form is [functorName,:.],e) == ; $InteractiveMode: local:= nil ; e:= putDomainsInScope(name,e) --frame diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index 168c6a5..7f1cc8f 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -2232,9 +2232,6 @@ which will walk the structure $Y$ looking for this constant. (def-boot-val |$FontTable| '(|FontTable|) "???") (def-boot-var |$forceDatabaseUpdate| "See load function.") (def-boot-var |$form| "???") -(def-boot-val |$FormalMapVariableList| - '(\#1 \#2 \#3 \#4 \#5 \#6 \#7 \#8 \#9 - \#10 \#11 \#12 \#13 \#14 \#15) "???") (def-boot-val |$FormalMapVariableList2| '(\#\#1 \#\#2 \#\#3 \#\#4 \#\#5 \#\#6 \#\#7 \#\#8 \#\#9 \#\#10 \#\#11 \#\#12 \#\#13 \#\#14 \#\#15) "???")