From 967f23ac31a0833c680ba4144c28e27bae8c7ee1 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Fri, 1 Jun 2012 09:09:23 +0000 Subject: * boot/ast.boot (%LoadUnit): Add field for enclosing function. Remove references to $op. --- src/boot/strap/ast.clisp | 31 ++++++++-------- src/boot/strap/parser.clisp | 79 +++++++++++++++++++++-------------------- src/boot/strap/translator.clisp | 3 +- 3 files changed, 59 insertions(+), 54 deletions(-) (limited to 'src/boot/strap') 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|) -- cgit v1.2.3