1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. 2-- All rights reserved. 3-- 4-- Redistribution and use in source and binary forms, with or without 5-- modification, are permitted provided that the following conditions are 6-- met: 7-- 8-- - Redistributions of source code must retain the above copyright 9-- notice, this list of conditions and the following disclaimer. 10-- 11-- - Redistributions in binary form must reproduce the above copyright 12-- notice, this list of conditions and the following disclaimer in 13-- the documentation and/or other materials provided with the 14-- distribution. 15-- 16-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the 17-- names of its contributors may be used to endorse or promote products 18-- derived from this software without specific prior written permission. 19-- 20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 32 33)package "BOOT" 34 35 36SPACE_CHAR := STR_ELT('" ", 0) 37-- Hardcode ASCII code to avoid editors messing up control code 38PAGE_CTL := 12 39ESCAPE := STR_ELT('"__ ", 0) 40STRING_CHAR := STR_ELT('"_" ", 0) 41PLUSCOMMENT := STR_ELT('"+ ", 0) 42MINUSCOMMENT:= STR_ELT('"- ", 0) 43RADIX_CHAR := STR_ELT('"r ", 0) 44DOT := STR_ELT('". ", 0) 45EXPONENT1 := STR_ELT('"E ", 0) 46EXPONENT2 := STR_ELT('"e ", 0) 47CLOSEPAREN := STR_ELT('") ", 0) 48CLOSEANGLE := STR_ELT('"> ", 0) 49QUESTION := STR_ELT('"? ", 0) 50 51scanKeyWords := [ _ 52 ['"add", "add"], _ 53 ['"and", "and"], _ 54 ['"break", "break"], _ 55 ['"by", "by"], _ 56 ['"case", "case"], _ 57 ['"catch", "catch"], _ 58 ['"default", "DEFAULT" ],_ 59 ['"define", "DEFN" ],_ 60 ['"do", "DO"],_ 61 ['"else", "else"], _ 62 ['"exquo", "exquo"], _ 63 ['"export","EXPORT" ],_ 64 ['"finally", "finally"], _ 65 ['"for", "for"], _ 66 ['"free", "FREE" ],_ 67 ['"from", "from"], _ 68 ['"generate", "generate"], _ 69 ['"goto", "goto"], _ 70 ['"has", "has"], _ 71 ['"if", "if"], _ 72 ['"import", "import"], _ 73 ['"in", "in"], _ 74 ['"inline", "INLINE" ],_ 75 ['"is", "is"], _ 76 ['"isnt", "isnt"], _ 77 ['"iterate", "ITERATE"],_ 78 ['"local", "local"], _ 79 ['"macro", "MACRO" ],_ 80 ['"mod", "mod"], _ 81 ['"not", "not"], _ 82 ['"or", "or"], _ 83 ['"pretend", "pretend"], _ 84 ['"quo", "quo"], _ 85 ['"rem", "rem"], _ 86 ['"repeat", "repeat"],_ 87 ['"return", "return"],_ 88 ['"rule","RULE" ],_ 89 ['"then", "then"],_ 90 ['"try", "try"], _ 91 ['"until", "until"], _ 92 ['"where", "where"], _ 93 ['"while", "while"],_ 94 ['"with", "with"], _ 95 ['"yield", "yield"], _ 96 ['"|", "|"], _ 97 ['".", "."], _ 98 ['"::", "::"], _ 99 ['":", ":"], _ 100 ['":-","COLONDASH" ],_ 101 ['"@", "@"], _ 102 ['"@@","ATAT" ],_ 103 ['",", ","],_ 104 ['";", ";"],_ 105 ['"**", "**"], _ 106 ['"*", "*"],_ 107 ['"+", "+"], _ 108 ['"-", "-"], _ 109 ['"<", "<"], _ 110 ['">", ">"], _ 111 ['"<=", "<="], _ 112 ['">=", ">="], _ 113 ['"=", "="], _ 114 ['"~=", "~="], _ 115 ['"~", "~"], _ 116 ['"^", "^" ], _ 117 ['"..","SEG" ],_ 118 ['"#","#" ],_ 119 ['"#1", "#1" ],_ 120 ['"&","AMPERSAND" ],_ 121 ['"$","$" ],_ 122 ['"/", "/"], _ 123 ['"\", "\"], _ 124 ['"//","SLASHSLASH" ],_ 125 ['"\\","BACKSLASHBACKSLASH" ],_ 126 ['"/\", "/\"], _ 127 ['"\/", "\/"], _ 128 ['"=>", "=>"], _ 129 ['":=", ":="], _ 130 ['"==", "=="], _ 131 ['"==>", "==>"],_ 132 ['"->","ARROW" ],_ 133 ['"<-","LARROW" ],_ 134 ['"+->", "+->"], _ 135 ['"(","(" ],_ 136 ['")",")" ],_ 137 ['"(|","(|" ],_ 138 ['"|)","|)" ],_ 139 ['"[","[" ],_ 140 ['"]","]" ],_ 141 ['"[__]","[]" ],_ 142 ['"{","{" ],_ 143 ['"}","}" ],_ 144 ['"{__}","{}" ],_ 145 ['"[|","[|" ],_ 146 ['"|]","|]" ],_ 147 ['"[|__|]","[||]" ],_ 148 ['"{|","{|" ],_ 149 ['"|}","|}" ],_ 150 ['"{|__|}","{||}" ],_ 151 ['"<<", "<<"], _ 152 ['">>", ">>"], _ 153 ['"'", "'" ],_ 154 ['"`", "BACKQUOTE" ]_ 155 ] 156 157scanKeyTableCons()== 158 KeyTable := MAKE_HASHTABLE("EQUAL") 159 for st in scanKeyWords repeat 160 HPUT(KeyTable, first st, CADR st) 161 KeyTable 162 163scanInsert(s,d) == 164 l := #s 165 h := STR_ELT(s, 0) 166 u := ELT(d,h) 167 n := #u 168 k:=0 169 while l <= #(ELT(u,k)) repeat 170 k:=k+1 171 v := MAKE_VEC(n + 1) 172 for i in 0..k-1 repeat QSETVELT(v, i, ELT(u, i)) 173 QSETVELT(v, k, s) 174 for i in k..n-1 repeat QSETVELT(v, i + 1, ELT(u, i)) 175 QSETVELT(d, h, v) 176 s 177 178scanDictCons()== 179 l:= HKEYS scanKeyTable 180 d := 181 a := MAKE_VEC(256) 182 b := MAKE_VEC(1) 183 QSETVELT(b, 0, make_full_CVEC(0, '" ")) 184 for i in 0..255 repeat QSETVELT(a, i, b) 185 a 186 for s in l repeat scanInsert(s,d) 187 d 188 189scanPunCons()== 190 listing := HKEYS scanKeyTable 191 a := make_BVEC(256, 0) 192 for i in 0..255 repeat SETELT_BVEC(a, i, 0) 193 for k in listing repeat 194 if not startsId? k.0 then 195 SETELT_BVEC(a, STR_ELT(k, 0), 1) 196 a 197 198scanKeyTable:=scanKeyTableCons() 199 200scanDict:=scanDictCons() 201 202scanPun:=scanPunCons() 203 204for i in [ _ 205 ["=", "="], _ 206 ["*", "*"], _ 207 ["has", "has"], _ 208 ["case", "case"], _ 209 ["exquo", "exquo"], _ 210 ["rem", "rem"], _ 211 ["mod", "mod"], _ 212 ["quo", "quo"], _ 213 ["/", "/"], _ 214 ["\", "\"], _ 215 ["SLASHSLASH" ,"//"], _ 216 ["BACKSLASHBACKSLASH","\\"], _ 217 ["/\", "/\"], _ 218 ["\/", "\/"], _ 219 ["**", "**"], _ 220 ["^", "^"], _ 221 ["+", "+"], _ 222 ["-", "-"], _ 223 ["<", "<"], _ 224 [">", ">"], _ 225 ["<<", "<<"], _ 226 [">>", ">>"], _ 227 ["<=", "<="], _ 228 [">=", ">="], _ 229 ["~=", "~="], _ 230 ["by", "by"], _ 231 ["ARROW" ,"->"], _ 232 ["LARROW" ,"<-"], _ 233 ["|", "|"], _ 234 ["SEG" ,".."] _ 235 ] repeat MAKEPROP(first i, 'INFGENERIC, CADR i) 236 237-- Scanner 238 239is_white?(c) == c = SPACE_CHAR or c = PAGE_CTL 240 241skip_whitespace(ln, n) == 242 l := #ln 243 while n < l and is_white?(STR_ELT(ln, n)) repeat 244 n := n + 1 245 n 246 247DEFVAR($f) 248DEFVAR($floatok) 249DEFVAR($linepos) 250DEFVAR($ln) 251DEFVAR($n) 252DEFVAR($r) 253DEFVAR($sz) 254DEFPARAMETER($was_nonblank, false) 255 256DEFVAR($comment_indent, 0) 257DEFVAR($current_comment_block, nil) 258DEFVAR($comment_line) 259DEFVAR($last_nonempty_linepos, nil) 260DEFVAR($spad_scanner, false) 261 262finish_comment() == 263 NULL($current_comment_block) => nil 264 pos := 265 $comment_indent = 0 => $comment_line 266 first(rest(rest($last_nonempty_linepos))) 267 PUSH([pos, :NREVERSE($current_comment_block)], $COMBLOCKLIST) 268 $current_comment_block := nil 269 270-- lineoftoks bites off a token-dq from a line-stream 271-- returning the token-dq and the rest of the line-stream 272 273scanIgnoreLine(ln,n)== 274 if n = $sz then 275 false 276 else 277 fst := STR_ELT(ln, 0) 278 if EQ(fst, CLOSEPAREN) and ($sz > 1) and 279 not(is_white?(STR_ELT(ln, 1))) 280 then if incPrefix?('"command",1,ln) 281 then true 282 else nil 283 else n 284 285nextline(s)== 286 if npNull s 287 then false 288 else 289 $f:= first s 290 $r:= rest s 291 $ln := rest $f 292 $linepos:=CAAR $f 293 $n := skip_whitespace($ln, 0) -- spaces at beginning 294 $sz :=# $ln 295 true 296 297 298lineoftoks(s)== 299 $f: local:=nil 300 $r:local :=nil 301 $ln:local :=nil 302 $linepos:local:=nil 303 $n:local:=nil 304 $sz:local := nil 305 $floatok:local:=true 306 $was_nonblank := false 307 not nextline s => CONS(nil,nil) 308 if null scanIgnoreLine($ln,$n) -- line of spaces or starts ) or > 309 then cons(nil,$r) 310 else 311 toks:=[] 312 a:= incPrefix?('"command",1,$ln) 313 a => 314 $ln := SUBSTRING($ln, 8, nil) 315 b := dqUnit constoken($ln, $linepos, ["command", $ln], 0) 316 cons([[b, s]], $r) 317 318 while $n<$sz repeat 319 tok := scanToken() 320 if tok and $spad_scanner then finish_comment() 321 toks:=dqAppend(toks, tok) 322 if null toks 323 then cons([],$r) 324 else 325 $last_nonempty_linepos := $linepos 326 cons([[toks,s]],$r) 327 328 329scanToken () == 330 ln:=$ln 331 c := STR_ELT($ln, $n) 332 linepos:=$linepos 333 n:=$n 334 ch:=$ln.$n 335 b:= 336 startsComment?() => 337 scanComment() 338 [] 339 startsNegComment?() => 340 scanNegComment() 341 [] 342 c= QUESTION => 343 $n:=$n+1 344 lfid '"?" 345 punctuation? c => scanPunct () 346 startsId? ch => scanWord (false) 347 is_white?(c) => 348 scanSpace () 349 $was_nonblank := false 350 [] 351 c = STRING_CHAR => scanString () 352 digit? ch => scanNumber () 353 c=ESCAPE => scanEscape() 354 scanError () 355 null b => nil 356 nb := $was_nonblank and b.0 = "key" and b.1 = "(" 357 $was_nonblank := true 358 dqUnit constoken1(ln, linepos, b, n + lnExtraBlanks linepos, nb) 359 360-- to pair badge and badgee 361 362DEFPARAMETER($boot_package, FIND_-PACKAGE('"BOOT")) 363lfid x== ["id", INTERN(x, $boot_package)] 364 365lfkey x==["key",keyword x] 366 367lfinteger x == ["integer", x] 368 369lfrinteger (r,x)==["integer",CONCAT (r,CONCAT('"r",x))] 370--lfrfloat(a,w,v)==["rfloat",CONCAT(a,'"r.",v)] 371lffloat(a, w, e) == ["float", [a, w, e]] 372lfstring x==if #x=1 then ["char",x] else ["string",x] 373lfcomment (n, lp, x) == ["comment", x] 374lfnegcomment x== ["negcomment", x] 375lferror x==["error",x] 376lfspaces x==["spaces",x] 377 378constoken1(ln, lp, b, n, nb) == 379-- [b.0,b.1,cons(lp,n)] 380 a:=cons(b.0,b.1) 381 if nb then ncPutQ(a, "nonblank", true) 382 ncPutQ(a,"posn",cons(lp,n)) 383 a 384 385constoken(ln, lp, b, n) == constoken1(ln, lp, b, n, false) 386 387scanEscape()== 388 $n:=$n+1 389 a:=scanEsc() 390 if a then scanWord true else nil 391 392scanEsc()== 393 if $n>=$sz 394 then if nextline($r) 395 then 396 $n := 0 397 false 398 else false 399 else 400 true 401 402checkEsc()== 403 if STR_ELT($ln, $sz - 1) = ESCAPE then scanEsc() 404 405startsComment?()== 406 if $n<$sz 407 then 408 if STR_ELT($ln, $n) = PLUSCOMMENT then 409 www:=$n+1 410 if www>=$sz 411 then false 412 else STR_ELT($ln, www) = PLUSCOMMENT 413 else false 414 else false 415 416startsNegComment?()== 417 if $n< $sz 418 then 419 if STR_ELT($ln, $n) = MINUSCOMMENT then 420 www:=$n+1 421 if www>=$sz 422 then false 423 else STR_ELT($ln, www) = MINUSCOMMENT 424 else false 425 else false 426 427scanNegComment()== 428 n:=$n 429 $n:=$sz 430 res := lfnegcomment SUBSTRING($ln,n,nil) 431 checkEsc() 432 res 433 434scanComment()== 435 n:=$n 436 $n:=$sz 437 c_str := SUBSTRING($ln,n,nil) 438 if $spad_scanner then 439 if not(n = $comment_indent) then 440 finish_comment() 441 $comment_line := first(rest(rest($linepos))) 442 $comment_indent := n 443 PUSH(CONCAT(make_full_CVEC(n, '" "), c_str), $current_comment_block) 444 res := lfcomment(n, $linepos, c_str) 445 checkEsc() 446 res 447 448 449scanPunct()== 450 sss:=subMatch($ln,$n) 451 a:= # sss 452 if a=0 453 then 454 scanError() 455 else 456 $n:=$n+a 457 scanKeyTr sss 458 459scanKeyTr w== 460 if EQ(keyword w, ".") 461 then if $floatok 462 then scanPossFloat(w) 463 else lfkey w 464 else 465 $floatok:=not scanCloser? w 466 lfkey w 467 468scanPossFloat (w)== 469 if $n>=$sz or not digit? $ln.$n 470 then lfkey w 471 else 472 w:=spleI(function digit?) 473 scanExponent('"0",w) 474 475scanCloser:=[")","}","]","|)","|}","|]"] 476 477scanCloser? w== MEMQ(keyword w,scanCloser) 478 479scanSpace()== 480 n:=$n 481 $n := skip_whitespace($ln, $n) 482 $floatok:=true 483 lfspaces ($n-n) 484 485e_concat(s1, s2) == 486 #s2 = 0 => s1 487 idChar?(s2.0) => CONCAT(s1, "__", s2) 488 CONCAT(s1, s2) 489 490scanString()== 491 $n:=$n+1 492 $floatok:=false 493 lfstring scanS () 494 495scanS()== 496 if $n>=$sz 497 then 498 ncSoftError(cons($linepos,lnExtraBlanks $linepos+$n),"S2CN0001",[]) 499 '"" 500 else 501 n:=$n 502 strsym :=STRPOS ('"_"",$ln,$n,nil) or $sz 503 escsym:=STRPOS ('"__" 504 ,$ln,$n,nil) or $sz 505 mn:=MIN(strsym,escsym) 506 if mn=$sz 507 then 508 $n:=$sz 509 ncSoftError(cons($linepos,lnExtraBlanks $linepos+$n), 510 "S2CN0001",[]) 511 SUBSTRING($ln,n,nil) 512 else if mn=strsym 513 then 514 $n:=mn+1 515 SUBSTRING($ln,n,mn-n) 516 else --escape is found first 517 str:=SUBSTRING($ln,n,mn-n)-- before escape 518 $n:=mn+1 519 a:=scanEsc() -- case of end of line when false 520 not(a) => CONCAT(str, scanS()) 521 ec := $ln.$n 522 $n := $n + 1 523 e_concat(str, CONCAT(ec, scanS())) 524 525posend(line,n)== 526 while n<#line and idChar? line.n repeat n:=n+1 527 n 528 529digit? x== DIGITP x 530 531scanW(b)== -- starts pointing to first char 532 n1:=$n -- store starting character position 533 $n := inc_SI($n) -- the first character is not tested 534 l:=$sz 535 endid:=posend($ln,$n) 536 if endid = l or STR_ELT($ln, endid) ~= ESCAPE then 537 -- not escaped 538 $n:=endid 539 [b, SUBSTRING($ln, n1, sub_SI(endid, n1))] -- l overflows 540 else -- escape and endid~=l 541 str:=SUBSTRING($ln,n1,endid-n1) 542 $n:=endid+1 543 a:=scanEsc() 544 bb:=if a -- escape nonspace 545 then scanW(true) 546 else 547 if $n>=$sz 548 then [b,'""] 549 else 550 if idChar?($ln.$n) 551 then scanW(b) 552 else [b,'""] 553 [bb.0 or b, e_concat(str, bb.1)] 554 555scanWord(esp) == 556 aaa:=scanW(false) 557 w:=aaa.1 558 $floatok:=false 559 if esp or aaa.0 560 then lfid w 561 else if (keyword? w and ($spad_scanner or w ~= '"not")) 562 then 563 $floatok:=true 564 lfkey w 565 else lfid w 566 567 568 569spleI(dig)==spleI1(dig,false) 570spleI1(dig,zro) == 571 n:=$n 572 l:= $sz 573 while $n<l and FUNCALL(dig,($ln.$n)) repeat $n:=$n+1 574 if $n = l or STR_ELT($ln, $n) ~= ESCAPE 575 then if n=$n and zro 576 then '"0" 577 else SUBSTRING($ln,n,$n-n) 578 else -- escaped 579 str:=SUBSTRING($ln,n,$n-n) 580 $n:=$n+1 581 a:=scanEsc() 582 bb:=spleI1(dig,zro)-- escape, anyno spaces are ignored 583 CONCAT(str,bb) 584 585scanCheckRadix(r,w)== 586 ns:=#w 587 ns = 0 => 588 ncSoftError([$linepos, :lnExtraBlanks $linepos+$n], "S2CN0004", []) 589 done:=false 590 for i in 0..ns-1 repeat 591 a:=rdigit? w.i 592 if null a or a>=r 593 then ncSoftError(cons($linepos,lnExtraBlanks $linepos+$n-ns+i), 594 "S2CN0002", [w.i]) 595 596scanNumber() == 597 a := spleI(function digit?) 598 if $n>=$sz 599 then lfinteger a 600 else 601 if STR_ELT($ln, $n) ~= RADIX_CHAR then 602 if $floatok and STR_ELT($ln, $n) = DOT then 603 n:=$n 604 $n:=$n+1 605 if $n<$sz and STR_ELT($ln, $n) = DOT then 606 $n:=n 607 lfinteger a 608 else 609 w:=spleI1(function digit?,true) 610 scanExponent(a,w) 611 else lfinteger a 612 else 613 $n:=$n+1 614 w:=spleI1(function rdigit?, false) 615 scanCheckRadix(PARSE_-INTEGER a,w) 616 if $n>=$sz 617 then 618 lfrinteger(a,w) 619 else if STR_ELT($ln, $n) = DOT then 620 n:=$n 621 $n:=$n+1 622 if $n < $sz and STR_ELT($ln, $n) = DOT then 623 $n:=n 624 lfrinteger(a,w) 625 else 626 --$n:=$n+1 627 v:=spleI1(function rdigit?, false) 628 scanCheckRadix(PARSE_-INTEGER a,v) 629 scanExponent(CONCAT(a,'"r",w),v) 630 else lfrinteger(a,w) 631 632scanExponent(a,w)== 633 if $n>=$sz 634 then lffloat(a,w,'"0") 635 else 636 n:=$n 637 c := STR_ELT($ln, $n) 638 if c=EXPONENT1 or c=EXPONENT2 639 then 640 $n:=$n+1 641 if $n>=$sz 642 then 643 $n:=n 644 lffloat(a,w,'"0") 645 else if digit?($ln.$n) 646 then 647 e:=spleI(function digit?) 648 lffloat(a,w,e) 649 else 650 c1 := STR_ELT($ln, $n) 651 if c1=PLUSCOMMENT or c1=MINUSCOMMENT 652 then 653 $n:=$n+1 654 if $n>=$sz 655 then 656 $n:=n 657 lffloat(a,w,'"0") 658 else 659 if digit?($ln.$n) 660 then 661 e:=spleI(function digit?) 662 lffloat(a,w, 663 (if c1=MINUSCOMMENT then CONCAT('"-",e)else e)) 664 else 665 $n:=n 666 lffloat(a,w,'"0") 667 else lffloat(a,w,'"0") 668 669rdigit? x== 670 STRPOS(x,'"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",0,nil) 671 672scanError()== 673 n:=$n 674 $n:=$n+1 675 ncSoftError(cons($linepos,lnExtraBlanks $linepos+$n), 676 "S2CN0003",[$ln.n]) 677 lferror ($ln.n) 678 679 680keyword st == HGET(scanKeyTable,st) 681 682keyword? st == not null HGET(scanKeyTable,st) 683 684subMatch(l,i)==substringMatch(l,scanDict,i) 685 686substringMatch (l,d,i)== 687 h := STR_ELT(l, i) 688 u:=ELT(d,h) 689 ll:=SIZE l 690 done:=false 691 s1:='"" 692 for j in 0.. SIZE u - 1 while not done repeat 693 s:=ELT(u,j) 694 ls:=SIZE s 695 done:=if ls+i > ll 696 then false 697 else 698 eql:= true 699 for k in 1..ls-1 while eql repeat 700 eql := EQL(STR_ELT(s, k), STR_ELT(l, k + i)) 701 if eql 702 then 703 s1:=s 704 true 705 else false 706 s1 707 708punctuation? c == c < 256 and ELT_BVEC(scanPun, c) = 1 709