obliqparse/src/ObFrame.m3


 Copyright 1991 Digital Equipment Corporation.               
 Distributed only by permission.                             
MODULE ObFrame;
IMPORT ObErr, SynWr, SynScan, Rd, TextRd, Lex, FileRd, Text, OSError,
       Pathname, ObLib, ObValue, SynLocation, ObEval, Thread,
       ObCommand, Fmt, Fingerprint, Pickle2 AS Pickle, Wr,
       PickleStubs, NetObj, TextList;
IMPORT Env AS ProcessEnv;
IMPORT ObPathSep;

PROCEDURE FmtSearchPath(searchPath: SearchPath): TEXT  =
  BEGIN
    IF searchPath=NIL THEN RETURN "";
    ELSIF searchPath.rest=NIL THEN RETURN searchPath.first;
    ELSE RETURN
      searchPath.first &
        Text.FromChar(SearchPathSeparator) &
        FmtSearchPath(searchPath.rest);
    END;
  END FmtSearchPath;

PROCEDURE LexSearchPath(rd: TextRd.T): SearchPath =
  VAR item, junk: TEXT; rest: SearchPath;
  BEGIN
    TRY
      IF Rd.EOF(rd) (* NOWARN *) THEN RETURN NIL
      ELSE
        junk :=
            Lex.Scan(rd, (* NOWARN *)
                     Lex.Blanks + SET OF CHAR{SearchPathSeparator}); (*NOWARN*)
        item :=
            Lex.Scan(rd, (* NOWARN *)
                     Lex.NonBlanks - SET OF CHAR{SearchPathSeparator});(*NOWARN*)
        IF Text.Empty(junk) AND Text.Empty(item) THEN RETURN NIL END;
        rest := LexSearchPath(rd);
        IF Text.Empty(item) THEN RETURN rest;
        ELSIF NOT Pathname.Valid(item) THEN RETURN rest;
        ELSE RETURN NEW(SearchPath, first:=item, rest:=rest);
        END;
      END;
    EXCEPT
    | Rd.Failure, Thread.Alerted => RETURN NIL;
    END;
  END LexSearchPath;

PROCEDURE PostFile(sc: SynScan.T; filename: Pathname.T): BOOLEAN =
  VAR rd: Rd.T;
  BEGIN
    TRY
      rd:= FileRd.Open(filename);
      SynWr.Text(SynWr.out, "Loading '" & filename & "'\n");
      SynScan.PushInput(sc, Pathname.Last(filename), rd, TRUE, TRUE);
      RETURN TRUE;
    EXCEPT OSError.E => RETURN FALSE
    END;
  END PostFile;

PROCEDURE LoadFile(sc: SynScan.T; filename: Pathname.T;
  complain: BOOLEAN:=TRUE) =
  VAR scan: SearchPath;
  BEGIN
    IF Pathname.Valid(filename) THEN
      IF Pathname.Absolute(filename) THEN
        IF PostFile(sc, filename) THEN RETURN END;
      ELSE
        scan := searchPath;
        WHILE scan # NIL DO
          IF PostFile(sc,
               Pathname.Join(scan.first, filename, NIL))
          THEN RETURN
          END;
          scan := scan.rest;
        END;
      END;
    END;
    IF complain THEN
      SynScan.ErrorMsg(sc, "Could not open file '" & filename
        & "' along path '" & FmtSearchPath(searchPath) & "'");
    END;
  END LoadFile;

PROCEDURE ModuleFrame(sc: SynScan.T; name, for: TEXT;
  imports: NameList; env: Env) RAISES {ObErr.Fail} =
Push scanner inputs so it will first load the imports first to last, then establish a frame for this module, and then finish reading this module. The last PushInput is executed first.
  BEGIN
    SynScan.PushInput(sc, "<none>",
      TextRd.New("establish " & name & " for " & for & ";\n"),
      TRUE, TRUE);
    LoadImports(sc, imports, env);
  END ModuleFrame;

PROCEDURE ModuleEnd(sc: SynScan.T; ideList: NameList) =
  VAR qual := "qualify";
      first := TRUE;
  BEGIN
    IF ideList # NIL THEN
      qual := qual & " exporting";
    END;
    WHILE ideList # NIL DO
      IF first THEN
        first := FALSE;
        qual := qual & " " & ideList.first;
      ELSE
        qual := qual & ", " & ideList.first;
      END;
      ideList := ideList.rest;
    END;
    SynScan.PushInput(sc, "<none>", TextRd.New(qual & ";\n"), TRUE, TRUE);
  END ModuleEnd;

PROCEDURE LoadImports(sc: SynScan.T; imports: NameList; env: Env)
  RAISES {ObErr.Fail} =
last to first, so the scanner will see them first to last
  BEGIN
    IF imports#NIL THEN
      LoadImports(sc, imports.rest, env);
      ImportFrame(sc, imports.first, env);
    END;
  END LoadImports;

PROCEDURE ImportFrame(sc: SynScan.T; name: TEXT; env: Env) =
  VAR scan: Env;
  BEGIN
    scan:=FindFrame(name, env);
    IF scan=NIL THEN LoadFile(sc, name & ".obl");
    ELSIF SynScan.TopLevel(sc) THEN
      SynWr.Text(SynWr.out, "(Frame '" & name &
        "' already exists and has not been reloaded)\n");
    END;
  END ImportFrame;

PROCEDURE ModAndLib(name, for: TEXT): TEXT =
  BEGIN
    IF Text.Equal(name, for) THEN RETURN "'" & name & "'"
    ELSE RETURN "'" & name & "' for '" & for & "'" END;
  END ModAndLib;

PROCEDURE EstablishFrame(name, for: TEXT; env: Env): Env
    RAISES {ObErr.Fail} =
  VAR moduleExists, frameExists: BOOLEAN;
  BEGIN
    SynWr.Text(SynWr.out, "Establishing " & ModAndLib(name,for) & "\n");
    moduleExists := ObLib.Lookup(name, env.libEnv)#NIL;
    frameExists := FindFrame(name, env)#NIL;
    IF frameExists THEN
      RETURN SaveFrame(name, for, DeleteFrame(name, env));
    ELSIF moduleExists THEN
      ObErr.Fault(SynWr.out,
        "Module name conflicts with existing library: '" & name & "_'");
      <*ASSERT FALSE*>
    ELSE
      RETURN SaveFrame(name, for, env);
    END;
  END EstablishFrame;

PROCEDURE SaveFrame(name, for: TEXT; env: Env): Env
    RAISES {ObErr.Fail} =
  VAR scan: Env;
  BEGIN
    scan:=FindFrame(name, env);
    IF scan#NIL THEN
      ObErr.Fault(SynWr.out, "Frame already exists: '" & name & "'");
      RETURN env;
    END;
    IF NOT Text.Empty(name) THEN
      SynWr.Text(SynWr.out, "(Created frame " & ModAndLib(name,for) & ")\n");
    END;
    RETURN
      NEW(Env,
        frameName := name,
        forName := for,
        libEnv := env.libEnv,
        scopeEnv := env.scopeEnv,
        checkEnv := env.checkEnv,
        valueEnv := env.valueEnv,
        nextFrame := env);
  END SaveFrame;

PROCEDURE DeleteFrame(name: TEXT; env: Env): Env =
  VAR scan: Env;
  BEGIN
    scan:=FindFrame(name, env);
    IF scan=NIL THEN
      RETURN env;
    ELSE
      LOOP
        SynWr.Text(SynWr.out,
          "(Deleted frame " & ModAndLib(env.frameName,env.forName) & ")\n");
	IF env=scan THEN EXIT END;
	env:=env.nextFrame;
      END;
      RETURN scan.nextFrame;
    END;
  END DeleteFrame;

PROCEDURE FindFrame(name: TEXT; env: Env): Env =
  VAR scan: Env;
  BEGIN
    scan:=env;
    LOOP
      IF scan=NIL THEN EXIT END;
      IF Text.Equal(scan.frameName, name) THEN EXIT END;
      scan := scan.nextFrame;
    END;
    RETURN scan;
  END FindFrame;

TYPE
  FrameLib =
    ObLib.T OBJECT
      OVERRIDES
        Eval := FrameLibEval;
      END;

PROCEDURE InNameList(name: TEXT; list: NameList): BOOLEAN =
  BEGIN
    WHILE list # NIL DO
      IF Text.Equal(name, list.first) THEN RETURN TRUE END;
      list := list.rest;
    END;
    RETURN FALSE;
  END InNameList;

PROCEDURE QualifyFrame(env: Env; ideList: NameList): Env =
  VAR scanValueEnv: ObValue.Env;
      frameCount, frameSize: INTEGER; opCodes: REF ObLib.OpCodes;
      library: ObLib.T; newLibEnv: ObLib.Env; newEnv: Env;
      seen, tail: TextList.T := NIL;
  BEGIN
    IF Text.Empty(env.frameName) THEN RETURN env END;
    scanValueEnv := env.valueEnv;
    frameSize := 0;
    frameCount := 0;
    LOOP
      IF scanValueEnv=env.nextFrame.valueEnv THEN EXIT END;
      IF ideList = NIL OR InNameList(scanValueEnv.name.text, ideList) THEN
        IF NOT TextList.Member(seen, scanValueEnv.name.text) THEN
          (* want a list of the elements in the same order *)
          IF seen = NIL THEN
            tail := TextList.List1(scanValueEnv.name.text);
            seen := tail;
          ELSE
            tail.tail := TextList.List1(scanValueEnv.name.text);
            tail := tail.tail;
          END;
          INC(frameSize);
        END;
      END;
      INC(frameCount);
      scanValueEnv:=scanValueEnv.rest;
    END;
    opCodes := NEW(REF ObLib.OpCodes, frameSize);
    scanValueEnv := env.valueEnv;
    frameSize := 0;
    FOR i:=0 TO frameCount-1 DO
      IF seen # NIL AND Text.Equal(scanValueEnv.name.text, seen.head) THEN
        seen := seen.tail;
        opCodes[frameSize] :=
            NEW(FrameOpCode, name:=scanValueEnv.name.text,
                arity := -2, fixity := ObLib.OpFixity.Qualified,
                val := NARROW(scanValueEnv, ObValue.LocalEnv).val);
        INC(frameSize);
      END;
      scanValueEnv:=scanValueEnv.rest;
    END;
    library := NEW(FrameLib, name:=env.forName, opCodes:=opCodes);
    newLibEnv := ObLib.Extend(library, env.libEnv);
    newEnv :=
      NEW(Env,
          frameName := env.frameName,
          forName := env.forName,
          libEnv := newLibEnv,
          scopeEnv := env.nextFrame.scopeEnv,
          checkEnv := env.nextFrame.checkEnv,
          valueEnv := env.nextFrame.valueEnv,
          nextFrame := env.nextFrame);
    SynWr.Text(SynWr.out,
      "(Closed frame " & ModAndLib(env.frameName,env.forName) & ")\n");
    RETURN newEnv;
  END QualifyFrame;

PROCEDURE FrameLibEval(self: FrameLib; opCode: ObLib.OpCode;
                       arity: ObLib.OpArity; READONLY args: ObValue.ArgArray;
                       <*UNUSED*>temp: BOOLEAN; loc: SynLocation.T)
  : ObValue.Val RAISES {ObValue.Error, ObValue.Exception} =
  VAR frameOpCode: FrameOpCode;
  BEGIN
    frameOpCode := NARROW(opCode, FrameOpCode);
    IF arity = -1 THEN
      RETURN frameOpCode.val;
    ELSIF arity > NUMBER(args) THEN
      ObValue.RaiseError("Too many arguments", loc);
      <*ASSERT FALSE*>
    ELSE
      TYPECASE frameOpCode.val OF
      | ObValue.ValFun(fun) =>
        RETURN ObEval.Call(fun, SUBARRAY(args, 0, arity), loc);
      ELSE
         ObValue.RaiseError("Not expecting argument list for: " &
          self.name & "_" & opCode.name, loc);
         <*ASSERT FALSE*>
      END;
    END;
  END FrameLibEval;

TYPE
  HelpCommand = ObCommand.T OBJECT
    short, long: TEXT;
  END;

PROCEDURE AddHelpFrame(name, sort, short, long: TEXT;
                          <*UNUSED*>env: Env) =
  (* add a help file for this module *)
  BEGIN
    ObCommand.Register(ObLib.helpCommandSet,
                       NEW(HelpCommand, name:=name,
                           sortingName:= sort,
                           short := short, long := long,
                           Exec:= Help));
  END AddHelpFrame;

PROCEDURE Help (comm: ObCommand.T; arg : TEXT; <* UNUSED *> data : REFANY) =
  VAR self := NARROW(comm, HelpCommand);
  BEGIN
    IF Text.Equal (arg, "!") THEN
      SynWr.Text (SynWr.out,
                  "  " & Fmt.Pad (self.name, 18, ' ', Fmt.Align.Left) &
                  "(" & self.short & ")\n");
    ELSIF Text.Equal (arg, "?") THEN
      SynWr.Text (SynWr.out, self.long);
      SynWr.NewLine (SynWr.out);
    ELSE
      SynWr.Text(SynWr.out, "Command " & self.name & ": bad argument: " & arg);
      SynWr.NewLine (SynWr.out);
    END;
  END Help;

PROCEDURE Setup()  =
  VAR envPath: TEXT;
  BEGIN
    envPath := ProcessEnv.Get("OBLIQPATH");
    IF envPath=NIL THEN
      searchPath :=
        NEW(SearchPath,
            first:=Pathname.Current,
            rest:= NIL);
    ELSE
      searchPath := LexSearchPath(TextRd.New(envPath));
    END;
  END Setup;

TYPE
  ObFrameSpecial = Pickle.Special BRANDED OBJECT
                       OVERRIDES
                         write := WriteLib;
                         read := ReadLib;
                       END;

TYPE
  LocalHandle = OpCodeHandle OBJECT
                       OVERRIDES
                         getOpCodes := GetOpCodes;
                       END;

VAR
  handle := NEW(LocalHandle);
Implementation note: I think this is guaranteed to work. The only worry is if the library can disappear via garbage collection between the time the pickle is written and the time GetOpCodes is called. I don't think this can happen. Since all netobj calls are synchronous, the higher level caller of the pickler will write all the info and then wait for the return value from the remote call. The remote process reads all the info, which includes calling ReadLib below and potentially calling GetOpCodes, before the remote procedure is executed and the return value written.

PROCEDURE GetOpCodes (<*UNUSED*>self: LocalHandle;
                      ts: Fingerprint.T): REF ObLib.OpCodes=
  VAR lib := ObLib.LookupFP(ts);
  BEGIN
    IF lib = NIL THEN RETURN NIL END;
    RETURN lib.opCodes;
  END GetOpCodes;

PROCEDURE WriteLib (<*UNUSED*>ts: ObFrameSpecial;
                    ref: REFANY; out: Pickle.Writer)
  RAISES {Pickle.Error, Wr.Failure, Thread.Alerted} =
  VAR o := NARROW(ref, FrameLib);
  BEGIN
    ObLib.CheckFP(o);
    PickleStubs.OutBytes(out, o.ts.byte);
    PickleStubs.OutText(out, o.name);
    PickleStubs.OutRef(out, handle);
  END WriteLib;

PROCEDURE ReadLib (<*UNUSED*>ts: ObFrameSpecial;
                   in: Pickle.Reader;
                   id: Pickle.RefID):REFANY
  RAISES {Pickle.Error, Rd.EndOfFile, Rd.Failure, Thread.Alerted} =
  VAR fp: Fingerprint.T;
      rHandle: OpCodeHandle;
      lib: FrameLib := NIL;
      name: TEXT;
  BEGIN
    PickleStubs.InBytes(in, fp.byte);
    name := PickleStubs.InText(in);
    rHandle := PickleStubs.InRef(in);

    lib := ObLib.LookupFP(fp);
    IF lib = NIL THEN
      TRY
        lib := NEW(FrameLib, name:=name, opCodes:= NIL, ts:=fp);
        in.noteRef(lib, id);
        lib.opCodes := rHandle.getOpCodes(fp);
        (* check again, using the full object *)
        lib := ObLib.LookupFP(fp, lib);
      EXCEPT NetObj.Error => END;
    ELSE
      in.noteRef(lib, id);
    END;
    RETURN lib;
  END ReadLib;

BEGIN
  Pickle.RegisterSpecial(NEW(ObFrameSpecial, sc := TYPECODE(FrameLib)));
  SearchPathSeparator := ObPathSep.SearchPathSeparator;
END ObFrame.