diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 5 | ||||
| -rw-r--r-- | src/boot/ast.boot | 21 | ||||
| -rw-r--r-- | src/boot/parser.boot | 9 | ||||
| -rw-r--r-- | src/boot/strap/ast.clisp | 31 | ||||
| -rw-r--r-- | src/boot/strap/parser.clisp | 79 | ||||
| -rw-r--r-- | src/boot/strap/translator.clisp | 3 | ||||
| -rw-r--r-- | src/boot/translator.boot | 1 |
7 files changed, 81 insertions, 68 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 1587853c..045700cd 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,5 +1,10 @@ 2012-06-01 Gabriel Dos Reis <gdr@cs.tamu.edu> + * boot/ast.boot (%LoadUnit): Add field for enclosing function. + Remove references to $op. + +2012-06-01 Gabriel Dos Reis <gdr@cs.tamu.edu> + * boot/ast.boot (%LoadUnit): Add fields for side conditions. * boot/parser.boot: Adjust. diff --git a/src/boot/ast.boot b/src/boot/ast.boot index 91a3d030..ff360d3a 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -120,7 +120,7 @@ structure %Ast == structure %LoadUnit == Record(fdefs: %List %Thing,sigs: %List %Thing,xports: %List %Identifier,_ csts: %List %Binding,varno: %Short,letno: %Short,isno: %Short,_ - sconds: %List %Thing) with + sconds: %List %Thing,op: %Identifier) with functionDefinitions == (.fdefs) -- functions defined in this TU globalSignatures == (.sigs) -- signatures proclaimed by this TU exportedNames == (.xports) -- names exported by this TU @@ -129,9 +129,10 @@ structure %LoadUnit == letVariableNumer == (.letno) -- let variable sequence number isVariableNumber == (.isno) -- is variable sequence number sideConditions == (.sconds) -- list of side declarations + enclosingFunction == (.op) -- name of current enclosing function makeLoadUnit() == - mk%LoadUnit(nil,nil,nil,nil,0,0,0,nil) + mk%LoadUnit(nil,nil,nil,nil,0,0,0,nil,nil) pushFunctionDefinition(tu,def) == functionDefinitions(tu) := [def,:functionDefinitions tu] @@ -601,7 +602,7 @@ bfSUBLIS1(p,e)== sameObject?(first f,e) => bfSUBLIS(p, rest f) bfSUBLIS1(rest p,e) -defSheepAndGoats(x)== +defSheepAndGoats(tu,x)== case x of %Definition(op,args,body) => argl := @@ -610,17 +611,17 @@ defSheepAndGoats(x)== argl = nil => opassoc := [[op,:body]] [opassoc,[],[]] - op1 := makeSymbol strconc(symbolName $op,'",",symbolName op) + op1 := makeSymbol strconc(symbolName enclosingFunction tu,'",",symbolName op) opassoc := [[op,:op1]] defstack := [[op1,args,body]] [opassoc,defstack,[]] - %Pile defs => defSheepAndGoatsList defs + %Pile defs => defSheepAndGoatsList(tu,defs) otherwise => [[],[],[x]] -defSheepAndGoatsList(x)== +defSheepAndGoatsList(tu,x)== x = nil => [[],[],[]] - [opassoc,defs,nondefs] := defSheepAndGoats first x - [opassoc1,defs1,nondefs1] := defSheepAndGoatsList rest x + [opassoc,defs,nondefs] := defSheepAndGoats(tu,first x) + [opassoc1,defs1,nondefs1] := defSheepAndGoatsList(tu,rest x) [[:opassoc,:opassoc1],[:defs,:defs1],[:nondefs,:nondefs1]] --% LET @@ -1166,7 +1167,7 @@ groupFluidVars(inits,vars,stmts) == ["LET*",inits,["DECLARE",["SPECIAL",:vars]],bfMKPROGN stmts] bfTagged(tu,a,b)== - $op = nil => %Signature(a,b) -- surely a toplevel decl + enclosingFunction tu = nil => %Signature(a,b) -- surely a toplevel decl symbol? a => b is "local" => bfLET(tu,compFluid a,nil) $typings := [["TYPE",b,a],:$typings] @@ -1263,7 +1264,7 @@ bfSequence l == ["COND",:transform,bfAlternative('T,bfSequence aft)] bfWhere(tu,context,expr)== - [opassoc,defs,nondefs] := defSheepAndGoats context + [opassoc,defs,nondefs] := defSheepAndGoats(tu,context) a:=[[first d,second d,bfSUBLIS(opassoc,third d)] for d in defs] sideConditions(tu) := [:a,:sideConditions tu] diff --git a/src/boot/parser.boot b/src/boot/parser.boot index d612a89e..2ef81452 100644 --- a/src/boot/parser.boot +++ b/src/boot/parser.boot @@ -987,7 +987,7 @@ bpDefinition ps == false bpStoreName ps == - $op := first parserTrees ps + enclosingFunction(parserLoadUnit ps) := first parserTrees ps sideConditions(parserLoadUnit ps) := nil $typings := nil true @@ -1318,15 +1318,18 @@ bpCaseItem ps == ++ Main entry point into the parser module. bpOutItem ps == - $op: local := nil + op := enclosingFunction parserLoadUnit ps varno := parserGensymSequenceNumber ps try + enclosingFunction(parserLoadUnit ps) := nil parserGensymSequenceNumber(ps) := 0 bpRequire(ps,function bpComma) catch(e: BootSpecificError) => bpSpecificErrorHere(ps,e) bpTrap ps - finally parserGensymSequenceNumber(ps) := varno + finally + parserGensymSequenceNumber(ps) := varno + enclosingFunction(parserLoadUnit ps) := op b := bpPop1 ps t := b is ["+LINE",:.] => [ b ] diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index ae24d89c..b977f958 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -152,13 +152,14 @@ |varno| |letno| |isno| - |sconds|) + |sconds| + |op|) (DEFMACRO |mk%LoadUnit| - (|fdefs| |sigs| |xports| |csts| |varno| |letno| |isno| |sconds|) + (|fdefs| |sigs| |xports| |csts| |varno| |letno| |isno| |sconds| |op|) (LIST '|MAKE-%LoadUnit| :|fdefs| |fdefs| :|sigs| |sigs| :|xports| |xports| :|csts| |csts| :|varno| |varno| :|letno| |letno| :|isno| |isno| - :|sconds| |sconds|)) + :|sconds| |sconds| :|op| |op|)) (DEFMACRO |functionDefinitions| (|bfVar#1|) (LIST '|%LoadUnit-fdefs| |bfVar#1|)) @@ -176,7 +177,9 @@ (DEFMACRO |sideConditions| (|bfVar#1|) (LIST '|%LoadUnit-sconds| |bfVar#1|)) -(DEFUN |makeLoadUnit| () (|mk%LoadUnit| NIL NIL NIL NIL 0 0 0 NIL)) +(DEFMACRO |enclosingFunction| (|bfVar#1|) (LIST '|%LoadUnit-op| |bfVar#1|)) + +(DEFUN |makeLoadUnit| () (|mk%LoadUnit| NIL NIL NIL NIL 0 0 0 NIL NIL)) (DEFUN |pushFunctionDefinition| (|tu| |def|) (SETF (|functionDefinitions| |tu|) (CONS |def| (|functionDefinitions| |tu|)))) @@ -839,9 +842,8 @@ (COND ((EQ (CAR |f|) |e|) (|bfSUBLIS| |p| (CDR |f|))) (T (|bfSUBLIS1| (CDR |p|) |e|))))))) -(DEFUN |defSheepAndGoats| (|x|) +(DEFUN |defSheepAndGoats| (|tu| |x|) (LET* (|defstack| |op1| |opassoc| |argl|) - (DECLARE (SPECIAL |$op|)) (CASE (CAR |x|) (|%Definition| (LET ((|op| (CADR |x|)) (|args| (CADDR |x|)) (|body| (CADDDR |x|))) @@ -854,23 +856,24 @@ (T (SETQ |op1| (INTERN - (CONCAT (SYMBOL-NAME |$op|) "," (SYMBOL-NAME |op|)))) + (CONCAT (SYMBOL-NAME (|enclosingFunction| |tu|)) "," + (SYMBOL-NAME |op|)))) (SETQ |opassoc| (LIST (CONS |op| |op1|))) (SETQ |defstack| (LIST (LIST |op1| |args| |body|))) (LIST |opassoc| |defstack| NIL)))))) (|%Pile| (LET ((|defs| (CADR |x|))) - (|defSheepAndGoatsList| |defs|))) + (|defSheepAndGoatsList| |tu| |defs|))) (T (LIST NIL NIL (LIST |x|)))))) -(DEFUN |defSheepAndGoatsList| (|x|) +(DEFUN |defSheepAndGoatsList| (|tu| |x|) (LET* (|nondefs1| |defs1| |opassoc1| |nondefs| |defs| |opassoc| |LETTMP#1|) (COND ((NULL |x|) (LIST NIL NIL NIL)) - (T (SETQ |LETTMP#1| (|defSheepAndGoats| (CAR |x|))) + (T (SETQ |LETTMP#1| (|defSheepAndGoats| |tu| (CAR |x|))) (SETQ |opassoc| (CAR |LETTMP#1|)) (SETQ |defs| (CADR . #1=(|LETTMP#1|))) (SETQ |nondefs| (CADDR . #1#)) - (SETQ |LETTMP#1| (|defSheepAndGoatsList| (CDR |x|))) + (SETQ |LETTMP#1| (|defSheepAndGoatsList| |tu| (CDR |x|))) (SETQ |opassoc1| (CAR |LETTMP#1|)) (SETQ |defs1| (CADR . #2=(|LETTMP#1|))) (SETQ |nondefs1| (CADDR . #2#)) @@ -2073,8 +2076,8 @@ (|bfMKPROGN| |stmts|)))))) (DEFUN |bfTagged| (|tu| |a| |b|) - (DECLARE (SPECIAL |$typings| |$op|)) - (COND ((NULL |$op|) (|%Signature| |a| |b|)) + (DECLARE (SPECIAL |$typings|)) + (COND ((NULL (|enclosingFunction| |tu|)) (|%Signature| |a| |b|)) ((SYMBOLP |a|) (COND ((EQ |b| '|local|) (|bfLET| |tu| (|compFluid| |a|) NIL)) (T (SETQ |$typings| (CONS (LIST 'TYPE |b| |a|) |$typings|)) @@ -2273,7 +2276,7 @@ (DEFUN |bfWhere| (|tu| |context| |expr|) (LET* (|a| |nondefs| |defs| |opassoc| |LETTMP#1|) (PROGN - (SETQ |LETTMP#1| (|defSheepAndGoats| |context|)) + (SETQ |LETTMP#1| (|defSheepAndGoats| |tu| |context|)) (SETQ |opassoc| (CAR |LETTMP#1|)) (SETQ |defs| (CADR . #1=(|LETTMP#1|))) (SETQ |nondefs| (CADDR . #1#)) diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp index 01a10a34..8bd130d9 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -1033,9 +1033,10 @@ (T (|bpRestore| |ps| |a|) NIL)))))) (DEFUN |bpStoreName| (|ps|) - (DECLARE (SPECIAL |$typings| |$op|)) + (DECLARE (SPECIAL |$typings|)) (PROGN - (SETQ |$op| (CAR (|parserTrees| |ps|))) + (SETF (|enclosingFunction| (|parserLoadUnit| |ps|)) + (CAR (|parserTrees| |ps|))) (SETF (|sideConditions| (|parserLoadUnit| |ps|)) NIL) (SETQ |$typings| NIL) T)) @@ -1376,42 +1377,44 @@ (|bpPush| |ps| (|bfCaseItem| (|bpPop2| |ps|) (|bpPop1| |ps|))))) (DEFUN |bpOutItem| (|ps|) - (LET* (|t| |r| |ISTMP#2| |l| |ISTMP#1| |b| |varno|) + (LET* (|t| |r| |ISTMP#2| |l| |ISTMP#1| |b| |varno| |op|) (DECLARE (SPECIAL |$InteractiveMode|)) - (LET ((|$op| NIL)) - (DECLARE (SPECIAL |$op|)) - (PROGN - (SETQ |varno| (|parserGensymSequenceNumber| |ps|)) - (UNWIND-PROTECT - (LET ((#1=#:G721 - (CATCH :OPEN-AXIOM-CATCH-POINT - (PROGN - (SETF (|parserGensymSequenceNumber| |ps|) 0) - (|bpRequire| |ps| #'|bpComma|))))) + (PROGN + (SETQ |op| (|enclosingFunction| (|parserLoadUnit| |ps|))) + (SETQ |varno| (|parserGensymSequenceNumber| |ps|)) + (UNWIND-PROTECT + (LET ((#1=#:G721 + (CATCH :OPEN-AXIOM-CATCH-POINT + (PROGN + (SETF (|enclosingFunction| (|parserLoadUnit| |ps|)) NIL) + (SETF (|parserGensymSequenceNumber| |ps|) 0) + (|bpRequire| |ps| #'|bpComma|))))) + (COND + ((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT)) (COND - ((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT)) - (COND - ((EQUAL (CAR #2=(CDR #1#)) '(|BootSpecificError|)) - (LET ((|e| (CDR #2#))) - (PROGN (|bpSpecificErrorHere| |ps| |e|) (|bpTrap| |ps|)))) - (T (THROW :OPEN-AXIOM-CATCH-POINT #1#)))) - (T #1#))) - (SETF (|parserGensymSequenceNumber| |ps|) |varno|)) - (SETQ |b| (|bpPop1| |ps|)) - (SETQ |t| - (COND ((AND (CONSP |b|) (EQ (CAR |b|) '+LINE)) (LIST |b|)) - ((AND (CONSP |b|) (EQ (CAR |b|) 'L%T) - (PROGN - (SETQ |ISTMP#1| (CDR |b|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |l| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |r| (CAR |ISTMP#2|)) T))))) - (SYMBOLP |l|)) - (COND (|$InteractiveMode| (LIST (LIST 'SETQ |l| |r|))) - (T (LIST (LIST 'DEFPARAMETER |l| |r|))))) - (T (|translateToplevel| |ps| |b| NIL)))) - (|bpPush| |ps| |t|))))) + ((EQUAL (CAR #2=(CDR #1#)) '(|BootSpecificError|)) + (LET ((|e| (CDR #2#))) + (PROGN (|bpSpecificErrorHere| |ps| |e|) (|bpTrap| |ps|)))) + (T (THROW :OPEN-AXIOM-CATCH-POINT #1#)))) + (T #1#))) + (PROGN + (SETF (|parserGensymSequenceNumber| |ps|) |varno|) + (SETF (|enclosingFunction| (|parserLoadUnit| |ps|)) |op|))) + (SETQ |b| (|bpPop1| |ps|)) + (SETQ |t| + (COND ((AND (CONSP |b|) (EQ (CAR |b|) '+LINE)) (LIST |b|)) + ((AND (CONSP |b|) (EQ (CAR |b|) 'L%T) + (PROGN + (SETQ |ISTMP#1| (CDR |b|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |l| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |r| (CAR |ISTMP#2|)) T))))) + (SYMBOLP |l|)) + (COND (|$InteractiveMode| (LIST (LIST 'SETQ |l| |r|))) + (T (LIST (LIST 'DEFPARAMETER |l| |r|))))) + (T (|translateToplevel| |ps| |b| NIL)))) + (|bpPush| |ps| |t|)))) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index afe93b70..a5d81629 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -433,10 +433,9 @@ (DEFUN |shoeOutParse| (|toks|) (LET* (|found| |ps|) - (DECLARE (SPECIAL |$returns| |$typings| |$op|)) + (DECLARE (SPECIAL |$returns| |$typings|)) (PROGN (SETQ |ps| (|makeParserState| |toks|)) - (SETQ |$op| NIL) (SETQ |$typings| NIL) (SETQ |$returns| NIL) (|bpFirstTok| |ps|) diff --git a/src/boot/translator.boot b/src/boot/translator.boot index 97d96616..377a721a 100644 --- a/src/boot/translator.boot +++ b/src/boot/translator.boot @@ -356,7 +356,6 @@ shoeAddComment l== shoeOutParse toks == ps := makeParserState toks - $op :=nil $typings := [] $returns := [] bpFirstTok ps |