Eval.borg

`*-----------------------------------*`
`*          >>>Pico v.1.1<<<         *`
`*            Theo D'Hondt           *`
`*  VUB Programming Technology Lab   *`
`*              (c)1999              *`
`*-----------------------------------*`
`*             evaluator             *`
`*      (METACIRCULAR VERSION)       *`
`*-----------------------------------*`

{ Eval(Exp):
    Error('evaluator not initialized');

  Apply(Fun, Tab):
    Error('evaluator not initialized');

  Capture():
    Error('evaluator not initialized');

  Init_Eval(Dct):
    { DCT: Dct;

      eval_reference(Ref)::
        { nam: Ref[REF_NAM_idx];
          Get_Any(nam, DCT) };

      call_function(Exp, Dct)::
        { dct: DCT;
          DCT:= Dct;
          val: Eval(Exp);
          DCT:= dct;
          val };

      bind_reference(Exp, Ref, Dct)::
        { nam: Ref[REF_NAM_idx];
          val: Eval(Exp);
          Add_Var(nam, val, Dct) };

      bind_application(Exp, Apl, Dct)::
        { nam: Apl[APL_NAM_idx];
          arg: Apl[APL_ARG_idx];
          fun: Make_FUN(nam, arg, Exp, DCT);
          Add_Var(nam, fun, Dct) };

      bind_error(Tab, Err, Dct)::
        Error('illegal parameter');

      bind_case:: case(REF_tag <> bind_reference,
                       APL_tag <> bind_application,
                          void <> bind_error);

      call_table(TbA, TbP, Dct)::
        { tbA: TbA[TAB_TAB_idx];
          tbP: TbP[TAB_TAB_idx];
          siz: size(tbA);
          if(siz = size(tbP),
             for(k: 1, k <= siz, k:= k+1,
                 { arg: tbA[k];
                   par: tbP[k];
                   tag: par[TAG_idx];
                   cas: bind_case(tag);
                   Dct:= cas(arg, par, Dct) }),
             Error('illegal argument count'));
          Dct };

      call_reference(Tab, Ref, Dct)::
        { nam: Ref[REF_NAM_idx];
          tab: Tab[TAB_TAB_idx];
          siz: size(tab);
          exp: if(siz > 0,
                  { idx: 0;
                    arg[siz]: Eval(tab[idx:= idx+1]);
                    Make_TAB(arg) },
                  _EMPTY_);
          Add_Var(nam, exp, Dct) };

      call_error(Tab, Apl, Dct)::
        Error('illegal parameter');

      call_case:: case(TAB_tag <> call_table,
                       REF_tag <> call_reference,
                          void <> call_error);

      eval_call(Fun, Tab)::
        { par: Fun[FUN_PAR_idx];
          exp: Fun[FUN_EXP_idx];
          dct: Fun[FUN_DCT_idx];
          tag: par[TAG_idx];
          cas: call_case(tag);
          dct:= cas(Tab, par, dct);
          call_function(exp, dct) };

      application(Exp, Arg)::
        { if(Arg[TAG_idx] != TAB_tag,
             Arg:= Eval(Arg));
          if(Arg[TAG_idx] = TAB_tag,
            if(Exp[TAG_idx] = FUN_tag,
               eval_call(Exp, Arg),
               if(Exp[TAG_idx] = NAT_tag,
                 { nat: Exp[NAT_NAT_idx];
                   nat@Arg },
                 Error('(native) function required'))),
            Error('illegal argument')) };

      eval_application(Apl)::
        { nam: Apl[APL_NAM_idx];
          arg: Apl[APL_ARG_idx];
          exp: Get_Any(nam, DCT);
          application(exp, arg) };

      tabulation(Exp, Idx)::
        if(Idx[TAG_idx] = TAB_tag,
          { itb: Idx[TAB_TAB_idx];
            siz: size(itb);
            loop(Tab, Cnt):
              { val: Eval(itb[Cnt]);
                if(val[TAG_idx] = NBR_tag,
                  { nbr: val[NBR_VAL_idx];
                    tag: Tab[TAG_idx];
                    if(nbr>0,
                      if(tag = TAB_tag,
                        { tab: Tab[TAB_TAB_idx];
                          if(nbr > size(tab),
                            Error('index beyond size'),
                            if(Cnt < siz,
                              loop(tab[nbr], Cnt+1),
                              tab[nbr])) },
                        if(nbr > SIZ_tab(tag),
                          Error('index beyond size'),
                          if(Cnt < siz,
                            loop(Tab[nbr+1], Cnt+1),
                            Tab[nbr+1]))),
                      Error('non-positive index')) },
                  Error('invalid size')) };
            loop(Exp, 1) },
          Error('indexes required'));

      eval_tabulation(Tbl)::
        { nam: Tbl[TBL_NAM_idx];
          idx: Tbl[TBL_IDX_idx];
          exp: Get_Any(nam, DCT);
          tabulation(exp, idx) };

      message_reference(Ref, Dct)::
        { nam: Ref[REF_NAM_idx];
          Get_Cst(nam, Dct) };

      message_application(Apl, Dct)::
        { nam: Apl[APL_NAM_idx];
          arg: Apl[APL_ARG_idx];
          fun: Get_Cst(nam, Dct);
          application(fun, arg) };

      message_tabulation(Tbl, Dct)::
        { nam: Tbl[TBL_NAM_idx];
          idx: Tbl[TBL_IDX_idx];
          exp: Get_Cst(nam, Dct);
          tabulation(exp, idx) };

      message_error(Nam, Inv)::
         Error('abstract grammar violation');

      message_case:: case(REF_tag <> message_reference,
                          APL_tag <> message_application,
                          TBL_tag <> message_tabulation,
                             void <> message_error);

      eval_message(Mes)::
        { nam: Mes[MES_NAM_idx];
          exp: Get_Any(nam, DCT);
          if((exp[TAG_idx] != VAR_tag)&(exp[TAG_idx] != CST_tag),
            Error('dictionary required'),
            { inv: Mes[MES_INV_idx];
              tag: inv[TAG_idx];
              cas: message_case(tag);
              cas(inv, exp) }) };

      add_reference(Ref, Exp, Add)::
        { nam: Ref[REF_NAM_idx];
          val: Eval(Exp);
          DCT:= Add(nam, val, DCT);
          val };

      add_application(Apl, Exp, Add)::
        { nam: Apl[APL_NAM_idx];
          arg: Apl[APL_ARG_idx];
          fun: Make_FUN(nam, arg, Exp, _VOID_);
          DCT:= Add(nam, fun, DCT);
          fun[FUN_DCT_idx]:= DCT;
          fun };

      add_tabulation(Tbl, Exp, Add)::
        { nam: Tbl[TBL_NAM_idx];
          idx: Tbl[TBL_IDX_idx];
          if(idx[TAG_idx] = TAB_tag,
             { itb: idx[TAB_TAB_idx];
               siz: size(itb);
               loop(cnt):
                 { val: Eval(itb[cnt]);
                   if(val[TAG_idx] = NBR_tag,
                      { nbr: val[NBR_VAL_idx];
                        if(nbr>0,
                           { tab[nbr]: if(cnt1),
                                                   Eval(Exp));
                             Make_TAB(tab) },
                           Error('non-positive index')) },
                   Error('invalid size')) };
               tab: loop(1);
               DCT:= Add(nam, tab, DCT);
               tab },
             Error('indexes required')) };

      add_error(Inv, Exp, Add)::
         Error('abstract grammar violation');

      add_case:: case(REF_tag <> add_reference,
                      APL_tag <> add_application,
                      TBL_tag <> add_tabulation,
                         void <> add_error);

      eval_definition(Def)::
        { inv: Def[DEF_INV_idx];
          exp: Def[DEF_EXP_idx];
          tag: inv[TAG_idx];
          cas: add_case(tag);
          cas(inv, exp, Add_Var) };

      eval_declaration(Dcl)::
        { inv: Dcl[DCL_INV_idx];
          exp: Dcl[DCL_EXP_idx];
          tag: inv[TAG_idx];
          cas: add_case(tag);
          cas(inv, exp, Add_Cst) };

      assign_reference(Ref, Exp)::
        { nam: Ref[REF_NAM_idx];
          val: Eval(Exp);
          Set_Var(nam, val, DCT);
          val };

      assign_application(Apl, Exp)::
        { nam: Apl[APL_NAM_idx];
          arg: Apl[APL_ARG_idx];
          fun: Make_FUN(nam, arg, Exp, DCT);
          Set_Var(nam, fun, DCT);
          fun };

      assign_tabulation(Tbl, Exp)::
        { nam: Tbl[TBL_NAM_idx];
          exp: Get_Any(nam, DCT);
          idx: Tbl[TBL_IDX_idx];
          if(idx[TAG_idx] = TAB_tag,
            { itb: idx[TAB_TAB_idx];
              siz: size(itb);
              loop(Tab, Cnt):
                { val: Eval(itb[Cnt]);
                  if(val[TAG_idx] = NBR_tag,
                    { nbr: val[NBR_VAL_idx];
                      tag: Tab[TAG_idx];
                      if(nbr>0,
                        if(tag = TAB_tag,
                          { tab: Tab[TAB_TAB_idx];
                            if(nbr > size(tab),
                              Error('index beyond size'),
                              if(Cnt < siz,
                                loop(tab[nbr], Cnt+1),
                                tab[nbr]:= Eval(Exp))) },
                          if(nbr > AG_range(tag),
                            Error('index beyond size'),
                            if(Cnt < siz,
                              loop(Tab[nbr+1], Cnt+1),
                              Tab[nbr+1]:= Eval(Exp)))),
                        Error('non-positive index')) },
                    Error('invalid size')) };
              loop(exp, 1) },
            Error('indexes required')) };

      assign_error(Inv, Exp)::
         Error('abstract grammar violation');

      assign_case:: case(REF_tag <> assign_reference,
                         APL_tag <> assign_application,
                         TBL_tag <> assign_tabulation,
                            void <> assign_error);

      eval_assignment(Exp)::
        { inv: Exp[SET_INV_idx];
          exp: Exp[SET_EXP_idx];
          tag: inv[TAG_idx];
          cas: assign_case(tag);
          cas(inv, exp) };

      eval_identity(Exp)::
        Exp;

      eval_error(Inv, Exp)::
         Error('abstract grammar violation');

      eval_case:: case(VOI_tag <> eval_identity,
                       NAT_tag <> eval_identity,
                       FRC_tag <> eval_identity,
                       TXT_tag <> eval_identity,
                       TAB_tag <> eval_identity,
                       FUN_tag <> eval_identity,
                       REF_tag <> eval_reference,
                       APL_tag <> eval_application,
                       TBL_tag <> eval_tabulation,
                       MES_tag <> eval_message,
                       DEF_tag <> eval_definition,
                       DCL_tag <> eval_declaration,
                       SET_tag <> eval_assignment,
                       VAR_tag <> eval_identity,
                       CST_tag <> eval_identity,
                       CTX_tag <> eval_identity,
                       NBR_tag <> eval_identity,
                          void <> eval_error);

      Init_Eval(Dct):=
        { DCT:= Dct;
          void };

      Eval(Exp):=
        { tag: Exp[TAG_idx];
          cas: eval_case(tag);
          cas(Exp) };

      Apply(Fun, Tab):=
        if(Fun[TAG_idx] = FUN_tag,
           eval_call(Fun, Tab),
           { nat: Fun[NAT_NAT_idx];
             nat@Tab });

      Capture():=
        DCT;

      void };

  display('evaluator .... installed', eoln) }