diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 676d39c..a0f2c54 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -6814,7 +6814,7 @@ constructMacro (form is [nam,[lam,vl,body]]) \refsdollar{NRTputInHead}{elt} \begin{chunk}{defun NRTputInHead} (defun |NRTputInHead| (bod) - (let (fn args |elt| clauses tmp1 dom tmp2 ind k) + (let (fn clauses dom tmp2 ind k) (declare (special |$elt|)) (cond ((atom bod) bod) @@ -10356,6 +10356,77 @@ The way XLAMs work: \end{chunk} +\defun{compApplyModemap}{compApplyModemap} +\calls{compApplyModemap}{length} +\calls{compApplyModemap}{pmatchWithSl} +\calls{compApplyModemap}{sublis} +\calls{compApplyModemap}{comp} +\calls{compApplyModemap}{coerce} +\calls{compApplyModemap}{compMapCond} +\calls{compApplyModemap}{member} +\calls{compApplyModemap}{genDeltaEntry} +\refsdollar{compApplyModemap}{e} +\refsdollar{compApplyModemap}{bindings} +\defsdollar{compApplyModemap}{e} +\defsdollar{compApplyModemap}{bindings} +\begin{chunk}{defun compApplyModemap} +(defun |compApplyModemap| (form modemap |$e| sl) + (declare (special |$e|)) + (let (op argl mc mr margl fnsel g mp lt ltp temp1 f) + (declare (special |$bindings| |$e|)) + ; -- $e is the current environment + ; -- sl substitution list, nil means bottom-up, otherwise top-down + ; -- 0. fail immediately if #argl=#margl + (setq op (car form)) + (setq argl (cdr form)) + (setq mc (caar modemap)) + (setq mr (cadar modemap)) + (setq margl (cddar modemap)) + (setq fnsel (cdr modemap)) + (when (= (|#| argl) (|#| margl)) + ; 1. use modemap to evaluate arguments, returning failed if not possible + (setq lt + (prog (t0) + (return + (do ((t1 argl (cdr t1)) (y NIL) (t2 margl (cdr t2)) (m nil)) + ((or (atom t1) (atom t2)) (nreverse0 t0)) + (setq y (car t1)) + (setq m (car t2)) + (setq t0 + (cons + (progn + (setq sl (|pmatchWithSl| mp m sl)) + (setq g (sublis sl m)) + (setq temp1 (or (|comp| y g |$e|) (return '|failed|))) + (setq mp (cadr temp1)) + (setq |$e| (caddr temp1)) + temp1) + t0))))))) + ; 2. coerce each argument to final domain, returning failed + ; if not possible + (unless (eq lt '|failed|) + (setq ltp + (loop for y in lt for d in (sublis sl margl) + collect (or (|coerce| y d) (return '|failed|)))) + (unless (eq ltp '|failed|) + ; 3. obtain domain-specific function, if possible, and return + ; $bindings is bound by compMapCond + (setq temp1 (|compMapCond| op mc sl fnsel)) + (when temp1 + ; can no longer trust what the modemap says for a reference into + ; an exterior domain (it is calculating the displacement based on view + ; information which is no longer valid; thus ignore this index and + ; store the signature instead. + (setq f (car temp1)) + (setq |$bindings| (cadr temp1)) + (if (and (consp f) (consp (qcdr f)) (consp (qcddr f)) ; f is [op1,.] + (eq (qcdddr f) nil) + (|member| (qcar f) '(elt const |Subsumed|))) + (list (|genDeltaEntry| (cons op modemap)) ltp |$bindings|) + (list f ltp |$bindings|)))))))) + +\end{chunk} + \defun{getUniqueSignature}{getUniqueSignature} \calls{getUniqueSignature}{getUniqueModemap} \begin{chunk}{defun getUniqueSignature} @@ -21018,6 +21089,42 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} +\defun{compApply}{compApply} +\calls{compApply}{comp} +\calls{compApply}{Pair} +\calls{compApply}{removeEnv} +\calls{compApply}{resolve} +\calls{compApply}{AddContour} +\refsdollar{compApply}{EmptyMode} +\begin{chunk}{defun compApply} +(defun |compApply| (sig varl body argl m e) + (let (temp1 argtl contour code mq bodyq) + (declare (special |$EmptyMode|)) + (setq argtl + (loop for x in argl + collect (progn + (setq temp1 (|comp| x |$EmptyMode| e)) + (setq e (caddr temp1)) + temp1))) + (setq contour + (loop for x in varl + for mq in (cdr sig) + for a in argl + collect + (|Pair| x + (list + (list '|mode| mq) + (list '|value| (|removeEnv| (|comp| a mq e))))))) + (setq code + (cons (list 'lambda varl bodyq) + (loop for tt in argtl + collect (car tt)))) + (setq mq (|resolve| m (car sig))) + (setq bodyq (car (|comp| body mq (|addContour| contour e)))) + (list code mq e))) + +\end{chunk} + \defun{compTypeOf}{compTypeOf} \calls{compTypeOf}{eqsubstlist} \calls{compTypeOf}{get} @@ -21129,6 +21236,46 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} +\defun{compAtomWithModemap}{compAtomWithModemap} +\calls{compAtomWithModemap}{transImplementation} +\calls{compAtomWithModemap}{modeEqual} +\calls{compAtomWithModemap}{convert} +\refsdollar{compAtomWithModemap}{NoValueMode} +\begin{chunk}{defun compAtomWithModemap} +(defun |compAtomWithModemap| (x m env v) + (let (tt transimp y) + (declare (special |$NoValueMode|)) + (cond + ((setq transimp + (loop for map in v + when ; map is [[.,target],[.,fn]]] + (and (consp map) (consp (qcar map)) (consp (qcdar map)) + (eq (qcddar map) nil) + (consp (qcdr map)) (eq (qcddr map) nil) + (consp (qcadr map)) (consp (qcdadr map)) + (eq (qcddadr map) nil)) + collect + (list (|transImplementation| x map (qcadadr map)) (qcadar map) env))) + (cond + ((setq tt + (let (result) + (loop for item in transimp + when (|modeEqual| m (cadr item)) + do (setq result (or result item))) + result)) + tt) + ((eql 1 (|#| (setq transimp + (loop for ta in transimp + when (setq y (|convert| ta m)) + collect y)))) + (car transimp)) + ((and (< 0 (|#| transimp)) (equal m |$NoValueMode|)) + (car transimp)) + (t (format t "compAtomWithModemap case 4~%") + nil)))))) + +\end{chunk} + \defun{convert}{convert} \calls{convert}{resolve} \calls{convert}{coerce} @@ -21369,6 +21516,27 @@ preferred to the underlying representation -- RDJ 9/12/83 \end{chunk} +\defun{compToApply}{compToApply} +\calls{compToApply}{compNoStacking} +\calls{compToApply}{compApplication} +\refsdollar{compToApply}{EmptyMode} +\begin{chunk}{defun compToApply} +(defun |compToApply| (op argl m e) + (let (tt m1) + (declare (special |$EmptyMode|)) + (setq tt (|compNoStacking| op |$EmptyMode| e)) + (when tt + (setq m1 (cadr tt)) + (cond + ((and (consp (car tt)) (eq (qcar (car tt)) 'quote) + (consp (qcdr (car tt))) (eq (qcddr (car tt)) nil) + (equal (qcadr (car tt)) m1)) + nil) + (t + (|compApplication| op argl m (caddr tt) tt)))))) + +\end{chunk} + \defun{getFormModemaps}{getFormModemaps} \calls{getFormModemaps}{qcar} \calls{getFormModemaps}{qcdr} @@ -22572,9 +22740,12 @@ The current input line. \getchunk{defun comp2} \getchunk{defun comp3} \getchunk{defun compAdd} +\getchunk{defun compApply} +\getchunk{defun compApplyModemap} \getchunk{defun compArgumentConditions} \getchunk{defun compArgumentsAndTryAgain} \getchunk{defun compAtom} +\getchunk{defun compAtomWithModemap} \getchunk{defun compAtSign} \getchunk{defun compBoolean} \getchunk{defun compCapsule} @@ -22666,6 +22837,7 @@ The current input line. \getchunk{defun compSymbol} \getchunk{defun compSubsetCategory} \getchunk{defun compSuchthat} +\getchunk{defun compToApply} \getchunk{defun compTopLevel} \getchunk{defun compTuple2Record} \getchunk{defun compTypeOf} diff --git a/changelog b/changelog index 734ca89..b94b588 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20111019 tpd src/axiom-website/patches.html 20111019.01.tpd.patch +20111019 tpd src/interp/apply.lisp treeshake compiler +20111019 tpd books/bookvol9 treeshake compiler 20111015 tpd src/axiom-website/patches.html 20111015.01.tpd.patch 20110105 tpd src/interp/nrungo.lisp treeshake interpreter 20111015 tpd books/bookvol5 treeshake interpreter diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 97612b7..bc7d53d 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3658,5 +3658,7 @@ books/bookvol10.* remove noweb, move to lisp tangle
src/interp/nruntime.lisp removed
20111015.01.tpd.patch books/bookvol5 treeshake interpreter
+20111019.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/apply.lisp.pamphlet b/src/interp/apply.lisp.pamphlet index 44559ea..ac7b53b 100644 --- a/src/interp/apply.lisp.pamphlet +++ b/src/interp/apply.lisp.pamphlet @@ -13,117 +13,6 @@ (in-package "BOOT" ) -;oldCompilerAutoloadOnceTrigger() == nil - -(defun |oldCompilerAutoloadOnceTrigger| () nil) - -;compAtomWithModemap(x,m,e,v) == -; Tl := -; [[transImplementation(x,map,fn),target,e] -; for map in v | map is [[.,target],[.,fn]]] => -; --accept only monadic operators -; T:= or/[t for (t:= [.,target,.]) in Tl | modeEqual(m,target)] => T -; 1=#(Tl:= [y for t in Tl | (y:= convert(t,m))]) => first Tl -; 0<#Tl and m=$NoValueMode => first Tl -; nil - -(DEFUN |compAtomWithModemap| (|x| |m| |e| |v|) - (PROG (TMP1 TMP2 TMP3 TMP4 TMP5 |fn| |target| T$ |y| TRANSIMP) - (declare (special |$NoValueMode|)) - (RETURN - (SEQ (COND - ((SETQ TRANSIMP - (PROG (T0) - (SETQ T0 NIL) - (RETURN - (DO ((T1 |v| (CDR T1)) (|map| NIL)) - ((OR (ATOM T1) - (PROGN (SETQ |map| (CAR T1)) NIL)) - (NREVERSE0 T0)) - (SEQ (EXIT (COND - ((AND (CONSP |map|) - (PROGN - (SETQ TMP1 (QCAR |map|)) - (AND (CONSP TMP1) - (PROGN - (SETQ TMP2 (QCDR TMP1)) - (AND (CONSP TMP2) - (EQ (QCDR TMP2) NIL) - (PROGN - (SETQ |target| - (QCAR TMP2)) - T))))) - (PROGN - (SETQ TMP3 (QCDR |map|)) - (AND (CONSP TMP3) - (EQ (QCDR TMP3) NIL) - (PROGN - (SETQ TMP4 (QCAR TMP3)) - (AND (CONSP TMP4) - (PROGN - (SETQ TMP5 - (QCDR TMP4)) - (AND (CONSP TMP5) - (EQ (QCDR TMP5) NIL) - (PROGN - (SETQ |fn| - (QCAR TMP5)) - T)))))))) - (SETQ T0 - (CONS - (CONS - (|transImplementation| |x| - |map| |fn|) - (CONS |target| - (CONS |e| NIL))) - T0)))))))))) - (EXIT (COND - ((SETQ T$ - (PROG (T2) - (SETQ T2 NIL) - (RETURN - (DO ((T3 NIL T2) - (T4 TRANSIMP (CDR T4)) (|t| NIL)) - ((OR T3 (ATOM T4) - (PROGN (SETQ |t| (CAR T4)) NIL) - (PROGN - (PROGN - (SETQ |target| (CADR |t|)) - |t|) - NIL)) - T2) - (SEQ - (EXIT - (COND - ((|modeEqual| |m| |target|) - (SETQ T2 (OR T2 |t|)))))))))) - T$) - ((EQL 1 - (|#| (SETQ TRANSIMP - (PROG (T5) - (SETQ T5 NIL) - (RETURN - (DO - ((T6 TRANSIMP (CDR T6)) - (|t| NIL)) - ((OR (ATOM T6) - (PROGN - (SETQ |t| (CAR T6)) - NIL)) - (NREVERSE0 T5)) - (SEQ - (EXIT - (COND - ((SETQ |y| - (|convert| |t| |m|)) - (SETQ T5 - (CONS |y| T5)))))))))))) - (CAR TRANSIMP)) - ((AND (QSLESSP 0 (|#| TRANSIMP)) - (BOOT-EQUAL |m| |$NoValueMode|)) - (CAR TRANSIMP)) - (T NIL))))))))) - ;transImplementation(op,map,fn) == ;--+ ; fn := genDeltaEntry [op,:map] @@ -136,92 +25,6 @@ ((AND (CONSP FN) (EQ (QCAR FN) 'XLAM)) (CONS FN NIL)) (T (CONS '|call| (CONS FN NIL))))) -;compApply(sig,varl,body,argl,m,e) == -; argTl:= [[.,.,e]:= comp(x,$EmptyMode,e) for x in argl] -; contour:= -; [Pair(x,[["mode",m'],["value",removeEnv comp(a,m',e)]]) -; for x in varl for m' in sig.source for a in argl] -; code:= [["LAMBDA",varl,body'],:[T.expr for T in argTl]] -; m':= resolve(m,sig.target) -; body':= (comp(body,m',addContour(contour,e))).expr -; [code,m',e] - -(DEFUN |compApply| (SIG VARL BODY ARGL M E) - (LET (TEMP1 ARGTL CONTOUR CODE MQ BODYQ) - (declare (special |$EmptyMode|)) - (SETQ ARGTL - (PROG (T0) - (SETQ T0 NIL) - (RETURN - (DO ((T1 ARGL (CDR T1)) (|x| NIL)) - ((OR (ATOM T1) (PROGN (SETQ |x| (CAR T1)) NIL)) - (NREVERSE0 T0)) - (SEQ (EXIT (SETQ T0 - (CONS (PROGN - (SETQ TEMP1 - (|comp| |x| |$EmptyMode| E)) - (SETQ E (CADDR TEMP1)) - TEMP1) - T0)))))))) - (SETQ CONTOUR - (PROG (T2) - (SETQ T2 NIL) - (RETURN - (DO ((T3 VARL (CDR T3)) (|x| NIL) (T4 (CDR SIG) (CDR T4)) - (MQ NIL) (T5 ARGL (CDR T5)) (|a| NIL)) - ((OR (ATOM T3) (PROGN (SETQ |x| (CAR T3)) NIL) - (ATOM T4) (PROGN (SETQ MQ (CAR T4)) NIL) - (ATOM T5) (PROGN (SETQ |a| (CAR T5)) NIL)) - (NREVERSE0 T2)) - (SETQ T2 - (CONS (|Pair| |x| - (CONS (CONS '|mode| (CONS MQ NIL)) - (CONS - (CONS '|value| - (CONS - (|removeEnv| (|comp| |a| MQ E)) - NIL)) - NIL))) - T2)))))) - (SETQ CODE - (CONS (CONS 'LAMBDA (CONS VARL (CONS BODYQ NIL))) - (PROG (T6) - (SETQ T6 NIL) - (RETURN - (DO ((T7 ARGTL (CDR T7)) (T$ NIL)) - ((OR (ATOM T7) (PROGN (SETQ T$ (CAR T7)) NIL)) - (NREVERSE0 T6)) - (SETQ T6 (CONS (CAR T$) T6))))))) - (SETQ MQ (|resolve| M (CAR SIG))) - (SETQ BODYQ (CAR (|comp| BODY MQ (|addContour| CONTOUR E)))) - (CONS CODE (CONS MQ (CONS E NIL))))) - -;compToApply(op,argl,m,e) == -; T:= compNoStacking(op,$EmptyMode,e) or return nil -; m1:= T.mode -; T.expr is ["QUOTE", =m1] => nil -; compApplication(op,argl,m,T.env,T) - -(DEFUN |compToApply| (|op| |argl| |m| |e|) - (PROG (T$ |m1| TMP1 TMP2) - (declare (special |$EmptyMode|)) - (RETURN - (PROGN - (SETQ T$ - (OR (|compNoStacking| |op| |$EmptyMode| |e|) - (RETURN NIL))) - (SETQ |m1| (CADR T$)) - (COND - ((PROGN - (SETQ TMP1 (CAR T$)) - (AND (CONSP TMP1) (EQ (QCAR TMP1) 'QUOTE) - (PROGN - (SETQ TMP2 (QCDR TMP1)) - (AND (CONSP TMP2) (EQ (QCDR TMP2) NIL) - (EQUAL (QCAR TMP2) |m1|))))) - NIL) - (T (|compApplication| |op| |argl| |m| (CADDR T$) T$))))))) - ;compApplication(op,argl,m,e,T) == ; T.mode is ['Mapping, retm, :argml] => ; #argl ^= #argml => nil @@ -741,119 +544,6 @@ |m|)))))))) ;--% APPLY MODEMAPS -;compApplyModemap(form,modemap,$e,sl) == -; [op,:argl] := form --form to be compiled -; [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing -; -- $e is the current environment -; -- sl substitution list, nil means bottom-up, otherwise top-down -; -- 0. fail immediately if #argl=#margl -; if #argl^=#margl then return nil -; -- 1. use modemap to evaluate arguments, returning failed if -; -- not possible -; lt:= -; [[.,m',$e]:= -; comp(y,g,$e) or return "failed" where -; g:= SUBLIS(sl,m) where -; sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl] -; lt="failed" => return nil -; -- 2. coerce each argument to final domain, returning failed -; -- if not possible -; lt':= [coerce(y,d) or return "failed" -; for y in lt for d in SUBLIS(sl,margl)] -; lt'="failed" => return nil -; -- 3. obtain domain-specific function, if possible, and return -; --$bindings is bound by compMapCond -; [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil -;--+ can no longer trust what the modemap says for a reference into -;--+ an exterior domain (it is calculating the displacement based on view -;--+ information which is no longer valid; thus ignore this index and -;--+ store the signature instead. -;--$NRTflag=true and f is [op1,d,.] and NE(d,'$) and MEMBER(op1,'(ELT CONST)) => -; f is [op1,d,.] and MEMBER(op1,'(ELT CONST Subsumed)) => -; [genDeltaEntry [op,:modemap],lt',$bindings] -; [f,lt',$bindings] - -(DEFUN |compApplyModemap| (|form| |modemap| |$e| |sl|) - (DECLARE (SPECIAL |$e|)) - (PROG (|op| |argl| |mc| |mr| |margl| |fnsel| |g| |m'| |lt| |lt'| - TEMP1 |f| |op1| TMP1 |d| TMP2) - (declare (special |$bindings| |$e|)) - (RETURN - (SEQ (PROGN - (SETQ |op| (CAR |form|)) - (SETQ |argl| (CDR |form|)) - (SETQ |mc| (CAAR |modemap|)) - (SETQ |mr| (CADAR |modemap|)) - (SETQ |margl| (CDDAR |modemap|)) - (SETQ |fnsel| (CDR |modemap|)) - (COND ((NEQUAL (|#| |argl|) (|#| |margl|)) (RETURN NIL))) - (SETQ |lt| - (PROG (T0) - (SETQ T0 NIL) - (RETURN - (DO ((T1 |argl| (CDR T1)) (|y| NIL) - (T2 |margl| (CDR T2)) (|m| NIL)) - ((OR (ATOM T1) - (PROGN (SETQ |y| (CAR T1)) NIL) - (ATOM T2) - (PROGN (SETQ |m| (CAR T2)) NIL)) - (NREVERSE0 T0)) - (SEQ (EXIT (SETQ T0 - (CONS - (PROGN - (SETQ |sl| - (|pmatchWithSl| |m'| |m| |sl|)) - (SETQ |g| (SUBLIS |sl| |m|)) - (SETQ TEMP1 - (OR (|comp| |y| |g| |$e|) - (RETURN '|failed|))) - (SETQ |m'| (CADR TEMP1)) - (SETQ |$e| (CADDR TEMP1)) - TEMP1) - T0)))))))) - (COND - ((BOOT-EQUAL |lt| '|failed|) (RETURN NIL)) - (T (SETQ |lt'| - (PROG (T3) - (SETQ T3 NIL) - (RETURN - (DO ((T4 |lt| (CDR T4)) (|y| NIL) - (T5 (SUBLIS |sl| |margl|) (CDR T5)) - (|d| NIL)) - ((OR (ATOM T4) - (PROGN (SETQ |y| (CAR T4)) NIL) - (ATOM T5) - (PROGN (SETQ |d| (CAR T5)) NIL)) - (NREVERSE0 T3)) - (SEQ (EXIT - (SETQ T3 - (CONS - (OR (|coerce| |y| |d|) - (RETURN '|failed|)) - T3)))))))) - (COND - ((BOOT-EQUAL |lt'| '|failed|) (RETURN NIL)) - (T (SETQ TEMP1 - (OR (|compMapCond| |op| |mc| |sl| |fnsel|) - (RETURN NIL))) - (SETQ |f| (CAR TEMP1)) - (SETQ |$bindings| (CADR TEMP1)) - (COND - ((AND (CONSP |f|) - (PROGN - (SETQ |op1| (QCAR |f|)) - (SETQ TMP1 (QCDR |f|)) - (AND (CONSP TMP1) - (PROGN - (SETQ |d| (QCAR TMP1)) - (SETQ TMP2 (QCDR TMP1)) - (AND (CONSP TMP2) - (EQ (QCDR TMP2) NIL))))) - (|member| |op1| '(ELT CONST |Subsumed|))) - (CONS (|genDeltaEntry| (CONS |op| |modemap|)) - (CONS |lt'| (CONS |$bindings| NIL)))) - (T (CONS |f| - (CONS |lt'| (CONS |$bindings| NIL)))))))))))))) ;compMapCond(op,mc,$bindings,fnsel) == ; or/[compMapCond'(u,op,mc,$bindings) for u in fnsel]