diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index fa4564f..666c072 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -942,51 +942,61 @@ and mode. \usesdollar{s-process}{LocalFrame} \uses{s-process}{curoutstream} <>= -(defun s-process (X) - (let ((|$Index| 0) - ($macroassoc ()) - ($newspad t) - (|$PolyMode| |$EmptyMode|) - (|$compUniquelyIfTrue| nil) - |$currentFunction| - (|$postStack| nil) - |$topOp| - (|$semanticErrorStack| ()) - (|$warningStack| ()) - (|$exitMode| |$EmptyMode|) - (|$exitModeStack| ()) - (|$returnMode| |$EmptyMode|) - (|$leaveMode| |$EmptyMode|) - (|$leaveLevelStack| ()) - $top_level |$insideFunctorIfTrue| |$insideExpressionIfTrue| - |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| - |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| - (|$DomainFrame| '((NIL))) - (|$e| |$EmptyEnvironment|) - (|$genFVar| 0) - (|$genSDVar| 0) - (|$VariableCount| 0) - (|$previousTime| (get-internal-run-time)) - (|$LocalFrame| '((NIL)))) - (prog ((curstrm curoutstream) |$s| |$x| |$m| u) - (declare (special curstrm |$s| |$x| |$m| curoutstream)) - (setq $traceflag t) - (if (not x) (return nil)) - (setq x (if $boot (def-rename (|new2OldLisp| x)) - (|parseTransform| (|postTransform| x)))) - (if |$TranslateOnly| (return (setq |$Translation| x))) - (when |$postStack| (|displayPreCompilationErrors|) (return nil)) - (cond (|$PrintOnly| - (format t "~S =====>~%" |$currentLine|) - (return (prettyprint x)))) - (if (not $boot) - (if |$InteractiveMode| - (|processInteractive| x nil) - (if (setq u (|compTopLevel| x |$EmptyMode| |$InteractiveFrame|)) - (setq |$InteractiveFrame| (third u)))) - (def-process x)) - (if |$semanticErrorStack| (|displaySemanticErrors|)) - (terpri)))) +(defun s-process (x) + (prog ((|$Index| 0) + ($macroassoc ()) + ($newspad t) + (|$PolyMode| |$EmptyMode|) + (|$compUniquelyIfTrue| nil) + |$currentFunction| + (|$postStack| nil) + |$topOp| + (|$semanticErrorStack| ()) + (|$warningStack| ()) + (|$exitMode| |$EmptyMode|) + (|$exitModeStack| ()) + (|$returnMode| |$EmptyMode|) + (|$leaveMode| |$EmptyMode|) + (|$leaveLevelStack| ()) + $top_level |$insideFunctorIfTrue| |$insideExpressionIfTrue| + |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| + |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| + (|$DomainFrame| '((NIL))) + (|$e| |$EmptyEnvironment|) + (|$genFVar| 0) + (|$genSDVar| 0) + (|$VariableCount| 0) + (|$previousTime| (get-internal-run-time)) + (|$LocalFrame| '((NIL))) + (curstrm curoutstream) |$s| |$x| |$m| u) + (declare (special |$Index| $macroassoc $newspad |$PolyMode| |$EmptyMode| + |$compUniquelyIfTrue| |$currentFunction| |$postStack| |$topOp| + |$semanticErrorStack| |$warningStack| |$exitMode| |$exitModeStack| + |$returnMode| |$leaveMode| |$leaveLevelStack| $top_level + |$insideFunctorIfTrue| |$insideExpressionIfTrue| + |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| + |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| + |$DomainFrame| |$e| |$EmptyEnvironment| |$genFVar| |$genSDVar| + |$VariableCount| |$previousTime| |$LocalFrame| + curstrm |$s| |$x| |$m| curoutstream $traceflag)) + (setq $traceflag t) + (if (not x) (return nil)) + (if $boot + (setq x (def-rename (|new2OldLisp| x))) + (setq x (|parseTransform| (|postTransform| x)))) + (when |$TranslateOnly| (return (setq |$Translation| x))) + (when |$postStack| (|displayPreCompilationErrors|) (return nil)) + (when |$PrintOnly| + (format t "~S =====>~%" |$currentLine|) + (return (prettyprint x))) + (if (not $boot) + (if |$InteractiveMode| + (|processInteractive| x nil) + (when (setq u (|compTopLevel| x |$EmptyMode| |$InteractiveFrame|)) + (setq |$InteractiveFrame| (third u)))) + (def-process x)) + (when |$semanticErrorStack| (|displaySemanticErrors|)) + (terpri))) @ @@ -1341,6 +1351,103 @@ preferred to the underlying representation -- RDJ 9/12/83 @ +\defun{compAtom}{compAtom} +\begin{verbatim} +;compAtom(x,m,e) == +; T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => T +; x="nil" => +; T:= +; modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e) +; modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e) +; T => convert(T,m) +; t:= +; isSymbol x => +; compSymbol(x,m,e) or return nil +; m = $Expression and primitiveType x => [x,m,e] +; STRINGP x => [x,x,e] +; [x,primitiveType x or return nil,e] +; convert(t,m) +\end{verbatim} +\calls{compAtom}{compAtomWithModemap} +\calls{compAtom}{get} +\calls{compAtom}{modeIsAggregateOf} +\calls{compAtom}{compList} +\calls{compAtom}{compVector} +\calls{compAtom}{convert} +\calls{compAtom}{isSymbol} +\calls{compAtom}{compSymbol} +\calls{compAtom}{primitiveType} +\calls{compAtom}{primitiveType} +\usesdollar{compAtom}{Expression} +<>= +(defun |compAtom| (x m e) + (prog (tmp1 tmp2 r td tt) + (declare (special |$Expression|)) + (return + (cond + ((setq td (|compAtomWithModemap| x m e (|get| x '|modemap| e))) td) + ((eq x '|nil|) + (setq td + (cond + ((progn + (setq tmp1 (|modeIsAggregateOf| '|List| m e)) + (and (pairp tmp1) + (progn + (setq tmp2 (qcdr tmp1)) + (and (pairp tmp2) + (eq (qcdr tmp2) nil) + (progn + (setq r (qcar tmp2)) t))))) + (|compList| x (list '|List| r) e)) + ((progn + (setq tmp1 (|modeIsAggregateOf| '|Vector| m e)) + (and (pairp tmp1) + (progn + (setq tmp2 (qcdr tmp1)) + (and (pairp tmp2) (eq (qcdr tmp2) nil) + (progn + (setq r (qcar tmp2)) t))))) + (|compVector| x (list '|Vector| r) e)))) + (when td (|convert| td m))) + (t + (setq tt + (cond + ((|isSymbol| x) (or (|compSymbol| x m e) (return nil))) + ((and (equal m |$Expression|) (|primitiveType| x)) (list x m e )) + ((stringp x) (list x x e )) + (t (list x (or (|primitiveType| x) (return nil)) e )))) + (|convert| tt m)))))) + +@ + +\defun{compExpression}{compExpression} +\calls{compExpression}{getl} +\calls{compExpression}{compForm} +\usesdollar{compExpression}{insideExpressionIfTrue} +<>= +(defun |compExpression| (x m e) + (let (|$insideExpressionIfTrue| fn) + (declare (special |$insideExpressionIfTrue|)) + (setq |$insideExpressionIfTrue| t) + (if (and (atom (car x)) (setq fn (getl (car x) 'special))) + (funcall fn x m e) + (|compForm| x m e)))) + +@ + +\defun{compForm}{compForm} +\calls{compForm}{compForm1} +\calls{compForm}{compArgumentsAndTryAgain} +\calls{compForm}{stackMessageIfNone} +<>= +(defun |compForm| (form m e) + (cond + ((|compForm1| form m e)) + ((|compArgumentsAndTryAgain| form m e)) + (t (|stackMessageIfNone| (list '|cannot compile| '|%b| form '|%d| ))))) + +@ + \defun{compWithMappingMode}{compWithMappingMode} \calls{compWithMappingMode}{compWithMappingMode1} \usesdollar{compWithMappingMode}{formalArgList} @@ -1397,8 +1504,8 @@ preferred to the underlying representation -- RDJ 9/12/83 ; $FUNNAME :local := nil ; $FUNNAME__TAIL :local := [nil] ; expandedFunction:=COMP_-TRAN CADR uu -; frees:=FreeList(expandedFunction,vl,nil,e) -; where FreeList(u,bound,free,e) == +; frees:=freelist(expandedFunction,vl,nil,e) +; where freelist(u,bound,free,e) == ; atom u => ; not IDENTP u => free ; MEMQ(u,bound) => free @@ -1412,25 +1519,25 @@ preferred to the underlying representation -- RDJ 9/12/83 ; EQ(op,'LAMBDA) => ; bound:=UNIONQ(bound,CADR u) ; for v in CDDR u repeat -; free:=FreeList(v,bound,free,e) +; 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:=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:=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:=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:=freelist(v,bound,free,e) ; free ; expandedFunction := ; --One free can go by itself, more than one needs a vector @@ -1476,7 +1583,7 @@ preferred to the underlying representation -- RDJ 9/12/83 \calls{compWithMappingMode1}{extractCodeAndConstructTriple} \calls{compWithMappingMode1}{optimizeFunctionDef} \calls{compWithMappingMode1}{comp-tran} -\calls{compWithMappingMode1}{compWithMappingMode1,FreeList} +\calls{compWithMappingMode1}{freelist} \usesdollar{compWithMappingMode1}{formalArgList} \usesdollar{compWithMappingMode1}{killOptimizeIfTrue} \usesdollar{compWithMappingMode1}{funname} @@ -1632,8 +1739,7 @@ preferred to the underlying representation -- RDJ 9/12/83 (setq $funname nil) (setq $funnameTail (list nil)) (setq expandedFunction (comp-tran (cadr uu))) - (setq frees - (|compWithMappingMode1,FreeList| expandedFunction vl nil e)) + (setq frees (freelist expandedFunction vl nil e)) (setq expandedFunction (cond ((eql (|#| frees) 0) @@ -1715,6 +1821,56 @@ preferred to the underlying representation -- RDJ 9/12/83 @ +\defun{freelist}{Create a list of unbound symbols} +We walk argument u looking for symbols that are unbound. If we find a +symbol we add it to the free list. If it occurs in a prog then it is +bound and we remove it from the free list. Multiple instances of a single +symbol in the free list are represented by the alist (symbol . count) +\calls{freelist}{freelist} +\calls{freelist}{assq} +\calls{freelist}{identp} +\calls{freelist}{getmode} +\calls{freelist}{unionq} +<>= +(defun freelist (u bound free e) + (let (v op) + (if (atom u) + (cond + ((null (identp u)) free) + ((memq u bound) free) + ; more than 1 free becomes alist (name . number) + ((setq v (assq u free)) (rplacd v (+ 1 (cdr v))) free) + ((null (|getmode| u e)) free) + (t (cons (cons u 1) free))) + (progn + (setq op (car u)) + (cond + ((memq op '(quote go |function|)) free) + ((eq op 'lambda) ; lambdas bind symbols + (setq bound (unionq bound (cadr u))) + (dolist (v (cddr u)) + (setq free (freelist v bound free e)))) + ((eq op 'prog) ; progs bind symbols + (setq bound (unionq bound (cadr u))) + (dolist (v (cddr u)) + (unless (atom v) + (setq free (freelist v bound free e))))) + ((eq op 'seq) + (dolist (v (cdr u)) + (unless (atom v) + (setq free (freelist v bound free e))))) + ((eq op 'cond) + (dolist (v (cdr u)) + (dolist (vv v) + (setq free (freelist vv bound free e))))) + (t + (when (atom op) (setq u (cdr u))) ; atomic functions aren't descended + (dolist (v u) + (setq free (freelist v bound free e))))) + free)))) + +@ + \defun{compOrCroak1,compactify}{compOrCroak1,compactify} \calls{compOrCroak1,compactify}{compOrCroak1,compactify} \calls{compOrCroak1,compactify}{lassoc} @@ -1924,6 +2080,9 @@ if \verb|$InteractiveMode| then use a null outputstream <> <> <> +<> +<> +<> <> <> <> @@ -1943,6 +2102,8 @@ if \verb|$InteractiveMode| then use a null outputstream <> <> +<> + <> <> diff --git a/changelog b/changelog index 7069a5e..fcf652e 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20100903 tpd src/axiom-website/patches.html 20100903.01.tpd.patch +20100903 tpd src/interp/compiler.lisp treeshake compiler +20100903 tpd books/bookvol9 treeshake compiler 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 diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 8103b21..41f6d6b 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3099,5 +3099,7 @@ books/bookvolbib add Tim Lahey's Sage Integration Test Suite
books/bookvol9 treeshake compiler
20100831.01.tpd.patch books/bookvol9 treeshake compiler
+20100903.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/compiler.lisp.pamphlet b/src/interp/compiler.lisp.pamphlet index 3d1053f..686ca87 100644 --- a/src/interp/compiler.lisp.pamphlet +++ b/src/interp/compiler.lisp.pamphlet @@ -220,98 +220,6 @@ @ -<<*>>= -(DEFUN |compWithMappingMode1,FreeList| (|u| |bound| |free| |e|) - (PROG (|v| |op|) - (RETURN - (SEQ (IF (ATOM |u|) - (EXIT (SEQ (IF (NULL (IDENTP |u|)) (EXIT |free|)) - (IF (MEMQ |u| |bound|) (EXIT |free|)) - (IF (SPADLET |v| (ASSQ |u| |free|)) - (EXIT (SEQ - (RPLACD |v| (PLUS 1 (CDR |v|))) - (EXIT |free|)))) - (IF (NULL (|getmode| |u| |e|)) (EXIT |free|)) - (EXIT (CONS (CONS |u| 1) |free|))))) - (SPADLET |op| (CAR |u|)) - (IF (MEMQ |op| '(QUOTE GO |function|)) (EXIT |free|)) - (IF (EQ |op| 'LAMBDA) - (EXIT (SEQ (SPADLET |bound| (UNIONQ |bound| (CADR |u|))) - (DO ((G166546 (CDDR |u|) (CDR G166546)) - (|v| NIL)) - ((OR (ATOM G166546) - (PROGN - (SETQ |v| (CAR G166546)) - NIL)) - NIL) - (SEQ (EXIT (SPADLET |free| - (|compWithMappingMode1,FreeList| - |v| |bound| |free| |e|))))) - (EXIT |free|)))) - (IF (EQ |op| 'PROG) - (EXIT (SEQ (SPADLET |bound| (UNIONQ |bound| (CADR |u|))) - (DO ((G166556 (CDDR |u|) (CDR G166556)) - (|v| NIL)) - ((OR (ATOM G166556) - (PROGN - (SETQ |v| (CAR G166556)) - NIL)) - NIL) - (SEQ (EXIT (COND - ((NULL (ATOM |v|)) - (SPADLET |free| - (|compWithMappingMode1,FreeList| - |v| |bound| |free| |e|))))))) - (EXIT |free|)))) - (IF (EQ |op| 'SEQ) - (EXIT (SEQ (DO ((G166566 (CDR |u|) (CDR G166566)) - (|v| NIL)) - ((OR (ATOM G166566) - (PROGN - (SETQ |v| (CAR G166566)) - NIL)) - NIL) - (SEQ (EXIT (COND - ((NULL (ATOM |v|)) - (SPADLET |free| - (|compWithMappingMode1,FreeList| - |v| |bound| |free| |e|))))))) - (EXIT |free|)))) - (IF (EQ |op| 'COND) - (EXIT (SEQ (DO ((G166575 (CDR |u|) (CDR G166575)) - (|v| NIL)) - ((OR (ATOM G166575) - (PROGN - (SETQ |v| (CAR G166575)) - NIL)) - NIL) - (SEQ (EXIT (DO - ((G166584 |v| - (CDR G166584)) - (|vv| NIL)) - ((OR (ATOM G166584) - (PROGN - (SETQ |vv| (CAR G166584)) - NIL)) - NIL) - (SEQ - (EXIT - (SPADLET |free| - (|compWithMappingMode1,FreeList| - |vv| |bound| |free| |e|)))))))) - (EXIT |free|)))) - (IF (ATOM |op|) (SPADLET |u| (CDR |u|)) NIL) - (DO ((G166593 |u| (CDR G166593)) (|v| NIL)) - ((OR (ATOM G166593) - (PROGN (SETQ |v| (CAR G166593)) NIL)) - NIL) - (SEQ (EXIT (SPADLET |free| - (|compWithMappingMode1,FreeList| |v| - |bound| |free| |e|))))) - (EXIT |free|))))) - - -@ \subsection{extractCodeAndConstructTriple} <<*>>= ;extractCodeAndConstructTriple(u, m, oldE) == @@ -347,100 +255,7 @@ (CONS |m| (CONS |oldE| NIL)))))))) @ -\subsection{compExpression} -<<*>>= -;compExpression(x,m,e) == -; $insideExpressionIfTrue: local:= true -; atom first x and (fn:= GET(first x,"SPECIAL")) => -; FUNCALL(fn,x,m,e) -; compForm(x,m,e) - -(DEFUN |compExpression| (|x| |m| |e|) - (PROG (|$insideExpressionIfTrue| |fn|) - (DECLARE (SPECIAL |$insideExpressionIfTrue|)) - (RETURN - (PROGN - (SPADLET |$insideExpressionIfTrue| 'T) - (COND - ((AND (ATOM (CAR |x|)) - (SPADLET |fn| (GETL (CAR |x|) 'SPECIAL))) - (FUNCALL |fn| |x| |m| |e|)) - ('T (|compForm| |x| |m| |e|))))))) -@ -\subsection{compAtom} -<<*>>= -;compAtom(x,m,e) == -; T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => T -; x="nil" => -; T:= -; modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e) -; modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e) -; T => convert(T,m) -; t:= -; isSymbol x => -; compSymbol(x,m,e) or return nil -; m = $Expression and primitiveType x => [x,m,e] -; STRINGP x => [x,x,e] -; [x,primitiveType x or return nil,e] -; convert(t,m) - -(DEFUN |compAtom| (|x| |m| |e|) - (PROG (|ISTMP#1| |ISTMP#2| R T$ |t|) - (declare (special |$Expression|)) - (RETURN - (COND - ((SPADLET T$ - (|compAtomWithModemap| |x| |m| |e| - (|get| |x| '|modemap| |e|))) - T$) - ((BOOT-EQUAL |x| '|nil|) - (SPADLET T$ - (COND - ((PROGN - (SPADLET |ISTMP#1| - (|modeIsAggregateOf| '|List| |m| |e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET R (QCAR |ISTMP#2|)) - 'T))))) - (|compList| |x| (CONS '|List| (CONS R NIL)) |e|)) - ((PROGN - (SPADLET |ISTMP#1| - (|modeIsAggregateOf| '|Vector| |m| |e|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET R (QCAR |ISTMP#2|)) - 'T))))) - (|compVector| |x| (CONS '|Vector| (CONS R NIL)) - |e|)))) - (COND (T$ (|convert| T$ |m|)))) - ('T - (SPADLET |t| - (COND - ((|isSymbol| |x|) - (OR (|compSymbol| |x| |m| |e|) (RETURN NIL))) - ((AND (BOOT-EQUAL |m| |$Expression|) - (|primitiveType| |x|)) - (CONS |x| (CONS |m| (CONS |e| NIL)))) - ((STRINGP |x|) - (CONS |x| (CONS |x| (CONS |e| NIL)))) - ('T - (CONS |x| - (CONS (OR (|primitiveType| |x|) - (RETURN NIL)) - (CONS |e| NIL)))))) - (|convert| |t| |m|)))))) - -@ \subsection{primitiveType} <<*>>= ;primitiveType x == @@ -647,29 +462,6 @@ (|hasType,fn| (|get| |x| '|condition| |e|))) @ -\subsection{compForm} -<<*>>= -;compForm(form,m,e) == -; T:= -; compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return -; stackMessageIfNone ["cannot compile","%b",form,"%d"] -; T - -(DEFUN |compForm| (|form| |m| |e|) - (PROG (T$) - (RETURN - (PROGN - (SPADLET T$ - (OR (|compForm1| |form| |m| |e|) - (|compArgumentsAndTryAgain| |form| |m| |e|) - (RETURN - (|stackMessageIfNone| - (CONS '|cannot compile| - (CONS '|%b| - (CONS |form| (CONS '|%d| NIL)))))))) - T$)))) - -@ \subsection{compArgumentsAndTryAgain} <<*>>= ;compArgumentsAndTryAgain(form is [.,:argl],m,e) ==