<* PRAGMA LL *> MODULEEditor EXPORTSEditor ,JunoHandleLexErr ,EditorUI ; IMPORT JunoError, View, Drawing, ToolBox, EditorXtra, JunoConfig; IMPORT JunoParse, JunoLex, JunoAST, JunoUnparse, JunoToken; IMPORT JunoScope, JunoCompile; FROM JunoCompileErr IMPORT Error, Raise; IMPORT JunoRT; IMPORT TextPort; IMPORT VBT, Rect, Axis, TextVBT, HVSplit, Split; IMPORT Rd, Wr, Formatter, TextRd, TextWr, Text, Atom, Lex, Fmt, FloatMode; IMPORT AtomAtomTbl, AtomRefTbl; FROM Thread IMPORT Alerted; <* FATAL Rd.Failure, Wr.Failure, Alerted *> CONST MinUnparseWidth = 15; CmdPrefix = "Cmd"; REVEAL T = Public BRANDED "Editor.T" OBJECT trees, lastTree: Forest := NIL; currentTree: Forest; treesValid, textPretty := FALSE; width: INTEGER := -1; maxCurrCmd: INTEGER := -1; toolTypes: AtomAtomTbl.T; setMenus: AtomRefTbl.T; OVERRIDES init := Init; reshape := Reshape; shape := Shape; modified := Modified; txtModified := NoOp; getToolType := GetToolType; getMenu := GetMenu; END; (* An "Editor.T" is an editor for a Juno module. If "t: T", then "t.trees" is the list of parse trees for the top-level blocks of the module. "t.trees" holds the truth iff "t.treesValid". The value of "currentTree" points at the tree containing the top line of the textport; it is set by Parse and maintained by Unparse, and is valid only if "treesValid" is true. It is used to prevent the textport from scrolling undesirably when the user reshapes the editor or remakes it by clicking "Run". The boolean "t.textPretty" is TRUE iff the editor contains the result of unparsing "t.trees"; note that "t.textPretty => t.treesValid". Hence there are 3 combinations for the two booleans: | Valid Pretty Meaning | F F the editor contains the truth, and is not pretty-printed | T F "t.trees" is the result of successfully parsing the source | T T the editor contains the unparsed version of "t.trees" If "t.textPretty", then "t.width" is the width at which the trees were unparsed. If the trees were unparsed into an empty window, then "t.textPretty" is TRUE, and "t.width = -1". The editor also implements an abstract "current command stack". The procedures declared in the editor with names of the form "CmdPrefix & Fmt.Int(X)", where "CmdPrefix" is a global constant and "X" is a non-negative integer, are on the stack. The value "X" is called the index of the current command. "t.maxCurrCmd" is the value of the maximum current command index; this is the current command on the top of the stack. The stack is empty iff "t.maxCurrCmd = -1". *) Forest = ForestPublic BRANDED "Editor.Forest" OBJECT start, end: CARDINAL; END; (* For each tree "t" in the list of trees, "t.start" and "t.end" are the indices in the module editor of the first and last character of the unparsed version of "t". This interval includes the whitespace charcters following "t". *) PROCEDURENoOp (<*UNUSED*> tp: T) = BEGIN END NoOp; PROCEDUREInit (tp: T; src: TEXT; readOnly := FALSE): T = BEGIN EVAL TextPort.T.init(tp, font := JunoConfig.codeFont, wrap := FALSE, readOnly := readOnly); TextPort.SetModified(tp, TRUE); TextPort.SetText(tp, src); TextPort.SetModified(tp, FALSE); tp.toolTypes := NEW(AtomAtomTbl.Default).init(); tp.setMenus := NEW(AtomRefTbl.Default).init(); RETURN tp END Init; PROCEDUREScrollToCurrentTree (tp: T) = VAR pos: INTEGER; BEGIN IF tp.currentTree = NIL THEN pos := 0 ELSE pos := tp.currentTree.start END; EditorXtra.IndexToTop(tp, pos) END ScrollToCurrentTree; PROCEDURESetCurrentTree (tp: T) = VAR cpos := EditorXtra.TopLineIndex(tp); f := tp.trees; BEGIN WHILE f # NIL AND f.end <= cpos DO f := f.next END; tp.currentTree := f END SetCurrentTree; PROCEDUREReshape (tp: T; READONLY cd: VBT.ReshapeRec) = <* LL.sup = VBT.mu.tp *> BEGIN IF Rect.IsEmpty(cd.new) THEN tp.width := -1 ELSE VAR width := Width(tp); BEGIN IF tp.treesValid AND (NOT tp.textPretty OR width # tp.width) THEN SetCurrentTree(tp); Unparse2(tp, width); ScrollToCurrentTree(tp) END END END; TextPort.T.reshape(tp, cd) END Reshape; PROCEDUREShape (tp: T; ax: Axis.T; n: CARDINAL): VBT.SizeRange = VAR res := TextPort.T.shape(tp, ax, n); BEGIN res.lo := 0; res.hi := VBT.DefaultShape.hi; RETURN res END Shape; PROCEDUREModified (tp: T) = <* LL.sup < VBT.mu *> BEGIN TextPort.T.modified(tp); tp.treesValid := FALSE; tp.textPretty := FALSE; tp.txtModified() END Modified; PROCEDUREGetToolType (ed: T; nm: Atom.T; VAR (*OUT*) type: Atom.T): BOOLEAN = BEGIN RETURN ed.toolTypes.get(nm, type) END GetToolType; PROCEDUREGetMenu (ed: T; nm: Atom.T): VBT.T = VAR menuRef: REFANY; BEGIN IF ed.setMenus.get(nm, menuRef) THEN RETURN menuRef ELSE RETURN TextVBT.New("No parameters have been defined") END END GetMenu; PROCEDURETrees (tp: T): Forest = BEGIN RETURN tp.trees END Trees; PROCEDUREValid (tp: T): BOOLEAN = BEGIN RETURN tp.treesValid END Valid; PROCEDUREHandleLexErr ( err: JunoLex.ErrorRec; rd: Rd.T; wr: Wr.T; VAR (*OUT*) start, finish: INTEGER) = BEGIN Wr.PutText(wr, "\n"); CASE err.kind OF <* NOWARN *> | JunoLex.ErrorKind.UnclosedComment, JunoLex.ErrorKind.UnclosedText => start := Wr.Index(wr); Wr.PutText(wr, err.initialChars); Wr.PutText(wr, Rd.GetText(rd, LAST(CARDINAL))); finish := Wr.Index(wr) | JunoLex.ErrorKind.BadInitialChar, JunoLex.ErrorKind.BadEscapeChar, JunoLex.ErrorKind.BadReal => Wr.PutText(wr, err.initialChars); start := Wr.Index(wr); finish := start + 1; Wr.PutText(wr, Rd.GetText(rd, LAST(CARDINAL))); IF start = Wr.Index(wr) THEN Wr.PutChar(wr, ' ') END END END HandleLexErr; PROCEDURECurrCmdIndex (ast: JunoAST.T): INTEGER =
Ifast
is a procedure declaration for a procedure whose name has the value of the global constantCmdPrefix
as a prefix, then return the value of the suffix; otherwise, return -1.
BEGIN TYPECASE ast OF JunoAST.ProcDecl (pd) => VAR procName := Atom.ToText(pd.header.name); prefixLen := Text.Length(CmdPrefix); res: INTEGER; BEGIN IF Text.Equal(CmdPrefix, Text.Sub(procName, 0, prefixLen)) THEN TRY res := Lex.Int(TextRd.New(Text.Sub(procName, prefixLen))) EXCEPT Lex.Error, FloatMode.Trap, Rd.Failure => res := -1 END; RETURN res END END ELSE (* SKIP *) END; RETURN -1 END CurrCmdIndex; PROCEDUREParse (tp: T; time: VBT.TimeStamp): BOOLEAN = BEGIN IF tp.treesValid THEN RETURN TRUE END; RETURN Parse2(tp, time) END Parse; PROCEDUREParse2 (tp: T; time: VBT.TimeStamp): BOOLEAN = VAR errmsg: TEXT; rd := TextRd.New(TextPort.GetText(tp)); wr: TextWr.T; w := Width(tp); start, finish := -1; cpos := EditorXtra.TopLineIndex(tp); ip: JunoParse.IterativeParse; <*FATAL Rd.Failure, Wr.Failure *> BEGIN TRY ip := JunoParse.StartIterativeParse(rd) EXCEPT JunoLex.Error (err) => wr := TextWr.New(); errmsg := JunoLex.ErrorText(err.kind); HandleLexErr(err, rd, wr, start, finish); ip := NIL END; tp.trees := NIL; tp.lastTree := NIL; tp.currentTree := NIL; tp.maxCurrCmd := -1; IF ip # NIL THEN LOOP VAR ast: JunoAST.Block; tokens: CARDINAL; BEGIN TRY JunoParse.Block(ip, ast, tokens) EXCEPT JunoLex.Error (err) => wr := TextWr.New(); UnparseTrees(tp.trees, wr, w); IF ast # NIL THEN JunoUnparse.Block(wr, ast, tokens, indent := 0, width := w, prec := JunoConfig.realPrec) END; errmsg := JunoLex.ErrorText(err.kind); HandleLexErr(err, rd, wr, start, finish); EXIT | JunoParse.Error(err) => wr := TextWr.New(); UnparseTrees(tp.trees, wr, w); IF ast # NIL THEN JunoUnparse.Block(wr, ast, tokens, indent := 0, width := w, prec := JunoConfig.realPrec) END; Wr.PutChar(wr, '\n'); errmsg := "Parse error"; IF err.expected # JunoToken.Kind.Unknown THEN errmsg := errmsg & " (expected " & JunoToken.KindName[err.expected] & ")" END; start := Wr.Index(wr); Wr.PutText(wr, JunoToken.ToText(err.found)); finish := Wr.Index(wr); Wr.PutChar(wr, ' '); Wr.PutText(wr, err.additional); Wr.PutText(wr, Rd.GetText(rd, LAST(CARDINAL))); EXIT END; IF ast = NIL THEN EXIT END; (* Next, append "ast" to the list ending at "tp.lastTree". Also, if it is the first parsed item that ends past the top line of the textport, record it in "currentTree". *) VAR f := NEW(Forest, tree := ast, next := NIL); BEGIN AppendTree(tp, f); IF tp.currentTree = NIL AND JunoParse.GetIndex(ip) > cpos THEN tp.currentTree := f END END; tp.maxCurrCmd := MAX(tp.maxCurrCmd, CurrCmdIndex(ast)) END END; (* loop *) JunoParse.FinishIterativeParse(ip) END; (* if *) IF start # finish THEN <* ASSERT start # -1 AND finish # -1 *> TextPort.SetModified(tp, TRUE); TextPort.SetText(tp, TextWr.ToText(wr)); TextPort.SetModified(tp, FALSE); Wr.Close(wr); JunoError.P(tp, errmsg, start, finish, time); RETURN FALSE ELSE TextPort.SetModified(tp, FALSE); TextPort.Normalize(tp, cpos); tp.treesValid := TRUE; RETURN TRUE END END Parse2; PROCEDUREUnparse (tp: T; errast: JunoAST.T := NIL; msg: TEXT := NIL; time: VBT.TimeStamp := 0) = <* LL.sup < tp *> BEGIN <* ASSERT tp.treesValid *> <* ASSERT (errast # NIL) = (msg # NIL) *> IF Rect.IsEmpty(VBT.Domain(tp)) THEN tp.width := -1 ELSE VAR width := Width(tp); BEGIN IF NOT tp.textPretty OR width # tp.width THEN Unparse2(tp, width, errast, msg, time) END END; IF errast = NIL THEN ScrollToCurrentTree(tp) END END END Unparse; PROCEDUREUnparse2 (tp: T; width: CARDINAL; errast: JunoAST.T := NIL; msg: TEXT := NIL; time: VBT.TimeStamp := 0) = <* FATAL Wr.Failure *> VAR wr := TextWr.New(); BEGIN UnparseTrees(tp.trees, wr, width, errast := errast); VAR txt := TextWr.ToText(wr); start, finish: INTEGER; BEGIN IF errast # NIL THEN start := Text.FindChar(txt, '\001'); finish := Text.FindChar(txt, '\002'); <* ASSERT start # -1 AND finish # -1 *> txt := Text.Sub(txt, 0, start) & Text.Sub(txt, start + 1, finish - start - 1) & Text.Sub(txt, finish + 1) END; TextPort.SetModified(tp, TRUE); TextPort.SetText(tp, txt); TextPort.SetModified(tp, FALSE); IF errast # NIL THEN VAR t := tp.trees; BEGIN (* update the "start" and "end" values for blocks appearing after the erroneous tree "errast" *) WHILE t # NIL DO IF t.start > finish THEN DEC(t.start, 2); DEC(t.end, 2) ELSIF t.end > finish THEN DEC(t.end, 2) END; t := t.next END END; IF time # 0 THEN JunoError.P(tp, msg, start, finish - 1, time) END END; Wr.Close(wr) END; tp.textPretty := TRUE; tp.width := width END Unparse2; PROCEDUREUnparseTrees (f: Forest; wr: Wr.T; width: CARDINAL; errast: JunoAST.T := NIL) =
Unparse the list of treesf
towr
at the widthwidth
. Iferrast # NIL
, then bracket the unparsing oferrast
by the characters '\001' and '\002' when unparsing. This procedure also sets thestart
andend
fields of each tree inf
.
VAR fmt := Formatter.New(wr, width); BEGIN WHILE f # NIL DO f.start := Wr.Index(wr); JunoUnparse.ToFmt(fmt, f.tree, indent := 0, prec := JunoConfig.realPrec, errast := errast); Formatter.NewLine(fmt, freshLine := FALSE); (* Print a second newline so long as it would not separate two consecutive UI declarations. *) IF NOT (ISTYPE(f.tree, JunoAST.UIDecl) AND f.next # NIL AND ISTYPE(f.next.tree, JunoAST.UIDecl)) THEN Formatter.NewLine(fmt, freshLine := FALSE) END; Formatter.Flush(fmt); f.end := Wr.Index(wr); f := f.next END; Formatter.Close(fmt) END UnparseTrees; PROCEDUREAppendTree (tp: T; t: Forest) =
Appendt
totp
's list of trees.
BEGIN IF tp.trees = NIL THEN tp.trees := t ELSE tp.lastTree.next := t END; tp.lastTree := t END AppendTree; PROCEDUREAddTree (ed: T; ast: JunoAST.T) = VAR t := NEW(Forest, tree := ast); BEGIN AppendTree(ed, t); ed.maxCurrCmd := MAX(ed.maxCurrCmd, CurrCmdIndex(ast)); (* unparse the new tree to the end of the editor *) VAR wr := TextWr.New(); BEGIN t.start := TextPort.Length(ed); JunoUnparse.P(wr, ast, 0, Width(ed), prec := JunoConfig.realPrec, errast := NIL); Wr.PutText(wr, "\n\n"); VAR wasMod := TextPort.IsModified(ed); BEGIN TextPort.SetModified(ed, TRUE); TextPort.PutText(ed, TextWr.ToText(wr)); t.end := TextPort.Length(ed); TextPort.Normalize(ed, t.start); TextPort.SetModified(ed, wasMod) END; Wr.Close(wr) END; (* update the editor's tables for a UIDecl *) TYPECASE ast OF JunoAST.UIDecl (ui) => <* FATAL Error *> BEGIN IF ed.toolTypes.put(FirstName(ui, 1).id1, ui.name) THEN <* ASSERT FALSE *> END END ELSE (* SKIP *) END END AddTree; PROCEDURENextCmdNum (ed: T): CARDINAL = BEGIN RETURN ed.maxCurrCmd + 1 END NextCmdNum; PROCEDURENextCmdName (ed: T): Atom.T = BEGIN RETURN Atom.FromText(CmdPrefix & Fmt.Int(NextCmdNum(ed))) END NextCmdName; PROCEDUREPopCurrCmd (ed: T; VAR (*OUT*) nm: JunoAST.Id): JunoAST.Cmd = <* LL.sup <= VBT.mu *> BEGIN IF NOT ed.treesValid OR ed.maxCurrCmd < 0 THEN RETURN NIL END; Unparse(ed); VAR t: Forest := NIL; BEGIN VAR curr := ed.trees; prev: Forest := NIL; max := -1; BEGIN (* Set "t" to the tree to delete, set "max" to the new current command maximum, and set "prev" to the tree before "t" (or "NIL" if "t" is the first tree in the list). *) WHILE curr # NIL DO VAR ix := CurrCmdIndex(curr.tree); BEGIN IF ix = ed.maxCurrCmd THEN t := curr ELSE max := MAX(max, ix) END END; IF t = NIL THEN prev := curr END; curr := curr.next END; ed.maxCurrCmd := max; (* remove "t" from "trees[ed]" *) IF ed.lastTree = t THEN ed.lastTree := prev END; IF prev = NIL THEN ed.trees := t.next ELSE prev.next := t.next END; END; (* delete the text for "t" from "src[ed]" *) VAR wasMod := TextPort.IsModified(ed); BEGIN TextPort.SetModified(ed, TRUE); TextPort.Replace(ed, t.start, t.end, ""); TextPort.SetModified(ed, wasMod) END; (* return the procedure body *) VAR decl := NARROW(t.tree, JunoAST.ProcDecl); body := decl.body; BEGIN nm := decl.header.name; TYPECASE body OF JunoAST.If (if) => IF ISTYPE(if.body, JunoAST.Proj) THEN RETURN if.body ELSE RETURN body END ELSE RETURN body END END END END PopCurrCmd; PROCEDUREWidth (ed: TextPort.T): CARDINAL = VAR res := VBT.TextWidth(ed, "m", ed.getFont()); BEGIN IF res # 0 THEN res := Rect.HorSize(VBT.Domain(ed)) DIV res - 2; END; RETURN MAX(MinUnparseWidth, res) END Width; PROCEDUREModuleName (ed: T): Atom.T = VAR first := ed.trees; BEGIN WHILE first # NIL DO TYPECASE first.tree OF JunoAST.Module (m) => RETURN m.name | JunoAST.Comment => first := first.next ELSE EXIT END END; RETURN NIL END ModuleName; VAR (* CONST *) global_mod := Atom.FromText("_GLOBAL_MOD"); global_cmd := Atom.FromText("_GLOBAL_CMD"); global_slot := JunoRT.GetCodeIndex(JunoRT.ProcAttr{ global_mod, global_cmd, JunoRT.Sig{0,0,0}}); PROCEDUREProcessExecRes (READONLY res: JunoRT.ExecRes; error_ast: JunoAST.T) RAISES {Error} =
RaisesError
ifres.trapCode # JunoRT.TrapCode.NormalHalt
, with a message constructed fromres.errorCode
, and with error ASTerror_ast
.
BEGIN IF res.trapCode # JunoRT.TrapCode.NormalHalt THEN Raise(JunoRT.TrapMessage(res), error_ast) END END ProcessExecRes; PROCEDUREPass0 ( VAR forest: Forest; scp: JunoScope.T; uniqueModName: BOOLEAN; VAR (*OUT*) mod: JunoAST.Id) : JunoScope.T RAISES {Error} =
Process theMODULE
andIMPORT
declarations inforest
, setmod
to the name of the initial module declaration (or NIL if there is none), and setforest
to point to the first declaration after the longest prefix of the form<comment>* <module> (<comment> | <import>)*
.Returns a restricted version of
scp
as determined by any IMPORT statements, orscp
itself if there were no IMPORT statements. This implementation assumes that all bundled modules are defined inscp
, and that identifiers forBuiltIn.juno
are defined in proper ancestor scopes ofscp
.If
uniqueModName = TRUE
, then any specified module name must not appear inscp
; if it does,Error
is raised. Similarly, any modules specified in anIMPORT
statement must appear inscp
; if they do not,Error
is raised.
VAR res: JunoScope.T := NIL; BEGIN mod := NIL; WHILE forest # NIL DO TYPECASE forest.tree OF | JunoAST.Comment => (* SKIP *) | JunoAST.Module (md) => IF mod # NIL THEN EXIT END; IF uniqueModName AND JunoScope.Lookup(scp, md.name) # NIL THEN Raise("A \"" & Atom.ToText(md.name) & "\" module is already defined", md) END; mod := md.name ELSE EXIT END; forest := forest.next END; WHILE forest # NIL DO TYPECASE forest.tree OF JunoAST.Comment => (* SKIP *) | JunoAST.Import (imp) => (* form new scope if necessary *) IF res = NIL THEN res := JunoScope.New(JunoScope.Parent(scp)) END; (* copy imported modules bound in "scp" to "res" *) VAR curr := imp.idList.head; ent: JunoScope.Entity; BEGIN WHILE curr # NIL DO ent := JunoScope.Lookup(scp, curr.id, localOnly := TRUE); IF ent = NIL THEN Raise("\""& Atom.ToText(curr.id) &"\" is not a bundled module", imp.idList) END; TRY JunoScope.Bind(res, curr.id, ent) EXCEPT JunoScope.NameClash => Raise("\""& Atom.ToText(curr.id) &"\" repeated in IMPORTs", imp.idList) END; curr := curr.next END END ELSE EXIT END; forest := forest.next END; IF res = NIL THEN RETURN scp ELSE RETURN res END END Pass0; PROCEDUREPass1 ( forest: Forest; public, scp: JunoScope.T; mod: JunoAST.Id) RAISES {Error} =
Pass1 processes the top-level declarations inforest
for the module namedmod
.Forest
is assumed to have been produced by Pass0, so it does not contain the MODULE and IMPORT declarations at the start of the module. Pass1 treats each type of top-level declaration as follows:(* Comment
Skip. | MODULE, IMPORT Raise Error. | CONST, VAR, PROC Only install entries in "scp" (and "public"). | PRED, FUNC Install entries in "scp" (and "public") and compile | bodies in order of occurrence. | UI Skip. | Entries are only installed in the "public" scope if the declaration is not PRIVATE. *) <* FATAL JunoScope.NameClash *> BEGIN WHILE forest # NIL DO TYPECASE forest.tree OF <*NOWARN*> | JunoAST.Module (md) => IF mod = NIL THEN Raise("MODULE header not at start of file", md) ELSE Raise("Only one MODULE header is allowed", md) END | JunoAST.Import (import) => Raise("IMPORT may only be preceded by MODULE header", import) | JunoAST.Comment => (* SKIP *) | JunoAST.ConstDecl (cd) => VAR curr := cd.head; BEGIN WHILE curr # NIL DO IF JunoScope.Lookup(scp, curr.name) # NIL THEN Raise("\""&Atom.ToText(curr.name)&"\" is already declared", cd) END; VAR c := NEW(JunoScope.Const, init := curr.value, index := JunoRT.GetVarIndex(mod, curr.name)); BEGIN JunoScope.Bind(scp, curr.name, c); IF NOT cd.private THEN JunoScope.Bind(public, curr.name, c) END END; curr := curr.next END END | JunoAST.VarDecl (vd) => VAR curr := vd.head; BEGIN WHILE curr # NIL DO IF JunoScope.Lookup(scp, curr.name) # NIL THEN Raise("\""&Atom.ToText(curr.name)&"\" is already declared", vd) END; VAR v := NEW(JunoScope.Var, init := curr.value, index := JunoRT.GetVarIndex(mod, curr.name)); BEGIN JunoScope.Bind(scp, curr.name, v); IF NOT vd.private THEN JunoScope.Bind(public, curr.name, v) END END; curr := curr.next END END | JunoAST.ProcDecl (proc) => WITH pnm = proc.header.name DO IF JunoScope.Lookup(scp, pnm) # NIL THEN Raise("\"" & Atom.ToText(pnm) & "\" is already declared", proc.header) END; VAR p := JunoScope.NewProc(proc, mod); BEGIN JunoScope.Bind(scp, pnm, p); IF NOT proc.private THEN JunoScope.Bind(public, pnm, p) END END END | JunoAST.PredDecl (pred) => WITH pnm = pred.header.name DO IF JunoScope.Lookup(scp, pnm) # NIL THEN Raise("\"" & Atom.ToText(pnm) & "\" is already declared", pred.header) END; VAR p := JunoScope.NewPred(pred, mod); BEGIN JunoCompile.PredDecl(pnm, p, scp); JunoScope.Bind(scp, pnm, p); IF NOT pred.private THEN JunoScope.Bind(public, pnm, p) END END END | JunoAST.FuncDecl (func) => WITH fnm = func.header.name DO IF JunoScope.Lookup(scp, fnm) # NIL THEN Raise("\"" & Atom.ToText(fnm) & "\" is already declared", func.header) END; VAR f := JunoScope.NewFunc(func, mod); BEGIN JunoCompile.FuncDecl(fnm, f, scp); JunoScope.Bind(scp, fnm, f); IF NOT func.private THEN JunoScope.Bind(public, fnm, f) END END END | JunoAST.UIDecl => (* SKIP *) END; forest := forest.next END END Pass1; PROCEDUREPass2 (forest: Forest; scp: JunoScope.T) RAISES {Error} =
Compile procedure bodies.
BEGIN WHILE forest # NIL DO TYPECASE forest.tree OF | JunoAST.ProcDecl(proc) => VAR p: JunoScope.Proc := JunoScope.Lookup(scp, proc.header.name, localOnly := TRUE); BEGIN EVAL JunoCompile.ProcDecl(proc.header.name, p, scp) END ELSE (* SKIP *) END; forest := forest.next END END Pass2; PROCEDUREPass3 (forest: Forest; scp: JunoScope.T) RAISES {Error} =
Compile and run constant and global variable initializers.
BEGIN WHILE forest # NIL DO TYPECASE forest.tree OF | JunoAST.ConstDecl (cd) => VAR curr := cd.head; BEGIN WHILE curr # NIL DO VAR c: JunoScope.Const := JunoScope.Lookup( scp, curr.name, localOnly := TRUE); res_slot: CARDINAL; BEGIN JunoRT.code_tbl[global_slot] := JunoCompile.Expr( c.init, scp, curr.name, (*OUT*) res_slot, pure := FALSE); ProcessExecRes(JunoRT.ExecFromSlot(global_slot), cd); JunoRT.value_tbl[c.index] := JunoRT.value_tbl[res_slot] END; curr := curr.next END END | JunoAST.VarDecl (vd) => VAR curr := vd.head; BEGIN WHILE curr # NIL DO VAR v: JunoScope.Var := JunoScope.Lookup( scp, curr.name, localOnly := TRUE); res_slot: CARDINAL; init: JunoAST.Expr := v.init; BEGIN IF init = JunoAST.NilExpr THEN init := JunoAST.NilVal END; JunoRT.code_tbl[global_slot] := JunoCompile.Expr( init, scp, curr.name, res_slot, pure := FALSE); ProcessExecRes(JunoRT.ExecFromSlot(global_slot), vd); JunoRT.value_tbl[v.index] := JunoRT.value_tbl[res_slot] END; curr := curr.next END END ELSE (* SKIP *) END; forest := forest.next END END Pass3; PROCEDURECompile ( te: T; time: VBT.TimeStamp; scp: JunoScope.T; VAR (*OUT*) nm: JunoAST.Id; VAR (*OUT*) entity: JunoScope.Mod; uniqueModName := TRUE): BOOLEAN = <* LL.sup < te *> BEGIN IF NOT Parse(te, time) THEN RETURN FALSE END; RETURN Compile2(te, time, scp, uniqueModName, nm, entity) END Compile; PROCEDURECompile2 ( te: T; time: VBT.TimeStamp; parent: JunoScope.T; uniqueModName: BOOLEAN; VAR (*OUT*) nm: JunoAST.Id; VAR (*OUT*) entity: JunoScope.Mod) : BOOLEAN = <* LL.sup < te *> VAR forest := te.trees; restrict, public, scp: JunoScope.T; BEGIN TRY restrict := Pass0(forest, parent, uniqueModName, nm); (* Initialize "public", "scp" so module is compiled under restricted scope. *) public := JunoScope.New(restrict); scp := JunoScope.New(restrict); Pass1(forest, public, scp, nm); Pass2(forest, scp); Pass3(forest, scp); (* Make "parent" the parent scope of "public" and "scp" *) IF restrict # parent THEN JunoScope.SetParent(public, parent); JunoScope.SetParent(scp, parent) END EXCEPT Error (err) => <* ASSERT err.ast # NIL *> te.textPretty := FALSE; (* for error to be unparsed *) Unparse(te, err.ast, err.msg, time); RETURN FALSE END; entity := NEW(JunoScope.Mod, public_scp := public, scp := scp); RETURN TRUE END Compile2; TYPE InCnt = { EqualsZero, EqualsOne, AtLeastOne, Any }; PROCEDUREPass4 (rt: View.Root; ed: T; scp: JunoScope.T) RAISES {Error} =
Compile and process UI declarations.
VAR forest := ed.trees; BEGIN (* clear the "UI" tables *) EVAL NARROW(ed.toolTypes, AtomAtomTbl.Default).init( sizeHint := ed.toolTypes.size()); EVAL NARROW(ed.setMenus, AtomRefTbl.Default).init( sizeHint := ed.setMenus.size()); WHILE forest # NIL DO TYPECASE forest.tree OF | JunoAST.UIDecl (ui) => IF ui.name = PointToolSym OR ui.name = TextToolSym OR ui.name = SetToolSym OR ui.name = TemplToolSym THEN VAR nm: JunoAST.QId; ent: JunoScope.Entity; BEGIN nm := FirstName(ui, argCnt := 1); ent := CheckEnt(nm, scp); IF ui.name = PointToolSym THEN IF NOT ISTYPE(ent, JunoScope.Code) THEN (* not a predicate, function, or procedure *) Raise("Must be a predicate, function, or procedure", nm) END; IF ISTYPE(ent, JunoScope.Proc) THEN CheckProc(ent, nm) (* check for no OUT or INOUT args *) END ELSIF ui.name = TextToolSym THEN CheckProc(ent, nm, InCnt.AtLeastOne) ELSIF ui.name = SetToolSym THEN CheckProc(ent, nm, InCnt.EqualsOne) ELSIF ui.name = TemplToolSym THEN CheckProc(ent, nm, InCnt.EqualsZero) END; IF ed.toolTypes.put(nm.id1, ui.name) THEN Raise("Duplicate UI declaration", nm) END END ELSIF ui.name = ParamSym THEN VAR nm := FirstName(ui, argCnt := 2); ent := CheckEnt(nm, scp); valueAST := ui.args.head.next.expr; mod := ModuleName(ed); buttonName: TEXT; button: VBT.T; menu: VBT.T; menuRef: REFANY; BEGIN CheckProc(ent, nm, InCnt.EqualsOne); TYPECASE valueAST OF JunoAST.LitValue => (*SKIP*) | JunoAST.QId (qid) => (* Check that "qid" names a legal term *) VAR res, unit: JunoScope.Entity; BEGIN res := JunoScope.LookupQId(scp, qid, unit); TYPECASE res OF NULL => Raise("Unknown identifier", qid) | JunoScope.Const, JunoScope.Var, JunoScope.Proc => (* SKIP - these are legal terms *) ELSE Raise("Parameter value must be\n" & "a CONST, VAR, or PROC", qid) END END; valueAST := Qualify(qid, mod) ELSE Raise("Parameter value must be a\n" & "(qualified) identifier or literal", valueAST) END; <* FATAL Wr.Failure *> VAR twr := NEW(TextWr.T).init(); BEGIN JunoUnparse.Expr(twr, valueAST, tokens := LAST(INTEGER), width := LAST(INTEGER), prec := JunoConfig.realPrec); buttonName := TextWr.ToText(twr) END; button := NEW(ToolBox.SetButton).init(rt, buttonName, Drawing.NewSetTool(Qualify(nm, mod), valueAST)); IF NOT ed.setMenus.get(nm.id1, menuRef) THEN menu := NEW(HVSplit.T).init(Axis.T.Ver); EVAL ed.setMenus.put(nm.id1, menu) ELSE menu := menuRef END; Split.AddChild(menu, button) END ELSE Raise("Unknown UI declaration", ui) END ELSE (* SKIP *) END; forest := forest.next END END Pass4; PROCEDUREQualify (qid: JunoAST.QId; mod: Atom.T): JunoAST.QId =
Ifqid
is unqualified andmod # NIL
, returnmod . qid.id1
, else returnqid
.
BEGIN IF qid.id0 = JunoAST.NilId AND mod # NIL THEN RETURN NEW(JunoAST.QId, bp := qid, id0 := mod, id1 := qid.id1) ELSE RETURN qid END END Qualify; PROCEDUREFirstName (ui: JunoAST.UIDecl; argCnt: CARDINAL): JunoAST.QId RAISES {Error} =
Checks thatui
hasargCnt
arguments, which is required to be non-zero. If so, returns the unqualified identifier that is the first argument. RaisesError
with the appropriate error message if the first argument is not an unqualified identifier.
BEGIN <* ASSERT argCnt > 0 *> IF ui.args.size # argCnt THEN VAR errAST: JunoAST.T; BEGIN IF ui.args.size = 0 THEN errAST := ui ELSE errAST := ui.args END; Raise("Wrong number of arguments", errAST) END END; TYPECASE ui.args.head.expr OF JunoAST.QId (qid) => IF qid.id0 # JunoAST.NilId THEN Raise("Expecting unqualified identifier", qid) END; RETURN qid ELSE Raise("Expecting an identifier", ui.args.head.expr); RETURN NIL (* not reached -- just to surpress compiler warning *) END END FirstName; PROCEDURECheckEnt (qid: JunoAST.QId; scp: JunoScope.T): JunoScope.Entity RAISES {Error} =
Returns the entity bound toqid
inscp
. Requires thatqid
is unqualified. RaisesError
with an appropriate error message ifqid
is not bound inscp
.
VAR res := JunoScope.Lookup(scp, qid.id1); BEGIN IF res = NIL THEN Raise("Undefined", qid) END; RETURN res END CheckEnt; PROCEDURECheckProc (ent: JunoScope.Entity; ast: JunoAST.T; inCnt := InCnt.Any) RAISES {Error} =
Check thatent
is a procedure with no OUT or INOUT parameters. IfinCnt
isEqualsOne
, then the procedure must have exactly one IN argument; if it isAtLeastOne
, then it must have at least one IN argument. RaisesError
so thatast
will be highlighted if any of these checks fail; otherwise, this procedure is a no-op.
BEGIN TYPECASE ent OF JunoScope.Proc (p) => IF p.out_cnt # 0 OR p.inout_cnt # 0 THEN Raise("Procedure may not have any\nOUT or INOUT arguments", ast) END; IF inCnt = InCnt.EqualsOne AND p.in_cnt # 1 THEN Raise("Procedure must have\nexactly one IN argument", ast) ELSIF inCnt = InCnt.AtLeastOne AND p.in_cnt = 0 THEN Raise("Procedure must have\nat least one IN argument", ast) ELSIF inCnt = InCnt.EqualsZero AND p.in_cnt # 0 THEN Raise("Procedure must have\nno IN arguments", ast) END ELSE Raise("Must be a procedure", ast) END END CheckProc; PROCEDURECompileUI ( rt: View.Root; te: T; time: VBT.TimeStamp; scp: JunoScope.T): BOOLEAN = BEGIN <* ASSERT te.treesValid *> TRY Pass4(rt, te, scp) EXCEPT Error (err) => <* ASSERT err.ast # NIL *> Unparse(te, err.ast, err.msg, time); RETURN FALSE END; RETURN TRUE END CompileUI; PROCEDURESaveSlots (wr: Wr.T) = BEGIN Wr.PutText(wr, Fmt.Int(global_slot) & "\n") END SaveSlots; PROCEDURERestoreSlots (rd: Rd.T) = <* FATAL FloatMode.Trap, Lex.Error, Rd.Failure, Rd.EndOfFile *> BEGIN global_slot := Lex.Int(rd); IF Rd.GetChar(rd) # 'n' THEN <* ASSERT FALSE *> END END RestoreSlots; BEGIN PointToolSym := Atom.FromText("PointTool"); TextToolSym := Atom.FromText("TextTool"); SetToolSym := Atom.FromText("SetTool"); ParamSym := Atom.FromText("Param"); TemplToolSym := Atom.FromText("Template"); END Editor.