aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2009-09-04 05:50:37 +0000
committerdos-reis <gdr@axiomatics.org>2009-09-04 05:50:37 +0000
commit9d4b58dc1f45d4d49ce68997000825dd3e7f247a (patch)
tree81124164f4adbb0d9c8f14426ca5f35c40d625d6
parent5ec566efd3ae43b1bf470e5da19de940ac95c0dd (diff)
downloadopen-axiom-9d4b58dc1f45d4d49ce68997000825dd3e7f247a.tar.gz
-rw-r--r--src/boot/includer.boot290
-rw-r--r--src/boot/parser.boot773
-rw-r--r--src/boot/pile.boot124
-rw-r--r--src/boot/scanner.boot668
-rw-r--r--src/boot/strap/includer.clisp5
-rw-r--r--src/boot/strap/scanner.clisp11
-rw-r--r--src/boot/translator.boot39
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==