diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 944c1ff..fa4564f 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -1069,53 +1069,17 @@ to be a {\tt DEF} form to compile, The second argument, {\tt m}, is the mode. The third argument, {\tt e}, is the environment. -In the call to {\tt compOrCroak1} the fourth argument {\tt comp} -is the function to call. - \defun{compOrCroak}{compOrCroak} \calls{compOrCroak}{compOrCroak1} <>= (defun |compOrCroak| (x m e) - (|compOrCroak1| x m e '|comp|)) - -@ - -Which results in the call: -\begin{verbatim} -(|compOrCroak1| - (DEF (|CohenCategory|) - ((|Category|)) - (NIL) - (|Join| - (|SetCategory|) - (CATEGORY |package| - (SIGNATURE |kind| ((|Boolean|) |CExpr|)) - (SIGNATURE |operand| (|CExpr| |CExpr| (|Integer|))) - (SIGNATURE |numberOfOperand| ((|Integer|) |CExpr|)) - (SIGNATURE |construct| (|CExpr| |CExpr| |CExpr|))))) - |$EmptyMode| - (((( - |$DomainsInScope| - (FLUID . |true|) - (|special| |$EmptyMode| |$NoValueMode|))))) - |comp|) -\end{verbatim} -\defun{compOrCroak1}{compOrCroak1} -\calls{compOrCroak1}{compOrCroak1,fn} -This call expects the first argument {\tt x} -to be a {\tt DEF} form to compile, -The second argument, {\tt m}, is the mode. -The third argument, {\tt e}, is the environment. -The fourth argument {\tt comp} is the function to call. -<>= -(defun |compOrCroak1| (x m e compFn) - (|compOrCroak1,fn| x m e nil nil compFn)) + (|compOrCroak1| x m e nil nil)) @ This results in a call to the inner function with \begin{verbatim} -(|compOrCroak1,fn| +(|compOrCroak1| (DEF (|CohenCategory|) ((|Category|)) (NIL) @@ -1137,31 +1101,34 @@ This results in a call to the inner function with \end{verbatim} The inner function augments the environment with information from the compiler stack {\tt \$compStack} and -{\tt \$compErrorMessageStack}. - -\defun{compOrCroak1,fn}{compOrCroak1,fn} -\calls{compOrCroak1,fn}{comp} -\calls{compOrCroak1,fn}{compOrCroak1,compactify} -\calls{compOrCroak1,fn}{stackSemanticError} -\calls{compOrCroak1,fn}{mkErrorExpr} -\calls{compOrCroak1,fn}{displaySemanticErrors} -\calls{compOrCroak1,fn}{say} -\calls{compOrCroak1,fn}{displayComp} -\calls{compOrCroak1,fn}{userError} -\usesdollar{compOrCroak1,fn}{compStack} -\usesdollar{compOrCroak1,fn}{compErrorMessageStack} -\usesdollar{compOrCroak1,fn}{level} -\usesdollar{compOrCroak1,fn}{s} -\usesdollar{compOrCroak1,fn}{scanIfTrue} -\usesdollar{compOrCroak1,fn}{exitModeStack} -\catches{compOrCroak1,fn}{compOrCroak} -<>= -(defun |compOrCroak1,fn| (x m e |$compStack| |$compErrorMessageStack| compFn) +{\tt \$compErrorMessageStack}. Note that these variables are passed +in the argument list so they get preserved on the call stack. The +calling function gets called for every inner form so we use this +implicit stacking to retain the information. + +\defun{compOrCroak1}{compOrCroak1} +\calls{compOrCroak1}{comp} +\calls{compOrCroak1}{compOrCroak1,compactify} +\calls{compOrCroak1}{stackSemanticError} +\calls{compOrCroak1}{mkErrorExpr} +\calls{compOrCroak1}{displaySemanticErrors} +\calls{compOrCroak1}{say} +\calls{compOrCroak1}{displayComp} +\calls{compOrCroak1}{userError} +\usesdollar{compOrCroak1}{compStack} +\usesdollar{compOrCroak1}{compErrorMessageStack} +\usesdollar{compOrCroak1}{level} +\usesdollar{compOrCroak1}{s} +\usesdollar{compOrCroak1}{scanIfTrue} +\usesdollar{compOrCroak1}{exitModeStack} +\catches{compOrCroak1}{compOrCroak} +<>= +(defun |compOrCroak1| (x m e |$compStack| |$compErrorMessageStack|) (declare (special |$compStack| |$compErrorMessageStack|)) (let (td errorMessage) (declare (special |$level| |$s| |$scanIfTrue| |$exitModeStack|)) (cond - ((setq td (catch '|compOrCroak| (funcall compFn x m e))) td) + ((setq td (catch '|compOrCroak| (|comp| x m e))) td) (t (setq |$compStack| (cons (list x m e |$exitModeStack|) |$compStack|)) (setq |$s| (|compOrCroak1,compactify| |$compStack|)) @@ -1182,6 +1149,572 @@ from the compiler stack {\tt \$compStack} and @ +\defun{comp}{comp} +\calls{comp}{compNoStacking} +\usesdollar{comp}{compStack} +\usesdollar{comp}{exitModeStack} +<>= +(defun |comp| (x m e) + (let (td) + (declare (special |$compStack| |$exitModeStack|)) + (if (setq td (|compNoStacking| x m e)) + (setq |$compStack| nil) + (push (list x m e |$exitModeStack|) |$compStack|)) + td)) + +@ + +\defun{compNoStacking}{compNoStacking} +\verb|$Representation| is bound in compDefineFunctor, set by doIt. +This hack says that when something is undeclared, \$ is +preferred to the underlying representation -- RDJ 9/12/83 +\calls{compNoStacking}{comp2} +\calls{compNoStacking}{compNoStacking1} +\usesdollar{compNoStacking}{compStack} +\usesdollar{compNoStacking}{Representation} +\usesdollar{compNoStacking}{EmptyMode} +<>= +(defun |compNoStacking| (x m e) + (let (td) + (declare (special |$compStack| |$Representation| |$EmptyMode|)) + (if (setq td (|comp2| x m e)) + (if (and (equal m |$EmptyMode|) (equal (cadr td) |$Representation|)) + (list (car td) '$ (caddr td)) + td) + (|compNoStacking1| x m e |$compStack|)))) + +@ + +\defun{compNoStacking1}{compNoStacking1} +\calls{compNoStacking1}{get} +\calls{compNoStacking1}{comp2} +\usesdollar{compNoStacking1}{compStack} +<>= +(defun |compNoStacking1| (x m e |$compStack|) + (declare (special |$compStack|)) + (let (u td) + (if (setq u (|get| (if (eq m '$) '|Rep| m) '|value| e)) + (if (setq td (|comp2| x (car u) e)) + (list (car td) m (caddr td)) + nil) + nil))) + +@ + +\defun{comp2}{comp2} +\calls{comp2}{comp3} +\calls{comp2}{isDomainForm} +\calls{comp2}{isFunctor} +\calls{comp2}{insert} +\calls{comp2}{opOf} +\calls{comp2}{nequal} +\calls{comp2}{addDomain} +\usesdollar{comp2}{bootStrapMode} +\usesdollar{comp2}{packagesUsed} +\usesdollar{comp2}{lisplib} +<>= +(defun |comp2| (x m e) + (let (tmp1) + (declare (special |$bootStrapMode| |$packagesUsed| $lisplib)) + (when (setq tmp1 (|comp3| x m e)) + (destructuring-bind (y mprime e) tmp1 + (when (and $lisplib (|isDomainForm| x e) (|isFunctor| x)) + (setq |$packagesUsed| (|insert| (list (|opOf| x)) |$packagesUsed|))) + ; isDomainForm test needed to prevent error while compiling Ring + ; $bootStrapMode-test necessary for compiling Ring in $bootStrapMode + (if (and (nequal m mprime) + (or |$bootStrapMode| (|isDomainForm| mprime e))) + (list y mprime (|addDomain| mprime e)) + (list y mprime e)))))) + +@ + +\defun{comp3}{comp3} +\begin{verbatim} +;comp3(x,m,$e) == +; --returns a Triple or %else nil to signalcan't do' +; $e:= addDomain(m,$e) +; e:= $e --for debugging purposes +; m is ["Mapping",:.] => compWithMappingMode(x,m,e) +; m is ["QUOTE",a] => (x=a => [x,m,$e]; nil) +; STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) +; ^x or atom x => compAtom(x,m,e) +; op:= first x +; getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u +; op is ["KAPPA",sig,varlist,body] => compApply(sig,varlist,body,rest x,m,e) +; op=":" => compColon(x,m,e) +; op="::" => compCoerce(x,m,e) +; not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) => +; compTypeOf(x,m,e) +; t:= compExpression(x,m,e) +; t is [x',m',e'] and not MEMBER(m',getDomainsInScope e') => +; [x',m',addDomain(m',e')] +; t +\end{verbatim} +\calls{comp3}{addDomain} +\calls{comp3}{compWithMappingMode} +\calls{comp3}{stringimage} +\calls{comp3}{compAtom} +\calls{comp3}{getmode} +\calls{comp3}{applyMapping} +\calls{comp3}{compApply} +\calls{comp3}{compColon} +\calls{comp3}{compCoerce} +\calls{comp3}{stringPrefix?} +\calls{comp3}{pname} +\calls{comp3}{compTypeOf} +\calls{comp3}{compExpression} +\calls{comp3}{member} +\calls{comp3}{getDomainsInScope} +\usesdollar{comp3}{e} +\usesdollar{comp3}{insideCompTypeOf} +<>= +(defun |comp3| (x m |$e|) + (declare (special |$e|)) + (let (e a op ml u sig varlist tmp3 body tt xprime tmp1 mprime tmp2 eprime) + (declare (special |$insideCompTypeOf|)) + (setq |$e| (|addDomain| m |$e|)) + (setq e |$e|) + (cond + ((and (pairp m) (eq (qcar m) '|Mapping|)) (|compWithMappingMode| x m e)) + ((and (pairp m) (eq (qcar m) 'quote) + (progn + (setq tmp1 (qcdr m)) + (and (pairp tmp1) (eq (qcdr tmp1) nil) + (progn (setq a (qcar tmp1)) t)))) + (when (equal x a) (list x m |$e|))) + ((stringp m) + (when (and (atom x) (or (equal m x) (equal m (stringimage x)))) + (list m m e ))) + ((or (null x) (atom x)) (|compAtom| x m e)) + (t + (setq op (car x)) + (cond + ((and (progn + (setq tmp1 (|getmode| op e)) + (and (pairp tmp1) + (eq (qcar tmp1) '|Mapping|) + (progn (setq ml (qcdr tmp1)) t))) + (setq u (|applyMapping| x m e ml))) + u) + ((and (pairp op) (eq (qcar op) 'kappa) + (progn + (setq tmp1 (qcdr op)) + (and (pairp tmp1) + (progn + (setq sig (qcar tmp1)) + (setq tmp2 (qcdr tmp1)) + (and (pairp tmp2) + (progn + (setq varlist (qcar tmp2)) + (setq tmp3 (qcdr tmp2)) + (and (pairp tmp3) + (eq (qcdr tmp3) nil) + (progn + (setq body (qcar tmp3)) + t)))))))) + (|compApply| sig varlist body (cdr x) m e)) + ((eq op '|:|) (|compColon| x m e)) + ((eq op '|::|) (|compCoerce| x m e)) + ((and (null (eq |$insideCompTypeOf| t)) + (|stringPrefix?| "TypeOf" (pname op))) + (|compTypeOf| x m e)) + (t + (setq tt (|compExpression| x m e)) + (cond + ((and (pairp tt) + (progn + (setq xprime (qcar tt)) + (setq tmp1 (qcdr tt)) + (and (pairp tmp1) + (progn + (setq mprime (qcar tmp1)) + (setq tmp2 (qcdr tmp1)) + (and (pairp tmp2) + (eq (qcdr tmp2) nil) + (progn + (setq eprime (qcar tmp2)) + t))))) + (null (|member| mprime (|getDomainsInScope| eprime)))) + (list xprime mprime (|addDomain| mprime eprime))) + (t tt)))))))) + +@ + +\defun{compWithMappingMode}{compWithMappingMode} +\calls{compWithMappingMode}{compWithMappingMode1} +\usesdollar{compWithMappingMode}{formalArgList} +<>= +(defun |compWithMappingMode| (x m oldE) + (declare (special |$formalArgList|)) + (|compWithMappingMode1| x m oldE |$formalArgList|)) + +@ + +\defun{compWithMappingMode1}{compWithMappingMode1} +\begin{verbatim} +;compWithMappingMode1(x,m is ["Mapping",m',:sl],oldE,$formalArgList) == +; $killOptimizeIfTrue: local:= true +; e:= oldE +; isFunctor x => +; if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and +; (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl] +; ) and extendsCategoryForm("$",target,m') then return [x,m,e] +; if STRINGP x then x:= INTERN x +; ress:=nil +; old_style:=true +; if x is ["+->",vl,nx] then +; old_style:=false +; vl is [":",:.] => +; ress:=compLambda(x,m,oldE) +; ress +; vl:= +; vl is ["Tuple",:vl1] => vl1 +; vl +; vl:= +; SYMBOLP(vl) => [vl] +; LISTP(vl) and (and/[SYMBOLP(v) for v in vl]) => vl +; stackAndThrow ["bad +-> arguments:",vl] +; $formatArgList:=[:vl,:$formalArgList] +; x:=nx +; else +; vl:=take(#sl,$FormalMapVariableList) +; ress => ress +; for m in sl for v in vl repeat +; [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) +; old_style and not null vl and not hasFormalMapVariable(x, vl) => return +; [u,.,.] := comp([x,:vl],m',e) or return nil +; extractCodeAndConstructTriple(u, m, oldE) +; null vl and (t := comp([x], m', e)) => return +; [u,.,.] := t +; extractCodeAndConstructTriple(u, m, oldE) +; [u,.,.]:= comp(x,m',e) or return nil +; uu:=optimizeFunctionDef [nil,['LAMBDA,vl,u]] +; -- At this point, we have a function that we would like to pass. +; -- Unfortunately, it makes various free variable references outside +; -- itself. So we build a mini-vector that contains them all, and +; -- pass this as the environment to our inner function. +; $FUNNAME :local := nil +; $FUNNAME__TAIL :local := [nil] +; expandedFunction:=COMP_-TRAN CADR uu +; frees:=FreeList(expandedFunction,vl,nil,e) +; where FreeList(u,bound,free,e) == +; atom u => +; not IDENTP u => free +; MEMQ(u,bound) => free +; v:=ASSQ(u,free) => +; RPLACD(v,1+CDR v) +; free +; not getmode(u, e) => free +; [[u,:1],:free] +; op:=CAR u +; MEMQ(op, '(QUOTE GO function)) => free +; EQ(op,'LAMBDA) => +; bound:=UNIONQ(bound,CADR u) +; for v in CDDR u repeat +; free:=FreeList(v,bound,free,e) +; free +; EQ(op,'PROG) => +; bound:=UNIONQ(bound,CADR u) +; for v in CDDR u | NOT ATOM v repeat +; free:=FreeList(v,bound,free,e) +; free +; EQ(op,'SEQ) => +; for v in CDR u | NOT ATOM v repeat +; free:=FreeList(v,bound,free,e) +; free +; EQ(op,'COND) => +; for v in CDR u repeat +; for vv in v repeat +; free:=FreeList(vv,bound,free,e) +; free +; if ATOM op then u:=CDR u --Atomic functions aren't descended +; for v in u repeat +; free:=FreeList(v,bound,free,e) +; free +; expandedFunction := +; --One free can go by itself, more than one needs a vector +; --An A-list name . number of times used +; #frees = 0 => ['LAMBDA,[:vl,"$$"], :CDDR expandedFunction] +; #frees = 1 => +; vec:=first first frees +; ['LAMBDA,[:vl,vec], :CDDR expandedFunction] +; scode:=nil +; vec:=nil +; locals:=nil +; i:=-1 +; for v in frees repeat +; i:=i+1 +; vec:=[first v,:vec] +; scode:=[['SETQ,first v,[($QuickCode => 'QREFELT;'ELT),"$$",i]],:scode] +; locals:=[first v,:locals] +; body:=CDDR expandedFunction +; if locals then +; if body is [['DECLARE,:.],:.] then +; body:=[CAR body,['PROG,locals,:scode,['RETURN,['PROGN,:CDR body]]]] +; else body:=[['PROG,locals,:scode,['RETURN,['PROGN,:body]]]] +; vec:=['VECTOR,:NREVERSE vec] +; ['LAMBDA,[:vl,"$$"],:body] +; fname:=['CLOSEDFN,expandedFunction] +; --Like QUOTE, but gets compiled +; uu:= +; frees => ['CONS,fname,vec] +; ['LIST,fname] +; [uu,m,oldE] +\end{verbatim} +\calls{compWithMappingMode1}{isFunctor} +\calls{compWithMappingMode1}{get} +\calls{compWithMappingMode1}{qcar} +\calls{compWithMappingMode1}{qcdr} +\calls{compWithMappingMode1}{extendsCategoryForm} +\calls{compWithMappingMode1}{compLambda} +\calls{compWithMappingMode1}{stackAndThrow} +\calls{compWithMappingMode1}{take} +\calls{compWithMappingMode1}{compMakeDeclaration} +\calls{compWithMappingMode1}{hasFormalMapVariable} +\calls{compWithMappingMode1}{comp} +\calls{compWithMappingMode1}{extractCodeAndConstructTriple} +\calls{compWithMappingMode1}{optimizeFunctionDef} +\calls{compWithMappingMode1}{comp-tran} +\calls{compWithMappingMode1}{compWithMappingMode1,FreeList} +\usesdollar{compWithMappingMode1}{formalArgList} +\usesdollar{compWithMappingMode1}{killOptimizeIfTrue} +\usesdollar{compWithMappingMode1}{funname} +\usesdollar{compWithMappingMode1}{funnameTail} +\usesdollar{compWithMappingMode1}{QuickCode} +\usesdollar{compWithMappingMode1}{EmptyMode} +\usesdollar{compWithMappingMode1}{FormalMapVariableList} +\usesdollar{compWithMappingMode1}{CategoryFrame} +<>= +(defun |compWithMappingMode1| (x m oldE |$formalArgList|) + (declare (special |$formalArgList|)) + (prog (|$killOptimizeIfTrue| $funname $funnameTail mprime sl tmp1 tmp2 + tmp3 tmp4 tmp5 tmp6 target argModeList nx oldstyle ress vl1 vl e tt + u frees i scode locals body vec expandedFunction fname uu) + (declare (special |$killOptimizeIfTrue| $funname $funnameTail + |$QuickCode| |$EmptyMode| |$FormalMapVariableList| + |$CategoryFrame|)) + (return + (seq + (progn + (setq mprime (cadr m)) + (setq sl (cddr m)) + (setq |$killOptimizeIfTrue| t) + (setq e oldE) + (cond + ((|isFunctor| x) + (cond + ((and (progn + (setq tmp1 (|get| x '|modemap| |$CategoryFrame|)) + (and (pairp tmp1) + (progn + (setq tmp2 (qcar tmp1)) + (and (pairp tmp2) + (progn + (setq tmp3 (qcar tmp2)) + (and (pairp tmp3) + (progn + (setq tmp4 (qcdr tmp3)) + (and (pairp tmp4) + (progn + (setq target (qcar tmp4)) + (setq argModeList (qcdr tmp4)) + t))))) + (progn + (setq tmp5 (qcdr tmp2)) + (and (pairp tmp5) (eq (qcdr tmp5) nil))))))) + (prog (t1) + (setq t1 t) + (return + (do ((t2 nil (null t1)) + (t3 argModeList (cdr t3)) + (mode nil) + (t4 sl (cdr t4)) + (s nil)) + ((or t2 (atom t3) + (progn (setq mode (car t3)) nil) + (atom t4) + (progn (setq s (car t4)) nil)) + t1) + (seq (exit + (setq t1 + (and t1 (|extendsCategoryForm| '$ s mode)))))))) + (|extendsCategoryForm| '$ target mprime)) + (return (list x m e ))) + (t nil))) + (t + (when (stringp x) (setq x (intern x))) + (setq ress nil) + (setq oldstyle t) + (cond + ((and (pairp x) + (eq (qcar x) '+->) + (progn + (setq tmp1 (qcdr x)) + (and (pairp tmp1) + (progn + (setq vl (qcar tmp1)) + (setq tmp2 (qcdr tmp1)) + (and (pairp tmp2) + (eq (qcdr tmp2) nil) + (progn (setq nx (qcar tmp2)) t)))))) + (setq oldstyle nil) + (cond + ((and (pairp vl) (eq (qcar vl) '|:|)) + (setq ress (|compLambda| x m oldE)) + ress) + (t + (setq vl + (cond + ((and (pairp vl) + (eq (qcar vl) '|@Tuple|) + (progn (setq vl1 (qcdr vl)) t)) + vl1) + (t vl))) + (setq vl + (cond + ((symbolp vl) (cons vl nil)) + ((and + (listp vl) + (prog (t5) + (setq t5 t) + (return + (do ((t7 nil (null t5)) + (t6 vl (cdr t6)) + (v nil)) + ((or t7 (atom t6) (progn (setq v (car t6)) nil)) t5) + (seq + (exit + (setq t5 (and t5 (symbolp v))))))))) + vl) + (t + (|stackAndThrow| (cons '|bad +-> arguments:| (list vl )))))) + (setq |$formatArgList| (append vl |$formalArgList|)) + (setq x nx)))) + (t + (setq vl (take (|#| sl) |$FormalMapVariableList|)))) + (cond + (ress ress) + (t + (do ((t8 sl (cdr t8)) (m nil) (t9 vl (cdr t9)) (v nil)) + ((or (atom t8) + (progn (setq m (car t8)) nil) + (atom t9) + (progn (setq v (car t9)) nil)) + nil) + (seq (exit (progn + (setq tmp6 + (|compMakeDeclaration| (list '|:| v m ) |$EmptyMode| e)) + (setq e (caddr tmp6)) + tmp6)))) + (cond + ((and oldstyle + (null (null vl)) + (null (|hasFormalMapVariable| x vl))) + (return + (progn + (setq tmp6 (or (|comp| (cons x vl) mprime e) (return nil))) + (setq u (car tmp6)) + (|extractCodeAndConstructTriple| u m oldE)))) + ((and (null vl) (setq tt (|comp| (cons x nil) mprime e))) + (return + (progn + (setq u (car tt)) + (|extractCodeAndConstructTriple| u m oldE)))) + (t + (setq tmp6 (or (|comp| x mprime e) (return nil))) + (setq u (car tmp6)) + (setq uu (|optimizeFunctionDef| `(nil (lambda ,vl ,u)))) +; -- At this point, we have a function that we would like to pass. +; -- Unfortunately, it makes various free variable references outside +; -- itself. So we build a mini-vector that contains them all, and +; -- pass this as the environment to our inner function. + (setq $funname nil) + (setq $funnameTail (list nil)) + (setq expandedFunction (comp-tran (cadr uu))) + (setq frees + (|compWithMappingMode1,FreeList| expandedFunction vl nil e)) + (setq expandedFunction + (cond + ((eql (|#| frees) 0) + (cons 'lambda (cons (append vl (list '$$)) + (cddr expandedFunction)))) + ((eql (|#| frees) 1) + (setq vec (caar frees)) + (cons 'lambda (cons (append vl (list vec)) + (cddr expandedFunction)))) + (t + (setq scode nil) + (setq vec nil) + (setq locals nil) + (setq i -1) + (do ((t0 frees (cdr t0)) (v nil)) + ((or (atom t0) (progn (setq v (car t0)) nil)) nil) + (seq + (exit + (progn + (setq i (plus i 1)) + (setq vec (cons (car v) vec)) + (setq scode + (cons + (cons 'setq + (cons (car v) + (cons + (cons + (cond + (|$QuickCode| 'qrefelt) + (t 'elt)) + (cons '$$ (cons i nil))) + nil))) + scode)) + (setq locals (cons (car v) locals)))))) + (setq body (cddr expandedFunction)) + (cond + (locals + (cond + ((and (pairp body) + (progn + (setq tmp1 (qcar body)) + (and (pairp tmp1) + (eq (qcar tmp1) 'declare)))) + (setq body + (cons (car body) + (cons + (cons 'prog + (cons locals + (append scode + (cons + (cons 'return + (cons + (cons 'progn + (cdr body)) + nil)) + nil)))) + nil)))) + (t + (setq body + (cons + (cons 'prog + (cons locals + (append scode + (cons + (cons 'return + (cons + (cons 'progn body) + nil)) + nil)))) + nil)))))) + (setq vec (cons 'vector (nreverse vec))) + (cons 'lambda (cons (append vl (list '$$)) body))))) + (setq fname (list 'closedfn expandedFunction)) + (setq uu + (cond + (frees (list 'cons fname vec)) + (t (list 'list fname)))) + (list uu m oldE)))))))))))) + +@ + \defun{compOrCroak1,compactify}{compOrCroak1,compactify} \calls{compOrCroak1,compactify}{compOrCroak1,compactify} \calls{compOrCroak1,compactify}{lassoc} @@ -1365,9 +1898,9 @@ if \verb|$InteractiveMode| then use a null outputstream <>= (defun |compileFileQuietly| (fn) (let ( - (*standard-output* - (if |$InteractiveMode| (make-broadcast-stream) - *standard-output*))) + (*standard-output* + (if |$InteractiveMode| (make-broadcast-stream) + *standard-output*))) (declare (special *standard-output* |$InteractiveMode|)) (compile-file fn))) @@ -1388,6 +1921,9 @@ if \verb|$InteractiveMode| then use a null outputstream <> +<> +<> +<> <> <> <> @@ -1398,11 +1934,14 @@ if \verb|$InteractiveMode| then use a null outputstream <> <> <> +<> +<> <> <> -<> <> <> +<> +<> <> diff --git a/changelog b/changelog index 3146483..7069a5e 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20100831 tpd src/axiom-website/patches.html 20100831.01.tpd.patch +20100831 tpd src/interp/vmlisp.lisp treeshake compiler +20100831 tpd src/interp/compiler.lisp treeshake compiler +20100831 tpd books/bookvol9 treeshake compiler 20100830 tpd src/axiom-website/patches.html 20100830.02.tpd.patch 20100830 tpd books/bookvol9 treeshake compiler 20100830 tpd src/axiom-website/patches.html 20100830.01.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index db7ae44..8103b21 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3097,5 +3097,7 @@ books/bookvol9 treeshake compiler
books/bookvolbib add Tim Lahey's Sage Integration Test Suite
20100830.02.tpd.patch books/bookvol9 treeshake compiler
+20100831.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/compiler.lisp.pamphlet b/src/interp/compiler.lisp.pamphlet index d8d2602..3d1053f 100644 --- a/src/interp/compiler.lisp.pamphlet +++ b/src/interp/compiler.lisp.pamphlet @@ -44,219 +44,7 @@ (PROGN (SPADLET |$tripleCache| NIL) (|comp| |$x| |$m| |$f|))) @ -\subsection{comp} -<<*>>= -;comp(x,m,e) == -; T:= compNoStacking(x,m,e) => ($compStack:= nil; T) -; $compStack:= [[x,m,e,$exitModeStack],:$compStack] -; nil - -(DEFUN |comp| (|x| |m| |e|) - (PROG (T$) - (declare (special |$compStack| |$exitModeStack|)) - (RETURN - (COND - ((SPADLET T$ (|compNoStacking| |x| |m| |e|)) - (SPADLET |$compStack| NIL) T$) - ('T - (SPADLET |$compStack| - (CONS (CONS |x| - (CONS |m| - (CONS |e| - (CONS |$exitModeStack| NIL)))) - |$compStack|)) - NIL))))) - -@ -\subsection{compNoStacking} -<<*>>= -;compNoStacking(x,m,e) == -; T:= comp2(x,m,e) => -; (m=$EmptyMode and T.mode=$Representation => [T.expr,"$",T.env]; T) -; --$Representation is bound in compDefineFunctor, set by doIt -; --this hack says that when something is undeclared, $ is -; --preferred to the underlying representation -- RDJ 9/12/83 -; compNoStacking1(x,m,e,$compStack) - -(DEFUN |compNoStacking| (|x| |m| |e|) - (PROG (T$) - (declare (special |$compStack| |$Representation| |$EmptyMode|)) - (RETURN - (COND - ((SPADLET T$ (|comp2| |x| |m| |e|)) - (COND - ((AND (BOOT-EQUAL |m| |$EmptyMode|) - (BOOT-EQUAL (CADR T$) |$Representation|)) - (CONS (CAR T$) (CONS '$ (CONS (CADDR T$) NIL)))) - ('T T$))) - ('T (|compNoStacking1| |x| |m| |e| |$compStack|)))))) - -@ -\subsection{compNoStacking1} -<<*>>= -;compNoStacking1(x,m,e,$compStack) == -; u:= get(if m="$" then "Rep" else m,"value",e) => -; (T:= comp2(x,u.expr,e) => [T.expr,m,T.env]; nil) -; nil - -(DEFUN |compNoStacking1| (|x| |m| |e| |$compStack|) - (DECLARE (SPECIAL |$compStack|)) - (PROG (|u| T$) - (RETURN - (COND - ((SPADLET |u| - (|get| (COND ((BOOT-EQUAL |m| '$) '|Rep|) ('T |m|)) - '|value| |e|)) - (COND - ((SPADLET T$ (|comp2| |x| (CAR |u|) |e|)) - (CONS (CAR T$) (CONS |m| (CONS (CADDR T$) NIL)))) - ('T NIL))) - ('T NIL))))) - -@ -\subsection{comp2} -<<*>>= -;comp2(x,m,e) == -; [y,m',e]:= comp3(x,m,e) or return nil -; if $LISPLIB and isDomainForm(x,e) then -; if isFunctor x then -; $packagesUsed:= insert([opOf x],$packagesUsed) -; --if null atom y and isDomainForm(y,e) then e := addDomain(x,e) -; --line commented out to prevent adding derived domain forms -; m^=m' and ($bootStrapMode or isDomainForm(m',e))=>[y,m',addDomain(m',e)] -; --isDomainForm test needed to prevent error while compiling Ring -; --$bootStrapMode-test necessary for compiling Ring in $bootStrapMode -; [y,m',e] - -(DEFUN |comp2| (|x| |m| |e|) - (PROG (|LETTMP#1| |y| |m'|) - (declare (special |$bootStrapMode| |$packagesUsed| $LISPLIB)) - (RETURN - (PROGN - (SPADLET |LETTMP#1| (OR (|comp3| |x| |m| |e|) (RETURN NIL))) - (SPADLET |y| (CAR |LETTMP#1|)) - (SPADLET |m'| (CADR |LETTMP#1|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - (COND - ((AND $LISPLIB (|isDomainForm| |x| |e|)) - (COND - ((|isFunctor| |x|) - (SPADLET |$packagesUsed| - (|insert| (CONS (|opOf| |x|) NIL) - |$packagesUsed|))) - ('T NIL)))) - (COND - ((AND (NEQUAL |m| |m'|) - (OR |$bootStrapMode| (|isDomainForm| |m'| |e|))) - (CONS |y| (CONS |m'| (CONS (|addDomain| |m'| |e|) NIL)))) - ('T (CONS |y| (CONS |m'| (CONS |e| NIL))))))))) - -@ -\subsection{comp3} -<<*>>= -;comp3(x,m,$e) == -; --returns a Triple or %else nil to signalcan't do' -; $e:= addDomain(m,$e) -; e:= $e --for debugging purposes -; m is ["Mapping",:.] => compWithMappingMode(x,m,e) -; m is ["QUOTE",a] => (x=a => [x,m,$e]; nil) -; STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) -; ^x or atom x => compAtom(x,m,e) -; op:= first x -; getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u -; op is ["KAPPA",sig,varlist,body] => compApply(sig,varlist,body,rest x,m,e) -; op=":" => compColon(x,m,e) -; op="::" => compCoerce(x,m,e) -; not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) => -; compTypeOf(x,m,e) -; t:= compExpression(x,m,e) -; t is [x',m',e'] and not MEMBER(m',getDomainsInScope e') => -; [x',m',addDomain(m',e')] -; t - -(DEFUN |comp3| (|x| |m| |$e|) - (DECLARE (SPECIAL |$e|)) - (PROG (|e| |a| |op| |ml| |u| |sig| |varlist| |ISTMP#3| |body| |t| - |x'| |ISTMP#1| |m'| |ISTMP#2| |e'|) - (declare (special |$insideCompTypeOf|)) - (RETURN - (PROGN - (SPADLET |$e| (|addDomain| |m| |$e|)) - (SPADLET |e| |$e|) - (COND - ((AND (PAIRP |m|) (EQ (QCAR |m|) '|Mapping|)) - (|compWithMappingMode| |x| |m| |e|)) - ((AND (PAIRP |m|) (EQ (QCAR |m|) 'QUOTE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |m|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) - (COND - ((BOOT-EQUAL |x| |a|) - (CONS |x| (CONS |m| (CONS |$e| NIL)))) - ('T NIL))) - ((STRINGP |m|) - (COND - ((ATOM |x|) - (COND - ((OR (BOOT-EQUAL |m| |x|) - (BOOT-EQUAL |m| (STRINGIMAGE |x|))) - (CONS |m| (CONS |m| (CONS |e| NIL)))) - ('T NIL))) - ('T NIL))) - ((OR (NULL |x|) (ATOM |x|)) (|compAtom| |x| |m| |e|)) - ('T (SPADLET |op| (CAR |x|)) - (COND - ((AND (PROGN - (SPADLET |ISTMP#1| (|getmode| |op| |e|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|Mapping|) - (PROGN (SPADLET |ml| (QCDR |ISTMP#1|)) 'T))) - (SPADLET |u| (|applyMapping| |x| |m| |e| |ml|))) - |u|) - ((AND (PAIRP |op|) (EQ (QCAR |op|) 'KAPPA) - (PROGN - (SPADLET |ISTMP#1| (QCDR |op|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |sig| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |varlist| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |body| (QCAR |ISTMP#3|)) - 'T)))))))) - (|compApply| |sig| |varlist| |body| (CDR |x|) |m| |e|)) - ((BOOT-EQUAL |op| '|:|) (|compColon| |x| |m| |e|)) - ((BOOT-EQUAL |op| '|::|) (|compCoerce| |x| |m| |e|)) - ((AND (NULL (BOOT-EQUAL |$insideCompTypeOf| 'T)) - (|stringPrefix?| "TypeOf" (PNAME |op|))) - (|compTypeOf| |x| |m| |e|)) - ('T (SPADLET |t| (|compExpression| |x| |m| |e|)) - (COND - ((AND (PAIRP |t|) - (PROGN - (SPADLET |x'| (QCAR |t|)) - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |m'| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |e'| (QCAR |ISTMP#2|)) - 'T))))) - (NULL (|member| |m'| (|getDomainsInScope| |e'|)))) - (CONS |x'| - (CONS |m'| (CONS (|addDomain| |m'| |e'|) NIL)))) - ('T |t|)))))))))) -@ \subsection{compTypeOf} <<*>>= ;compTypeOf(x:=[op,:argl],m,e) == @@ -431,127 +219,8 @@ ('T (|stackAndThrow| (CONS '|compLambda| (CONS |x| NIL))))))))) @ -\subsection{compWithMappingMode} -<<*>>= -;compWithMappingMode(x,m,oldE) == -; compWithMappingMode1(x,m,oldE,$formalArgList) -(DEFUN |compWithMappingMode| (|x| |m| |oldE|) - (declare (special |$formalArgList|)) - (|compWithMappingMode1| |x| |m| |oldE| |$formalArgList|)) - -@ -\subsection{compWithMappingMode1} <<*>>= -;compWithMappingMode1(x,m is ["Mapping",m',:sl],oldE,$formalArgList) == -; $killOptimizeIfTrue: local:= true -; e:= oldE -; isFunctor x => -; if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and -; (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl] -; ) and extendsCategoryForm("$",target,m') then return [x,m,e] -; if STRINGP x then x:= INTERN x -; ress:=nil -; old_style:=true -; if x is ["+->",vl,nx] then -; old_style:=false -; vl is [":",:.] => -; ress:=compLambda(x,m,oldE) -; ress -; vl:= -; vl is ["Tuple",:vl1] => vl1 -; vl -; vl:= -; SYMBOLP(vl) => [vl] -; LISTP(vl) and (and/[SYMBOLP(v) for v in vl]) => vl -; stackAndThrow ["bad +-> arguments:",vl] -; $formatArgList:=[:vl,:$formalArgList] -; x:=nx -; else -; vl:=take(#sl,$FormalMapVariableList) -; ress => ress -; for m in sl for v in vl repeat -; [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) -; old_style and not null vl and not hasFormalMapVariable(x, vl) => return -; [u,.,.] := comp([x,:vl],m',e) or return nil -; extractCodeAndConstructTriple(u, m, oldE) -; null vl and (t := comp([x], m', e)) => return -; [u,.,.] := t -; extractCodeAndConstructTriple(u, m, oldE) -; [u,.,.]:= comp(x,m',e) or return nil -; uu:=optimizeFunctionDef [nil,['LAMBDA,vl,u]] -; -- At this point, we have a function that we would like to pass. -; -- Unfortunately, it makes various free variable references outside -; -- itself. So we build a mini-vector that contains them all, and -; -- pass this as the environment to our inner function. -; $FUNNAME :local := nil -; $FUNNAME__TAIL :local := [nil] -; expandedFunction:=COMP_-TRAN CADR uu -; frees:=FreeList(expandedFunction,vl,nil,e) -; where FreeList(u,bound,free,e) == -; atom u => -; not IDENTP u => free -; MEMQ(u,bound) => free -; v:=ASSQ(u,free) => -; RPLACD(v,1+CDR v) -; free -; not getmode(u, e) => free -; [[u,:1],:free] -; op:=CAR u -; MEMQ(op, '(QUOTE GO function)) => free -; EQ(op,'LAMBDA) => -; bound:=UNIONQ(bound,CADR u) -; for v in CDDR u repeat -; free:=FreeList(v,bound,free,e) -; free -; EQ(op,'PROG) => -; bound:=UNIONQ(bound,CADR u) -; for v in CDDR u | NOT ATOM v repeat -; free:=FreeList(v,bound,free,e) -; free -; EQ(op,'SEQ) => -; for v in CDR u | NOT ATOM v repeat -; free:=FreeList(v,bound,free,e) -; free -; EQ(op,'COND) => -; for v in CDR u repeat -; for vv in v repeat -; free:=FreeList(vv,bound,free,e) -; free -; if ATOM op then u:=CDR u --Atomic functions aren't descended -; for v in u repeat -; free:=FreeList(v,bound,free,e) -; free -; expandedFunction := -; --One free can go by itself, more than one needs a vector -; --An A-list name . number of times used -; #frees = 0 => ['LAMBDA,[:vl,"$$"], :CDDR expandedFunction] -; #frees = 1 => -; vec:=first first frees -; ['LAMBDA,[:vl,vec], :CDDR expandedFunction] -; scode:=nil -; vec:=nil -; locals:=nil -; i:=-1 -; for v in frees repeat -; i:=i+1 -; vec:=[first v,:vec] -; scode:=[['SETQ,first v,[($QuickCode => 'QREFELT;'ELT),"$$",i]],:scode] -; locals:=[first v,:locals] -; body:=CDDR expandedFunction -; if locals then -; if body is [['DECLARE,:.],:.] then -; body:=[CAR body,['PROG,locals,:scode,['RETURN,['PROGN,:CDR body]]]] -; else body:=[['PROG,locals,:scode,['RETURN,['PROGN,:body]]]] -; vec:=['VECTOR,:NREVERSE vec] -; ['LAMBDA,[:vl,"$$"],:body] -; fname:=['CLOSEDFN,expandedFunction] -; --Like QUOTE, but gets compiled -; uu:= -; frees => ['CONS,fname,vec] -; ['LIST,fname] -; [uu,m,oldE] - (DEFUN |compWithMappingMode1,FreeList| (|u| |bound| |free| |e|) (PROG (|v| |op|) (RETURN @@ -641,302 +310,6 @@ |bound| |free| |e|))))) (EXIT |free|))))) -(DEFUN |compWithMappingMode1| (|x| |m| |oldE| |$formalArgList|) - (DECLARE (SPECIAL |$formalArgList|)) - (PROG (|$killOptimizeIfTrue| $FUNNAME $FUNNAME_TAIL |m'| |sl| - |ISTMP#3| |ISTMP#4| |target| |argModeList| |ISTMP#5| - |ISTMP#2| |nx| |oldstyle| |ress| |vl1| |vl| |e| |t| - |LETTMP#1| |u| |frees| |i| |scode| |locals| |ISTMP#1| - |body| |vec| |expandedFunction| |fname| |uu|) - (DECLARE (SPECIAL |$killOptimizeIfTrue| $FUNNAME $FUNNAME_TAIL - |$QuickCode| |$EmptyMode| |$FormalMapVariableList| - |$CategoryFrame|)) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR |m|) '|Mapping|) (CAR |m|))) - (SPADLET |m'| (CADR |m|)) - (SPADLET |sl| (CDDR |m|)) - (SPADLET |$killOptimizeIfTrue| 'T) - (SPADLET |e| |oldE|) - (COND - ((|isFunctor| |x|) - (COND - ((AND (PROGN - (SPADLET |ISTMP#1| - (|get| |x| '|modemap| - |$CategoryFrame|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |target| - (QCAR |ISTMP#4|)) - (SPADLET |argModeList| - (QCDR |ISTMP#4|)) - 'T))))) - (PROGN - (SPADLET |ISTMP#5| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL))))))) - (PROG (G166666) - (SPADLET G166666 'T) - (RETURN - (DO ((G166673 NIL (NULL G166666)) - (G166674 |argModeList| - (CDR G166674)) - (|mode| NIL) - (G166675 |sl| (CDR G166675)) - (|s| NIL)) - ((OR G166673 (ATOM G166674) - (PROGN - (SETQ |mode| (CAR G166674)) - NIL) - (ATOM G166675) - (PROGN - (SETQ |s| (CAR G166675)) - NIL)) - G166666) - (SEQ (EXIT - (SETQ G166666 - (AND G166666 - (|extendsCategoryForm| '$ |s| - |mode|)))))))) - (|extendsCategoryForm| '$ |target| |m'|)) - (RETURN (CONS |x| (CONS |m| (CONS |e| NIL))))) - ('T NIL))) - ('T (COND ((STRINGP |x|) (SPADLET |x| (INTERN |x|)))) - (SPADLET |ress| NIL) (SPADLET |oldstyle| 'T) - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) '+->) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |vl| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |nx| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |oldstyle| NIL) - (COND - ((AND (PAIRP |vl|) (EQ (QCAR |vl|) '|:|)) - (SPADLET |ress| (|compLambda| |x| |m| |oldE|)) - |ress|) - ('T - (SPADLET |vl| - (COND - ((AND (PAIRP |vl|) - (EQ (QCAR |vl|) '|@Tuple|) - (PROGN - (SPADLET |vl1| (QCDR |vl|)) - 'T)) - |vl1|) - ('T |vl|))) - (SPADLET |vl| - (COND - ((SYMBOLP |vl|) (CONS |vl| NIL)) - ((AND (LISTP |vl|) - (PROG (G166685) - (SPADLET G166685 'T) - (RETURN - (DO - ((G166691 NIL - (NULL G166685)) - (G166692 |vl| - (CDR G166692)) - (|v| NIL)) - ((OR G166691 - (ATOM G166692) - (PROGN - (SETQ |v| - (CAR G166692)) - NIL)) - G166685) - (SEQ - (EXIT - (SETQ G166685 - (AND G166685 - (SYMBOLP |v|))))))))) - |vl|) - ('T - (|stackAndThrow| - (CONS '|bad +-> arguments:| - (CONS |vl| NIL)))))) - (SPADLET |$formatArgList| - (APPEND |vl| |$formalArgList|)) - (SPADLET |x| |nx|)))) - ('T - (SPADLET |vl| - (TAKE (|#| |sl|) |$FormalMapVariableList|)))) - (COND - (|ress| |ress|) - ('T - (DO ((G166706 |sl| (CDR G166706)) (|m| NIL) - (G166707 |vl| (CDR G166707)) (|v| NIL)) - ((OR (ATOM G166706) - (PROGN (SETQ |m| (CAR G166706)) NIL) - (ATOM G166707) - (PROGN (SETQ |v| (CAR G166707)) NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |LETTMP#1| - (|compMakeDeclaration| - (CONS '|:| - (CONS |v| (CONS |m| NIL))) - |$EmptyMode| |e|)) - (SPADLET |e| (CADDR |LETTMP#1|)) - |LETTMP#1|)))) - (COND - ((AND |oldstyle| (NULL (NULL |vl|)) - (NULL (|hasFormalMapVariable| |x| |vl|))) - (RETURN - (PROGN - (SPADLET |LETTMP#1| - (OR - (|comp| (CONS |x| |vl|) |m'| |e|) - (RETURN NIL))) - (SPADLET |u| (CAR |LETTMP#1|)) - (|extractCodeAndConstructTriple| |u| |m| - |oldE|)))) - ((AND (NULL |vl|) - (SPADLET |t| - (|comp| (CONS |x| NIL) |m'| |e|))) - (RETURN - (PROGN - (SPADLET |u| (CAR |t|)) - (|extractCodeAndConstructTriple| |u| |m| - |oldE|)))) - ('T - (SPADLET |LETTMP#1| - (OR (|comp| |x| |m'| |e|) (RETURN NIL))) - (SPADLET |u| (CAR |LETTMP#1|)) - (SPADLET |uu| - (|optimizeFunctionDef| - (CONS NIL - (CONS - (CONS 'LAMBDA - (CONS |vl| (CONS |u| NIL))) - NIL)))) - (SPADLET $FUNNAME NIL) - (SPADLET $FUNNAME_TAIL (CONS NIL NIL)) - (SPADLET |expandedFunction| - (COMP-TRAN (CADR |uu|))) - (SPADLET |frees| - (|compWithMappingMode1,FreeList| - |expandedFunction| |vl| NIL |e|)) - (SPADLET |expandedFunction| - (COND - ((EQL (|#| |frees|) 0) - (CONS 'LAMBDA - (CONS - (APPEND |vl| (CONS '$$ NIL)) - (CDDR |expandedFunction|)))) - ((EQL (|#| |frees|) 1) - (SPADLET |vec| (CAR (CAR |frees|))) - (CONS 'LAMBDA - (CONS - (APPEND |vl| (CONS |vec| NIL)) - (CDDR |expandedFunction|)))) - ('T (SPADLET |scode| NIL) - (SPADLET |vec| NIL) - (SPADLET |locals| NIL) - (SPADLET |i| (SPADDIFFERENCE 1)) - (DO ((G166723 |frees| - (CDR G166723)) - (|v| NIL)) - ((OR (ATOM G166723) - (PROGN - (SETQ |v| (CAR G166723)) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |i| (PLUS |i| 1)) - (SPADLET |vec| - (CONS (CAR |v|) |vec|)) - (SPADLET |scode| - (CONS - (CONS 'SETQ - (CONS (CAR |v|) - (CONS - (CONS - (COND - (|$QuickCode| 'QREFELT) - ('T 'ELT)) - (CONS '$$ (CONS |i| NIL))) - NIL))) - |scode|)) - (SPADLET |locals| - (CONS (CAR |v|) |locals|)))))) - (SPADLET |body| - (CDDR |expandedFunction|)) - (COND - (|locals| - (COND - ((AND (PAIRP |body|) - (PROGN - (SPADLET |ISTMP#1| - (QCAR |body|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) - 'DECLARE)))) - (SPADLET |body| - (CONS (CAR |body|) - (CONS - (CONS 'PROG - (CONS |locals| - (APPEND |scode| - (CONS - (CONS 'RETURN - (CONS - (CONS 'PROGN - (CDR |body|)) - NIL)) - NIL)))) - NIL)))) - ('T - (SPADLET |body| - (CONS - (CONS 'PROG - (CONS |locals| - (APPEND |scode| - (CONS - (CONS 'RETURN - (CONS - (CONS 'PROGN |body|) - NIL)) - NIL)))) - NIL)))))) - (SPADLET |vec| - (CONS 'VECTOR - (NREVERSE |vec|))) - (CONS 'LAMBDA - (CONS - (APPEND |vl| (CONS '$$ NIL)) - |body|))))) - (SPADLET |fname| - (CONS 'CLOSEDFN - (CONS |expandedFunction| NIL))) - (SPADLET |uu| - (COND - (|frees| (CONS 'CONS - (CONS |fname| - (CONS |vec| NIL)))) - ('T (CONS 'LIST (CONS |fname| NIL))))) - (CONS |uu| (CONS |m| (CONS |oldE| NIL)))))))))))))) @ \subsection{extractCodeAndConstructTriple} diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index c7c9bb5..82bdfde 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -2413,7 +2413,7 @@ which will walk the structure $Y$ looking for this constant. (def-boot-var |$fromSpadTrace| "Interpreter>Trace.boot") (def-boot-var $function "Interpreter>System.boot") (def-boot-var $FunName "???") -(def-boot-var $FunName_Tail "???") +(def-boot-var $FunnameTail "???") (def-boot-val |$ConstructorNames| '(|SubDomain| |List| |Union| |Record| |Vector|) "Used in isFunctor test, and compDefine.") @@ -4273,10 +4273,10 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size (defun COMP-1 (X) (let* ((FNAME (car X)) ($FUNNAME FNAME) - ($FUNNAME_TAIL (LIST FNAME)) + ($FUNNAMETAIL (LIST FNAME)) (LAMEX (second X)) ($closedfns nil)) - (declare (special $FUNNAME $FUNNAME_TAIL $CLOSEDFNS)) + (declare (special $FUNNAME $FUNNAMETAIL $CLOSEDFNS)) (setq LAMEX (COMP-TRAN LAMEX)) (COMP-NEWNAM LAMEX) (if (fboundp FNAME) @@ -4480,7 +4480,7 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size (COND ((NOT (eq U 'DCQ)) (COND ((OR (AND (eq $NEWSPAD T) (NOT $BOOT)) (MEMQ $FUNNAME |$traceletFunctions|)) - (NCONC X $FUNNAME_TAIL) + (NCONC X $FUNNAMETAIL) (RPLACA X 'LETT)) ; this devious trick (due to RDJ) is needed since the compile ; looks only at global variables in top-level environment; @@ -6093,7 +6093,7 @@ special. (setq |$Newline| #\Newline) (setq |$createUpdateFiles| nil) (SETQ $FUNNAME NIL) ;; this and next used in COMP,TRAN,1 -(SETQ $FUNNAME_TAIL '(())) +(SETQ $FUNNAMETAIL '(())) (SETQ |$Slot1DataBase| (MAKE-HASHTABLE 'ID)) ;; See NRUNTIME BOOT (SETQ |$ruleSetsInitialized| NIL) (SETQ |$NRTmakeCompactDirect| NIL)