MODULE M3Query;

(* Copyright (C) 1991, Digital Equipment Corporation           *)
(* All rights reserved.                                        *)
(* See the file COPYRIGHT for a full description.              *)

IMPORT IO, IOErr, TextStream, Err, Fmt, StdIO, Text, PropertyV;
IMPORT M3Context, M3Error, M3CUnit, M3CUnit_priv, M3Assert;
IMPORT M3CParse, M3CSrcPos, M3CId, M3CLiteral, M3CGoList, M3CGo;
IMPORT AST, M3AST, M3AST_AS, M3AST_FE, SeqM3AST_AS_STM, SeqM3AST_AS_EXP; 
IMPORT ASTWalk;
IMPORT M3ASTQueryImpl;
IMPORT M3CBackEnd_C;
IMPORT Rd, Bundle, M3CheckBundle;

IMPORT M3AST_AS_F, M3AST_SM_F, M3AST_FE_F, M3AST_TL_F;

CONST
  M3ASTQueryText = "M3ASTQuery";
  EvalQueryText = "EvalQuery";
  MainText = "Main";
  M3ASTQueryBundleText = "M3ASTQuery.i3.tb";
  EvalQueryBundleText = "EvalQuery.m3.tb";

VAR
  parser_g: M3CParse.T := NIL;
  parse_errors_g := FALSE;
  init_g := FALSE;
  br_context_g: M3Context.T := NIL;
  eval_ast_g: M3AST_AS.Compilation_Unit;
  sem_err_handler_g := NEW(M3Error.Notification, notify := SemErrorHandler);

TYPE MyErrorHandler = M3CParse.ErrorHandler OBJECT
  OVERRIDES
    handle := ParseErrorHandler;
  END;

PROCEDURE Context(c: M3Context.T; expr: TEXT) RAISES {}=
  BEGIN 
    IF NOT init_g THEN
      VAR
        bundle := M3CheckBundle.Get();
        main_cu: M3AST_AS.Compilation_Unit;
        phases := M3CGoList.AllPhases;
      BEGIN
        br_context_g := M3Context.New();
        M3CGoList.CompileUnitsInContext(br_context_g,
                                        ARRAY OF TEXT{MainText},
                                        ARRAY OF TEXT{}, ARRAY OF TEXT{},
                                        phases);
        M3Context.Add(br_context_g, M3ASTQueryText, M3CUnit.Type.Interface,
           CompileFromBundle(br_context_g, bundle, M3ASTQueryBundleText));
        eval_ast_g := CompileFromBundle(br_context_g, bundle,
                                        EvalQueryBundleText);
        M3Context.Add(br_context_g, EvalQueryText, M3CUnit.Type.Module,
                      eval_ast_g);
        AttributeQueryProcs();
        init_g := TRUE;
      END;
    END; (* if *)
    Compile(c, expr);
  END Context;

PROCEDURE CompileFromBundle(
    c: M3Context.T;
    b: Bundle.T;
    elem: TEXT): M3AST_AS.Compilation_Unit
    RAISES {}=
  BEGIN
      VAR s := TextStream.Open(Bundle.Get(b, elem));
        cu := M3AST_AS.NewCompilation_Unit();
        status := M3CUnit.AllPhases;
      BEGIN
        M3CGo.CompileUnit(cu, c, s, ImportedUnitProc, status, NIL);
        cu.fe_uid := NEW(M3CUnit.Uid, filename := elem);
        RETURN cu;
      END;
  END CompileFromBundle;

PROCEDURE ImportedUnitProc(
    name: TEXT;
    unitType: M3CUnit.Type;
    context: M3Context.T;
    VAR (*out*) cu: M3AST_AS.Compilation_Unit
    ): BOOLEAN=
  BEGIN
    M3Assert.Check(M3Context.Find(context, name, unitType, cu));
    RETURN TRUE;
  END ImportedUnitProc;

PROCEDURE AttributeQueryProcs() RAISES {}=
  VAR cu: M3AST_AS.Compilation_Unit;
  BEGIN
    M3Assert.Check(
       M3Context.Find(br_context_g, M3ASTQueryText, M3CUnit.Type.Interface,
       cu));
    ASTWalk.VisitNodes(cu, NEW(ASTWalk.Closure,
        callback := AttributeQueryProcOnNode));
  END AttributeQueryProcs;

PROCEDURE AttributeQueryProcOnNode(cl: ASTWalk.Closure; n: AST.NODE;
    vm: ASTWalk.VisitMode) RAISES {}=
  BEGIN
    TYPECASE n OF
    | M3AST_AS.Proc_id(p) =>
        PropertyV.Put(p.tl_pset, M3ASTQueryImpl.FindProc(
            M3CId.ToText(p.lx_symrep)));
    ELSE    
    END; 
  END AttributeQueryProcOnNode;


PROCEDURE Compile(c: M3Context.T; expr: TEXT) RAISES {}=
  VAR
    s := TextStream.Open(expr);
    p := NewParser(s);
    node: REFANY;
  BEGIN
    TRY
      parse_errors_g := FALSE;
      node := M3CParse.Any(p);
      IF parse_errors_g THEN RETURN END;

      TYPECASE node OF
      | M3AST_AS.EXP(e) =>
          VAR
            phases := M3AST_FE.Unit_status{M3AST_FE.Unit_state.SemChecked};
          BEGIN
            PasteIn(e);
            M3CUnit.ExclState(eval_ast_g.fe_status, M3CUnit.State.SErrors);
            M3CUnit.ExclState(eval_ast_g.fe_status, M3CUnit.State.SemChecked);
            M3Error.AddNotification(sem_err_handler_g);
            M3Error.SetCu(eval_ast_g);
            M3CGo.CompileUnit(eval_ast_g, br_context_g, NIL, ResolveImports,
              phases, NIL);
            IF M3AST_FE.Unit_state.SErrors IN eval_ast_g.fe_status THEN 
              M3Error.ShowAll(e);
            ELSE
              EvalQuery(c, e);
            END;
            M3Error.RemoveNotification(sem_err_handler_g);
          END;
      ELSE
        IO.PutF(StdIO.Err(), "invalid query expression\n");
      END; (* typecase *)
    FINALLY
      IOErr.Close(s, Err.Severity.Warning);
    END; (* try *)
  END Compile;

PROCEDURE ResolveImports(
    name: TEXT;
    unitType: M3CUnit.Type;
    context: M3Context.T;
    VAR (*out*) cu: M3AST_AS.Compilation_Unit
    ): BOOLEAN RAISES {}=
  BEGIN
    M3Assert.Check(M3Context.Find(br_context_g, name, unitType, cu));
  END ResolveImports;


PROCEDURE PasteIn(e: M3AST_AS.EXP) RAISES {}=
  VAR eval_st: M3AST_AS.Eval_st :=
          SeqM3AST_AS_STM.First(
          NARROW(eval_ast_g.as_root, M3AST_AS.UNIT_NORMAL).as_block.as_stm_s);
  BEGIN
    eval_st.as_exp := e;
  END PasteIn;

EXCEPTION Bad;

PROCEDURE RaiseBad() RAISES {Bad}=
  BEGIN
    RAISE Bad;
  END RaiseBad;


TYPE
  EvalContext_Closure = M3Context.Closure OBJECT
    query: M3AST_AS.EXP;
  OVERRIDES
    callback := EvalQueryOnUnit;
  END;

  EvalWalk_Closure = ASTWalk.Closure OBJECT
    ccl: EvalContext_Closure;
  OVERRIDES
    callback := EvalQueryOnNode;
  END;

PROCEDURE EvalQuery(c: M3Context.T; e: M3AST_AS.EXP) RAISES {}=
  VAR
    ccl := NEW(EvalContext_Closure, query := e);
  BEGIN
    TRY
      M3Context.Apply(c, ccl, FALSE);
    EXCEPT
    | Bad => 
        IO.PutF(StdIO.Err(), "invalid query expression\n");
    END;
  END EvalQuery;

PROCEDURE EvalQueryOnUnit(     
      ccl: EvalContext_Closure;
      ut: M3CUnit.Type;
      name: TEXT;
      cu: M3AST_AS.Compilation_Unit) RAISES {Bad}=
    VAR wcl := NEW(EvalWalk_Closure, ccl := ccl);
  BEGIN    
    M3Error.SetCu(cu); 
    ASTWalk.VisitNodes(cu, wcl);
    M3Error.ShowAll(cu.as_root);  
  END EvalQueryOnUnit;


PROCEDURE EvalQueryOnNode(cl: EvalWalk_Closure;
    n: AST.NODE; vm: ASTWalk.VisitMode) RAISES {Bad}=
  VAR
    cr: CallResult; rb: BOOLEAN; rn: M3AST.NODE; rc: INTEGER;
  BEGIN
    cr := Eval(cl.ccl.query, n, rb, rn, rc);
    IF cr =  CallResult.Bool THEN
      IF rb THEN M3Error.Report(n, "match"); END; 
    ELSE RaiseBad();
    END; (* if *)
  END EvalQueryOnNode;

TYPE CallResult = {Bool, Int, Node};

PROCEDURE Eval(e: M3AST_AS.EXP; n: M3AST.NODE;
    VAR (*out*) rb: BOOLEAN; VAR (*out*) rn: M3AST.NODE;
    VAR (*out *) rc: INTEGER;
    ): CallResult RAISES {Bad}=
  VAR
    cr1, cr2: CallResult;
    c1, c2: INTEGER; b1, b2: BOOLEAN; n1, n2: M3AST.NODE;
  BEGIN
    TYPECASE e OF
    | M3AST_AS.Binary(b) =>
        cr1 := Eval(b.as_exp1, n, b1, n1, c1);
        TYPECASE b.as_binary_op OF
        | M3AST_AS.Eq =>
            cr2 := Eval(b.as_exp2, n, b2, n2, c2);
            CASE cr1 OF
            | CallResult.Int => rb := c1 = c2; RETURN CallResult.Bool;
            | CallResult.Node => rb := n1 = n2; RETURN CallResult.Bool;
            | CallResult.Bool => rb := b1 = b2; RETURN CallResult.Bool;
            END; (* case *)
        | M3AST_AS.Ne =>
            cr2 := Eval(b.as_exp2, n, b2, n2, c2);
            CASE cr1 OF
            | CallResult.Int => rb := c1 # c2; RETURN CallResult.Bool;
            | CallResult.Node => rb := n1 # n2; RETURN CallResult.Bool;
            | CallResult.Bool => rb := b1 # b2; RETURN CallResult.Bool;
            END; (* case *)
        | M3AST_AS.Ge, M3AST_AS.Gt, M3AST_AS.Le, M3AST_AS.Lt =>
            cr2 := Eval(b.as_exp2, n, b2, n2, c2);
            TYPECASE b.as_binary_op OF
            | M3AST_AS.Ge =>  rb := c1 >= c2; RETURN CallResult.Bool;
            | M3AST_AS.Gt =>  rb := c1 > c2; RETURN CallResult.Bool;
            | M3AST_AS.Le =>  rb := c1 <= c2; RETURN CallResult.Bool;
            | M3AST_AS.Lt =>  rb := c1 < c2; RETURN CallResult.Bool;
            END;
        | M3AST_AS.And =>
            IF b1 THEN
              cr2 := Eval(b.as_exp2, n, b2, n2, c2);
              rb := b2;
            ELSE
              rb := FALSE;
            END;
            RETURN CallResult.Bool;
        | M3AST_AS.Or =>
            IF b1 THEN
              rb := TRUE;
            ELSE
              cr2 := Eval(b.as_exp2, n, b2, n2, c2);
              rb := b2;
            END; (* if *)
            RETURN CallResult.Bool;
        ELSE RaiseBad();
        END;
    | M3AST_AS.Unary(u) =>
        cr1 := Eval(u.as_exp, n, b1, n1, c1);
        TYPECASE u.as_unary_op OF
        | M3AST_AS.Not => rb := NOT b1; RETURN CallResult.Bool;
        ELSE RaiseBad();
        END; (* typecase *)
    | M3AST_AS.Call(c) =>
        CASE EvalCall(c, n, b1, n1, c1) OF
        | CallResult.Bool => rb := b1; RETURN CallResult.Bool;
        | CallResult.Node => rn := n1; RETURN CallResult.Node;
        | CallResult.Int => rc := c1; RETURN CallResult.Int;
        END;
    | M3AST_AS.Integer_literal(l) =>
        rc := NARROW(l.sm_exp_value, M3CBackEnd_C.Integer_value).sm_value;
        RETURN CallResult.Int;
    ELSE RaiseBad();
    END; (* typecase *)
  END Eval;

PROCEDURE EvalCall(c: M3AST_AS.Call; n: M3AST.NODE;
    VAR (*out*) rb: BOOLEAN; VAR (*out*) rn: M3AST.NODE;
    VAR (*out *) rc: INTEGER;
    ): CallResult RAISES {Bad}=
  VAR
    proc := PropertyV.GetSub(
        NARROW(c.as_callexp, M3AST_AS.Exp_used_id).vUSED_ID.sm_def.tl_pset,
        TYPECODE(M3ASTQueryImpl.Proc));
    iter_actuals := SeqM3AST_AS_EXP.NewIter(c.sm_actual_s);
    actual: M3AST_AS.EXP;
    actuals: ARRAY [0..9] OF M3AST_AS.EXP;
    i := 0;
  BEGIN
    WHILE SeqM3AST_AS_EXP.Next(iter_actuals, actual) DO
      actuals[i] := actual; INC(i);
    END; (* while *)
    IF NOT ISTYPE(actuals[i-1], M3AST_AS.Nil_literal) THEN
      VAR rb: BOOLEAN; rn: M3AST.NODE;
      BEGIN
        IF EvalCall(actuals[i-1], n, rb, rn, rc) = CallResult.Node THEN
          n := rn;
        ELSE RaiseBad();
        END;
      END;
    END; (* if *)
    TRY
      TYPECASE proc OF
      | NULL => RaiseBad();
      | M3ASTQueryImpl.NodeToBoolProc(p) =>
          rb := p.p(n); RETURN CallResult.Bool;
      | M3ASTQueryImpl.NodeAndTextToBoolProc(p) =>
          rb := p.p(TextValue(actuals[0]), n); RETURN CallResult.Bool;
      | M3ASTQueryImpl.NodeToNodeProc(p) =>
          rn := p.p(n); RETURN CallResult.Node;
      | M3ASTQueryImpl.NodeToIntProc(p) =>
          rc := p.p(n); RETURN CallResult.Int;
      | M3ASTQueryImpl.NodeAndIntToNodeProc(p) =>
          rn := p.p(IntValue(actuals[0]), n); RETURN CallResult.Int;
      END; (* if *)
    EXCEPT
    | M3ASTQueryImpl.BadAttribute => RaiseBad();
    END;
  END EvalCall;

PROCEDURE TextValue(e: M3AST_AS.EXP): TEXT RAISES {}=
  BEGIN
    RETURN NARROW(e.sm_exp_value, M3CBackEnd_C.Text_value).sm_value;
  END TextValue;


PROCEDURE IntValue(e: M3AST_AS.EXP): INTEGER RAISES {}=
  BEGIN
    RETURN NARROW(e.sm_exp_value, M3CBackEnd_C.Integer_value).sm_value;
  END IntValue;


<*INLINE*> PROCEDURE NewParser(input: IO.Stream): M3CParse.T RAISES {}=
  BEGIN
    (* reuse global parser *)
    IF parser_g = NIL THEN
      parser_g := M3CParse.New(input, M3CId.Table(), M3CLiteral.Table(),
        NEW(MyErrorHandler));
    ELSE
      M3CParse.Reset(parser_g, s := input);
    END; (* if *)
    RETURN parser_g;
  END NewParser;

PROCEDURE SemErrorHandler(n: M3Error.Notification;
                          cu: M3AST_AS.Compilation_Unit; e: BOOLEAN)=
  BEGIN
    IF e THEN M3CUnit.InclState(cu.fe_status, M3CUnit.State.SErrors); END;
  END SemErrorHandler;

PROCEDURE ParseErrorHandler(
    h: MyErrorHandler;
    pos: M3CSrcPos.T;
    msg: TEXT)
    RAISES {}=
  VAR line, linePos: CARDINAL;
  BEGIN
    line := M3CSrcPos.Unpack(pos, linePos);
    IO.PutF(StdIO.Err(),
        "line %s,%s: %s\n", Fmt.Int(line), Fmt.Int(linePos), msg);
    parse_errors_g := TRUE;
  END ParseErrorHandler;


BEGIN

END M3Query.