From 9d4b58dc1f45d4d49ce68997000825dd3e7f247a Mon Sep 17 00:00:00 2001 From: dos-reis Date: Fri, 4 Sep 2009 05:50:37 +0000 Subject: --- src/boot/scanner.boot | 668 +++++++++++++++++++++++--------------------------- 1 file changed, 309 insertions(+), 359 deletions(-) (limited to 'src/boot/scanner.boot') 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 + 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 -- cgit v1.2.3