aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/ChangeLog5
-rw-r--r--src/boot/ast.boot21
-rw-r--r--src/boot/parser.boot9
-rw-r--r--src/boot/strap/ast.clisp31
-rw-r--r--src/boot/strap/parser.clisp79
-rw-r--r--src/boot/strap/translator.clisp3
-rw-r--r--src/boot/translator.boot1
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-02 21:31:53 +0000