-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2008, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are -- met: -- -- - Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- - Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in -- the documentation and/or other materials provided with the -- distribution. -- -- - Neither the name of The Numerical Algorithms Group Ltd. nor the -- names of its contributors may be used to endorse or promote products -- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- import tokens import includer namespace BOOTTRAN module scanner -- converts X to double-float. double x == FLOAT(x, 1.0) dqUnit s== a := [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 dqConcat ld== if null ld then nil else if null rest ld then first ld else dqAppend(first ld,dqConcat rest ld) dqToList s == if null s then nil else first s shoeConstructToken(ln,lp,b,n) == [b.0,b.1,:cons(lp,n)] shoeTokType x == first x shoeTokPart x == second x shoeTokPosn x == CDDR x 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 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) 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) 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) -- 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) -- to pair badge and badgee shoeLeafId x == ["ID",INTERN x] shoeLeafKey x== ["KEY",shoeKeyWord x] shoeLeafInteger x== ["INTEGER",shoeIntValue x] shoeLeafFloat(a,w,e)== b:=shoeIntValue CONCAT(a,w) c:= double b * EXPT(double 10, e-#w) ["FLOAT",c] shoeLeafString x == ["STRING",x] shoeLeafLisp x == ["LISP",x] shoeLeafLispExp x == ["LISPEXP",x] shoeLeafLine x == ["LINE",x] shoeLeafComment x == ["COMMENT", x] shoeLeafNegComment x== ["NEGCOMMENT", x] shoeLeafError x == ["ERROR",x] 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 shoeEscape()== $n:=$n+1 a:=shoeEsc() if a then shoeWord true else 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 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 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 shoeNegComment()== n:=$n $n:=$sz shoeLeafNegComment SUBSTRING($ln,n,nil) shoeComment()== n:=$n $n:=$sz shoeLeafComment SUBSTRING($ln,n,nil) shoePunct()== sss:=shoeMatch($ln,$n) $n:=$n+#sss shoeKeyTr sss shoeKeyTr w== if EQ(shoeKeyWord w,"DOT") then if $floatok then shoePossFloat(w) else shoeLeafKey w else $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) shoeSpace()== n:=$n $n:=STRPOSL('" ",$ln,$n,true) $floatok:=true if null $n then shoeLeafSpaces 0 $n:= # $ln else shoeLeafSpaces ($n-n) shoeString()== $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) shoeIdEnd(line,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)] 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 shoeInteger() == shoeInteger1(false) shoeInteger1(zro) == n:=$n l:= $sz while $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 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) 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) shoeOrdToNum x== DIGIT_-CHAR_-P x shoeKeyWord st == GETHASH(st,shoeKeyTable) shoeKeyWordP st == not null GETHASH(st,shoeKeyTable) 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 shoePunctuation c == shoePun.c =1