--load parser table's
include lexi.e   
constant TRUE=1 , FALSE = 0 
-- table's for the parser .
sequence termtab={},partab={},stacktab={}
constant opcode={"EXIT","LIT","PUNC","TEXT","NUM","TERM","BRK","REP","CALL","RTE","RET","BRE","BRF","BRS"}
integer pc=1,opc,suc,nbr --program counter , op_code , succes_flag , no_branch_flag
constant P_CODE=1,P_VALUE=2,P_TEXT=3
sequence P_result={0,0,0}
sequence opexec={} -- executeble op_code

-- definities voor de free format reading en de parser .
constant ident={"ABCDEFGHIJKLNMOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLNMOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_"}                   
constant num  ={"0123456789","0123456789"}
constant punctuation = {"?/()#$*-+:=<>&{}[]@!,;'.^\"",{}}
constant terminals={ident,num,punctuation}
constant IDENT=1,NUMBER=2,PUNCT=3

--load compiled parser table 

function readf() 
sequence result={}, dec 
sequence terminals_read=terminals&{"\n"} 
L_in(terminals_read)
while L_result[L_INDEX]!=4 do 
   if    L_result[L_INDEX]=1 then result=append(result,L_result[L_SEARCH])
   elsif L_result[L_INDEX]=2 then dec   =value(L_result[L_SEARCH])--convert text to int.
                                  result=append(result,dec[2])
   elsif L_result[L_INDEX]=3 then result=append(result,L_result[L_SEARCH])
   elsif L_result[L_INDEX]<0 then result = -1 exit  -- eof
   else  L_error("Onbekend teken")  
   end if
   L_in(terminals_read)
end while 
return result
end function    

procedure P_load(integer file)
sequence num_term,result
--set scanner for free format reading
if not L_init(file) then puts(1,"syntax File not there\n") abort(1) end if
L_any(" ")-- ANCHOR = 1
-- begin loading       
num_term=readf() -- eerste element bevat aantal te lezen Keywords   
printf(1,"Terminal Table (length=%i)\n",num_term)
for i=1 to num_term[1] do
  result=readf() -- in principe kan readf meer dan 1 resultaat geven .
  termtab=append(termtab,result[1]) 
end for 
puts(1,"Program code ")
result=readf()  -- De tabel regel bevat drie getallen alleen de eerste twee gebruiken.
while sequence(result) do
  partab&=result[1..2]
  result=readf()
end while
printf(1,"(length=%i)\n",{length(partab)}) -- print grote van de gelezen tabel
-- end loading

-- no more file's to handle ?
if L_end()
then puts(1,"End failed , stil work to do\n")
else puts(1,"End successfull\n")
end if
close(file)
end procedure        


-- assembler of the code
-- opr = 1 ; lit ,  <result> : 
-- opr = 2 ; punc,  <fail>   : token == punc , textstring = teken .
-- opr = 3 ; text,  <fail>   : token == text , textstring = text  .
-- opr = 4 ; num ,  <fail>   : token == num  , textstring = nummer.
-- opr = 5 ; term,  <term> , <succes> <fail>
-- opr = 6 ; break, <end_break>
-- opr = 7 ; repeat,<begin_repeat>
-- opr = 8 ; call,  <routine>, <succes>, <fail>
-- opr = 9 ; rte,   0        : return from stack ,set suc=true , <suc>
-- opr =10 ; ret,   0        : return from stack ,if suc <suc> else <fail>  
-- opr =11 ; bre,   <adres>  : set suc=true , <adres>
-- opr =12 ; brf,   <fail>   : if suc <pc+1>  else <adres>
-- opr =13 ; brs,   <succes> : if suc <adres> else <pc+1>  

-- disassembler
procedure P_dias()
while pc<=length(partab) do
  opc=partab[pc]
  printf(1,"%4d %6s ",{pc,opcode[opc+1]})
  pc+=1
  if opc=5 then 
   printf(1,"%10s S(%d)F(%d)\n",{termtab[partab[pc]],partab[pc+1],partab[pc+2]})
   pc+=2
  elsif opc=8 then
   printf(1,"%10d S(%d)F(%d)\n",{partab[pc],partab[pc+1],partab[pc+2]})
   pc+=2
  else
   printf(1,"%10d\n",{partab[pc]})
  end if
  pc+=1
end while
end procedure

-- parser code routines
function EXIT()
 P_result[P_VALUE]=partab[pc]
 P_result[P_CODE] =0
 pc+=1
 return FALSE
end function
function LIT()
 P_result[P_VALUE]=partab[pc]
 P_result[P_CODE] =1
 pc+=1
 return FALSE
end function   
function PUNC() 
 if PUNCT = L_result[L_INDEX] 
 then suc = TRUE
     P_result[P_TEXT]=L_result[L_SEARCH]
     L_in(terminals)
     pc+=1
 else
     suc = FALSE
     pc  = partab[pc]
 end if     
 return TRUE
end function
function TEXT()
 if IDENT = L_result[L_INDEX] 
 then suc = TRUE
     P_result[P_TEXT]=L_result[L_SEARCH]
     L_in(terminals)
     pc+=1
 else
     suc = FALSE
     pc  = partab[pc]
 end if     
 return TRUE
end function
function NUM()
 if NUMBER = L_result[L_INDEX] 
 then suc = TRUE
     P_result[P_TEXT]=L_result[L_SEARCH]
     P_result[P_VALUE]=value(L_result[L_SEARCH])
     P_result[P_VALUE]=P_result[P_VALUE][2]
     L_in(terminals)
     pc+=1
 else
     suc = FALSE
     pc  = partab[pc]
 end if     
 return TRUE
end function
function TERM()
 if termtab[partab[pc]] = L_result[L_SEARCH] 
 then suc = TRUE
     P_result[P_TEXT]=L_result[L_SEARCH]
     if nbr then L_in(terminals) end if
     pc=partab[pc+1]
 else
     suc = FALSE
     pc  = partab[pc+2]
 end if     
 return TRUE
end function
function BRK()
 if nbr
 then nbr=FALSE
      P_result[P_TEXT]=L_result[L_SEARCH]
      pc+=1
 else
   if suc 
   then nbr=TRUE     
        pc=partab[pc]
   else L_in(terminals)     
        P_result[P_TEXT]=L_result[L_SEARCH]
        pc+=1  
   end if
 end if
 return TRUE       
end function
function REP()
 if suc
 then pc=partab[pc]
 else suc=TRUE
      pc+=1
 end if
 return TRUE
end function
function CALL()
-- put onto stack
 stacktab=prepend(stacktab,pc+1)
 pc=partab[pc]
 return TRUE
end function
function RTE()
 suc = TRUE
-- get from stack
 pc=stacktab[1]
 remove(stacktab,1)
 pc=partab[pc]
 return TRUE
end function
function RET()
 -- get from stack
 pc=stacktab[1]
 remove(stacktab,1) 
 if suc
 then pc=partab[pc]
 else pc=partab[pc+1]
 end if
 return TRUE
end function
function BRE()
 suc=TRUE
 pc=partab[pc]
 return TRUE
end function
function BRF()
 if suc
 then pc+=1
 else pc=partab[pc]
 end if
 return TRUE
end function
function BRS()
 if suc
 then pc=partab[pc]
 else pc+=1
 end if
 return TRUE
end function
 
 
   
procedure P_init(integer file;pc_start)
   if not L_init(file) then puts(1,"No input File there\n") abort(1) end if
   for i=1 to length(opcode) do
       opexec=append(opexec,routine_id(opcode[i]))
   end for 
   L_any(" \n") --ANCHOR=1
   pc=pc_start
   suc=TRUE -- succes = true
   nbr=TRUE -- no branch = true
   -- lees eerste lexi scan . lees eerste item  !
   L_in(terminals)  
end procedure

-- dit kan directer door via disam de ID intevullen
-- dan vervalt 'opc=partab[pc] + 1'
-- ook behoeft 'opexec' niet teworden aangemaakt .
-- dit is hoe PEU het doet .
-- die zegt 'while(*code!=-1){ object[*code].p.pp(); code++; }'
--
procedure P_get()
-- start 
opc=partab[pc]+1 
--printf(1,"pc=%d opc=%s ",{pc,opcode[opc]})
--printf(1,"skip=%s search=%s index=%d\n",L_result)
pc+=1
while call_func(opexec[opc],{}) 
do opc = partab[pc] + 1 
--   printf(1,"pc=%d opc=%s ",{pc,opcode[opc]})
--   printf(1,"skip=%s search=%s index=%d\n",L_result)
   pc+=1
end while
-- exit
end procedure 

-- parser 
-- P_load(file)    -- compiled syntax file
sequence file=open("d:/basic/syntax/in7.sct","r")
   P_load(file)
-- P_dias(file)    -- output diasambler text
   P_dias()  
-- P_init(file,pc) -- input file
   file=open("in7.syn","r")
   P_init(file,1) 
   puts(1,"execute !\n")
-- P_get() ->{ CODE , VALUE , TEXT }
   P_get()
   printf(1,"code=%d value=%d text=%s\n",P_result)
   while P_result[P_CODE] !=0 and not(P_result[P_CODE]=1 and P_result[P_VALUE]=1)  do
   P_get()
   printf(1,"code=%d value=%d text=%s\n",P_result)
   end while