-- 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.
--

--
-- Abstract:
--   This file defines the includer (or preprocessor) of Boot programs.
--

import tokens
namespace BOOTTRAN
module includer

-- BOOT INCLUDER
 
-- Line syntax is
--
--  Include ::= (SimpleLine | If )*  | ( )fin | empty)
--
--  SimpleLine::=
--        PlainLine |            includes the line
--        )say line |            outputs line to console
--        )eval line |           evaluates the boot line
--                                 nothing included
--        )line line |           line is reproduced as is in lisp output
--        )lisp line             line is read by lisp READ
--
-- If ::= )if SimpleLine* ElseLines )endif
--
-- ElseLines ::= )else SimpleLine* | )elseif SimpleLine* ElseLines | empty

++ returns a printable representation of `x', when it is a symbol
++ or a character, as string.  Otherwise, returns nil.
PNAME x ==
  symbol? x => symbolName x
  char? x => charString x
  nil

-- error out if file is not found. 
shoeNotFound fn == 
  coreError [fn, '" not found"]
  nil

 
shoeReadLispString(s,n) ==
  l := #s
  n >= l => nil
  readLispFromString strconc('"(", subString(s,n,l-n) ,'")")

-- write LINE to standard terminal I/O.
shoeConsole line ==
  writeLine(line,$stdio)
 
shoeSpaces n  ==  
  makeString(n,char ".")
 

--%

diagnosticLocation tok ==
  pos := tokenPosition tok
  strconc('"line ", toString lineNo pos, '", column ", 
    toString lineCharacter pos)

SoftShoeError(posn,key)==
  coreError ['"in line ", toString lineNo posn]
  shoeConsole lineString posn
  shoeConsole strconc(shoeSpaces lineCharacter posn,'"|")
  shoeConsole key
 
--%
structure %SourceLine ==
  Record(str: %String, num: %Short) with
    sourceLineString == (.str)
    sourceLineNumber == (.num)

macro makeSourceLine(s,n) ==
  mk%SourceLine(s,n)

-- Line inclusion support.
 
lineNo p ==
  sourceLineNumber CAAR p

lineString p == 
  sourceLineString CAAR p

lineCharacter p == 
  rest p
 
-- Lazy inclusion support.

$bStreamNil == ["nullstream"]
 
bStreamNull x ==
  x = nil or x is ["nullstream",:.] => true
  while x is ["nonnullstream",op,:args] repeat
    st := apply(op,args)
    x.first := first st
    x.rest := rest st
  x is ["nullstream",:.]
 
bMap(f,x) == 
  bDelay(function bMap1, [f,x])
 
bMap1(f,x)==
  bStreamNull x => $bStreamNil
  [apply(f,[first x]),:bMap(f,rest x)]

bDelay(f,x) ==
  ["nonnullstream",f,:x]
 
bAppend(x,y) ==
  bDelay(function bAppend1,[x,y])
 
bAppend1(x,y)==
  bStreamNull x =>
    bStreamNull y => ["nullstream"]
    y
  [first x,:bAppend(rest x,y)]
 
bNext(f,s) ==
  bDelay(function bNext1,[f,s])
 
bNext1(f,s)==
  bStreamNull s => ["nullstream"]
  h := apply(f,[s])
  bAppend(first h,bNext(f,rest h))
 
bRgen s ==
  bDelay(function bRgen1,[s])
 
bRgen1 s ==
  a := readLine s
  a ~= %nothing => [a,:bRgen s]
  ["nullstream"]
 
bIgen n ==
  bDelay(function bIgen1,[n])
 
bIgen1 n ==
  n := n + 1
  [n,:bIgen n]
 
bAddLineNumber(f1,f2) ==
  bDelay(function bAddLineNumber1,[f1,f2])
 
bAddLineNumber1(f1,f2)==
  bStreamNull f1 =>  ["nullstream"]
  bStreamNull f2 =>  ["nullstream"]
  [makeSourceLine(first f1,first f2),:bAddLineNumber(rest f1,rest f2)]


shoePrefixLisp x == 
  strconc('")lisp",x)

shoePrefixLine x== 
  strconc('")line",x)

shoePrefix?(prefix,whole) ==
  #prefix > #whole => false
  good:=true
  for i in 0..#prefix-1 for j in 0.. while good repeat
    good := stringChar(prefix,i) = stringChar(whole,j)
  good => subString(whole,#prefix) 
  good
 
shoePlainLine?(s) ==
  #s = 0 =>  true
  stringChar(s,0) ~= char ")"
 
shoeSay?          s  == shoePrefix?('")say",         s)
shoeEval?         s  == shoePrefix?('")eval",        s)
shoeFin?          s  == shoePrefix?('")fin",         s)
shoeIf?           s  == shoePrefix?('")if",          s)
shoeEndIf?        s  == shoePrefix?('")endif",       s)
shoeElse?         s  == shoePrefix?('")else",        s)
shoeElseIf?       s  == shoePrefix?('")elseif",      s)
shoeLisp?         s  == shoePrefix?('")lisp",        s)
shoeLine?         s  == shoePrefix?('")line",        s)
 
shoeInclude s == 
  bDelay(function shoeInclude1,[s])

shoeInclude1 s ==
  bStreamNull s => s
  [h,:t]  := s
  string  := sourceLineString h
  command := shoeFin? string  => $bStreamNil
  command := shoeIf? string   => shoeThen([true],[STTOMC command],t)
  bAppend(shoeSimpleLine h,shoeInclude t)
 
shoeSimpleLine(h) ==
  string := sourceLineString h
  shoePlainLine? string=> [h]
  command := shoeLisp? string => [h]
  command := shoeLine? string => [h]
  command := shoeSay? string =>
    shoeConsole command
    nil
  command:=shoeEval? string =>
    STTOMC command
    nil
  shoeLineSyntaxError(h)
  nil
 
shoeThen(keep,b,s) == 
  bDelay(function shoeThen1,[keep,b,s])

shoeThen1(keep,b,s)==
  bPremStreamNull s=> s
  [h,:t] := s
  string := sourceLineString h
  command := shoeFin? string  => bPremStreamNil(h)
  keep1 := first keep
  b1 := first b
  command := shoeIf? string  =>
    keep1 and b1 =>  shoeThen([true,:keep],[STTOMC command,:b],t)
    shoeThen([false,:keep],[false,:b],t)
  command := shoeElseIf? string =>
    keep1 and not b1 =>
      shoeThen([true,:rest keep],[STTOMC command,:rest b],t)
    shoeThen([false,:rest keep],[false,:rest b],t)
  command :=shoeElse? string =>
   keep1 and not b1=>shoeElse([true,:rest keep],[true,:rest b],t)
   shoeElse([false,:rest keep],[false,:rest b],t)
  command :=shoeEndIf? string=>
    rest b = nil =>  shoeInclude t
    shoeThen(rest keep,rest b,t)
  keep1 and b1 => bAppend(shoeSimpleLine h,shoeThen(keep,b,t))
  shoeThen(keep,b,t)
 
shoeElse(keep,b,s) ==
  bDelay(function shoeElse1,[keep,b,s])

shoeElse1(keep,b,s)==
  bPremStreamNull s=> s
  [h,:t] := s
  string := sourceLineString h
  command := shoeFin? string => bPremStreamNil(h)
  b1 := first b
  keep1 := first keep
  command := shoeIf? string =>
    keep1 and b1 => shoeThen([true,:keep],[STTOMC command,:b],t)
    shoeThen([false,:keep],[false,:b],t)
  command := shoeEndIf? string =>
    rest b = nil =>  shoeInclude t
    shoeThen(rest keep,rest b,t)
  keep1 and b1 => bAppend(shoeSimpleLine h,shoeElse(keep,b,t))
  shoeElse(keep,b,t)
 
shoeLineSyntaxError(h)==
  shoeConsole strconc('"INCLUSION SYNTAX ERROR IN LINE ",
			     toString sourceLineNumber h)
  shoeConsole sourceLineString h
  shoeConsole '"LINE IGNORED"
 
bPremStreamNil(h)==
  shoeConsole strconc('"UNEXPECTED )fin IN LINE ",toString sourceLineNumber h)
  shoeConsole sourceLineString h
  shoeConsole '"REST OF FILE IGNORED"
  $bStreamNil
 
bPremStreamNull(s)==
  bStreamNull s =>
    shoeConsole '"FILE TERMINATED BEFORE )endif"
    true
  false