diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 87601f9..038128f 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -10426,6 +10426,101 @@ The way XLAMs work: \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|)))))) + +\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))))) + +\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 + ((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{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{getUniqueSignature}{getUniqueSignature} \calls{getUniqueSignature}{getUniqueModemap} \begin{chunk}{defun getUniqueSignature} @@ -21088,6 +21183,76 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} +\defun{applyMapping}{applyMapping} +\calls{applyMapping}{nequal} +\calls{applyMapping}{isCategoryForm} +\calls{applyMapping}{sublis} +\calls{applyMapping}{comp} +\calls{applyMapping}{convert} +\calls{applyMapping}{member} +\calls{applyMapping}{get} +\calls{applyMapping}{getAbbreviation} +\calls{applyMapping}{encodeItem} +\refsdollar{applyMapping}{FormalMapVariableList} +\refsdollar{applyMapping}{form} +\refsdollar{applyMapping}{op} +\refsdollar{applyMapping}{prefix} +\refsdollar{applyMapping}{formalArgList} +\begin{chunk}{defun applyMapping} +(defun |applyMapping| (t0 m e ml) + (prog (op argl mlp temp1 arglp nprefix opp form pairlis) + (declare (special |$FormalMapVariableList| |$form| |$op| |$prefix| + |$formalArgList|)) + (return + (progn + (setq op (car t0)) + (setq argl (cdr t0)) + (cond + ((nequal (|#| argl) (1- (|#| ml))) nil) + ((|isCategoryForm| (car ml) e) + (setq pairlis + (loop for a in argl for v in |$FormalMapVariableList| + collect (cons v a))) + (setq mlp (sublis pairlis ml)) + (setq arglp + (loop for x in argl for mp in (rest mlp) + collect (car + (progn + (setq temp1 (or (|comp| x mp e) (return '|failed|))) + (setq e (caddr temp1)) + temp1)))) + (when (eq arglp '|failed|) (return nil)) + (setq form (cons op arglp)) + (|convert| (list form (car mlp) e) m)) + (t + (setq arglp + (loop for x in argl for mp in (rest ml) + collect (car + (progn + (setq temp1 (or (|comp| x mp e) (return '|failed|))) + (setq e (caddr temp1)) + temp1)))) + (when (eq arglp '|failed|) (return nil)) + (setq form + (cond + ((and (null (|member| op |$formalArgList|)) + (atom op) + (null (|get| op '|value| e))) + (setq nprefix + (or |$prefix| (|getAbbreviation| |$op| (|#| (cdr |$form|))))) + (setq opp + (intern (strconc + (|encodeItem| nprefix) '|;| (|encodeItem| op)))) + (cons opp (append arglp (list '$)))) + (t + (cons '|call| (cons (list '|applyFun| op) arglp))))) + (setq pairlis + (loop for a in arglp for v in |$FormalMapVariableList| + collect (cons v a))) + (|convert| (list form (sublis pairlis (car ml)) e) m))))))) + +\end{chunk} + \defun{compApply}{compApply} \calls{compApply}{comp} \calls{compApply}{Pair} @@ -21274,6 +21439,17 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} +\defun{transImplementation}{transImplementation} +\calls{transImplementation}{genDeltaEntry} +\begin{chunk}{defun transImplementation} +(defun |transImplementation| (op map fn) + (setq fn (|genDeltaEntry| (cons op map))) + (if (and (consp fn) (eq (qcar fn) 'xlam)) + (cons fn nil) + (cons '|call| (cons fn nil)))) + +\end{chunk} + \defun{convert}{convert} \calls{convert}{resolve} \calls{convert}{coerce} @@ -21535,6 +21711,77 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} +\defun{compApplication}{compApplication} +\calls{compApplication}{eltForm} +\calls{compApplication}{resolve} +\calls{compApplication}{coerce} +\calls{compApplication}{strconc} +\calls{compApplication}{encodeItem} +\calls{compApplication}{getAbbreviation} +\calls{compApplication}{length} +\calls{compApplication}{member} +\calls{compApplication}{comp} +\calls{compApplication}{nequal} +\calls{compApplication}{isCategoryForm} +\refsdollar{compApplication}{Category} +\refsdollar{compApplication}{formatArgList} +\refsdollar{compApplication}{op} +\refsdollar{compApplication}{form} +\refsdollar{compApplication}{prefix} +\begin{chunk}{defun compApplication} +(defun |compApplication| (op argl m env tt) + (let (argml retm temp1 argTl nprefix opp form eltForm) + (declare (special |$form| |$op| |$prefix| |$formalArgList| |$Category|)) + (cond + ((and (consp (cadr tt)) (eq (qcar (cadr tt)) '|Mapping|) + (consp (qcdr (cadr tt)))) + (setq retm (qcadr (cadr tt))) + (setq argml (qcddr (cadr tt))) + (cond + ((nequal (|#| argl) (|#| argml)) nil) + (t + (setq retm (|resolve| m retm)) + (cond + ((or (equal retm |$Category|) (|isCategoryForm| retm env)) + nil) + (t + (setq argTl + (loop for x in argl for m in argml + collect (progn + (setq temp1 (or (|comp| x m env) (return '|failed|))) + (setq env (caddr temp1)) + temp1))) + (cond + ((eq argTl '|failed|) nil) + (t + (setq form + (cond + ((and + (null + (or (|member| op |$formalArgList|) + (|member| (car tt) |$formalArgList|))) + (atom (car tt))) + (setq nprefix + (or |$prefix| (|getAbbreviation| |$op| (|#| (cdr |$form|))))) + (setq opp + (intern + (strconc (|encodeItem| nprefix) '|;| (|encodeItem| (car tt))))) + (cons opp + (append + (loop for item in argTl collect (car item)) + (list '$)))) + (t + (cons '|call| + (cons (list '|applyFun| (car tt)) + (loop for item in argTl collect (car item))))))) + (|coerce| (list form retm env) (|resolve| retm m))))))))) + ((eq op '|elt|) nil) + (t + (setq eltForm (cons '|elt| (cons op argl))) + (|comp| eltForm m env))))) + +\end{chunk} + \defun{getFormModemaps}{getFormModemaps} \calls{getFormModemaps}{qcar} \calls{getFormModemaps}{qcdr} @@ -21787,6 +22034,90 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} +\defun{compFocompFormWithModemap}{compFocompFormWithModemap} +\calls{compFocompFormWithModemap}{isCategoryForm} +\calls{compFocompFormWithModemap}{isFunctor} +\calls{compFocompFormWithModemap}{substituteIntoFunctorModemap} +\calls{compFocompFormWithModemap}{listOfSharpVars} +\calls{compFocompFormWithModemap}{coerceable} +\calls{compFocompFormWithModemap}{compApplyModemap} +\calls{compFocompFormWithModemap}{isCategoryForm} +\calls{compFocompFormWithModemap}{identp} +\calls{compFocompFormWithModemap}{get} +\calls{compFocompFormWithModemap}{last} +\calls{compFocompFormWithModemap}{convert} +\refsdollar{compFocompFormWithModemap}{Category} +\refsdollar{compFocompFormWithModemap}{FormalMapVariableList} +\begin{chunk}{defun compFormWithModemap} +(defun |compFormWithModemap| (form m env modemap) + (prog (op argl sv target cexpr targetp map temp1 f transimp sl mp formp z c + xp ep tt) + (declare (special |$Category| |$FormalMapVariableList|)) + (return + (progn + (setq op (car form)) + (setq argl (cdr form)) + (setq map (car modemap)) + (setq target (cadar modemap)) + (when (and (|isCategoryForm| target env) (|isFunctor| op)) + (setq temp1 (or (|substituteIntoFunctorModemap| argl modemap env) + (return nil))) + (setq modemap (car temp1)) + (setq env (cadr temp1)) + (setq map (car modemap)) + (setq target (cadar modemap)) + (setq cexpr (cdr modemap)) + modemap) + (setq sv (|listOfSharpVars| map)) + (when sv + (loop for x in argl for ss in |$FormalMapVariableList| + do (when (|member| ss sv) + (setq modemap (msubst x ss modemap)) + (setq map (car modemap)) + (setq target (cadar modemap)) + (setq cexpr (cdr modemap)) + modemap))) + (cond + ((null (setq targetp (|coerceable| target m env))) nil) + (t + (setq map (cons targetp (cdr map))) + (setq temp1 (or (|compApplyModemap| form modemap env nil) + (return nil))) + (setq f (car temp1)) + (setq transimp (cadr temp1)) + (setq sl (caddr temp1)) + (setq mp (sublis sl (elt map 1))) + (setq xp + (progn + (setq formp (cons f (loop for tt in transimp collect (car tt)))) + (cond + ((or (equal mp |$Category|) (|isCategoryForm| mp env)) formp) + ((and (eq op '|elt|) (consp f) (eq (qcar f) 'xlam) + (identp (car argl)) + (setq c (|get| (car argl) '|condition| env)) + (consp c) (eq (qcdr c) nil) + (consp (qcar c)) (eq (qcaar c) '|case|) + (consp (qcdar c)) (equal (qcadar c) z) + (consp (qcddar c)) (eq (qcdr (qcddar c)) nil) + (or (and (consp (qcaddar c)) + (eq (qcar (qcaddar c)) '|:|) + (consp (qcdr (qcaddar c))) + (equal (qcadr (qcaddar c)) (cadr argl)) + (consp (qcddr (qcaddar c))) + (eq (qcdddr (qcaddar c)) nil) + (equal (qcaddr (qcaddar c)) m)) + (eq (qcaddar c) (cadr argl)))) + (list 'cdr (car argl))) + (t (cons '|call| formp))))) + (setq ep + (if transimp + (caddr (|last| transimp)) + env)) + (setq tt (list xp mp ep)) + (|convert| tt m))))))) + +\end{chunk} + \defun{compFormPartiallyBottomUp}{compFormPartiallyBottomUp} \calls{compFormPartiallyBottomUp}{compForm3} \calls{compFormPartiallyBottomUp}{compFormMatch} @@ -22705,6 +23036,7 @@ The current input line. \getchunk{defun aplTran} \getchunk{defun aplTran1} \getchunk{defun aplTranList} +\getchunk{defun applyMapping} \getchunk{defun argsToSig} \getchunk{defun assignError} \getchunk{defun AssocBarGensym} @@ -22738,6 +23070,7 @@ The current input line. \getchunk{defun comp2} \getchunk{defun comp3} \getchunk{defun compAdd} +\getchunk{defun compApplication} \getchunk{defun compApply} \getchunk{defun compApplyModemap} \getchunk{defun compArgumentConditions} @@ -22784,6 +23117,7 @@ The current input line. \getchunk{defun compFormMatch} \getchunk{defun compForMode} \getchunk{defun compFormPartiallyBottomUp} +\getchunk{defun compFormWithModemap} \getchunk{defun compFromIf} \getchunk{defun compFunctorBody} \getchunk{defun compHas} @@ -22812,6 +23146,10 @@ The current input line. \getchunk{defun compMacro} \getchunk{defun compMakeCategoryObject} \getchunk{defun compMakeDeclaration} +\getchunk{defun compMapCond} +\getchunk{defun compMapCond'} +\getchunk{defun compMapCond''} +\getchunk{defun compMapCondFun} \getchunk{defun compNoStacking} \getchunk{defun compNoStacking1} \getchunk{defun compOrCroak} @@ -23281,6 +23619,7 @@ The current input line. \getchunk{defun token-lookahead-type} \getchunk{defun token-print} \getchunk{defun transformOperationAlist} +\getchunk{defun transImplementation} \getchunk{defun transIs} \getchunk{defun transIs1} \getchunk{defun translabel} diff --git a/changelog b/changelog index 6864876..e440a30 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20111112 tpd src/axiom-website/patches.html 20111112.01.tpd.patch +20111112 tpd src/interp/apply.lisp treeshake compiler +20111112 tpd books/bookvol9 treeshake compiler 20111108 tpd src/axiom-website/patches.html 20111108.02.tpd.patch 20111108 tpd src/interp/i-spec1.lisp treeshake interpreter 20111108 tpd books/bookvol5 treeshake interpreter diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 7ba6ba9..0f90319 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3676,5 +3676,7 @@ books/bookvolbib add references
src/axiom-website/documentation.html add Knuth quote
20111108.02.tpd.patch books/bookvol5 treeshake interpreter
+20111112.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/apply.lisp.pamphlet b/src/interp/apply.lisp.pamphlet index ac7b53b..cd1bbab 100644 --- a/src/interp/apply.lisp.pamphlet +++ b/src/interp/apply.lisp.pamphlet @@ -13,313 +13,6 @@ (in-package "BOOT" ) -;transImplementation(op,map,fn) == -;--+ -; fn := genDeltaEntry [op,:map] -; fn is ["XLAM",:.] => [fn] -; ["call",fn] - -(DEFUN |transImplementation| (OP MAP FN) - (SETQ FN (|genDeltaEntry| (CONS OP MAP))) - (COND - ((AND (CONSP FN) (EQ (QCAR FN) 'XLAM)) (CONS FN NIL)) - (T (CONS '|call| (CONS FN NIL))))) - -;compApplication(op,argl,m,e,T) == -; T.mode is ['Mapping, retm, :argml] => -; #argl ^= #argml => nil -; retm := resolve(m, retm) -; retm = $Category or isCategoryForm(retm,e) => nil -- not handled -; argTl := [[.,.,e] := comp(x,m,e) or return "failed" -; for x in argl for m in argml] -; argTl = "failed" => nil -; form:= -; not (MEMBER(op,$formalArgList) or MEMBER(T.expr,$formalArgList)) and ATOM T.expr => -; nprefix := $prefix or -; -- following needed for referencing local funs at capsule level -; getAbbreviation($op,#rest $form) -; [op',:[a.expr for a in argTl],"$"] where -; op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem T.expr) -; ['call, ['applyFun, T.expr], :[a.expr for a in argTl]] -; coerce([form, retm, e],resolve(retm,m)) -; op = 'elt => nil -; eltForm := ['elt, op, :argl] -; comp(eltForm, m, e) - -(DEFUN |compApplication| (|op| |argl| |m| |e| T$) - (PROG (TMP1 TMP2 |argml| |retm| TEMP1 |argTl| |nprefix| |op'| |form| - |eltForm|) - (declare (special |$form| |$op| |$prefix| |$formalArgList| |$Category|)) - (RETURN - (SEQ (COND - ((PROGN - (SETQ TMP1 (CADR T$)) - (AND (CONSP TMP1) (EQ (QCAR TMP1) '|Mapping|) - (PROGN - (SETQ TMP2 (QCDR TMP1)) - (AND (CONSP TMP2) - (PROGN - (SETQ |retm| (QCAR TMP2)) - (SETQ |argml| (QCDR TMP2)) - T))))) - (COND - ((NEQUAL (|#| |argl|) (|#| |argml|)) NIL) - (T (SETQ |retm| (|resolve| |m| |retm|)) - (COND - ((OR (BOOT-EQUAL |retm| |$Category|) - (|isCategoryForm| |retm| |e|)) - NIL) - (T (SETQ |argTl| - (PROG (T0) - (SETQ T0 NIL) - (RETURN - (DO ((T1 |argl| (CDR T1)) (|x| NIL) - (T2 |argml| (CDR T2)) (|m| NIL)) - ((OR (ATOM T1) - (PROGN - (SETQ |x| (CAR T1)) - NIL) - (ATOM T2) - (PROGN - (SETQ |m| (CAR T2)) - NIL)) - (NREVERSE0 T0)) - (SEQ - (EXIT - (SETQ T0 - (CONS - (PROGN - (SETQ TEMP1 - (OR (|comp| |x| |m| |e|) - (RETURN '|failed|))) - (SETQ |e| (CADDR TEMP1)) - TEMP1) - T0)))))))) - (COND - ((BOOT-EQUAL |argTl| '|failed|) NIL) - (T (SETQ |form| - (COND - ((AND - (NULL - (OR - (|member| |op| - |$formalArgList|) - (|member| (CAR T$) - |$formalArgList|))) - (ATOM (CAR T$))) - (SETQ |nprefix| - (OR |$prefix| - (|getAbbreviation| |$op| - (|#| (CDR |$form|))))) - (SETQ |op'| - (INTERN - (STRCONC - (|encodeItem| |nprefix|) '|;| - (|encodeItem| (CAR T$))))) - (CONS |op'| - (APPEND - (PROG (T3) - (SETQ T3 NIL) - (RETURN - (DO - ((T4 |argTl| (CDR T4)) - (|a| NIL)) - ((OR (ATOM T4) - (PROGN - (SETQ |a| (CAR T4)) - NIL)) - (NREVERSE0 T3)) - (SEQ - (EXIT - (SETQ T3 - (CONS (CAR |a|) T3))))))) - (CONS '$ NIL)))) - (T - (CONS '|call| - (CONS - (CONS '|applyFun| - (CONS (CAR T$) NIL)) - (PROG (T5) - (SETQ T5 NIL) - (RETURN - (DO - ((T6 |argTl| (CDR T6)) - (|a| NIL)) - ((OR (ATOM T6) - (PROGN - (SETQ |a| (CAR T6)) - NIL)) - (NREVERSE0 T5)) - (SEQ - (EXIT - (SETQ T5 - (CONS (CAR |a|) T5)))))))))))) - (|coerce| - (CONS |form| - (CONS |retm| (CONS |e| NIL))) - (|resolve| |retm| |m|))))))))) - ((BOOT-EQUAL |op| '|elt|) NIL) - (T (SETQ |eltForm| (CONS '|elt| (CONS |op| |argl|))) - (|comp| |eltForm| |m| |e|))))))) - -;compFormWithModemap(form is [op,:argl],m,e,modemap) == -; [map:= [.,target,:.],[pred,impl]]:= modemap -; -- this fails if the subsuming modemap is conditional -; --impl is ['Subsumed,:.] => nil -; if isCategoryForm(target,e) and isFunctor op then -; [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil -; [map:= [.,target,:.],:cexpr]:= modemap -; sv:=listOfSharpVars map -; if sv then -; -- SAY [ "compiling ", op, " in compFormWithModemap, -; -- mode= ",map," sharp vars=",sv] -; for x in argl for ss in $FormalMapVariableList repeat -; if ss in sv then -; [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap) -; -- SAY ["new map is",map] -; not (target':= coerceable(target,m,e)) => nil -; map:= [target',:rest map] -; [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil -; --generate code; return -; T:= -; [x',m',e'] where -; m':= SUBLIS(sl,map.(1)) -; x':= -; form':= [f,:[t.expr for t in Tl]] -; m'=$Category or isCategoryForm(m',e) => form' -; -- try to deal with new-style Unions where we know the conditions -; op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and -; (c:=get(z,'condition,e)) and -; c is [['case,=z,c1]] and -; (c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) => -;-- first is a full tag, as placed by getInverseEnvironment -;-- second is what getSuccessEnvironment will place there -; ["CDR",z] -; ["call",:form'] -; e':= -; Tl => (LAST Tl).env -; e -; convert(T,m) - -(DEFUN |compFormWithModemap| (|form| |m| |e| |modemap|) - (PROG (|op| |argl| |pred| |impl| |sv| |target| |cexpr| |target'| - |map| TEMP1 |f| TRANSIMP |sl| |m'| |form'| |z| |c| TMP3 - |c1| TMP1 TMP2 |x'| |e'| T$) - (declare (special |$Category| |$FormalMapVariableList|)) - (RETURN - (SEQ (PROGN - (SETQ |op| (CAR |form|)) - (SETQ |argl| (CDR |form|)) - (SETQ |map| (CAR |modemap|)) - (SETQ |target| (CADAR |modemap|)) - (SETQ |pred| (CAADR |modemap|)) - (SETQ |impl| (CADADR |modemap|)) - (COND - ((AND (|isCategoryForm| |target| |e|) - (|isFunctor| |op|)) - (SETQ TEMP1 - (OR (|substituteIntoFunctorModemap| |argl| - |modemap| |e|) - (RETURN NIL))) - (SETQ |modemap| (CAR TEMP1)) (SETQ |e| (CADR TEMP1)) - (SETQ |map| (CAR |modemap|)) - (SETQ |target| (CADAR |modemap|)) - (SETQ |cexpr| (CDR |modemap|)) |modemap|)) - (SETQ |sv| (|listOfSharpVars| |map|)) - (COND - (|sv| (DO ((T0 |argl| (CDR T0)) (|x| NIL) - (T1 |$FormalMapVariableList| (CDR T1)) - (|ss| NIL)) - ((OR (ATOM T0) (PROGN (SETQ |x| (CAR T0)) NIL) - (ATOM T1) - (PROGN (SETQ |ss| (CAR T1)) NIL)) - NIL) - (SEQ (EXIT (COND - ((|member| |ss| |sv|) - (SETQ |modemap| - (MSUBST |x| |ss| |modemap|)) - (SETQ |map| (CAR |modemap|)) - (SETQ |target| (CADAR |modemap|)) - (SETQ |cexpr| (CDR |modemap|)) - |modemap|) - (T NIL))))))) - (COND - ((NULL (SETQ |target'| (|coerceable| |target| |m| |e|))) - NIL) - (T (SETQ |map| (CONS |target'| (CDR |map|))) - (SETQ TEMP1 - (OR (|compApplyModemap| |form| |modemap| |e| - NIL) - (RETURN NIL))) - (SETQ |f| (CAR TEMP1)) (SETQ TRANSIMP (CADR TEMP1)) - (SETQ |sl| (CADDR TEMP1)) - (SETQ |m'| (SUBLIS |sl| (ELT |map| 1))) - (SETQ |x'| - (PROGN - (SETQ |form'| - (CONS |f| - (PROG (T2) - (SETQ T2 NIL) - (RETURN - (DO - ((T3 TRANSIMP (CDR T3)) - (|t| NIL)) - ((OR (ATOM T3) - (PROGN - (SETQ |t| (CAR T3)) - NIL)) - (NREVERSE0 T2)) - (SEQ - (EXIT - (SETQ T2 - (CONS (CAR |t|) T2))))))))) - (COND - ((OR (BOOT-EQUAL |m'| |$Category|) - (|isCategoryForm| |m'| |e|)) - |form'|) - ((AND (BOOT-EQUAL |op| '|elt|) (CONSP |f|) - (EQ (QCAR |f|) 'XLAM) - (IDENTP (SETQ |z| (CAR |argl|))) - (SETQ |c| - (|get| |z| '|condition| |e|)) - (CONSP |c|) (EQ (QCDR |c|) NIL) - (PROGN - (SETQ TMP1 (QCAR |c|)) - (AND (CONSP TMP1) - (EQ (QCAR TMP1) '|case|) - (PROGN - (SETQ TMP2 (QCDR TMP1)) - (AND (CONSP TMP2) - (EQUAL (QCAR TMP2) |z|) - (PROGN - (SETQ TMP3 (QCDR TMP2)) - (AND (CONSP TMP3) - (EQ (QCDR TMP3) NIL) - (PROGN - (SETQ |c1| (QCAR TMP3)) - T))))))) - (OR (AND (CONSP |c1|) - (EQ (QCAR |c1|) '|:|) - (PROGN - (SETQ TMP1 (QCDR |c1|)) - (AND (CONSP TMP1) - (EQUAL (QCAR TMP1) - (CADR |argl|)) - (PROGN - (SETQ TMP2 (QCDR TMP1)) - (AND (CONSP TMP2) - (EQ (QCDR TMP2) NIL) - (EQUAL (QCAR TMP2) |m|)))))) - (EQ |c1| (CADR |argl|)))) - (CONS 'CDR (CONS |z| NIL))) - (T (CONS '|call| |form'|))))) - (SETQ |e'| - (COND - (TRANSIMP (CADDR (|last| TRANSIMP))) - (T |e|))) - (SETQ T$ (CONS |x'| (CONS |m'| (CONS |e'| NIL)))) - (|convert| T$ |m|)))))))) - ;substituteIntoFunctorModemap(argl,modemap is [[dc,:sig],:.],e) == ; #dc^=#sig => ; keyedSystemError("S2GE0016",['"substituteIntoFunctorModemap", @@ -400,244 +93,8 @@ (CONS |e| NIL))) ('T NIL))))))) -;applyMapping([op,:argl],m,e,ml) == -; #argl^=#ml-1 => nil -; isCategoryForm(first ml,e) => -; --is op a functor? -; pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] -; ml' := SUBLIS(pairlis, ml) -; argl':= -; [T.expr for x in argl for m' in rest ml'] where -; T() == [.,.,e]:= comp(x,m',e) or return "failed" -; if argl'="failed" then return nil -; form:= [op,:argl'] -; convert([form,first ml',e],m) -; argl':= -; [T.expr for x in argl for m' in rest ml] where -; T() == [.,.,e]:= comp(x,m',e) or return "failed" -; if argl'="failed" then return nil -; form:= -; not MEMBER(op,$formalArgList) and ATOM op and not get(op,'value,e) => -; nprefix := $prefix or -; -- following needed for referencing local funs at capsule level -; getAbbreviation($op,#rest $form) -; [op',:argl',"$"] where -; op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op) -; ['call,['applyFun,op],:argl'] -; pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] -; convert([form,SUBLIS(pairlis,first ml),e],m) - -(DEFUN |applyMapping| (T0 |m| |e| |ml|) - (PROG (|op| |argl| |ml'| TEMP1 |argl'| |nprefix| |op'| |form| |pairlis|) - (declare (special |$FormalMapVariableList| |$form| |$op| |$prefix| - |$formalArgList|)) - (RETURN - (SEQ (PROGN - (SETQ |op| (CAR T0)) - (SETQ |argl| (CDR T0)) - (COND - ((NEQUAL (|#| |argl|) (SPADDIFFERENCE (|#| |ml|) 1)) - NIL) - ((|isCategoryForm| (CAR |ml|) |e|) - (SETQ |pairlis| - (PROG (T1) - (SETQ T1 NIL) - (RETURN - (DO ((T2 |argl| (CDR T2)) (|a| NIL) - (T3 |$FormalMapVariableList| (CDR T3)) - (|v| NIL)) - ((OR (ATOM T2) - (PROGN (SETQ |a| (CAR T2)) NIL) - (ATOM T3) - (PROGN (SETQ |v| (CAR T3)) NIL)) - (NREVERSE0 T1)) - (SEQ (EXIT (SETQ T1 - (CONS (CONS |v| |a|) T1)))))))) - (SETQ |ml'| (SUBLIS |pairlis| |ml|)) - (SETQ |argl'| - (PROG (T4) - (SETQ T4 NIL) - (RETURN - (DO ((T5 |argl| (CDR T5)) (|x| NIL) - (T6 (CDR |ml'|) (CDR T6)) (|m'| NIL)) - ((OR (ATOM T5) - (PROGN (SETQ |x| (CAR T5)) NIL) - (ATOM T6) - (PROGN (SETQ |m'| (CAR T6)) NIL)) - (NREVERSE0 T4)) - (SEQ (EXIT (SETQ T4 - (CONS - (CAR - (PROGN - (SETQ TEMP1 - (OR (|comp| |x| |m'| |e|) - (RETURN '|failed|))) - (SETQ |e| (CADDR TEMP1)) - TEMP1)) - T4)))))))) - (COND ((BOOT-EQUAL |argl'| '|failed|) (RETURN NIL))) - (SETQ |form| (CONS |op| |argl'|)) - (|convert| - (CONS |form| (CONS (CAR |ml'|) (CONS |e| NIL))) - |m|)) - (T (SETQ |argl'| - (PROG (T7) - (SETQ T7 NIL) - (RETURN - (DO ((T8 |argl| (CDR T8)) (|x| NIL) - (T9 (CDR |ml|) (CDR T9)) (|m'| NIL)) - ((OR (ATOM T8) - (PROGN (SETQ |x| (CAR T8)) NIL) - (ATOM T9) - (PROGN (SETQ |m'| (CAR T9)) NIL)) - (NREVERSE0 T7)) - (SEQ (EXIT - (SETQ T7 - (CONS - (CAR - (PROGN - (SETQ TEMP1 - (OR (|comp| |x| |m'| |e|) - (RETURN '|failed|))) - (SETQ |e| (CADDR TEMP1)) - TEMP1)) - T7)))))))) - (COND ((BOOT-EQUAL |argl'| '|failed|) (RETURN NIL))) - (SETQ |form| - (COND - ((AND (NULL (|member| |op| |$formalArgList|)) - (ATOM |op|) - (NULL (|get| |op| '|value| |e|))) - (SETQ |nprefix| - (OR |$prefix| - (|getAbbreviation| |$op| - (|#| (CDR |$form|))))) - (SETQ |op'| - (INTERN (STRCONC - (|encodeItem| |nprefix|) '|;| - (|encodeItem| |op|)))) - (CONS |op'| (APPEND |argl'| (CONS '$ NIL)))) - (T (CONS '|call| - (CONS - (CONS '|applyFun| (CONS |op| NIL)) - |argl'|))))) - (SETQ |pairlis| - (PROG (T10) - (SETQ T10 NIL) - (RETURN - (DO ((T11 |argl'| (CDR T11)) (|a| NIL) - (T12 |$FormalMapVariableList| - (CDR T12)) - (|v| NIL)) - ((OR (ATOM T11) - (PROGN (SETQ |a| (CAR T11)) NIL) - (ATOM T12) - (PROGN (SETQ |v| (CAR T12)) NIL)) - (NREVERSE0 T10)) - (SEQ (EXIT - (SETQ T10 - (CONS (CONS |v| |a|) T10)))))))) - (|convert| - (CONS |form| - (CONS (SUBLIS |pairlis| (CAR |ml|)) - (CONS |e| NIL))) - |m|)))))))) - ;--% APPLY MODEMAPS -;compMapCond(op,mc,$bindings,fnsel) == -; or/[compMapCond'(u,op,mc,$bindings) for u in fnsel] - -(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|)))))) - -;compMapCond'([cexpr,fnexpr],op,dc,bindings) == -; compMapCond''(cexpr,dc) => compMapCondFun(fnexpr,op,dc,bindings) -; stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d] - -(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))))) - -;compMapCond''(cexpr,dc) == -; cexpr=true => true -; --cexpr = "true" => true -; cexpr is ["AND",:l] => and/[compMapCond''(u,dc) for u in l] -; cexpr is ["OR",:l] => or/[compMapCond''(u,dc) for u in l] -; cexpr is ["not",u] => not compMapCond''(u,dc) -; cexpr is ["has",name,cat] => (knownInfo cexpr => true; false) -; --for the time being we'll stop here - shouldn't happen so far -; --$disregardConditionIfTrue => true -; --stackSemanticError(("not known that",'%b,name, -; -- '%d,"has",'%b,cat,'%d),nil) -; --now it must be an attribute -; MEMBER(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true -; --for the time being we'll stop here - shouldn't happen so far -; stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d] -; false - -(defun |compMapCond''| (cexpr dc) - (let (l u tmp1 tmp2) - (declare (special |$Information| |$e|)) - (cond - ((boot-equal 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)))) - -;compMapCondFun(fnexpr,op,dc,bindings) == [fnexpr,bindings] - -(defun |compMapCondFun| (fnexpr op dc bindings) - (declare (ignore op) (ignore dc)) - (cons fnexpr (cons bindings nil))) \end{chunk} \eject