#include <stdef.slb>

#define elem ('CMT'|'S1T'|'S2T'|'KYW'|'NTM'|'TKN')


function main()
 local s,t
  msgout

   tknident := 'identifier' | ( ( 'numeric' |
                                  'string'  |
                                  'character' ) & '_literal' )

   keywords := "ABORT_" | "ABS_" | "ACCEPT_" | "ACCESS_" | "ALL_" |
               "AND_" | "ARRAY_" | "AT_" | "BEGIN_" | "BODY_" |
               "CASE_" | "CONSTANT_" | "DECLARE_" | "DELAY_" |
               "DELTA_" | "DIGITS_" | "DO_" | "ELSE_" | "ELSIF_" |
               "END_" | "ENTRY_" | "EXCEPTION_" | "EXIT_" | "FOR_" |
               "FUNCTION_" | "GENERIC_" | "GOTO_" | "IF_" | "IN_" |
               "IS_" | "LIMITED_" | "LOOP_" | "MOD_" | "NEW_" |
               "NOT_" | "NULL_" | "OF_" | "OR_" | "OTHERS_" |
               "OUT_" | "PACKAGE_" | "PRAGMA_" | "PRIVATE_" |
               "PROCEDURE_" | "RAISE_" | "RANGE_" | "RECORD_" |
               "REM_" | "RENAMES_" | "RETURN_" | "REVERSE_" |
               "SELECT_" | "SEPARATE_" | "SUBTYPE_" | "TASK_" |
               "TERMINATE_" | "THEN_" | "TYPE_" | "USE_" | "WHEN_" |
               "WHILE_" | "WITH_" | "XOR_" | "ARROW_" | "DBLDOT_" |
               "EXP_" | "ASSIGN_" | "NOTEQL_" | "GTEQL_" | "LTEQ_" |
               "L_LBL_" | "R_LBL_" | "BOX_"

   nonterms := span ( '_' || ucase_ || lcase_ || '.' )

   nx1 := notany ( ucase_ || '_' )

   if dosparm ? '/' & &vid.fid then
                    { ifile ( "DSNI" ,  2 , fid||dot||'GRY')
                      ofile ( "YAC2" , 12 , fid||dot||'YC2')

                                      inf1 := table()
                                      inf2 := table()
                                      inf3 := table()
                                      inf4 := table()

    while s := DSNI do { t ||:= s || crlf_
                         s ?- ws_ & rm_
                      if s ?  ';' & rm_ then
                         t := proc(lo(Sane(blx(t)))) }

   endfile(2)
   endfile(12) }
end

function proc(s)
 local p1,p2,p3
 local q1,q2,q3
 local q,i
  prd +:= 1
  arm  := 0

        s ?  lm_ & arb.p1 & 'NTM' & &num.p2 &
             ws_.p3 & ':' <- ':'

  while s ?  (':'|'|').q1 & arb.q2 & ('|'|';').q3 <- q3 do
        q ||:= fix(q1,q2)
        s ?- ';' & ws_ & rm_

  emit ( '2' , Build(p1 || 'NTM' || p2 || p3 || q || blx(';')) )
end

function Build(s)
 local a
  repeat s ? elem & &num.a <- inf2[eval(a)]
 return s
end

function fix(a1,a2)
 local a

  arm +:= 1

  a   := crlf_
  a ||:= prologue()
  a ||:= dodef('CLIPS',printout(a2))
  a ||:= crlf_
  a ||:= dodef('ADAFE',interout(a2))
  a ||:= crlf_
  a ||:= epilogue()

  a2 ?- ws_ & rm_

  a2 ||:= bln_
  a2 ||:= brces(a || dupl(bln_,75))
  a2 ||:= crlf_

 return a1 || a2
end

function prologue()
 fre := ''
 return ''
end

function epilogue()
 return ''
end

function clx(s)
 return '-' || s || '-'
end

function printout(s)
 return stm ('$$' || blx('=') || 'emitpre' ||
         paras(tix2('ITEM' || blx(lpad(prd,5,bln_)) ||
                                  lpad(arm,3,bln_)))) || act(s) ||
        stm ('emitfin' || paras('')) || fre
end

function interout(s)
 return cmt('<front-end>') || crlf_
end

function act(s)
 local t,q1,q2

  dollar  := 0
  element := 0
  while s ?- ws_ & elem.q1 &
                   &num.q2 & ws_ do
                           { cond q1 { case 'NTM' : t ||:= dlr()
                                       case 'TKN' : t ||:= tkx(q2)
                                       case 'KYW' : t ||:= skp()
                                       case 'S1T' : t ||:= skp()
                                       case 'S2T' : t ||:= skp()
                                       case 'CMT' : t ||:= '' }}
 return t
end

function dlr()
 dollar +:= 1
 element +:= 1
 fre ||:= stm(free('$' || dollar))
 return stm ( 'emitntm' || paras('$' || dollar) )
end

function tkx(q)
 dollar +:= 1
 element +:= 1
 fre ||:= stm(free('$' || dollar))
 return stm ('emit' || ReTkn(q) || paras('$' || dollar) )
end

function ReTkn(a)
 cond inf2[eval(a)] { case 'IDENTIFIER'        : return 'idt'
                      case 'NUMERIC_LITERAL'   : return 'nbr'
                      case 'CHARACTER_LITERAL' : return 'chr'
                      case 'STRING_LITERAL'    : return 'str'
                                       default : return 'xxx'  }
end

function skp()
 dollar +:= 1
end

function dodef(s,t)
 return '#ifdef'  || bln_ || s || crlf_ || t || '#endif'
end

function stm(s)
 return dupl(bln_,20) || s || ';' || crlf_
end

function malloc(x)
 return 'malloc' || paras(x)
end

function cdcl1(x,y)
 return x || bln_ || y
end

function cdcl2(x,y)
 return x || bln_ || '*' || y
end

function cast2(x)
 return paras(x || bln_ || '*')
end

function free(s)
 return 'free' || paras(s)
end

function Place(a,b)
 if inf1[b]==='' then { bmp +:= 1
                                           inf1[b]   := bmp
                         if a==='S1T' then inf2[bmp] := tix1(b)
                                      else
                         if a==='S2T' then inf2[bmp] := tix2(b)
                                      else
                         if a==='CMT' then inf2[bmp] := cmt(b)
                                      else inf2[bmp] := b }

 return hi(a || inf1[b])
end

function hi(s)
 local c,t
  while s ?- lm_ & len(1).c do if asc(c)>127 then t ||:= c
                                             else t ||:= chr(asc(c)+128)
 return t
end

function lo(s)
 local c,t
  while s ?- lm_ & len(1).c do if asc(c)>127 then t ||:= chr(asc(c)-128)
                                             else t ||:= c
 return t
end

function UnTkn(s)
 local tmp
  repeat s ? tknident.tmp <- Place('TKN',upper_(tmp))
 return s
end

function UnKyw(s)
 local tmp,c1,c2
  repeat s ? nx1.c1 & keywords.tmp & nx1.c2 <- c1 ||
                                            Place('KYW',tmp) || c2
 return s
end

function UnNtm(s)
 local tmp
  repeat s ? nonterms.tmp <- Place('NTM',tmp)
 return s
end

function UnStr1(s)
 local tmp
  s ? tic1 & arbno((backslant&tic1)|
                    notany(tic1)|(tic1&tic1)).tmp &
                           tic1 <- Place('S1T',tmp)
 return s
end

function UnStr2(s)
 local tmp
  s ? tic2 & arbno((backslant&tic2)|
                    notany(tic2)|(tic2&tic2)).tmp &
                           tic2 <- Place('S2T',tmp)
 return s
end


function UnComt(s)
 local tmp
  s ? "/*" & arbno(break('*')|('*'&notany('/'))).tmp &
      "*/" <- Place('CMT',tmp)
 return s
end

function Sane(s)
 local tmp
  while s ? (tic1|tic2|"/*").tmp do cond tmp { case tic1 : s := UnStr1(s)
                                               case tic2 : s := UnStr2(s)
                                               case "/*" : s := UnComt(s) }
  repeat s ?- '#ifdef' & break('#') & '#endif'
  repeat s ?- '{' & brc & '}'
 return UnNtm(UnKyw(UnTkn(s)))
end