-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2014, 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

shoeTAB == abstractChar 9
 
dqUnit s==
  a := [s]
  [a,:a]
 
dqAppend(x,y)==
  x = nil => y
  y = nil => x
  x.rest.rest := first y
  x.rest := rest y
  x
 
dqConcat ld==
  ld = nil => nil
  rest ld = nil => first ld
  dqAppend(first ld,dqConcat rest ld)
 
dqToList s ==
  s = nil => nil
  first s
 
--%
structure %Lexer ==
  Record(line: %String, pos: %Maybe %Short) with
    lexerLineString == (.line)
    lexerCurrentPosition == (.pos)

makeLexer() ==
  mk%Lexer(nil,nil)

++ Return true if the lexer wants a fresh input line.
macro lexerRefresh? lex ==
  lexerCurrentPosition lex = nil

macro lexerLineLength lex ==
  #lexerLineString lex

++ Make the lexer ready to process a new input line.
lexerSetLine!(lex,line) ==
  lexerLineString(lex) := line
  lexerCurrentPosition(lex) := 0

++ Adjust the current position to the next non-blank character.
lexerSkipBlank! lex ==
  lexerCurrentPosition(lex) :=
    firstNonblankPosition(lexerLineString lex,lexerCurrentPosition lex)

++ Move the current position by a given amount   
lexerAdvancePosition!(lex,n == 1) ==
  lexerCurrentPosition(lex) := lexerCurrentPosition lex + n

++ Move the current position to end of line.
lexerSkipToEnd! lex ==
  lexerCurrentPosition(lex) := lexerLineLength lex

++ Set the current position at a given index.
lexerPosition!(lex,k) ==
  lexerCurrentPosition(lex) := k

++ Return the amount of space characters need to complete a tab
++ to its next logical stop.
lexerCharCountToCompleteTab lex ==
  7 - (lexerCurrentPosition lex rem 8)


++ Access the character the current position.
macro lexerCurrentChar lex ==
  stringChar(lexerLineString lex,lexerCurrentPosition lex)

++ Access the character at a given position.
macro lexerCharacterAt(lex,k) ==
  stringChar(lexerLineString lex,k)

++ Return the position of next character `c', or end of line.
lexerCharPosition(lex,c) ==
  charPosition(c,lexerLineString lex,lexerCurrentPosition lex)

++ Return true if the current position is at end of line.
lexerEol? lex ==
  lexerCurrentPosition lex >= lexerLineLength lex

--%  

lexerReadLisp lex ==
  shoeReadLispString(lexerLineString lex,lexerCurrentPosition lex)

shoeNextLine(lex,s) ==
  bStreamNull s => false
  $linepos := s
  [$f,:$r] := s
  lexerSetLine!(lex,sourceLineString $f)
  lexerSkipBlank! lex
  lexerRefresh? lex => true
  lexerCurrentChar lex = shoeTAB =>
    a := makeString(lexerCharCountToCompleteTab lex,char " ")
    lexerCurrentChar(lex) := char " "
    lexerLineString(lex) := strconc(a,lexerLineString lex)
    s1 := [makeSourceLine(lexerLineString lex,sourceLineNumber $f),:$r]
    shoeNextLine(lex,s1)
  true
 
shoeLineToks s ==
  $f: local := nil
  $r: local := nil
  $floatok: local := true
  $linepos: local := s
  lex := makeLexer()
  not shoeNextLine(lex,s) =>  [nil,:nil]
  lexerRefresh? lex => shoeLineToks $r
  lexerCharacterAt(lex,0) = char ")" =>
    command := shoeLine? lexerLineString lex =>
      dq := dqUnit makeToken($linepos,shoeLeafLine command,0)
      [[dq],:$r]
    command := shoeLisp? lexerLineString lex => shoeLispToken(lex,$r,command)
    shoeLineToks $r
  toks := []
  while not lexerEol? lex repeat
    toks := dqAppend(toks,shoeToken lex)
  toks = nil => shoeLineToks $r
  [[toks],:$r]
 
shoeLispToken(lex,s,string)==
  if #string = 0 or stringChar(string,0) = char ";" then
    string := '""
  ln := lexerLineString lex
  linepos := $linepos
  [r,:st] := shoeAccumulateLines(lex,s,string)
  dq := dqUnit makeToken(linepos,shoeLeafLisp st,0)
  [[dq],:r]
 
shoeAccumulateLines(lex,s,string)==
  not shoeNextLine(lex,s) =>  [s,:string]
  lexerRefresh? lex => shoeAccumulateLines(lex,$r,string)
  lexerLineLength lex = 0 => shoeAccumulateLines(lex,$r,string)
  lexerCharacterAt(lex,0) = char ")" =>
    command := shoeLisp? lexerLineString lex
    command and #command > 0 =>
      stringChar(command,0) = char ";" =>
		  shoeAccumulateLines(lex,$r,string)
      a := findChar(char ";",command) =>
	shoeAccumulateLines(lex,$r,
	   strconc(string,subString(command,0,a-1)))
      shoeAccumulateLines(lex,$r,strconc(string,command))
    shoeAccumulateLines(lex,$r,string)
  [s,:string]

-- returns true if token t is closing `parenthesis'.
shoeCloser t ==
  shoeKeyWord t in '(CPAREN CBRACK)
 
shoeToken lex ==
  linepos := $linepos
  n := lexerCurrentPosition lex
  ch := lexerCurrentChar lex
  b :=
    shoeStartsComment lex =>
      shoeComment lex
      []
    shoeStartsNegComment lex =>
      shoeNegComment lex
      []
    ch = char "!" => shoeLispEscape lex
    shoePunctuation codePoint ch => shoePunct lex
    shoeStartsId ch => shoeWord(lex,false)
    ch = char " " =>
      shoeSpace lex
      []
    ch = char "_"" => shoeString lex
    digit? ch => shoeNumber lex
    ch = char "__" => shoeEscape lex
    ch = shoeTAB =>
      lexerAdvancePosition! lex
      []
    ch = char "&" => shoeInert lex
    shoeError lex
  b = nil => nil
  dqUnit makeToken(linepos,b,n)
 
-- to pair badge and badgee
shoeLeafId x ==  
  ["ID",makeSymbol x]
 
shoeLeafKey x==
  ["KEY",shoeKeyWord x]
 
shoeLeafInteger x==
  ["INTEGER",shoeIntValue x]
 
shoeLeafFloat(a,w,e)==
  b:=shoeIntValue strconc(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 lex ==
  lexerAdvancePosition! lex
  lexerEol? lex =>
    SoftShoeError([$linepos,:lexerCurrentPosition lex],'"lisp escape error")
    shoeLeafError lexerCurrentChar lex
  a := lexerReadLisp lex
  a = nil =>
    SoftShoeError([$linepos,:lexerCurrentPosition lex],'"lisp escape error")
    shoeLeafError lexerCurrentChar lex
  [exp,n] := a
  n = nil =>
    lexerSkipToEnd! lex
    shoeLeafLispExp exp
  lexerPosition!(lex,n)
  shoeLeafLispExp  exp

shoeEscape lex ==
  lexerAdvancePosition! lex
  shoeEsc lex => shoeWord(lex,true)
  nil
 
shoeEsc lex ==
  lexerEol? lex =>
    shoeNextLine(lex,$r) =>
      while lexerRefresh? lex repeat
        shoeNextLine(lex,$r)
      shoeEsc lex
      false
    false
  n1 := firstNonblankPosition(lexerLineString lex,lexerCurrentPosition lex)
  n1 = nil =>
    shoeNextLine(lex,$r)
    while lexerRefresh? lex repeat 
      shoeNextLine(lex,$r)
    shoeEsc lex
    false
  true
 
shoeStartsComment lex ==
  not lexerEol? lex =>
    lexerCurrentChar lex = char "+" => 
       www := lexerCurrentPosition lex + 1
       www >= lexerLineLength lex => false
       lexerCharacterAt(lex,www) = char "+"
    false
  false
 
shoeStartsNegComment lex ==
  not lexerEol? lex =>
    lexerCurrentChar lex = char "-" =>
      www := lexerCurrentPosition lex + 1
      www >= lexerLineLength lex => false
      lexerCharacterAt(lex,www) = char "-"
    false
  false
 
shoeNegComment lex ==
  n := lexerCurrentPosition lex
  lexerSkipToEnd! lex
  shoeLeafNegComment subString(lexerLineString lex,n)
 
shoeComment lex ==
  n := lexerCurrentPosition lex
  lexerSkipToEnd! lex
  shoeLeafComment subString(lexerLineString lex,n)
 
shoePunct lex ==
  sss := shoeMatch lex
  lexerAdvancePosition!(lex,#sss)
  shoeKeyTr(lex,sss)
 
shoeKeyTr(lex,w) ==
  shoeKeyWord w = "DOT" =>
    $floatok => shoePossFloat(lex,w)
    shoeLeafKey w
  $floatok := not shoeCloser w
  shoeLeafKey w
 
shoePossFloat(lex,w)==
  lexerEol? lex or not digit? lexerCurrentChar lex => shoeLeafKey w
  w := shoeInteger lex
  shoeExponent(lex,'"0",w)
 
shoeSpace lex ==
  n := lexerCurrentPosition lex
  lexerSkipBlank! lex
  $floatok := true
  lexerRefresh? lex =>
     shoeLeafSpaces 0
     lexerSkipToEnd! lex
  shoeLeafSpaces(lexerCurrentPosition lex - n)
 
shoeString lex ==
  lexerAdvancePosition! lex
  $floatok := false
  shoeLeafString shoeS lex
 
shoeS lex ==
  lexerEol? lex =>
    SoftShoeError([$linepos,:lexerCurrentPosition lex],'"quote added")
    '""
  n := lexerCurrentPosition lex
  strsym := lexerCharPosition(lex,char "_"")
  escsym := lexerCharPosition(lex,char "__")
  mn := MIN(strsym,escsym)
  mn = lexerLineLength lex =>
    lexerSkipToEnd! lex
    SoftShoeError([$linepos,:lexerCurrentPosition lex],'"quote added")
    subString(lexerLineString lex,n)
  mn = strsym =>
    lexerPosition!(lex,mn + 1)
    subString(lexerLineString lex,n,mn-n)
  str := subString(lexerLineString lex,n,mn-n)
  lexerPosition!(lex,mn + 1)
  a := shoeEsc lex
  b := 
    a =>
      str := strconc(str,charString lexerCurrentChar lex)
      lexerAdvancePosition! lex
      shoeS lex
    shoeS lex
  strconc(str,b)
 
shoeIdEnd lex ==
  n := lexerCurrentPosition lex
  while n < lexerLineLength lex and shoeIdChar lexerCharacterAt(lex,n) repeat 
    n := n + 1
  n
 
shoeW(lex,b) ==
  n1 := lexerCurrentPosition lex
  lexerAdvancePosition! lex
  l := lexerLineLength lex
  endid := shoeIdEnd lex
  endid = l or lexerCharacterAt(lex,endid) ~= char "__" => 
    lexerPosition!(lex,endid)
    [b,subString(lexerLineString lex,n1,endid-n1)]
  str := subString(lexerLineString lex,n1,endid-n1)
  lexerPosition!(lex,endid + 1)
  a := shoeEsc lex
  bb := 
    a => shoeW(lex,true)
    [b,'""]   --  escape finds space or newline
  [bb.0 or b,strconc(str,bb.1)]
 
shoeWord(lex,esp) ==
   aaa := shoeW(lex,false)
   w:=aaa.1
   $floatok:=false
   esp or aaa.0 =>  shoeLeafId w
   shoeKeyWordP w =>
     $floatok:=true
     shoeLeafKey w
   shoeLeafId  w
 
shoeInert lex ==
  lexerAdvancePosition! lex
  ['INERT,second shoeW(lex,false)]

shoeInteger lex ==
  shoeInteger1(lex,false)
 
shoeInteger1(lex,zro) ==
  n := lexerCurrentPosition lex
  while not lexerEol? lex and digit? lexerCurrentChar lex repeat 
    lexerAdvancePosition! lex
  lexerEol? lex or lexerCurrentChar lex ~= char "__" =>
    n = lexerCurrentPosition lex and zro => '"0"
    subString(lexerLineString lex,n,lexerCurrentPosition lex - n)
  str := subString(lexerLineString lex,n,lexerCurrentPosition lex - n)
  lexerAdvancePosition! lex
  a := shoeEsc lex
  bb := shoeInteger1(lex,zro)
  strconc(str,bb)
 
shoeIntValue(s) ==
  ns := #s
  ival := 0
  for i in 0..ns-1 repeat
    d := digit? stringChar(s,i)
    ival := 10*ival + d
  ival
 
shoeNumber lex ==
  a := shoeInteger lex
  lexerEol? lex => shoeLeafInteger a
  $floatok and lexerCurrentChar lex = char "." => 
    n := lexerCurrentPosition lex
    lexerAdvancePosition! lex
    not lexerEol? lex and lexerCurrentChar lex = char "." =>
      lexerPosition!(lex,n)
      shoeLeafInteger a
    w := shoeInteger1(lex,true)
    shoeExponent(lex,a,w)
  shoeLeafInteger a
 
shoeExponent(lex,a,w)==
  lexerEol? lex => shoeLeafFloat(a,w,0)
  n := lexerCurrentPosition lex
  c := lexerCurrentChar lex
  c = char "E" or c = char "e" =>
    lexerAdvancePosition! lex
    lexerEol? lex =>
      lexerPosition!(lex,n)
      shoeLeafFloat(a,w,0)
    digit? lexerCurrentChar lex =>
      e := shoeInteger lex
      e := shoeIntValue e
      shoeLeafFloat(a,w,e)
    c1 := lexerCurrentChar lex
    c1 = char "+" or c1 = char "-" =>
      lexerAdvancePosition! lex
      lexerEol? lex =>
	lexerPosition!(lex,n)
	shoeLeafFloat(a,w,0)
      digit? lexerCurrentChar lex =>
	e := shoeInteger lex
	e := shoeIntValue e
	shoeLeafFloat(a,w,(c1 = char "-" => MINUS e; e))
      lexerPosition!(lex,n)
      shoeLeafFloat(a,w,0)
    -- FIXME: Missing alternative.
  shoeLeafFloat(a,w,0)
 
shoeError lex ==
  n := lexerCurrentPosition lex
  lexerAdvancePosition! lex
  SoftShoeError([$linepos,:n],
    strconc( '"The character whose number is ",
      toString codePoint lexerCharacterAt(lex,n),
        '" is not a Boot character"))
  shoeLeafError lexerCharacterAt(lex,n)
 
shoeKeyWord st   == 
  tableValue(shoeKeyTable,st)
 
shoeKeyWordP st  ==  
  tableValue(shoeKeyTable,st) ~= nil
 
shoeMatch lex == 
  shoeSubStringMatch(lexerLineString lex,shoeDict,lexerCurrentPosition lex)
 
shoeSubStringMatch(l,d,i) ==
  h := codePoint stringChar(l, i)
  u := d.h
  ll := #l
  done := false
  s1 := '""
  for j in 0.. #u - 1 while not done repeat
    s := u.j
    ls := #s
    done := 
      ls + i > ll => false
      eql := true
      for k in 1..ls-1 while eql repeat
	 eql := stringChar(s,k) = stringChar(l,k+i)
      eql => 
	s1 := s
	true
      false
  s1
 
shoePunctuation c == 
  shoePun.c = 1