source: applications/trunk/LFC/ToASR/ToASR.rf @ 3895

$module ToASR;

$use Access Arithm Convert Box List StdIO;
$use Parser GrammarParser;

$func Comp e.ast = e.asr;
Comp {
  (FUNC t.name (e.func_type) (e.var_decls) e.sentences) e.rest =
    e.func_type : e.types t,
    <Store &Idx 0>,
    <Map &GenerArg (e.types)> :: e.args,
    (LOCAL FUNC <RefName t.name> (e.args) ((EVAR)) (BRANCH (LEFT e.args) (CUTALL)
      <Map &CallEarley (e.args)>
      (ALT <Map &CompSentence (e.args) (e.var_decls) (e.sentences)>)
    ))
    <Comp e.rest>;
  t1 e.rest = t1 <Comp e.rest>;
  /*empty*/ = /*empty*/;
};

$box Idx;

$func GenerArg t.type = t.var;
GenerArg (TYPE (e.name)) =
  <Get &Idx> : s.n,
  <Store &Idx <Add s.n 1>>,
  (EVAR (s.n e.name));

$func CallEarley t.var = e.call;
CallEarley (EVAR (s.n e.name)) =
  (RESULT (CALL (Earley Earley) (PAREN TYPE (PAREN e.name)) (EVAR (s.n e.name))))
  (FORMAT (EVAR (s.n)));

$func CompSentence (e.args) (e.var_decls) t.sentence = e.branch;
CompSentence (e.args) (e.var_decls) (SENTENCE t.name (e.patterns) e.exp) =
  <Store &Idx 0>,
  (BRANCH <Map &CompPattern (e.args) (e.var_decls) (e.patterns)> (CUTALL) (RESULT <Map &CompTerm (e.exp)>));

$func CompPattern (e.args) (e.var_decls) t.pattern = e.pattern;
CompPattern (e.args) (e.var_decls) (e.pattern) =
  <Get &Idx> : s.n,
  <Store &Idx <Add s.n 1>>,
  <L s.n e.args> : (EVAR (s.n e.type_name)),
  (RESULT (EVAR (s.n)))
  (LEFT <FreshEVAR> (PAREN (PAREN TYPE (PAREN e.type_name) (EVAR (0 s.n))) <Map &VarType (e.var_decls) (e.pattern)> DOT 0) <FreshEVAR>)
  (RESULT (CALL (Earley RemoveParens) (EVAR (0 s.n))))
  (LEFT <Map &GetVar (e.pattern)>);

$func VarType (e.var_decls) t.pat = t.pat;
VarType (e.var_decls) t.pat, {
  t.pat : (VAR t.name) =
    e.var_decls : e (e t.pat e (TYPE (e.type_name))) e = (PAREN TYPE (PAREN e.type_name));
  t.pat;
};

$func GetVar t.pat = e.var;
GetVar {
  (VAR t.name) = (PAREN (EVAR t.name));
  t = ;
};

$func CompTerm t.term = e.asr;
CompTerm {
  (UNDEFINED) = (ERROR (BRANCH (RESULT UNDEFINED)));
  s.char = s.char;
  (VAR t.name) = (EVAR t.name);
  (CALL t.name e.args) = (CALL <RefName t.name> <Map &CompArg (e.args)>);
  (IF (e.cond) (e.exp_true) (e.exp_false)) = (ALT
    (BRANCH (RESULT <Map &CompTerm (e.cond)>) (LEFT 'True') (CUTALL) <Map &CompTerm (e.exp_true)>)
    (BRANCH <Map &CompTerm (e.exp_false)>)
  );
  t1 = t1;
};

$func CompArg t.arg = e.asr;
CompArg (e.exp) = (PAREN <Map &CompTerm (e.exp)>);

$box FreeIdx;
$func FreshEVAR = t.var;
FreshEVAR = {
  <Get &FreeIdx> : s.n =
    <Store &FreeIdx <Add s.n 1>>,
    (EVAR (s.n));
  <Store &FreeIdx 101>,
    (EVAR (100));
};

$func GenerMain t.fname e.grammar = t.func;
GenerMain t.fname e.grammar =
  (LOCAL FUNC <RefName ('Main')> () ((EVAR)) (BRANCH (LEFT) (CUTALL)
    (RESULT (CALL (Earley Init) e.grammar))
    (RESULT (CALL <RefName t.fname>))
  ));

$func AddPAREN e = e;
AddPAREN {
  (e1) e2 = (PAREN <AddPAREN e1>) <AddPAREN e2>;
  s1 e2 = s1 <AddPAREN e2>;
  /*empty*/ = /*empty*/;
};

$box ModuleName;

$func RefName t.name = t.ref_name;
RefName (e.chars) = (<Get &ModuleName> <ToWord e.chars>);

$func Main = e;
Main =
  <ParseFile "samples.lfc"> :: e.ast,
  <AddPAREN <ParseGrammarFile "samples.g">> :: e.grammar,
  <Store &ModuleName "samples">,
  (IMPORT FUNC ("refal" "plus" StdIO WriteLn) ((EVAR)) ())
  (IMPORT FUNC (Earley Init) ((EVAR)) ())
  (IMPORT FUNC (Earley RemoveParens) ((EVAR)) ((EVAR)))
  (IMPORT FUNC (Earley Earley) ((TVAR) (EVAR)) ((EVAR))) :: e.imports,
  <Channel> :: s.ch,
  <OpenFile s.ch "samples.asr" W>,
  <WriteLnCh s.ch (MODULE (<Get &ModuleName>) e.imports <Comp e.ast> <GenerMain ('isBit') e.grammar>)>,
  <CloseChannel s.ch>;