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