diff options
| -rw-r--r-- | src/boot/ast.boot | 46 | ||||
| -rw-r--r-- | src/boot/strap/ast.clisp | 62 |
2 files changed, 52 insertions, 56 deletions
diff --git a/src/boot/ast.boot b/src/boot/ast.boot index e59d290d..f6819e08 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -965,43 +965,43 @@ isDynamicVariable x == shoeCompTran1 x == atom x => - isDynamicVariable x => - $dollarVars:= - symbolMember?(x,$dollarVars)=>$dollarVars - [x,:$dollarVars] - nil + if isDynamicVariable x and not symbolMember?(x,$dollarVars) then + $dollarVars := [x,:$dollarVars] + x U := first x - U is "QUOTE" => nil + U is "QUOTE" => x x is ["L%T",l,r] => x.op := "SETQ" - shoeCompTran1 r + third(x) := shoeCompTran1 r symbol? l => - not bfBeginsDollar l=> - $locVars:= - symbolMember?(l,$locVars)=>$locVars - [l,:$locVars] - $dollarVars:= - symbolMember?(l,$dollarVars)=>$dollarVars - [l,:$dollarVars] + bfBeginsDollar l => + if not symbolMember?(l,$dollarVars) then + $dollarVars := [l,:$dollarVars] + x + if not symbolMember?(l,$locVars) then + $locVars := [l,:$locVars] + x l is ["FLUID",:.] => - $fluidVars:= - symbolMember?(second l,$fluidVars)=>$fluidVars - [second l,:$fluidVars] + if not symbolMember?(second l,$fluidVars) then + $fluidVars := [second l,:$fluidVars] x.rest.first := second l - U is "%Leave" => x.op := "RETURN" + x + U is "%Leave" => (x.op := "RETURN"; x) U in '(PROG LAMBDA) => newbindings := nil for y in second x repeat not symbolMember?(y,$locVars)=> $locVars := [y,:$locVars] newbindings := [y,:newbindings] - res := shoeCompTran1 CDDR x + rest(x).rest := shoeCompTran1 CDDR x $locVars := [y for y in $locVars | not symbolMember?(y,newbindings)] + x -- literal vectors. - x is ['vector,['LIST,:args]] => (x.op := 'VECTOR; x.args := args) - x is ['vector,'NIL] => (x.op := 'VECTOR; x.args := nil) - shoeCompTran1 first x - shoeCompTran1 rest x + x is ['vector,['LIST,:args]] => (x.op := 'VECTOR; x.args := args; x) + x is ['vector,'NIL] => (x.op := 'VECTOR; x.args := nil; x) + x.first := shoeCompTran1 first x + x.rest := shoeCompTran1 rest x + x bfTagged(a,b)== $op = nil => %Signature(a,b) -- surely a toplevel decl diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index 6aeeec23..4d3fb2a8 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -1827,21 +1827,19 @@ (T NIL))))) (DEFUN |shoeCompTran1| (|x|) - (PROG (|args| |res| |newbindings| |r| |ISTMP#2| |l| |ISTMP#1| U) + (PROG (|args| |newbindings| |r| |ISTMP#2| |l| |ISTMP#1| U) (DECLARE (SPECIAL |$fluidVars| |$locVars| |$dollarVars|)) (RETURN (COND ((ATOM |x|) (COND - ((|isDynamicVariable| |x|) - (SETQ |$dollarVars| - (COND - ((|symbolMember?| |x| |$dollarVars|) |$dollarVars|) - (T (CONS |x| |$dollarVars|))))) - (T NIL))) + ((AND (|isDynamicVariable| |x|) + (NOT (|symbolMember?| |x| |$dollarVars|))) + (SETQ |$dollarVars| (CONS |x| |$dollarVars|)))) + |x|) (T (SETQ U (CAR |x|)) (COND - ((EQ U 'QUOTE) NIL) + ((EQ U 'QUOTE) |x|) ((AND (CONSP |x|) (EQ (CAR |x|) 'L%T) (PROGN (SETQ |ISTMP#1| (CDR |x|)) @@ -1852,29 +1850,26 @@ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) (PROGN (SETQ |r| (CAR |ISTMP#2|)) T)))))) - (RPLACA |x| 'SETQ) (|shoeCompTran1| |r|) + (RPLACA |x| 'SETQ) + (SETF (CADDR |x|) (|shoeCompTran1| |r|)) (COND ((SYMBOLP |l|) (COND - ((NOT (|bfBeginsDollar| |l|)) - (SETQ |$locVars| - (COND - ((|symbolMember?| |l| |$locVars|) - |$locVars|) - (T (CONS |l| |$locVars|))))) - (T (SETQ |$dollarVars| - (COND - ((|symbolMember?| |l| |$dollarVars|) - |$dollarVars|) - (T (CONS |l| |$dollarVars|))))))) + ((|bfBeginsDollar| |l|) + (COND + ((NOT (|symbolMember?| |l| |$dollarVars|)) + (SETQ |$dollarVars| (CONS |l| |$dollarVars|)))) + |x|) + (T (COND + ((NOT (|symbolMember?| |l| |$locVars|)) + (SETQ |$locVars| (CONS |l| |$locVars|)))) + |x|))) ((AND (CONSP |l|) (EQ (CAR |l|) 'FLUID)) - (SETQ |$fluidVars| - (COND - ((|symbolMember?| (CADR |l|) |$fluidVars|) - |$fluidVars|) - (T (CONS (CADR |l|) |$fluidVars|)))) - (RPLACA (CDR |x|) (CADR |l|))))) - ((EQ U '|%Leave|) (RPLACA |x| 'RETURN)) + (COND + ((NOT (|symbolMember?| (CADR |l|) |$fluidVars|)) + (SETQ |$fluidVars| (CONS (CADR |l|) |$fluidVars|)))) + (RPLACA (CDR |x|) (CADR |l|)) |x|))) + ((EQ U '|%Leave|) (RPLACA |x| 'RETURN) |x|) ((|symbolMember?| U '(PROG LAMBDA)) (SETQ |newbindings| NIL) (LET ((|bfVar#136| (CADR |x|)) (|y| NIL)) @@ -1890,7 +1885,7 @@ (SETQ |newbindings| (CONS |y| |newbindings|)))))) (SETQ |bfVar#136| (CDR |bfVar#136|)))) - (SETQ |res| (|shoeCompTran1| (CDDR |x|))) + (RPLACD (CDR |x|) (|shoeCompTran1| (CDDR |x|))) (SETQ |$locVars| (LET ((|bfVar#138| NIL) (|bfVar#139| NIL) (|bfVar#137| |$locVars|) (|y| NIL)) @@ -1911,7 +1906,8 @@ (T (RPLACD |bfVar#139| #0#) (SETQ |bfVar#139| (CDR |bfVar#139|))))))) - (SETQ |bfVar#137| (CDR |bfVar#137|)))))) + (SETQ |bfVar#137| (CDR |bfVar#137|))))) + |x|) ((AND (CONSP |x|) (EQ (CAR |x|) '|vector|) (PROGN (SETQ |ISTMP#1| (CDR |x|)) @@ -1923,15 +1919,15 @@ (PROGN (SETQ |args| (CDR |ISTMP#2|)) T)))))) - (RPLACA |x| 'VECTOR) (RPLACD |x| |args|)) + (RPLACA |x| 'VECTOR) (RPLACD |x| |args|) |x|) ((AND (CONSP |x|) (EQ (CAR |x|) '|vector|) (PROGN (SETQ |ISTMP#1| (CDR |x|)) (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) (EQ (CAR |ISTMP#1|) 'NIL)))) - (RPLACA |x| 'VECTOR) (RPLACD |x| NIL)) - (T (|shoeCompTran1| (CAR |x|)) - (|shoeCompTran1| (CDR |x|))))))))) + (RPLACA |x| 'VECTOR) (RPLACD |x| NIL) |x|) + (T (RPLACA |x| (|shoeCompTran1| (CAR |x|))) + (RPLACD |x| (|shoeCompTran1| (CDR |x|))) |x|))))))) (DEFUN |bfTagged| (|a| |b|) (DECLARE (SPECIAL |$typings| |$op|)) |