diff options
Diffstat (limited to 'src/boot')
| -rw-r--r-- | src/boot/includer.boot | 290 | ||||
| -rw-r--r-- | src/boot/parser.boot | 773 | ||||
| -rw-r--r-- | src/boot/pile.boot | 124 | ||||
| -rw-r--r-- | src/boot/scanner.boot | 668 | ||||
| -rw-r--r-- | src/boot/strap/includer.clisp | 5 | ||||
| -rw-r--r-- | src/boot/strap/scanner.clisp | 11 | ||||
| -rw-r--r-- | src/boot/translator.boot | 39 |
7 files changed, 891 insertions, 1019 deletions
diff --git a/src/boot/includer.boot b/src/boot/includer.boot index 554b6b36..b7ee1dd7 100644 --- a/src/boot/includer.boot +++ b/src/boot/includer.boot @@ -149,34 +149,28 @@ lineCharacter p == rest p shoePackageStartsAt (lines,sz,name,stream)== - bStreamNull stream => [[],['nullstream]] - a:=CAAR stream - if #a >= 8 and SUBSTRING(a,0,8)='")package" - then shoePackageStartsAt(cons(CAAR stream,lines),sz,name,rest stream) - else - if #a<sz - then shoePackageStartsAt(lines, sz,name,rest stream) - else if SUBSTRING(a,0,sz)=name and (#a>sz and not shoeIdChar(a.sz)) - then [lines,stream] - else shoePackageStartsAt(lines,sz,name,rest stream) + bStreamNull stream => [[],['nullstream]] + a := CAAR stream + #a >= 8 and SUBSTRING(a,0,8)='")package" => + shoePackageStartsAt(cons(CAAR stream,lines),sz,name,rest stream) + #a < sz => + shoePackageStartsAt(lines, sz,name,rest stream) + SUBSTRING(a,0,sz)=name and (#a>sz and not shoeIdChar(a.sz)) => + [lines,stream] + shoePackageStartsAt(lines,sz,name,rest stream) shoeFindLines(fn,name,a)== - if null a - then - shoeNotFound fn - [] - else - [lines,b]:=shoePackageStartsAt([],#name,name, shoeInclude - bAddLineNumber(bRgen a,bIgen 0)) - b:=shoeTransform2 b - if bStreamNull b - then - shoeConsole strconc (name,'" not found in ",fn) - [] - else - if null lines - then shoeConsole '")package not found" - append(reverse lines,first b) + null a => + shoeNotFound fn + [] + [lines,b]:=shoePackageStartsAt([],#name,name, shoeInclude + bAddLineNumber(bRgen a,bIgen 0)) + b:=shoeTransform2 b + bStreamNull b => + shoeConsole strconc (name,'" not found in ",fn) + [] + null lines => shoeConsole '")package not found" + append(reverse lines,first b) -- Lazy inclusion support. @@ -200,12 +194,12 @@ bMap1(:z)== else cons(FUNCALL(f,first x),bMap(f,rest x)) shoeFileMap(f, fn)== - a:=shoeInputFile fn - null a => - shoeConsole strconc(fn,'" NOT FOUND") - $bStreamNil - shoeConsole strconc('"READING ",fn) - shoeInclude bAddLineNumber(bMap(f,bRgen a),bIgen 0) + a:=shoeInputFile fn + null a => + shoeConsole strconc(fn,'" NOT FOUND") + $bStreamNil + shoeConsole strconc('"READING ",fn) + shoeInclude bAddLineNumber(bMap(f,bRgen a),bIgen 0) bDelay(f,x) == @@ -215,46 +209,42 @@ bAppend(x,y) == bDelay(function bAppend1,[x,y]) bAppend1(:z)== - if bStreamNull first z - then if bStreamNull second z - then ["nullstream"] - else second z - else cons(CAAR z,bAppend(CDAR z,second z)) + bStreamNull first z => + bStreamNull second z => ["nullstream"] + second z + cons(CAAR z,bAppend(CDAR z,second z)) bNext(f,s) == bDelay(function bNext1,[f,s]) bNext1(f,s)== - bStreamNull s=> ["nullstream"] - h:= apply(f, [s]) - bAppend(first h,bNext(f,rest h)) + bStreamNull s=> ["nullstream"] + h:= apply(f, [s]) + bAppend(first h,bNext(f,rest h)) bRgen s == bDelay(function bRgen1,[s]) bRgen1(:s) == - a:=shoeReadLine first s - if shoePLACEP a - then --- shoeCLOSE first s - ["nullstream"] - else cons(a,bRgen first s) + a := shoeReadLine first s + shoePLACEP a => ["nullstream"] + cons(a,bRgen first s) bIgen n == bDelay(function bIgen1,[n]) bIgen1(:n)== - n:=first n+1 - cons(n,bIgen n) + n:=first n+1 + cons(n,bIgen n) bAddLineNumber(f1,f2) == bDelay(function bAddLineNumber1,[f1,f2]) bAddLineNumber1(:f)== - [f1,f2] := f - bStreamNull f1 => ["nullstream"] - bStreamNull f2 => ["nullstream"] - cons(cons(first f1,first f2),bAddLineNumber(rest f1,rest f2)) + [f1,f2] := f + bStreamNull f1 => ["nullstream"] + bStreamNull f2 => ["nullstream"] + cons(cons(first f1,first f2),bAddLineNumber(rest f1,rest f2)) @@ -274,15 +264,16 @@ shoeLineFileInput fn== shoeFileMap(function shoePrefixLine,fn) shoePrefix?(prefix,whole) == - #prefix > #whole => false - good:=true - for i in 0..#prefix-1 for j in 0.. while good repeat - good:= prefix.i = whole.j - if good then SUBSTRING(whole,#prefix,nil) else good + #prefix > #whole => false + good:=true + for i in 0..#prefix-1 for j in 0.. while good repeat + good:= prefix.i = whole.j + good => SUBSTRING(whole,#prefix,nil) + good shoePlainLine?(s) == - #s = 0 => true - s.0 ~= char ")" + #s = 0 => true + s.0 ~= char ")" shoeSay? s == shoePrefix?('")say", s) shoeEval? s == shoePrefix?('")eval", s) @@ -300,123 +291,122 @@ shoeIncludeLines? s == shoePrefix?('")includelines",s) shoeIncludeFunction? s == shoePrefix?('")includefunction",s) shoeBiteOff x== - n:=STRPOSL('" ",x,0,true) - null n => false - n1:=STRPOSL ('" ",x,n,nil) - null n1 => [SUBSTRING(x,n,nil),'""] - [SUBSTRING(x,n,n1-n),SUBSTRING(x,n1,nil)] + n:=STRPOSL('" ",x,0,true) + null n => false + n1:=STRPOSL ('" ",x,n,nil) + null n1 => [SUBSTRING(x,n,nil),'""] + [SUBSTRING(x,n,n1-n),SUBSTRING(x,n1,nil)] shoeFileName x== - a:=shoeBiteOff x - null a => '"" - c:=shoeBiteOff second a - null c => first a - strconc(first a,'".",first c) + a:=shoeBiteOff x + null a => '"" + c:=shoeBiteOff second a + null c => first a + strconc(first a,'".",first c) shoeFnFileName x== - a:=shoeBiteOff x - null a => ['"",'""] - c:=shoeFileName second a - null c => [first a,'""] - [first a, c] + a:=shoeBiteOff x + null a => ['"",'""] + c:=shoeFileName second a + null c => [first a,'""] + [first a, c] shoeFunctionFileInput [fun,fn]== - shoeOpenInputFile (a,fn, - shoeInclude bAddLineNumber( shoeFindLines(fn,fun,a),bIgen 0)) + shoeOpenInputFile (a,fn, + shoeInclude bAddLineNumber( shoeFindLines(fn,fun,a),bIgen 0)) shoeInclude s == bDelay(function shoeInclude1,[s]) shoeInclude1 s== - bStreamNull s=> s - [h,:t] :=s - string :=first h - command :=shoeFin? string => $bStreamNil - command :=shoeIf? string => shoeThen([true],[STTOMC command],t) - bAppend(shoeSimpleLine h,shoeInclude t) + bStreamNull s=> s + [h,:t] :=s + string :=first h + command :=shoeFin? string => $bStreamNil + command :=shoeIf? string => shoeThen([true],[STTOMC command],t) + bAppend(shoeSimpleLine h,shoeInclude t) shoeSimpleLine(h) == - string :=first h - shoePlainLine? string=> [h] - command:=shoeLisp? string => [h] - command:=shoeIncludeLisp? string => - shoeLispFileInput shoeFileName command - command:=shoeIncludeFunction? string => - shoeFunctionFileInput shoeFnFileName command - command:=shoeLine? string => [h] - command:=shoeIncludeLines? string => - shoeLineFileInput shoeFileName command - command:=shoeInclude? string => shoeFileInput shoeFileName command - command:=shoePackage? string => [h] - command:=shoeSay? string => - shoeConsole command - nil - command:=shoeEval? string => - STTOMC command - nil - shoeLineSyntaxError(h) - nil + string :=first h + shoePlainLine? string=> [h] + command:=shoeLisp? string => [h] + command:=shoeIncludeLisp? string => + shoeLispFileInput shoeFileName command + command:=shoeIncludeFunction? string => + shoeFunctionFileInput shoeFnFileName command + command:=shoeLine? string => [h] + command:=shoeIncludeLines? string => + shoeLineFileInput shoeFileName command + command:=shoeInclude? string => shoeFileInput shoeFileName command + command:=shoePackage? string => [h] + command:=shoeSay? string => + shoeConsole command + nil + command:=shoeEval? string => + STTOMC command + nil + shoeLineSyntaxError(h) + nil shoeThen(keep,b,s) == bDelay(function shoeThen1,[keep,b,s]) shoeThen1(keep,b,s)== - bPremStreamNull s=> s - [h,:t] :=s - string :=first h - command :=shoeFin? string => bPremStreamNil(h) - keep1:= first keep - b1 := first b - command :=shoeIf? string => - keep1 and b1=> shoeThen(cons(true,keep),cons(STTOMC command,b),t) - shoeThen(cons(false,keep),cons(false,b),t) - command :=shoeElseIf? string=> - keep1 and not b1=> - shoeThen(cons(true,rest keep),cons(STTOMC command,rest b),t) - shoeThen(cons(false,rest keep),cons(false,rest b),t) - command :=shoeElse? string => - keep1 and not b1=>shoeElse(cons(true,rest keep),cons(true,rest b),t) - shoeElse(cons(false,rest keep),cons(false,rest b),t) - command :=shoeEndIf? string=> - null rest b=> shoeInclude t - shoeThen(rest keep,rest b,t) - keep1 and b1 => bAppend(shoeSimpleLine h,shoeThen(keep,b,t)) - shoeThen(keep,b,t) + bPremStreamNull s=> s + [h,:t] :=s + string :=first h + command :=shoeFin? string => bPremStreamNil(h) + keep1:= first keep + b1 := first b + command :=shoeIf? string => + keep1 and b1=> shoeThen(cons(true,keep),cons(STTOMC command,b),t) + shoeThen(cons(false,keep),cons(false,b),t) + command :=shoeElseIf? string=> + keep1 and not b1=> + shoeThen(cons(true,rest keep),cons(STTOMC command,rest b),t) + shoeThen(cons(false,rest keep),cons(false,rest b),t) + command :=shoeElse? string => + keep1 and not b1=>shoeElse(cons(true,rest keep),cons(true,rest b),t) + shoeElse(cons(false,rest keep),cons(false,rest b),t) + command :=shoeEndIf? string=> + null rest b=> shoeInclude t + shoeThen(rest keep,rest b,t) + keep1 and b1 => bAppend(shoeSimpleLine h,shoeThen(keep,b,t)) + shoeThen(keep,b,t) shoeElse(keep,b,s) == bDelay(function shoeElse1,[keep,b,s]) shoeElse1(keep,b,s)== - bPremStreamNull s=> s - [h,:t] :=s - string :=first h - command :=shoeFin? string => bPremStreamNil(h) - b1:=first b - keep1:=first keep - command :=shoeIf? string=> - keep1 and b1=> shoeThen(cons(true,keep),cons(STTOMC command,b),t) - shoeThen(cons(false,keep),cons(false,b),t) - command :=shoeEndIf? string => - null rest b=> shoeInclude t - shoeThen(rest keep,rest b,t) - keep1 and b1 => bAppend(shoeSimpleLine h,shoeElse(keep,b,t)) - shoeElse(keep,b,t) + bPremStreamNull s=> s + [h,:t] :=s + string :=first h + command :=shoeFin? string => bPremStreamNil(h) + b1:=first b + keep1:=first keep + command :=shoeIf? string=> + keep1 and b1=> shoeThen(cons(true,keep),cons(STTOMC command,b),t) + shoeThen(cons(false,keep),cons(false,b),t) + command :=shoeEndIf? string => + null rest b=> shoeInclude t + shoeThen(rest keep,rest b,t) + keep1 and b1 => bAppend(shoeSimpleLine h,shoeElse(keep,b,t)) + shoeElse(keep,b,t) shoeLineSyntaxError(h)== - shoeConsole strconc('"INCLUSION SYNTAX ERROR IN LINE ", - STRINGIMAGE rest h) - shoeConsole first h - shoeConsole '"LINE IGNORED" + shoeConsole strconc('"INCLUSION SYNTAX ERROR IN LINE ", + STRINGIMAGE rest h) + shoeConsole first h + shoeConsole '"LINE IGNORED" bPremStreamNil(h)== - shoeConsole strconc('"UNEXPECTED )fin IN LINE ",STRINGIMAGE rest h) - shoeConsole first h - shoeConsole '"REST OF FILE IGNORED" - $bStreamNil + shoeConsole strconc('"UNEXPECTED )fin IN LINE ",STRINGIMAGE rest h) + shoeConsole first h + shoeConsole '"REST OF FILE IGNORED" + $bStreamNil bPremStreamNull(s)== - if bStreamNull s - then - shoeConsole '"FILE TERMINATED BEFORE )endif" - true - else false + bStreamNull s => + shoeConsole '"FILE TERMINATED BEFORE )endif" + true + false diff --git a/src/boot/parser.boot b/src/boot/parser.boot index 68ec4ea0..fa74a739 100644 --- a/src/boot/parser.boot +++ b/src/boot/parser.boot @@ -47,190 +47,169 @@ module parser bpFirstToken()== - $stok:= - if null $inputStream - then shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok) - else first $inputStream - $ttok:=shoeTokPart $stok - true + $stok:= + null $inputStream => shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok) + first $inputStream + $ttok := shoeTokPart $stok + true bpFirstTok()== - $stok:= - if null $inputStream - then shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok) - else first $inputStream - $ttok:=shoeTokPart $stok - $bpParenCount>0 and $stok is ["KEY",:.] => - $ttok = "SETTAB" => - $bpCount:=$bpCount+1 - bpNext() - $ttok = "BACKTAB" => - $bpCount:=$bpCount-1 - bpNext() - $ttok = "BACKSET" => - bpNext() - true - true + $stok:= + null $inputStream => shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok) + first $inputStream + $ttok:=shoeTokPart $stok + $bpParenCount>0 and $stok is ["KEY",:.] => + $ttok = "SETTAB" => + $bpCount:=$bpCount+1 + bpNext() + $ttok = "BACKTAB" => + $bpCount:=$bpCount-1 + bpNext() + $ttok = "BACKSET" => + bpNext() + true + true bpNext() == - $inputStream := rest($inputStream) - bpFirstTok() + $inputStream := rest($inputStream) + bpFirstTok() bpNextToken() == - $inputStream := rest($inputStream) - bpFirstToken() + $inputStream := rest($inputStream) + bpFirstToken() bpState()== [$inputStream,$stack,$bpParenCount,$bpCount] --cons($inputStream,$stack) bpRestore(x)== - $inputStream:=first x - bpFirstToken() - $stack:=second x - $bpParenCount:=third x - $bpCount:=CADDDR x - true + $inputStream:=first x + bpFirstToken() + $stack:=second x + $bpParenCount:=third x + $bpCount:=CADDDR x + true bpPush x==$stack:=[x,:$stack] bpPushId()== - $stack:= [bfReName $ttok,:$stack] + $stack:= [bfReName $ttok,:$stack] bpPop1()== - a:=first $stack - $stack:=rest $stack - a + a:=first $stack + $stack:=rest $stack + a bpPop2()== - a:=second $stack - RPLACD($stack,CDDR $stack) - a + a:=second $stack + RPLACD($stack,CDDR $stack) + a bpPop3()== - a:=third $stack - RPLACD(rest $stack,CDDDR $stack) - a + a:=third $stack + RPLACD(rest $stack,CDDDR $stack) + a bpIndentParenthesized f== - $bpCount:local:=0 - a:=$stok - if bpEqPeek "OPAREN" - then - $bpParenCount:=$bpParenCount+1 - bpNext() - if apply(f,nil) and bpFirstTok() and - (bpEqPeek "CPAREN" or bpParenTrap(a)) - then - $bpParenCount:=$bpParenCount-1 - bpNextToken() - $bpCount=0 => true - $inputStream:=append( bpAddTokens $bpCount,$inputStream) - bpFirstToken() - $bpParenCount=0 => - bpCancel() - true - true - else if bpEqPeek "CPAREN" - then - bpPush bfTuple [] - $bpParenCount:=$bpParenCount-1 - bpNextToken() - true - else bpParenTrap(a) - else false + $bpCount:local:=0 + a:=$stok + bpEqPeek "OPAREN" => + $bpParenCount:=$bpParenCount+1 + bpNext() + apply(f,nil) and bpFirstTok() and + (bpEqPeek "CPAREN" or bpParenTrap(a)) => + $bpParenCount:=$bpParenCount-1 + bpNextToken() + $bpCount=0 => true + $inputStream:=append( bpAddTokens $bpCount,$inputStream) + bpFirstToken() + $bpParenCount=0 => + bpCancel() + true + true + bpEqPeek "CPAREN" => + bpPush bfTuple [] + $bpParenCount:=$bpParenCount-1 + bpNextToken() + true + bpParenTrap(a) + false bpParenthesized f== - a:=$stok - if bpEqKey "OPAREN" - then - if apply(f,nil) and (bpEqKey "CPAREN" or bpParenTrap(a)) - then true - else if bpEqKey "CPAREN" - then - bpPush bfTuple [] - true - else bpParenTrap(a) - else false + a := $stok + bpEqKey "OPAREN" => + apply(f,nil) and (bpEqKey "CPAREN" or bpParenTrap(a)) => true + bpEqKey "CPAREN" => + bpPush bfTuple [] + true + bpParenTrap(a) + false bpBracket f== - a:=$stok - if bpEqKey "OBRACK" - then - if apply(f,nil) and (bpEqKey "CBRACK" or bpBrackTrap(a)) - then bpPush bfBracket bpPop1 () - else if bpEqKey "CBRACK" - then bpPush [] - else bpBrackTrap(a) - else false + a := $stok + bpEqKey "OBRACK" => + apply(f,nil) and (bpEqKey "CBRACK" or bpBrackTrap(a)) => + bpPush bfBracket bpPop1() + bpEqKey "CBRACK" => bpPush [] + bpBrackTrap(a) + false bpPileBracketed f== - if bpEqKey "SETTAB" - then if bpEqKey "BACKTAB" - then true - else if apply(f,nil) and - (bpEqKey "BACKTAB" or bpPileTrap()) - then bpPush bfPile bpPop1() - else false - else false + bpEqKey "SETTAB" => + bpEqKey "BACKTAB" => true + apply(f,nil) and (bpEqKey "BACKTAB" or bpPileTrap()) => + bpPush bfPile bpPop1() + false + false bpListof(f,str1,g)== - if apply(f,nil) - then - if bpEqKey str1 and (apply(f,nil) or bpTrap()) - then - a:=$stack - $stack:=nil - while bpEqKey str1 and (apply(f,nil) or bpTrap()) repeat 0 - $stack:=[NREVERSE $stack,:a] - bpPush FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()]) - else - true - else false + apply(f,nil) => + bpEqKey str1 and (apply(f,nil) or bpTrap()) => + a:=$stack + $stack:=nil + while bpEqKey str1 and (apply(f,nil) or bpTrap()) repeat 0 + $stack:=[NREVERSE $stack,:a] + bpPush FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()]) + true + false -- to do ,<backset> bpListofFun(f,h,g)== - if apply(f,nil) - then - if apply(h,nil) and (apply(f,nil) or bpTrap()) - then - a:=$stack - $stack:=nil - while apply(h,nil) and (apply(f,nil) or bpTrap()) repeat 0 - $stack:=[NREVERSE $stack,:a] - bpPush FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()]) - else - true - else false + apply(f,nil) => + apply(h,nil) and (apply(f,nil) or bpTrap()) => + a:=$stack + $stack:=nil + while apply(h,nil) and (apply(f,nil) or bpTrap()) repeat 0 + $stack:=[NREVERSE $stack,:a] + bpPush FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()]) + true + false bpList(f,str1)== - if apply(f,nil) - then - if bpEqKey str1 and (apply(f,nil) or bpTrap()) - then - a:=$stack - $stack:=nil - while bpEqKey str1 and (apply(f,nil) or bpTrap()) repeat 0 - $stack:=[NREVERSE $stack,:a] - bpPush [bpPop3(),bpPop2(),:bpPop1()] - else - bpPush [bpPop1()] - else bpPush nil + apply(f,nil) => + bpEqKey str1 and (apply(f,nil) or bpTrap()) => + a:=$stack + $stack:=nil + while bpEqKey str1 and (apply(f,nil) or bpTrap()) repeat 0 + $stack:=[NREVERSE $stack,:a] + bpPush [bpPop3(),bpPop2(),:bpPop1()] + bpPush [bpPop1()] + bpPush nil bpOneOrMore f== - apply(f,nil)=> - a:=$stack - $stack:=nil - while apply(f,nil) repeat 0 - $stack:=[NREVERSE $stack,:a] - bpPush [bpPop2(),:bpPop1()] - false + apply(f,nil)=> + a:=$stack + $stack:=nil + while apply(f,nil) repeat 0 + $stack:=[NREVERSE $stack,:a] + bpPush [bpPop2(),:bpPop1()] + false -- s must transform the head of the stack bpAnyNo s== - while apply(s,nil) repeat 0 - true + while apply(s,nil) repeat 0 + true -- AndOr(k,p,f)= k p @@ -239,31 +218,26 @@ bpAndOr(keyword,p,f)== and bpPush FUNCALL(f, bpPop1()) bpConditional f== - if bpEqKey "IF" and (bpWhere() or bpTrap()) and - (bpEqKey "BACKSET" or true) - then - if bpEqKey "SETTAB" - then if bpEqKey "THEN" - then (apply(f,nil) or bpTrap()) and bpElse(f) and bpEqKey "BACKTAB" - else bpMissing "THEN" - else if bpEqKey "THEN" - then (apply(f,nil) or bpTrap()) and bpElse(f) - else bpMissing "then" - else false + bpEqKey "IF" and (bpWhere() or bpTrap()) and (bpEqKey "BACKSET" or true) => + bpEqKey "SETTAB" => + bpEqKey "THEN" => + (apply(f,nil) or bpTrap()) and bpElse(f) and bpEqKey "BACKTAB" + bpMissing "THEN" + bpEqKey "THEN" => (apply(f,nil) or bpTrap()) and bpElse(f) + bpMissing "then" + false bpElse(f)== - a:=bpState() - if bpBacksetElse() - then (apply(f,nil) or bpTrap()) and - bpPush bfIf(bpPop3(),bpPop2(),bpPop1()) - else - bpRestore a - bpPush bfIfThenOnly(bpPop2(),bpPop1()) + a:=bpState() + bpBacksetElse() => + (apply(f,nil) or bpTrap()) and + bpPush bfIf(bpPop3(),bpPop2(),bpPop1()) + bpRestore a + bpPush bfIfThenOnly(bpPop2(),bpPop1()) bpBacksetElse()== - if bpEqKey "BACKSET" - then bpEqKey "ELSE" - else bpEqKey "ELSE" + bpEqKey "BACKSET" => bpEqKey "ELSE" + bpEqKey "ELSE" bpEqPeek s == $stok is ["KEY",:.] and EQ(s,$ttok) @@ -301,66 +275,65 @@ bpRecoverTrap()== bpPush [['"pile syntax error"]] bpListAndRecover(f)== - a:=$stack - b:=nil - $stack:=nil - done:=false - c:=$inputStream - while not done repeat --- $trapped:local:=false - found:=try apply(f,nil) catch TRAPPOINT - if found="TRAPPED" - then - $inputStream:=c - bpRecoverTrap() - else if not found - then - $inputStream:=c - bpGeneralErrorHere() - bpRecoverTrap() - if bpEqKey "BACKSET" - then - c:=$inputStream - else if bpEqPeek "BACKTAB" or null $inputStream - then - done:=true - else - $inputStream:=c - bpGeneralErrorHere() - bpRecoverTrap() - if bpEqPeek "BACKTAB" or null $inputStream - then done:=true - else - bpNext() - c:=$inputStream - b:=[bpPop1(),:b] - $stack:=a - bpPush NREVERSE b + a := $stack + b := nil + $stack := nil + done := false + c := $inputStream + while not done repeat + found := try apply(f,nil) catch TRAPPOINT + if found = "TRAPPED" + then + $inputStream:=c + bpRecoverTrap() + else if not found + then + $inputStream:=c + bpGeneralErrorHere() + bpRecoverTrap() + if bpEqKey "BACKSET" + then + c := $inputStream + else if bpEqPeek "BACKTAB" or null $inputStream + then + done := true + else + $inputStream := c + bpGeneralErrorHere() + bpRecoverTrap() + if bpEqPeek "BACKTAB" or null $inputStream + then done:=true + else + bpNext() + c := $inputStream + b := [bpPop1(),:b] + $stack := a + bpPush NREVERSE b bpMoveTo n== - null $inputStream => true - bpEqPeek "BACKTAB" => - n=0 => true - bpNextToken() - $bpCount:=$bpCount-1 - bpMoveTo(n-1) - bpEqPeek "BACKSET" => - n=0 => true - bpNextToken() - bpMoveTo n - bpEqPeek "SETTAB" => - bpNextToken() - bpMoveTo(n+1) - bpEqPeek "OPAREN" => - bpNextToken() - $bpParenCount:=$bpParenCount+1 - bpMoveTo n - bpEqPeek "CPAREN" => - bpNextToken() - $bpParenCount:=$bpParenCount-1 - bpMoveTo n + null $inputStream => true + bpEqPeek "BACKTAB" => + n=0 => true + bpNextToken() + $bpCount:=$bpCount-1 + bpMoveTo(n-1) + bpEqPeek "BACKSET" => + n=0 => true bpNextToken() bpMoveTo n + bpEqPeek "SETTAB" => + bpNextToken() + bpMoveTo(n+1) + bpEqPeek "OPAREN" => + bpNextToken() + $bpParenCount:=$bpParenCount+1 + bpMoveTo n + bpEqPeek "CPAREN" => + bpNextToken() + $bpParenCount:=$bpParenCount-1 + bpMoveTo n + bpNextToken() + bpMoveTo n -- A fully qualified name could be interpreted as a left reduction -- of an '::' infix operator. At the moment, we don't use @@ -523,25 +496,21 @@ bpMapping() == or bpSimpleMapping() bpCancel()== - a:=bpState() - if bpEqKeyNextTok "SETTAB" - then if bpCancel() - then if bpEqKeyNextTok "BACKTAB" - then true - else - bpRestore a - false - else - if bpEqKeyNextTok "BACKTAB" - then true - else - bpRestore a - false - else false + a := bpState() + bpEqKeyNextTok "SETTAB" => + bpCancel() => + bpEqKeyNextTok "BACKTAB" => true + bpRestore a + false + bpEqKeyNextTok "BACKTAB" => true + bpRestore a + false + false + bpAddTokens n== - n=0 => nil - n>0=> cons(shoeTokConstruct("KEY","SETTAB",shoeTokPosn $stok),bpAddTokens(n-1)) - cons(shoeTokConstruct("KEY","BACKTAB",shoeTokPosn $stok),bpAddTokens(n+1)) + n=0 => nil + n>0=> cons(shoeTokConstruct("KEY","SETTAB",shoeTokPosn $stok),bpAddTokens(n-1)) + cons(shoeTokConstruct("KEY","BACKTAB",shoeTokPosn $stok),bpAddTokens(n+1)) bpExceptions()== bpEqPeek "DOT" or bpEqPeek "QUOTE" or @@ -599,11 +568,12 @@ bpInfixOperator()== GET($ttok,"SHOEINF") and bpPushId() and bpNext() bpSelector()== - bpEqKey "DOT" and (bpPrimary() - and bpPush(bfElt(bpPop2(),bpPop1())) - or bpPush bfSuffixDot bpPop1() ) + bpEqKey "DOT" and (bpPrimary() + and bpPush(bfElt(bpPop2(),bpPop1())) + or bpPush bfSuffixDot bpPop1() ) -bpOperator()== bpPrimary() and bpAnyNo function bpSelector +bpOperator() == + bpPrimary() and bpAnyNo function bpSelector bpApplication()== bpPrimary() and bpAnyNo function bpSelector and @@ -631,81 +601,76 @@ bpInfKey s== $stok is ["KEY",:.] and MEMBER($ttok,s) and bpPushId() and bpNext() -bpInfGeneric s== bpInfKey s and (bpEqKey "BACKSET" or true) +bpInfGeneric s== + bpInfKey s and (bpEqKey "BACKSET" or true) bpRightAssoc(o,p)== - a:=bpState() - if apply(p,nil) - then - while bpInfGeneric o and (bpRightAssoc(o,p) or bpTrap()) repeat - bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) - true - else - bpRestore a - false + a := bpState() + apply(p,nil) => + while bpInfGeneric o and (bpRightAssoc(o,p) or bpTrap()) repeat + bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) + true + bpRestore a + false bpLeftAssoc(operations,parser)== - if apply(parser,nil) - then - while bpInfGeneric(operations) and - (apply(parser,nil) or bpTrap()) - repeat - bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) - true - else false + apply(parser,nil) => + while bpInfGeneric(operations) and (apply(parser,nil) or bpTrap()) + repeat + bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) + true + false bpString()== - shoeTokType $stok = "STRING" and - bpPush(["QUOTE",INTERN $ttok]) and bpNext() + shoeTokType $stok = "STRING" and + bpPush(["QUOTE",INTERN $ttok]) and bpNext() bpThetaName() == - if $stok is ["ID",:.] and GET($ttok,"SHOETHETA") - then - bpPushId() - bpNext() - else false + $stok is ["ID",:.] and GET($ttok,"SHOETHETA") => + bpPushId() + bpNext() + false bpReduceOperator()== - bpInfixOperator() or bpString() - or bpThetaName() + bpInfixOperator() or bpString() or bpThetaName() bpReduce()== - a:=bpState() - if bpReduceOperator() and bpEqKey "SLASH" - then - bpEqPeek "OBRACK" => (bpDConstruct() or bpTrap()) and - bpPush bfReduceCollect(bpPop2(),bpPop1()) - (bpApplication() or bpTrap()) and - bpPush bfReduce(bpPop2(),bpPop1()) - else - bpRestore a - false + a := bpState() + bpReduceOperator() and bpEqKey "SLASH" => + bpEqPeek "OBRACK" => + (bpDConstruct() or bpTrap()) and + bpPush bfReduceCollect(bpPop2(),bpPop1()) + (bpApplication() or bpTrap()) and + bpPush bfReduce(bpPop2(),bpPop1()) + bpRestore a + false bpTimes()== bpReduce() or bpLeftAssoc('(TIMES SLASH),function bpExpt) bpMinus()== - bpInfGeneric '(MINUS) and (bpTimes() or bpTrap()) - and bpPush(bfApplication(bpPop2(),bpPop1())) - or bpTimes() + bpInfGeneric '(MINUS) and (bpTimes() or bpTrap()) + and bpPush(bfApplication(bpPop2(),bpPop1())) + or bpTimes() bpArith()==bpLeftAssoc('(PLUS MINUS),function bpMinus) bpIs()== - bpArith() and (bpInfKey '(IS ISNT) and (bpPattern() or bpTrap()) - and bpPush bfISApplication(bpPop2(),bpPop2(),bpPop1()) - or true) + bpArith() and (bpInfKey '(IS ISNT) and (bpPattern() or bpTrap()) + and bpPush bfISApplication(bpPop2(),bpPop2(),bpPop1()) + or true) bpBracketConstruct(f)== - bpBracket f and bpPush bfConstruct bpPop1 () + bpBracket f and bpPush bfConstruct bpPop1() bpCompare()== - bpIs() and (bpInfKey '(SHOEEQ SHOENE LT LE GT GE IN) - and (bpIs() or bpTrap()) - and bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) - or true) + bpIs() and (bpInfKey '(SHOEEQ SHOENE LT LE GT GE IN) + and (bpIs() or bpTrap()) + and bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) + or true) -bpAnd()== bpLeftAssoc('(AND),function bpCompare) +bpAnd() == + bpLeftAssoc('(AND),function bpCompare) bpThrow() == bpEqKey "THROW" and bpApplication() and @@ -806,27 +771,25 @@ bpSeg()== bpIterator()== bpForIn() or bpSuchThat() or bpWhile() or bpUntil() -bpIteratorList()==bpOneOrMore function bpIterator - and bpPush bfIterators bpPop1 () +bpIteratorList()== + bpOneOrMore function bpIterator + and bpPush bfIterators bpPop1 () bpCrossBackSet()== bpEqKey "CROSS" and (bpEqKey "BACKSET" or true) bpIterators()== - bpListofFun(function bpIteratorList, - function bpCrossBackSet,function bfCross) + bpListofFun(function bpIteratorList, + function bpCrossBackSet,function bfCross) bpAssign()== - a:=bpState() - if bpStatement() - then - if bpEqPeek "BEC" - then - bpRestore a - bpAssignment() or bpTrap() - else true - else - bpRestore a - false + a := bpState() + bpStatement() => + bpEqPeek "BEC" => + bpRestore a + bpAssignment() or bpTrap() + true + bpRestore a + false bpAssignment()== bpAssignVariable() and @@ -836,26 +799,26 @@ bpAssignment()== -- should only be allowed in sequences bpExit()== - bpAssign() and (bpEqKey "EXIT" and - ((bpWhere() or bpTrap()) and - bpPush bfExit (bpPop2(),bpPop1())) - or true) + bpAssign() and (bpEqKey "EXIT" and + ((bpWhere() or bpTrap()) and + bpPush bfExit (bpPop2(),bpPop1())) + or true) bpDefinition()== - a:=bpState() - bpExit() => - bpEqPeek "DEF" => - bpRestore a - bpDef() - bpEqPeek "TDEF" => - bpRestore a - bpTypeAliasDefition() - bpEqPeek "MDEF" => - bpRestore a - bpMdef() - true - bpRestore a - false + a:=bpState() + bpExit() => + bpEqPeek "DEF" => + bpRestore a + bpDef() + bpEqPeek "TDEF" => + bpRestore a + bpTypeAliasDefition() + bpEqPeek "MDEF" => + bpRestore a + bpMdef() + true + bpRestore a + false bpStoreName()== $op := first $stack @@ -906,73 +869,75 @@ bpWhere()== and bpPush bfWhere(bpPop1(),bpPop1()) or true) bpDefinitionItem()== - a:=bpState() - if bpDDef() - then true - else - bpRestore a - if bpBDefinitionPileItems() - then true - else - bpRestore a - if bpPDefinitionItems() - then true - else - bpRestore a - bpWhere() + a := bpState() + bpDDef() => true + bpRestore a + bpBDefinitionPileItems() => true + bpRestore a + bpPDefinitionItems() => true + bpRestore a + bpWhere() bpDefinitionPileItems()== - bpListAndRecover function bpDefinitionItem - and bpPush %Pile bpPop1() + bpListAndRecover function bpDefinitionItem + and bpPush %Pile bpPop1() bpBDefinitionPileItems()== bpPileBracketed function bpDefinitionPileItems bpSemiColonDefinition()==bpSemiListing - (function bpDefinitionItem,function %Pile) + (function bpDefinitionItem,function %Pile) -bpPDefinitionItems()==bpParenthesized function bpSemiColonDefinition +bpPDefinitionItems()== + bpParenthesized function bpSemiColonDefinition bpComma()== bpModule() or bpImport() or bpNamespace() or bpTuple function bpWhere -bpTuple(p)==bpListofFun(p,function bpCommaBackSet,function bfTuple) +bpTuple(p) == + bpListofFun(p,function bpCommaBackSet,function bfTuple) -bpCommaBackSet()== bpEqKey "COMMA" and (bpEqKey "BACKSET" or true) +bpCommaBackSet() == + bpEqKey "COMMA" and (bpEqKey "BACKSET" or true) -bpSemiColon()==bpSemiListing (function bpComma,function bfSequence) +bpSemiColon() == + bpSemiListing (function bpComma,function bfSequence) -bpSemiListing(p,f)==bpListofFun(p,function bpSemiBackSet,f) +bpSemiListing(p,f) == + bpListofFun(p,function bpSemiBackSet,f) -bpSemiBackSet()== bpEqKey "SEMICOLON" and (bpEqKey "BACKSET" or true) +bpSemiBackSet()== + bpEqKey "SEMICOLON" and (bpEqKey "BACKSET" or true) -bpPDefinition()== bpIndentParenthesized function bpSemiColon +bpPDefinition()== + bpIndentParenthesized function bpSemiColon bpPileItems()== - bpListAndRecover function bpSemiColon and bpPush bfSequence bpPop1() + bpListAndRecover function bpSemiColon and bpPush bfSequence bpPop1() -bpBPileDefinition()== bpPileBracketed function bpPileItems +bpBPileDefinition()== + bpPileBracketed function bpPileItems bpIteratorTail()== - (bpEqKey "REPEAT" or true) and bpIterators() - ---bpExpression()== bpLogical() + (bpEqKey "REPEAT" or true) and bpIterators() -bpConstruct()==bpBracket function bpConstruction +bpConstruct()== + bpBracket function bpConstruction bpConstruction()== - bpComma() and - (bpIteratorTail() and - bpPush bfCollect (bpPop2(),bpPop1()) or - bpPush bfTupleConstruct bpPop1()) + bpComma() and + (bpIteratorTail() and + bpPush bfCollect (bpPop2(),bpPop1()) or + bpPush bfTupleConstruct bpPop1()) -bpDConstruct()==bpBracket function bpDConstruction +bpDConstruct()== + bpBracket function bpDConstruction bpDConstruction()== - bpComma() and - (bpIteratorTail() and - bpPush bfDCollect (bpPop2(),bpPop1()) or - bpPush bfDTuple bpPop1()) + bpComma() and + (bpIteratorTail() and + bpPush bfDCollect (bpPop2(),bpPop1()) or + bpPush bfDTuple bpPop1()) @@ -980,8 +945,9 @@ bpDConstruction()== --bpNameOrDot() == bpName() or bpDot() or bpEqual() -bpPattern()== bpBracketConstruct function bpPatternL - or bpName() or bpConstTok() +bpPattern()== + bpBracketConstruct function bpPatternL + or bpName() or bpConstTok() bpEqual()== bpEqKey "SHOEEQ" and (bpApplication() or bpConstTok() or @@ -1010,20 +976,19 @@ bpPatternColon()== bpPatternL() == bpPatternList() and bpPush bfTuple bpPop1() bpPatternList()== - if bpRegularPatternItemL() - then - while (bpEqKey "COMMA" and (bpRegularPatternItemL() or - (bpPatternTail() - and bpPush append(bpPop2(),bpPop1()) - or bpTrap();false) )) repeat - bpPush append(bpPop2(),bpPop1()) - true - else bpPatternTail() + bpRegularPatternItemL() => + while (bpEqKey "COMMA" and (bpRegularPatternItemL() or + (bpPatternTail() + and bpPush append(bpPop2(),bpPop1()) + or bpTrap();false) )) repeat + bpPush append(bpPop2(),bpPop1()) + true + bpPatternTail() bpPatternTail()== - bpPatternColon() and - (bpEqKey "COMMA" and (bpRegularList() or bpTrap()) - and bpPush append (bpPop2(),bpPop1()) or true) + bpPatternColon() and + (bpEqKey "COMMA" and (bpRegularList() or bpTrap()) + and bpPush append (bpPop2(),bpPop1()) or true) -- BOUND VARIABLE @@ -1050,27 +1015,26 @@ bpRegularBVItem() == or bpBracketConstruct function bpPatternL bpBVString()== - shoeTokType $stok = "STRING" and - bpPush(["BVQUOTE",INTERN $ttok]) and bpNext() + shoeTokType $stok = "STRING" and + bpPush(["BVQUOTE",INTERN $ttok]) and bpNext() bpRegularBVItemL() == - bpRegularBVItem() and bpPush [bpPop1()] + bpRegularBVItem() and bpPush [bpPop1()] bpColonName()== - bpEqKey "COLON" and (bpName() or bpBVString() or bpTrap()) + bpEqKey "COLON" and (bpName() or bpBVString() or bpTrap()) -- at most one colon at end bpBoundVariablelist()== - if bpRegularBVItemL() - then - while (bpEqKey "COMMA" and (bpRegularBVItemL() or - (bpColonName() - and bpPush bfColonAppend(bpPop2(),bpPop1()) - or bpTrap();false) )) repeat - bpPush append(bpPop2(),bpPop1()) - true - else bpColonName() and bpPush bfColonAppend(nil,bpPop1()) + bpRegularBVItemL() => + while (bpEqKey "COMMA" and (bpRegularBVItemL() or + (bpColonName() + and bpPush bfColonAppend(bpPop2(),bpPop1()) + or bpTrap();false) )) repeat + bpPush append(bpPop2(),bpPop1()) + true + bpColonName() and bpPush bfColonAppend(nil,bpPop1()) bpVariable()== @@ -1090,10 +1054,9 @@ bpAssignLHS()== bpPush bfTuple([bpPop2(),:bpPop1()]) or true) bpChecknull()== - a:=bpPop1() - if null a - then bpTrap() - else bpPush a + a := bpPop1() + null a => bpTrap() + bpPush a bpStruct()== bpEqKey "STRUCTURE" and @@ -1101,8 +1064,9 @@ bpStruct()== (bpEqKey "DEF" or bpTrap()) and bpTypeList() and bpPush %Structure(bpPop2(),bpPop1()) -bpTypeList() == bpPileBracketed function bpTypeItemList - or bpTerm function bpIdList and bpPush [bpPop1()] +bpTypeList() == + bpPileBracketed function bpTypeItemList + or bpTerm function bpIdList and bpPush [bpPop1()] bpTypeItem() == bpTerm function bpIdList @@ -1111,19 +1075,20 @@ bpTypeItemList() == bpListAndRecover function bpTypeItem bpTerm idListParser == - (bpName() or bpTrap()) and - ((bpParenthesized idListParser and - bpPush bfNameArgs (bpPop2(),bpPop1())) - or bpName() and bpPush bfNameArgs(bpPop2(),bpPop1())) - or bpPush(bfNameOnly bpPop1()) + (bpName() or bpTrap()) and + ((bpParenthesized idListParser and + bpPush bfNameArgs (bpPop2(),bpPop1())) + or bpName() and bpPush bfNameArgs(bpPop2(),bpPop1())) + or bpPush(bfNameOnly bpPop1()) -bpIdList()== bpTuple function bpName +bpIdList()== + bpTuple function bpName bpCase()== - bpEqKey "CASE" and - (bpWhere() or bpTrap()) and - (bpEqKey "OF" or bpMissing "OF") and - bpPiledCaseItems() + bpEqKey "CASE" and + (bpWhere() or bpTrap()) and + (bpEqKey "OF" or bpMissing "OF") and + bpPiledCaseItems() bpPiledCaseItems()== bpPileBracketed function bpCaseItemList and diff --git a/src/boot/pile.boot b/src/boot/pile.boot index f9c667ee..52bebdea 100644 --- a/src/boot/pile.boot +++ b/src/boot/pile.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -49,57 +49,44 @@ shoePileColumn t== -- s is a token-dq-stream shoePileInsert (s)== - if bStreamNull s - then cons([],s) - else - toktype:=shoeTokType CAAAR s - if toktype ="LISP" or toktype = "LINE" - then cons([first s],rest s) - else - a:=shoePileTree(-1,s) - cons([a.2],a.3) + bStreamNull s => cons([],s) + toktype := shoeTokType CAAAR s + toktype = "LISP" or toktype = "LINE" => cons([first s],rest s) + a:=shoePileTree(-1,s) + cons([a.2],a.3) shoePileTree(n,s)== - if bStreamNull s - then [false,n,[],s] - else - [h,t]:=[first s,rest s] - hh:=shoePileColumn h - if hh > n - then shoePileForests(h,hh,t) - else [false,n,[],s] + bStreamNull s => [false,n,[],s] + [h,t] := [first s,rest s] + hh := shoePileColumn h + hh > n => shoePileForests(h,hh,t) + [false,n,[],s] eqshoePileTree(n,s)== - if bStreamNull s - then [false,n,[],s] - else - [h,t]:=[first s,rest s] - hh:=shoePileColumn h - if hh = n - then shoePileForests(h,hh,t) - else [false,n,[],s] + bStreamNull s => [false,n,[],s] + [h,t] := [first s,rest s] + hh := shoePileColumn h + hh = n => shoePileForests(h,hh,t) + [false,n,[],s] shoePileForest(n,s)== - [b,hh,h,t]:= shoePileTree(n,s) - if b - then - [h1,t1]:=shoePileForest1(hh,t) - [cons(h,h1),t1] - else [[],s] + [b,hh,h,t] := shoePileTree(n,s) + b => + [h1,t1]:=shoePileForest1(hh,t) + [cons(h,h1),t1] + [[],s] shoePileForest1(n,s)== - [b,n1,h,t]:= eqshoePileTree(n,s) - if b - then - [h1,t1]:=shoePileForest1(n,t) - [cons(h,h1),t1] - else [[],s] + [b,n1,h,t] := eqshoePileTree(n,s) + b => + [h1,t1]:=shoePileForest1(n,t) + [cons(h,h1),t1] + [[],s] shoePileForests(h,n,s)== - [h1,t1]:=shoePileForest(n,s) - if bStreamNull h1 - then [true,n,h,s] - else shoePileForests(shoePileCtree(h,h1),n,t1) + [h1,t1] := shoePileForest(n,s) + bStreamNull h1 => [true,n,h,s] + shoePileForests(shoePileCtree(h,h1),n,t1) shoePileCtree(x,y) == dqAppend(x,shoePileCforest y) @@ -107,42 +94,31 @@ shoePileCtree(x,y) == -- only enshoePiles forests with >=2 trees shoePileCforest x== - if null x - then [] - else if null rest x - then first x - else - a:=first x - b:=shoePileCoagulate(a,rest x) - if null rest b - then first b - else shoeEnPile shoeSeparatePiles b + null x => [] + null rest x => first x + a := first x + b := shoePileCoagulate(a,rest x) + null rest b => first b + shoeEnPile shoeSeparatePiles b shoePileCoagulate(a,b)== - if null b - then [a] - else - c:=first b - if shoeTokPart CAAR c = "THEN" or shoeTokPart CAAR c = "ELSE" - then shoePileCoagulate (dqAppend(a,c),rest b) - else - d:=second a - e:=shoeTokPart d - if d is ["KEY",:.] and - (GET(e,"SHOEINF") or e = "COMMA" or e = "SEMICOLON") - then shoePileCoagulate(dqAppend(a,c),rest b) - else cons(a,shoePileCoagulate(c,rest b)) + null b => [a] + c := first b + shoeTokPart CAAR c = "THEN" or shoeTokPart CAAR c = "ELSE" => + shoePileCoagulate (dqAppend(a,c),rest b) + d := second a + e := shoeTokPart d + d is ["KEY",:.] and + (GET(e,"SHOEINF") or e = "COMMA" or e = "SEMICOLON") => + shoePileCoagulate(dqAppend(a,c),rest b) + cons(a,shoePileCoagulate(c,rest b)) shoeSeparatePiles x== - if null x - then [] - else if null rest x - then first x - else - a:=first x - semicolon:=dqUnit - shoeTokConstruct("KEY", "BACKSET",shoeLastTokPosn a) - dqConcat [a,semicolon,shoeSeparatePiles rest x] + null x => [] + null rest x => first x + a := first x + semicolon := dqUnit shoeTokConstruct("KEY", "BACKSET",shoeLastTokPosn a) + dqConcat [a,semicolon,shoeSeparatePiles rest x] shoeEnPile x== dqConcat [dqUnit shoeTokConstruct("KEY","SETTAB",shoeFirstTokPosn x), diff --git a/src/boot/scanner.boot b/src/boot/scanner.boot index aed1df0e..1c731116 100644 --- a/src/boot/scanner.boot +++ b/src/boot/scanner.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -47,24 +47,20 @@ dqUnit s== [a,:a] dqAppend(x,y)== - if null x - then y - else if null y - then x - else - RPLACD (rest x,first y) - RPLACD (x, rest y) - x + null x => y + null y => x + RPLACD (rest x,first y) + RPLACD (x, rest y) + x dqConcat ld== - if null ld - then nil - else if null rest ld - then first ld - else dqAppend(first ld,dqConcat rest ld) + null ld => nil + null rest ld => first ld + dqAppend(first ld,dqConcat rest ld) dqToList s == - if null s then nil else first s + null s => nil + first s shoeConstructToken(ln,lp,b,n) == [b.0,b.1,:cons(lp,n)] @@ -82,114 +78,111 @@ shoeTokConstruct(x,y,z) == [x,y,:z] shoeNextLine(s)== - if bStreamNull s - then false - else - $linepos:=s - $f:= first s - $r:= rest s - $ln:=first $f - $n:=STRPOSL('" ",$ln,0,true) - $sz :=# $ln - null $n => true - QENUM($ln,$n)=shoeTAB => - a:=MAKE_-FULL_-CVEC (7-REM($n,8) ,'" ") - $ln.$n:='" ".0 - $ln:=CONCAT(a,$ln) - s1:=cons(cons($ln,rest $f),$r) - shoeNextLine s1 - true + bStreamNull s => false + $linepos:=s + $f:= first s + $r:= rest s + $ln:=first $f + $n:=STRPOSL('" ",$ln,0,true) + $sz :=# $ln + null $n => true + QENUM($ln,$n)=shoeTAB => + a:=MAKE_-FULL_-CVEC (7-REM($n,8) ,'" ") + $ln.$n:='" ".0 + $ln:=CONCAT(a,$ln) + s1:=cons(cons($ln,rest $f),$r) + shoeNextLine s1 + true shoeLineToks(s)== - $f: local:=nil - $r:local :=nil - $ln:local :=nil - $n:local:=nil - $sz:local := nil - $floatok:local:=true - $linepos:local:=s - not shoeNextLine s => CONS(nil,nil) - null $n => shoeLineToks $r - fst:=QENUM($ln,0) - EQL(fst,shoeCLOSEPAREN)=> - command:=shoeLine? $ln=> - dq:=dqUnit shoeConstructToken - ($ln,$linepos,shoeLeafLine command,0) - cons([dq],$r) - command:=shoeLisp? $ln=> shoeLispToken($r,command) - command:=shoePackage? $ln=> - -- z:=first shoeBiteOff command - a:=CONCAT('"(IN-PACKAGE ",command,'")") - dq:=dqUnit shoeConstructToken - ($ln,$linepos,shoeLeafLisp a,0) - cons([dq],$r) - shoeLineToks $r - toks:=[] - while $n<$sz repeat toks:=dqAppend(toks,shoeToken()) - null toks => shoeLineToks $r - cons([toks],$r) + $f: local:=nil + $r:local :=nil + $ln:local :=nil + $n:local:=nil + $sz:local := nil + $floatok:local:=true + $linepos:local:=s + not shoeNextLine s => CONS(nil,nil) + null $n => shoeLineToks $r + fst:=QENUM($ln,0) + EQL(fst,shoeCLOSEPAREN)=> + command:=shoeLine? $ln=> + dq:=dqUnit shoeConstructToken + ($ln,$linepos,shoeLeafLine command,0) + cons([dq],$r) + command:=shoeLisp? $ln=> shoeLispToken($r,command) + command:=shoePackage? $ln=> + a:=CONCAT('"(IN-PACKAGE ",command,'")") + dq:=dqUnit shoeConstructToken + ($ln,$linepos,shoeLeafLisp a,0) + cons([dq],$r) + shoeLineToks $r + toks:=[] + while $n<$sz repeat toks:=dqAppend(toks,shoeToken()) + null toks => shoeLineToks $r + cons([toks],$r) shoeLispToken(s,string)== - string:= - # string=0 or EQL(QENUM(string,0),QENUM('";",0))=> '"" - string - ln:=$ln - linepos:=$linepos - [r,:st]:=shoeAccumulateLines(s,string) - dq:=dqUnit shoeConstructToken(ln,linepos,shoeLeafLisp st,0) - cons([dq],r) + string:= + # string=0 or EQL(QENUM(string,0),QENUM('";",0))=> '"" + string + ln:=$ln + linepos:=$linepos + [r,:st]:=shoeAccumulateLines(s,string) + dq:=dqUnit shoeConstructToken(ln,linepos,shoeLeafLisp st,0) + cons([dq],r) shoeAccumulateLines(s,string)== - not shoeNextLine s => CONS(s,string) - null $n => shoeAccumulateLines($r,string) - # $ln=0 => shoeAccumulateLines($r,string) - fst:=QENUM($ln,0) - EQL(fst,shoeCLOSEPAREN)=> - command:=shoeLisp? $ln - command and #command>0 => - EQL(QENUM(command,0),QENUM('";",0))=> - shoeAccumulateLines($r,string) - a:=STRPOS('";",command,0,nil) - a=> - shoeAccumulateLines($r, - CONCAT(string,SUBSTRING(command,0,a-1))) - shoeAccumulateLines($r,CONCAT(string,command)) - shoeAccumulateLines($r,string) - CONS(s,string) + not shoeNextLine s => CONS(s,string) + null $n => shoeAccumulateLines($r,string) + # $ln=0 => shoeAccumulateLines($r,string) + fst:=QENUM($ln,0) + EQL(fst,shoeCLOSEPAREN)=> + command:=shoeLisp? $ln + command and #command>0 => + EQL(QENUM(command,0),QENUM('";",0))=> + shoeAccumulateLines($r,string) + a:=STRPOS('";",command,0,nil) + a=> + shoeAccumulateLines($r, + CONCAT(string,SUBSTRING(command,0,a-1))) + shoeAccumulateLines($r,CONCAT(string,command)) + shoeAccumulateLines($r,string) + CONS(s,string) -- returns true if token t is closing `parenthesis'. shoeCloser t == shoeKeyWord t in '(CPAREN CBRACK) shoeToken () == - ln:=$ln - c:=QENUM($ln,$n) - linepos:=$linepos - n:=$n - ch:=$ln.$n - b:= - shoeStartsComment() => - shoeComment() - [] - shoeStartsNegComment() => - shoeNegComment() - [] - c=shoeLispESCAPE => - shoeLispEscape() - shoePunctuation c => shoePunct () - shoeStartsId ch => shoeWord (false) - c=shoeSPACE => - shoeSpace () - [] - c = shoeSTRING_CHAR => shoeString () - shoeDigit ch => shoeNumber () - c=shoeESCAPE => shoeEscape() - c=shoeTAB => - $n:=$n+1 - [] - shoeError () - null b => nil - dqUnit shoeConstructToken(ln,linepos,b,n) + ln:=$ln + c:=QENUM($ln,$n) + linepos:=$linepos + n:=$n + ch:=$ln.$n + b:= + shoeStartsComment() => + shoeComment() + [] + shoeStartsNegComment() => + shoeNegComment() + [] + c=shoeLispESCAPE => + shoeLispEscape() + shoePunctuation c => shoePunct () + shoeStartsId ch => shoeWord (false) + c=shoeSPACE => + shoeSpace () + [] + c = shoeSTRING_CHAR => shoeString () + shoeDigit ch => shoeNumber () + c=shoeESCAPE => shoeEscape() + c=shoeTAB => + $n:=$n+1 + [] + shoeError () + null b => nil + dqUnit shoeConstructToken(ln,linepos,b,n) -- to pair badge and badgee shoeLeafId x == @@ -202,9 +195,9 @@ shoeLeafInteger x== ["INTEGER",shoeIntValue x] shoeLeafFloat(a,w,e)== - b:=shoeIntValue CONCAT(a,w) - c:= double b * EXPT(double 10, e-#w) - ["FLOAT",c] + b:=shoeIntValue CONCAT(a,w) + c:= double b * EXPT(double 10, e-#w) + ["FLOAT",c] shoeLeafString x == ["STRING",x] @@ -231,279 +224,238 @@ shoeLeafSpaces x == ["SPACES",x] shoeLispEscape()== - $n:=$n+1 - if $n>=$sz - then - SoftShoeError(cons($linepos,$n),'"lisp escape error") - shoeLeafError ($ln.$n) - else - a:=shoeReadLispString($ln,$n) - null a => - SoftShoeError(cons($linepos,$n),'"lisp escape error") - shoeLeafError ($ln.$n) - [exp,n]:=a - null n => - $n:= $sz - shoeLeafLispExp exp - $n:=n - shoeLeafLispExp exp + $n:=$n+1 + $n >= $sz => + SoftShoeError(cons($linepos,$n),'"lisp escape error") + shoeLeafError ($ln.$n) + a:=shoeReadLispString($ln,$n) + null a => + SoftShoeError(cons($linepos,$n),'"lisp escape error") + shoeLeafError ($ln.$n) + [exp,n]:=a + null n => + $n:= $sz + shoeLeafLispExp exp + $n:=n + shoeLeafLispExp exp + shoeEscape()== - $n:=$n+1 - a:=shoeEsc() - if a then shoeWord true else nil + $n:=$n+1 + shoeEsc() => shoeWord true + nil shoeEsc()== - if $n>=$sz - then if shoeNextLine($r) - then - while null $n repeat shoeNextLine($r) - shoeEsc() - false - else false - else - n1:=STRPOSL('" ",$ln,$n,true) - if null n1 - then - shoeNextLine($r) - while null $n repeat shoeNextLine($r) - shoeEsc() - false - else true + $n >= $sz => + shoeNextLine($r) => + while null $n repeat shoeNextLine($r) + shoeEsc() + false + false + n1:=STRPOSL('" ",$ln,$n,true) + null n1 => + shoeNextLine($r) + while null $n repeat + shoeNextLine($r) + shoeEsc() + false + true shoeStartsComment()== - if $n<$sz - then - if QENUM($ln,$n)=shoePLUSCOMMENT - then - www:=$n+1 - if www>=$sz - then false - else QENUM($ln,www) = shoePLUSCOMMENT - else false - else false + $n < $sz => + QENUM($ln,$n) = shoePLUSCOMMENT => + www:=$n+1 + www >= $sz => false + QENUM($ln,www) = shoePLUSCOMMENT + false + false shoeStartsNegComment()== - if $n< $sz - then - if QENUM($ln,$n)=shoeMINUSCOMMENT - then - www:=$n+1 - if www>=$sz - then false - else QENUM($ln,www) = shoeMINUSCOMMENT - else false - else false + $n < $sz => + QENUM($ln,$n) = shoeMINUSCOMMENT => + www:=$n+1 + www >= $sz => false + QENUM($ln,www) = shoeMINUSCOMMENT + false + false shoeNegComment()== - n:=$n - $n:=$sz - shoeLeafNegComment SUBSTRING($ln,n,nil) + n := $n + $n := $sz + shoeLeafNegComment SUBSTRING($ln,n,nil) shoeComment()== - n:=$n - $n:=$sz - shoeLeafComment SUBSTRING($ln,n,nil) + n := $n + $n := $sz + shoeLeafComment SUBSTRING($ln,n,nil) shoePunct()== - sss:=shoeMatch($ln,$n) - $n:=$n+#sss - shoeKeyTr sss + sss := shoeMatch($ln,$n) + $n := $n + #sss + shoeKeyTr sss shoeKeyTr w== - if shoeKeyWord w = "DOT" - then if $floatok - then shoePossFloat(w) - else shoeLeafKey w - else - $floatok:=not shoeCloser w - shoeLeafKey w + shoeKeyWord w = "DOT" => + $floatok => shoePossFloat(w) + shoeLeafKey w + $floatok := not shoeCloser w + shoeLeafKey w shoePossFloat (w)== - if $n>=$sz or not shoeDigit $ln.$n - then shoeLeafKey w - else - w:=shoeInteger() - shoeExponent('"0",w) - + $n>=$sz or not shoeDigit $ln.$n => shoeLeafKey w + w := shoeInteger() + shoeExponent('"0",w) shoeSpace()== - n:=$n - $n:=STRPOSL('" ",$ln,$n,true) - $floatok:=true - if null $n - then - shoeLeafSpaces 0 - $n:= # $ln - else shoeLeafSpaces ($n-n) + n := $n + $n := STRPOSL('" ",$ln,$n,true) + $floatok := true + null $n => + shoeLeafSpaces 0 + $n:= # $ln + shoeLeafSpaces ($n-n) shoeString()== - $n:=$n+1 - $floatok:=false - shoeLeafString shoeS () + $n := $n+1 + $floatok := false + shoeLeafString shoeS () shoeS()== - if $n>=$sz - then - SoftShoeError(cons($linepos,$n),'"quote added") - '"" - else - n:=$n - strsym :=STRPOS ('"_"",$ln,$n,nil) or $sz - escsym:=STRPOS ('"__" - ,$ln,$n,nil) or $sz - mn:=MIN(strsym,escsym) - if mn=$sz - then - $n:=$sz - SoftShoeError(cons($linepos,$n),'"quote added") - SUBSTRING($ln,n,nil) - else if mn=strsym - then - $n:=mn+1 - SUBSTRING($ln,n,mn-n) - else - str:=SUBSTRING($ln,n,mn-n) - $n:=mn+1 - a:=shoeEsc() - b:=if a - then - str:=CONCAT(str,$ln.$n) - $n:=$n+1 - shoeS() - else shoeS() - CONCAT(str,b) + $n >= $sz => + SoftShoeError(cons($linepos,$n),'"quote added") + '"" + n := $n + strsym := STRPOS ('"_"",$ln,$n,nil) or $sz + escsym := STRPOS ('"__",$ln,$n,nil) or $sz + mn := MIN(strsym,escsym) + mn=$sz => + $n:=$sz + SoftShoeError(cons($linepos,$n),'"quote added") + SUBSTRING($ln,n,nil) + mn = strsym => + $n:=mn+1 + SUBSTRING($ln,n,mn-n) + str := SUBSTRING($ln,n,mn-n) + $n := mn+1 + a := shoeEsc() + b := + a => + str := CONCAT(str,$ln.$n) + $n := $n+1 + shoeS() + shoeS() + CONCAT(str,b) shoeIdEnd(line,n)== - while n<#line and shoeIdChar line.n repeat n:=n+1 - n + while n<#line and shoeIdChar line.n repeat + n := n+1 + n shoeDigit x== DIGIT_-CHAR_-P x shoeW(b)== - n1:=$n - $n:=$n+1 - l:=$sz - endid:=shoeIdEnd($ln,$n) - if endid=l or QENUM($ln,endid)~=shoeESCAPE - then - $n:=endid - [b,SUBSTRING($ln,n1,endid-n1)] - else - str:=SUBSTRING($ln,n1,endid-n1) - $n:=endid+1 - a:=shoeEsc() - bb:=if a - then shoeW(true) - else [b,'""] -- escape finds space or newline - [bb.0 or b,CONCAT(str,bb.1)] + n1 := $n + $n := $n+1 + l := $sz + endid := shoeIdEnd($ln,$n) + endid=l or QENUM($ln,endid) ~= shoeESCAPE => + $n := endid + [b,SUBSTRING($ln,n1,endid-n1)] + str := SUBSTRING($ln,n1,endid-n1) + $n := endid+1 + a := shoeEsc() + bb := + a => shoeW(true) + [b,'""] -- escape finds space or newline + [bb.0 or b,CONCAT(str,bb.1)] shoeWord(esp) == - aaa:=shoeW(false) - w:=aaa.1 - $floatok:=false - if esp or aaa.0 - then shoeLeafId w - else if shoeKeyWordP w - then - $floatok:=true - shoeLeafKey w - else shoeLeafId w + aaa:=shoeW(false) + w:=aaa.1 + $floatok:=false + esp or aaa.0 => shoeLeafId w + shoeKeyWordP w => + $floatok:=true + shoeLeafKey w + shoeLeafId w shoeInteger() == shoeInteger1(false) shoeInteger1(zro) == - n:=$n - l:= $sz - while $n<l and shoeDigit($ln.$n) repeat $n:=$n+1 - if $n=l or QENUM($ln,$n)~=shoeESCAPE - then if n=$n and zro - then '"0" - else SUBSTRING($ln,n,$n-n) - else - str:=SUBSTRING($ln,n,$n-n) - $n:=$n+1 - a:=shoeEsc() - bb:=shoeInteger1(zro) - CONCAT(str,bb) + n := $n + l := $sz + while $n <l and shoeDigit($ln.$n) repeat + $n := $n+1 + $n=l or QENUM($ln,$n)~=shoeESCAPE => + n = $n and zro => '"0" + SUBSTRING($ln,n,$n-n) + str := SUBSTRING($ln,n,$n-n) + $n := $n+1 + a := shoeEsc() + bb := shoeInteger1(zro) + CONCAT(str,bb) shoeIntValue(s) == - ns := #s - ival := 0 - for i in 0..ns-1 repeat - d := shoeOrdToNum ELT(s,i) - ival := 10*ival + d - ival + ns := #s + ival := 0 + for i in 0..ns-1 repeat + d := shoeOrdToNum ELT(s,i) + ival := 10*ival + d + ival shoeNumber() == - a := shoeInteger() - if $n>=$sz - then shoeLeafInteger a - else - if $floatok and QENUM($ln,$n)=shoeDOT - then - n:=$n - $n:=$n+1 - if $n<$sz and QENUM($ln,$n)=shoeDOT - then - $n:=n - shoeLeafInteger a - else - w:=shoeInteger1(true) - shoeExponent(a,w) - else shoeLeafInteger a + a := shoeInteger() + $n >= $sz => shoeLeafInteger a + $floatok and QENUM($ln,$n) = shoeDOT => + n := $n + $n := $n+1 + $n < $sz and QENUM($ln,$n)=shoeDOT => + $n := n + shoeLeafInteger a + w := shoeInteger1(true) + shoeExponent(a,w) + shoeLeafInteger a shoeExponent(a,w)== - if $n>=$sz - then shoeLeafFloat(a,w,0) - else - n:=$n - c:=QENUM($ln,$n) - if c=shoeEXPONENT1 or c=shoeEXPONENT2 - then - $n:=$n+1 - if $n>=$sz - then - $n:=n - shoeLeafFloat(a,w,0) - else if shoeDigit($ln.$n) - then - e:=shoeInteger() - e:=shoeIntValue e - shoeLeafFloat(a,w,e) - else - c1:=QENUM($ln,$n) - if c1=shoePLUSCOMMENT or c1=shoeMINUSCOMMENT - then - $n:=$n+1 - if $n>=$sz - then - $n:=n - shoeLeafFloat(a,w,0) - else - if shoeDigit($ln.$n) - then - e:=shoeInteger() - e:=shoeIntValue e - shoeLeafFloat(a,w, - (if c1=shoeMINUSCOMMENT then MINUS e else e)) - else - $n:=n - shoeLeafFloat(a,w,0) - else shoeLeafFloat(a,w,0) + $n >= $sz => shoeLeafFloat(a,w,0) + n := $n + c := QENUM($ln,$n) + c = shoeEXPONENT1 or c = shoeEXPONENT2 => + $n := $n+1 + $n >= $sz => + $n := n + shoeLeafFloat(a,w,0) + shoeDigit($ln.$n) => + e := shoeInteger() + e := shoeIntValue e + shoeLeafFloat(a,w,e) + c1 := QENUM($ln,$n) + c1 = shoePLUSCOMMENT or c1 = shoeMINUSCOMMENT => + $n := $n+1 + $n >= $sz => + $n := n + shoeLeafFloat(a,w,0) + shoeDigit($ln.$n) => + e := shoeInteger() + e := shoeIntValue e + shoeLeafFloat(a,w,(c1=shoeMINUSCOMMENT => MINUS e; e)) + $n := n + shoeLeafFloat(a,w,0) + -- FIXME: Missing alternative. + shoeLeafFloat(a,w,0) shoeError()== - n:=$n - $n:=$n+1 - SoftShoeError(cons($linepos,n), - CONCAT( '"The character whose number is ", - STRINGIMAGE QENUM($ln,n),'" is not a Boot character")) - shoeLeafError ($ln.n) + n:=$n + $n:=$n+1 + SoftShoeError(cons($linepos,n), + CONCAT( '"The character whose number is ", + STRINGIMAGE QENUM($ln,n),'" is not a Boot character")) + shoeLeafError ($ln.n) shoeOrdToNum x== DIGIT_-CHAR_-P x @@ -518,27 +470,25 @@ shoeMatch(l,i) == shoeSubStringMatch(l,shoeDict,i) shoeSubStringMatch (l,d,i)== - h:= QENUM(l, i) - u:=ELT(d,h) - ll:=SIZE l - done:=false - s1:='"" - for j in 0.. SIZE u - 1 while not done repeat - s:=ELT(u,j) - ls:=SIZE s - done:=if ls+i > ll - then false - else - eql:= true - for k in 1..ls-1 while eql repeat - eql:= EQL(QENUM(s,k),QENUM(l,k+i)) - if eql - then - s1:=s - true - else false - s1 + h := QENUM(l, i) + u := ELT(d,h) + ll := SIZE l + done := false + s1 := '"" + for j in 0.. SIZE u - 1 while not done repeat + s := ELT(u,j) + ls := SIZE s + done := + ls+i > ll => false + eql := true + for k in 1..ls-1 while eql repeat + eql := EQL(QENUM(s,k),QENUM(l,k+i)) + eql => + s1:=s + true + false + s1 shoePunctuation c == - shoePun.c =1 + shoePun.c = 1 diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp index 646429c2..f88bfa6f 100644 --- a/src/boot/strap/includer.clisp +++ b/src/boot/strap/includer.clisp @@ -121,9 +121,8 @@ ((|bStreamNull| |b|) (|shoeConsole| (CONCAT |name| " not found in " |fn|)) NIL) - (T (COND - ((NULL |lines|) (|shoeConsole| ")package not found"))) - (APPEND (REVERSE |lines|) (CAR |b|))))))))) + ((NULL |lines|) (|shoeConsole| ")package not found")) + (T (APPEND (REVERSE |lines|) (CAR |b|))))))))) (DEFPARAMETER |$bStreamNil| (LIST '|nullstream|)) diff --git a/src/boot/strap/scanner.clisp b/src/boot/strap/scanner.clisp index f7d77f67..4c4bda04 100644 --- a/src/boot/strap/scanner.clisp +++ b/src/boot/strap/scanner.clisp @@ -238,13 +238,10 @@ (T (SETQ |$n| |n|) (|shoeLeafLispExp| |exp|))))))))))) (DEFUN |shoeEscape| () - (PROG (|a|) - (DECLARE (SPECIAL |$n|)) - (RETURN - (PROGN - (SETQ |$n| (+ |$n| 1)) - (SETQ |a| (|shoeEsc|)) - (COND (|a| (|shoeWord| T)) (T NIL)))))) + (DECLARE (SPECIAL |$n|)) + (PROGN + (SETQ |$n| (+ |$n| 1)) + (COND ((|shoeEsc|) (|shoeWord| T)) (T NIL)))) (DEFUN |shoeEsc| () (PROG (|n1|) diff --git a/src/boot/translator.boot b/src/boot/translator.boot index 679bfafd..f931975e 100644 --- a/src/boot/translator.boot +++ b/src/boot/translator.boot @@ -584,15 +584,12 @@ SSORT l == SORT(l,function CLESSP) bootOutLines(l,outfn,s)== - if null l - then shoeFileLine(s,outfn) - else - a:=PNAME first l - if #s +#a > 70 - then - shoeFileLine(s,outfn) - bootOutLines(l,outfn,'" ") - else bootOutLines(rest l,outfn,CONCAT(s,'" ",a)) + null l => shoeFileLine(s,outfn) + a := PNAME first l + #s + #a > 70 => + shoeFileLine(s,outfn) + bootOutLines(l,outfn,'" ") + bootOutLines(rest l,outfn,CONCAT(s,'" ",a)) -- (xref "fn") produces a cross reference listing in "fn.xref" @@ -604,19 +601,17 @@ XREF fn== shoeOpenInputFile(a,infn,shoeXref(a,fn)) shoeXref(a,fn)== - if null a - then shoeNotFound fn - else - $lispWordTable :=MAKE_-HASHTABLE ("EQ") - DO_-SYMBOLS(i(FIND_-PACKAGE "LISP"),HPUT($lispWordTable,i,true)) - $bootDefined :=MAKE_-HASHTABLE "EQ" - $bootUsed :=MAKE_-HASHTABLE "EQ" - $GenVarCounter :=0 - $bfClamming :=false - shoeDefUse shoeTransformStream a - out:=CONCAT(fn,'".xref") - shoeOpenOutputFile(stream,out,shoeXReport stream) - out + null a => shoeNotFound fn + $lispWordTable :=MAKE_-HASHTABLE ("EQ") + DO_-SYMBOLS(i(FIND_-PACKAGE "LISP"),HPUT($lispWordTable,i,true)) + $bootDefined :=MAKE_-HASHTABLE "EQ" + $bootUsed :=MAKE_-HASHTABLE "EQ" + $GenVarCounter :=0 + $bfClamming :=false + shoeDefUse shoeTransformStream a + out:=CONCAT(fn,'".xref") + shoeOpenOutputFile(stream,out,shoeXReport stream) + out shoeXReport stream== |