Copyright (C) 1995, Digital Equipment Corporation
All rights reserved.
See the file COPYRIGHT for a full description.
Last modified on Tue Feb 28 15:59:51 PST 1995 by kalsow
MODULE QMachine;
IMPORT Atom, AtomList, IntRefTbl, Env, Fmt, Text, FileWr;
IMPORT Wr, Thread, Stdio, OSError, TextSeq;
IMPORT Pathname, Pipe, Process, File, FS, RTParams;
IMPORT M3Buf, M3File, M3Process, CoffTime;
IMPORT QIdent, QValue, QVal, QCode, QCompiler, QVTbl, QVSeq, QScanner;
FROM Quake IMPORT Error, ID, IDMap, NoID;
IMPORT IO;
CONST
OnUnix = (CoffTime.EpochAdjust = 0.0d0);
TYPE
QK = QValue.Kind;
Op = QCode.Op;
REVEAL
T = T_ BRANDED "QMachine.T" OBJECT
reg : Registers;
scopes : ScopeStack := NIL;
stack : ValueStack := NIL;
loops : LoopStack := NIL;
output : OutputStack := NIL;
frames : FrameStack := NIL;
includes : IncludeStack := NIL;
globals : IntRefTbl.T := NIL; (* ID -> QValue.Binding *)
tmp_files : TextSeq.T := NIL;
tracing : BOOLEAN := FALSE;
do_echo : BOOLEAN := FALSE;
last_cp : QCode.Stream := NIL;
bindings : QValue.Binding := NIL;
buffers : BufStack;
default_wr: Wr.T;
shell : TEXT := NIL;
sh_option : TEXT := NIL;
tmp_dir : TEXT := NIL;
OVERRIDES
init := Init;
evaluate := Evaluate;
get := Get;
put := Put;
lookup := LookUp;
push := Push;
pop := Pop;
error := Err;
cleanup := CleanUp;
include := Include;
normalize := Normalize;
start_call:= StartCall;
call_proc := CallProc;
cp_if := CopyIfNew;
make_dir := MakeDir;
cur_file := CurFile;
cur_path := CurPath;
cur_wr := CurWr;
set_wr := SetWr;
exec_echo := ExecEcho;
END;
TYPE
Registers = RECORD
cp : QCode.Stream := NIL; (* code pointer *)
pc : INTEGER := 0; (* program counter *)
xp : INTEGER := 0; (* scope stack pointer *)
sp : INTEGER := 0; (* value stack pointer *)
lp : INTEGER := 0; (* loop stack pointer *)
op : INTEGER := 0; (* output stack pointer *)
fp : INTEGER := 0; (* frame pointer *)
ln : INTEGER := 0; (* line number *)
ip : INTEGER := 0; (* include stack pointer *)
pi : QCode.ProcInfo := NIL; (* procedure info *)
fn : BOOLEAN := FALSE; (* => expect return result *)
END;
TYPE
ScopeStack = REF ARRAY OF QValue.Scope;
ValueStack = REF ARRAY OF QValue.T;
LoopStack = REF ARRAY OF LoopInfo;
OutputStack = REF ARRAY OF OutputInfo;
FrameStack = REF ARRAY OF FrameInfo;
IncludeStack = REF ARRAY OF IncludeInfo;
TYPE
LoopInfo = RECORD
iter : QVTbl.Iterator := NIL;
array : QVSeq.T := NIL;
next_elt : INTEGER := 0;
variable : QValue.Binding := NIL;
END;
TYPE
OutputInfo = RECORD
name : TEXT := NIL;
wr : Wr.T := NIL;
END;
TYPE
FrameInfo = RECORD
proc : QValue.Proc := NIL;
saved : Registers;
outer : BOOLEAN; (* TRUE => exit eval loop when the frame is popped *)
END;
TYPE
IncludeInfo = RECORD
file : QCode.Stream;
old_cp : QCode.Stream;
old_pc : INTEGER;
END;
TYPE
BufStack = RECORD
tos : INTEGER := 0;
bufs : ARRAY [0..9] OF M3Buf.T;
END;
-------------------------------------------------------- initialization ---
PROCEDURE Init (t: T; map: IDMap): T =
BEGIN
t.map := map;
t.scopes := NEW (ScopeStack, 40);
t.stack := NEW (ValueStack, 100);
t.loops := NEW (LoopStack, 20);
t.output := NEW (OutputStack, 10);
t.frames := NEW (FrameStack, 40);
t.includes := NEW (IncludeStack, 10);
t.globals := NEW (IntRefTbl.Default).init ();
t.default_wr := Stdio.stdout;
InitOSEnv (t);
InitBuiltins (t);
EVAL PushScope (t); (* so that "local" variables have a place to go *)
RETURN t;
END Init;
------------------------------------------------------------ evaluation ---
PROCEDURE Evaluate (t: T; s: QCode.Stream)
RAISES {Error, Thread.Alerted} =
BEGIN
PushInclude (t, s, t.reg);
Eval (t);
END Evaluate;
PROCEDURE Eval (t: T)
RAISES {Error, Thread.Alerted} =
VAR
op : QCode.Op;
arg : INTEGER;
val : QValue.T;
val2 : QValue.T;
arr : QVSeq.T;
tbl : QVTbl.T;
int : INTEGER;
bind : QValue.Binding;
txt : TEXT;
buf : M3Buf.T;
done : BOOLEAN;
BEGIN
LOOP
IF (t.tracing) THEN TraceInstruction (t) END;
WITH z = t.reg.cp.instrs [t.reg.pc] DO op := z.op; arg := z.a; END;
INC (t.reg.pc);
CASE op OF
| Op.Integer =>
val.kind := QK.Integer;
val.int := arg;
val.ref := NIL;
Push (t, val);
| Op.String =>
val.kind := QK.String;
val.int := arg;
val.ref := NIL;
Push (t, val);
| Op.BuildArray =>
arr := NEW (QVSeq.T).init (arg);
FOR i := 0 TO arg-1 DO Pop (t, val); arr.addlo (val); END;
val.kind := QK.Array;
val.int := 0;
val.ref := arr;
Push (t, val);
arr := NIL;
val.ref := NIL;
| Op.BuildTable =>
tbl := NEW (QVTbl.Default).init();
FOR i := arg-1 TO 0 BY -2 DO
Pop (t, val2);
Pop (t, val);
EVAL tbl.put (QVal.ToID (t, val), val2);
END;
val.kind := QK.Table;
val.int := 0;
val.ref := tbl;
Push (t, val);
tbl := NIL;
val.ref := NIL;
val2.ref := NIL;
| Op.GetEnv =>
PushText (t, Env.Get (t.map.id2txt (arg)));
| Op.PushProc =>
val.kind := QK.Proc;
val.int := 0;
val.ref := NEW (QValue.Proc, info := t.reg.cp.procs [arg],
env := t.scopes [0]);
(*env := t.scopes [t.reg.xp-1]);*)
(* In quake all procedures are global, and we don't want
dynamic scoping... *)
Push (t, val);
val.ref := NIL;
| Op.IsMember =>
Pop (t, val); int := QVal.ToID (t, val);
Pop (t, val); tbl := QVal.ToTable (t, val);
PushBool (t, tbl.get (int, val));
tbl := NIL;
val.ref := NIL;
| Op.Concat =>
Pop (t, val2);
Pop (t, val);
buf := GetBuf (t);
QVal.ToBuf (t, val, buf);
QVal.ToBuf (t, val2, buf);
PushText (t, M3Buf.ToText (buf));
FreeBuf (t, buf);
buf := NIL;
val2.ref := NIL;
val.ref := NIL;
| Op.And =>
Pop (t, val2);
Pop (t, val);
PushBool (t, QVal.ToBool (t, val) AND QVal.ToBool (t, val2));
val2.ref := NIL;
val.ref := NIL;
| Op.Or =>
Pop (t, val2);
Pop (t, val);
PushBool (t, QVal.ToBool (t, val) OR QVal.ToBool (t, val2));
val2.ref := NIL;
val.ref := NIL;
| Op.Not =>
Pop (t, val);
PushBool (t, NOT QVal.ToBool (t, val));
val.ref := NIL;
| Op.IndexTable =>
Pop (t, val); int := QVal.ToID (t, val);
Pop (t, val); tbl := QVal.ToTable (t, val);
IF NOT tbl.get (int, val) THEN
Err (t, Fmt.F ("table does not contain entry for: \"%s\"",
t.map.id2txt (int)));
END;
Push (t, val);
tbl := NIL;
val.ref := NIL;
| Op.SubscriptArray =>
Pop (t, val); int := QVal.ToInt (t, val);
Pop (t, val); arr := QVal.ToArray (t, val);
IF (int < 0) OR (arr.size() <= int) THEN
Err (t, "array subscript out of bounds: " & Fmt.Int (int));
END;
Push (t, arr.get(int));
arr := NIL;
val.ref := NIL;
| Op.InitForeach =>
Pop (t, val);
PushLoop (t, arg, val);
val.ref := NIL;
| Op.NextForeach =>
IF NOT IterateLoop (t) THEN
PopLoop (t);
INC (t.reg.pc, arg);
END;
| Op.Goto =>
INC (t.reg.pc, arg);
| Op.IfFalse =>
Pop (t, val);
IF NOT QVal.ToBool (t, val) THEN INC (t.reg.pc, arg); END;
val.ref := NIL;
| Op.Halt =>
PopInclude (t);
(**
IF (t.reg.ip <= 0) THEN EXIT; END;
**)
EXIT;
| Op.PushScope =>
EVAL PushScope (t);
| Op.PopScope =>
PopScope (t);
| Op.DefineG =>
bind := DefineGlobal (t, arg, readonly := FALSE);
Pop (t, bind.value);
| Op.DefineGR =>
bind := DefineGlobal (t, arg, readonly := TRUE);
Pop (t, bind.value);
| Op.DefineL =>
bind := Define (t, arg, readonly := FALSE);
Pop (t, bind.value);
| Op.DefineLR =>
bind := Define (t, arg, readonly := TRUE);
Pop (t, bind.value);
| Op.LoadVar =>
bind := LookUp (t, arg);
IF (bind # NIL) THEN
Push (t, bind.value);
ELSIF strict_variables THEN
Err (t, "undefined variable: " & t.map.id2txt (arg));
ELSE
PushText (t, t.map.id2txt (arg));
END;
| Op.Assign =>
bind := LookUp (t, arg);
IF (bind = NIL) THEN
bind := DefineGlobal (t, arg, readonly := FALSE);
ELSIF bind.readonly THEN
Err (t, "cannot assign to readonly variable: " & t.map.id2txt(arg));
END;
Pop (t, val);
bind.value := val;
| Op.AssignTable =>
Pop (t, val);
Pop (t, val2); int := QVal.ToID (t, val2);
Pop (t, val2); tbl := QVal.ToTable (t, val2);
EVAL tbl.put (int, val);
tbl := NIL;
val.ref := NIL;
val2.ref := NIL;
| Op.AssignArray =>
Pop (t, val);
Pop (t, val2); int := QVal.ToInt (t, val2);
Pop (t, val2); arr := QVal.ToArray (t, val2);
IF (int < 0) OR (arr.size() <= int) THEN
Err (t, "array subscript out of bounds: " & Fmt.Int (int));
END;
arr.put (int, val);
arr := NIL;
val.ref := NIL;
val2.ref := NIL;
| Op.Append =>
Pop (t, val);
Pop (t, val2); arr := QVal.ToArray (t, val2);
arr.addhi (val);
arr := NIL;
val.ref := NIL;
val2.ref := NIL;
| Op.StartRedirect =>
Pop (t, val); txt := QVal.ToText (t, val);
PushOutput (t, txt, append := FALSE);
txt := NIL;
val.ref := NIL;
| Op.StartAppendRedirect =>
Pop (t, val); txt := QVal.ToText (t, val);
PushOutput (t, txt, append := TRUE);
txt := NIL;
val.ref := NIL;
| Op.EndRedirect =>
PopOutput (t);
| Op.StartCall =>
PushFrame (t);
| Op.CallProc =>
DoCall (t, arg, FALSE, FALSE);
| Op.CallFunc =>
DoCall (t, arg, TRUE, FALSE);
| Op.SetLine =>
t.reg.ln := arg;
| Op.ReturnValue =>
CheckReturn (t, TRUE);
Pop (t, val);
done := PopFrame (t);
Push (t, val);
IF done THEN EXIT; END;
| Op.Return =>
CheckReturn (t, FALSE);
IF PopFrame (t) THEN EXIT END;
END; (* case *)
END; (* loop *)
END Eval;
PROCEDURE TraceInstruction (t: T)
RAISES {Thread.Alerted} =
BEGIN
TRY
PrintTrace (t);
EXCEPT Wr.Failure =>
t.tracing := FALSE;
END;
END TraceInstruction;
PROCEDURE PrintTrace (t: T)
RAISES {Wr.Failure, Thread.Alerted} =
VAR op: QCode.Op; arg: INTEGER;
BEGIN
IF (t.last_cp # t.reg.cp) THEN
Print ("****** ");
IF (t.reg.cp # NIL) THEN
Print (t.map.id2txt (t.reg.cp.source_file));
END;
Print (" ******", Wr.EOL);
t.last_cp := t.reg.cp;
END;
WITH z = t.reg.cp.instrs [t.reg.pc] DO op := z.op; arg := z.a; END;
FOR i := 1 TO t.reg.xp DO Print ("."); END;
Print (Fmt.Pad (Fmt.Int (t.reg.pc),4,' ',Fmt.Align.Left));
Print (" ", QCode.OpName[op]);
CASE QCode.OpFormat [op] OF
| 0 => (*done*)
| 1 => Print (" ", Fmt.Int (arg));
| 2 => Print (" (", Fmt.Int (arg), ") \"");
Print (t.map.id2txt (arg), "\"");
| 3 => Print (" pc+(", Fmt.Int (arg), ") => ",
Fmt.Int (t.reg.pc + 1 + arg));
END;
Print (Wr.EOL);
FlushIO ();
END PrintTrace;
------------------------------------------------------- procedure calls ---
PROCEDURE PushFrame (t: T)
RAISES {Error} =
VAR val: QValue.T;
BEGIN
Pop (t, val); (* the procedure value *)
StartCall (t, val);
END PushFrame;
PROCEDURE StartCall (t: T; READONLY proc: QValue.T)
RAISES {Error} =
BEGIN
IF (t.reg.fp >= NUMBER (t.frames^)) THEN ExpandFrames (t); END;
WITH f = t.frames[t.reg.fp] DO
f.proc := QVal.ToProc (t, proc);
f.saved := t.reg;
END;
INC (t.reg.fp);
END StartCall;
PROCEDURE ExpandFrames (t: T) =
VAR n := NUMBER (t.frames^); new := NEW (FrameStack, n+n);
BEGIN
SUBARRAY (new^, 0, n) := t.frames^;
t.frames := new;
END ExpandFrames;
PROCEDURE CallProc (t: T; n_args: INTEGER; isFunc: BOOLEAN)
RAISES {Error, Thread.Alerted} =
BEGIN
DoCall (t, n_args, isFunc, TRUE);
Eval (t);
END CallProc;
PROCEDURE DoCall (t: T; n_args: INTEGER; isFunc, outer: BOOLEAN)
RAISES {Error, Thread.Alerted} =
VAR p: QValue.Proc; s: QValue.Scope; val: QValue.T;
BEGIN
WITH f = t.frames[t.reg.fp-1] DO
f.outer := outer;
p := f.proc;
IF (p.info.n_args # n_args) AND (p.info.n_args >= 0) THEN
Err (t, Fmt.F ("%s to procedure %s (expected %s, received %s)",
"wrong number of parameters passed",
t.map.id2txt (p.info.name),
Fmt.Int (p.info.n_args), Fmt.Int (n_args)));
END;
IF (p.info.builtin) THEN
(* we save and restore the registers in case a builtin
procedure is on the stack when an error is raised *)
f.saved.pi := t.reg.pi;
f.saved.pc := t.reg.pc;
f.saved.cp := t.reg.cp;
f.saved.ln := t.reg.ln;
f.saved.fn := t.reg.fn;
t.reg.pi := p.info;
t.reg.pc := 0;
t.reg.cp := NIL;
t.reg.ln := 0;
t.reg.fn := isFunc;
p.info.handler (t, n_args);
IF (p.info.handler = DoInclude) THEN
(* the builtin include() function pops its own frame! *)
ELSE
CheckReturn (t, p.info.isFunc);
IF p.info.isFunc THEN
Pop (t, val);
EVAL PopFrame (t);
Push (t, val);
ELSE
EVAL PopFrame (t);
END;
END;
ELSE
f.saved.pi := t.reg.pi;
f.saved.pc := t.reg.pc;
f.saved.cp := t.reg.cp;
f.saved.ln := t.reg.ln;
t.reg.pi := p.info;
t.reg.pc := p.info.entry;
t.reg.cp := p.info.code;
t.reg.fn := isFunc;
s := PushScope (t);
s.parent := p.env; (* use procedure's static link *)
(* scope debugging
VAR m := "\n"; BEGIN
FOR i := 0 TO t.reg.xp -1 DO
m := m & " s: " & Fmt.Int(t.scopes[i].id);
IF t.scopes[i].parent = NIL THEN
m := m & " p: NIL\n";
ELSE
m := m & " p: " & Fmt.Int(t.scopes[i].parent.id) & "\n";
END;
END;
IO.Put("scopes (DoCall):" & m);
END;
*)
<*ASSERT s.parent # s*>
END;
END;
END DoCall;
PROCEDURE PopFrame (t: T): BOOLEAN
RAISES {Error, Thread.Alerted} =
VAR val: QValue.T;
BEGIN
DEC (t.reg.fp);
WITH f = t.frames[t.reg.fp] DO
f.proc := NIL;
WHILE (t.reg.ip > f.saved.ip) DO PopInclude (t); END;
t.reg.pi := f.saved.pi; f.saved.pi := NIL;
t.reg.cp := f.saved.cp; f.saved.cp := NIL;
t.reg.pc := f.saved.pc;
t.reg.ln := f.saved.ln;
t.reg.fn := f.saved.fn;
WHILE (t.reg.xp > f.saved.xp) DO PopScope (t); END;
WHILE (t.reg.sp > f.saved.sp) DO Pop (t, val); END;
WHILE (t.reg.lp > f.saved.lp) DO PopLoop (t); END;
WHILE (t.reg.op > f.saved.op) DO PopOutput (t); END;
RETURN f.outer;
END;
END PopFrame;
PROCEDURE CheckReturn (t: T; with_value: BOOLEAN)
RAISES {Error} =
BEGIN
IF (t.reg.fp < 1) THEN
Err (t, "return not in a function or procedure");
END;
IF (t.reg.fn = with_value) THEN
(* ok *)
ELSIF (t.reg.fn) THEN
Err (t, "expected return value is missing");
ELSE
Err (t, "unexpected return value");
END;
END CheckReturn;
------------------------------------------------------- global bindings ---
PROCEDURE Get (t: T; name: ID; VAR(*OUT*) value: QValue.T): BOOLEAN =
VAR ref: REFANY;
BEGIN
IF t.globals.get (name, ref) THEN
value := NARROW (ref, QValue.Binding).value;
RETURN TRUE;
ELSE
RETURN FALSE;
END;
END Get;
PROCEDURE Put (t: T; name: ID; READONLY value: QValue.T)
RAISES {Error} =
VAR bind := DefineGlobal (t, name, readonly := FALSE);
BEGIN
bind.value := value;
END Put;
----------------------------------------------- scopes & local bindings ---
PROCEDURE PushScope (t: T): QValue.Scope =
VAR m := "\n";
BEGIN
IF (t.reg.xp >= NUMBER (t.scopes^)) THEN ExpandScopes (t); END;
WITH s = t.scopes [t.reg.xp] DO
IF (s = NIL) THEN
s := NEW (QValue.Scope);
s.id := nextScopeId;
INC (nextScopeId);
END;
IF (t.reg.xp > 0)
THEN s.parent := t.scopes[t.reg.xp-1];
ELSE s.parent := NIL;
END;
<*ASSERT s.parent # s*>
(* scope debugging
FOR i := 0 TO t.reg.xp DO
m := m & " s: " & Fmt.Int(t.scopes[i].id);
IF t.scopes[i].parent = NIL THEN
m := m & " p: NIL\n";
ELSE
m := m & " p: " & Fmt.Int(t.scopes[i].parent.id) & "\n";
END;
END;
IO.Put("scopes:" & m);
*)
IF s.parent # NIL THEN
IF s.parent.parent = s THEN
TRY
Err (t, "loop in scopes, t.reg.xp = " & Fmt.Int(t.reg.xp) & m);
EXCEPT
Error(e) =>
TRY
Wr.PutText(Stdio.stderr, e);
EXCEPT ELSE END;
END;
s.parent.parent := NIL;
END;
END;
INC (t.reg.xp);
RETURN s;
END;
END PushScope;
VAR nextScopeId := 0;
PROCEDURE ExpandScopes (t: T) =
VAR n := NUMBER (t.scopes^); new := NEW (ScopeStack, n+n);
BEGIN
SUBARRAY (new^, 0, n) := t.scopes^;
t.scopes := new;
END ExpandScopes;
PROCEDURE PopScope (t: T) =
VAR b, last_b: QValue.Binding;
BEGIN
DEC (t.reg.xp);
WITH s = t.scopes [t.reg.xp] DO
b := s.bindings;
IF (b # NIL) THEN
(* recycle the bindings *)
WHILE (b # NIL) DO
b.readonly := FALSE;
b.name := NoID;
b.value.ref := NIL;
last_b := b;
b := b.next;
END;
last_b.next := t.bindings;
t.bindings := s.bindings;
s.bindings := NIL;
END;
s.parent := NIL;
END;
END PopScope;
PROCEDURE Define (t: T; id: ID; readonly: BOOLEAN): QValue.Binding
RAISES {Error} =
VAR old, new: QValue.Binding;
BEGIN
(* IO.Put("Define(" & Fmt.Int(id) & ")\n"); *)
WITH s = t.scopes [t.reg.xp-1] DO
old := s.bindings;
new := NewBinding (t);
new.next := old;
new.name := id;
new.readonly := readonly;
WHILE (old # NIL) DO
IF (old.name = id) THEN
Err (t, "duplicate symbol defined: " & t.map.id2txt (id));
END;
old := old.next;
END;
s.bindings := new;
END;
RETURN new;
END Define;
PROCEDURE DefineGlobal (t: T; id: ID; readonly: BOOLEAN): QValue.Binding
RAISES {Error} =
VAR ref: REFANY; bind: QValue.Binding;
BEGIN
IF t.globals.get (id, ref) THEN
bind := ref;
ELSE
bind := NewBinding (t);
bind.name := id;
bind.readonly := FALSE;
EVAL t.globals.put (id, bind);
END;
IF (bind.readonly) THEN
Err (t, "cannot redefine readonly global symbol: " & t.map.id2txt (id));
END;
bind.readonly := readonly;
RETURN bind;
END DefineGlobal;
PROCEDURE LookUp (t: T; id: ID): QValue.Binding =
VAR s: QValue.Scope; b: QValue.Binding; ref: REFANY;
BEGIN
(* IO.Put("LookUp(" & Fmt.Int(id) & ")\n"); *)
(* try the local scopes first *)
IF (t.reg.xp > 0) THEN
s := t.scopes [t.reg.xp-1];
WHILE (s # NIL) DO
b := s.bindings;
WHILE (b # NIL) DO
IF (b.name = id) THEN RETURN b; END;
b := b.next;
END;
s := s.parent;
END;
END;
(* finally try the globals *)
IF t.globals.get (id, ref)
THEN RETURN ref;
ELSE RETURN NIL;
END;
END LookUp;
PROCEDURE NewBinding (t: T): QValue.Binding =
VAR b := t.bindings;
BEGIN
IF (b # NIL) THEN
t.bindings := b.next;
b.next := NIL;
ELSE
b := NEW (QValue.Binding);
END;
RETURN b;
END NewBinding;
------------------------------------------------------------ data stack ---
PROCEDURE Push (t: T; READONLY value: QValue.T) =
BEGIN
IF (t.reg.sp >= NUMBER (t.stack^)) THEN ExpandStack (t); END;
t.stack [t.reg.sp] := value;
INC (t.reg.sp);
END Push;
PROCEDURE ExpandStack (t: T) =
VAR n := NUMBER (t.stack^); new := NEW (ValueStack, n+n);
BEGIN
SUBARRAY (new^, 0, n) := t.stack^;
t.stack := new;
END ExpandStack;
PROCEDURE Pop (t: T; VAR(*OUT*) value: QValue.T) RAISES {Error} =
BEGIN
IF (t.reg.sp <= 0) THEN Err (t, "empty stack"); END;
DEC (t.reg.sp);
WITH z = t.stack [t.reg.sp] DO
value := z;
z.ref := NIL;
END;
END Pop;
PROCEDURE PushText (t: T; s: TEXT) =
VAR v: QValue.T;
BEGIN
IF (s = NIL) THEN s := ""; END;
v.kind := QK.String;
v.int := t.map.txt2id (s);
v.ref := NIL;
Push (t, v);
END PushText;
PROCEDURE PushBool (t: T; b: BOOLEAN) =
VAR v: QValue.T;
BEGIN
v.kind := QK.String;
v.int := t.map.boolean [b];
v.ref := NIL;
Push (t, v);
END PushBool;
PROCEDURE PushInt (t: T; i: INTEGER) =
VAR v: QValue.T;
BEGIN
v.kind := QK.Integer;
v.int := i;
v.ref := NIL;
Push (t, v);
END PushInt;
PROCEDURE PushID (t: T; nm: ID) =
VAR v: QValue.T;
BEGIN
v.kind := QK.String;
v.int := nm;
v.ref := NIL;
Push (t, v);
END PushID;
PROCEDURE PopText (t: T): TEXT RAISES {Error} =
VAR v: QValue.T;
BEGIN
Pop (t, v);
RETURN QVal.ToText (t, v);
END PopText;
PROCEDURE PopBool (t: T): BOOLEAN RAISES {Error} =
VAR v: QValue.T;
BEGIN
Pop (t, v);
RETURN QVal.ToBool (t, v);
END PopBool;
PROCEDURE PopInt (t: T): INTEGER RAISES {Error} =
VAR v: QValue.T;
BEGIN
Pop (t, v);
RETURN QVal.ToInt (t, v);
END PopInt;
PROCEDURE PopID (t: T): ID RAISES {Error} =
VAR v: QValue.T;
BEGIN
Pop (t, v);
RETURN QVal.ToID (t, v);
END PopID;
---------------------------------------------------------- output stack ---
PROCEDURE PushOutput (t: T; nm: TEXT; append: BOOLEAN)
RAISES {Error} =
BEGIN
IF (t.reg.op >= NUMBER (t.output^)) THEN ExpandOutput (t); END;
WITH o = t.output [t.reg.op] DO
o.name := nm;
TRY
IF (append)
THEN o.wr := FileWr.OpenAppend (nm);
ELSE o.wr := FileWr.Open (nm);
END;
EXCEPT OSError.E(ec) =>
Err (t, Fmt.F ("unable to open \"%s\" for writing%s", nm, OSErr(ec)));
END;
END;
INC (t.reg.op);
END PushOutput;
PROCEDURE ExpandOutput (t: T) =
VAR n := NUMBER (t.output^); new := NEW (OutputStack, n+n);
BEGIN
SUBARRAY (new^, 0, n) := t.output^;
t.output := new;
END ExpandOutput;
PROCEDURE PopOutput (t: T)
RAISES {Error, Thread.Alerted} =
BEGIN
DEC (t.reg.op);
WITH o = t.output [t.reg.op] DO
TRY
Wr.Close (o.wr);
o.wr := NIL;
o.name := NIL;
EXCEPT Wr.Failure(ec) =>
Err (t, Fmt.F ("unable to close \"%s\"%s", o.name, OSErr(ec)));
END;
END;
END PopOutput;
PROCEDURE CurWr (t: T): Wr.T =
BEGIN
IF (t.reg.op <= 0)
THEN RETURN t.default_wr;
ELSE RETURN t.output [t.reg.op-1].wr;
END;
END CurWr;
PROCEDURE SetWr (t: T; wr: Wr.T) =
BEGIN
IF (t.reg.op <= 0)
THEN t.default_wr := wr;
ELSE t.output [t.reg.op-1].wr := wr;
END;
END SetWr;
------------------------------------------------------------ loop stack ---
PROCEDURE PushLoop (t: T; nm: ID; READONLY elts: QValue.T)
RAISES {Error} =
VAR tbl: QVTbl.T; arr: QVSeq.T;
BEGIN
IF (t.reg.lp >= NUMBER (t.loops^)) THEN ExpandLoops (t); END;
WITH x = t.loops [t.reg.lp] DO
IF (elts.kind = QK.Table) THEN
tbl := elts.ref;
x.iter := tbl.iterate ();
ELSIF (elts.kind = QK.Array) THEN
arr := elts.ref;
x.array := arr;
x.next_elt := 0;
ELSE
Err (t, "\"foreach\" not applied to an array or table");
END;
EVAL PushScope (t);
x.variable := Define (t, nm, readonly := TRUE);
END;
INC (t.reg.lp);
END PushLoop;
PROCEDURE ExpandLoops (t: T) =
VAR n := NUMBER (t.loops^); new := NEW (LoopStack, n+n);
BEGIN
SUBARRAY (new^, 0, n) := t.loops^;
t.loops := new;
END ExpandLoops;
PROCEDURE IterateLoop (t: T): BOOLEAN =
VAR int: INTEGER; val: QValue.T;
BEGIN
WITH x = t.loops [t.reg.lp-1] DO
IF (x.iter # NIL) THEN (* we're iterating over a table *)
IF NOT x.iter.next (int, val) THEN RETURN FALSE; END;
WITH z = x.variable.value DO
z.kind := QK.String;
z.int := int;
z.ref := NIL;
END;
ELSE (* we're iterating over an array *)
IF (x.next_elt >= x.array.size()) THEN RETURN FALSE; END;
x.variable.value := x.array.get (x.next_elt);
INC (x.next_elt);
END;
END;
RETURN TRUE;
END IterateLoop;
PROCEDURE PopLoop (t: T) =
BEGIN
PopScope (t);
DEC (t.reg.lp);
WITH x = t.loops [t.reg.lp] DO
x.iter := NIL;
x.array := NIL;
x.variable := NIL;
END;
END PopLoop;
--------------------------------------------------------- include stack ---
PROCEDURE PushInclude (t: T; s: QCode.Stream; VAR reg: Registers) =
BEGIN
IF (reg.ip >= NUMBER (t.includes^)) THEN ExpandIncludes (t); END;
WITH x = t.includes [reg.ip] DO
x.file := s;
x.old_cp := reg.cp;
x.old_pc := reg.pc;
END;
reg.cp := s;
reg.pc := 0;
INC (reg.ip);
END PushInclude;
PROCEDURE ExpandIncludes (t: T) =
VAR n := NUMBER (t.includes^); new := NEW (IncludeStack, n+n);
BEGIN
SUBARRAY (new^, 0, n) := t.includes^;
t.includes := new;
END ExpandIncludes;
PROCEDURE PopInclude (t: T) =
BEGIN
DEC (t.reg.ip);
WITH x = t.includes [t.reg.ip] DO
t.reg.cp := x.old_cp;
t.reg.pc := x.old_pc;
x.file := NIL;
x.old_cp := NIL;
END;
END PopInclude;
----------------------------------------------------- OS dependent goo! ---
PROCEDURE InitOSEnv (t: T) =
BEGIN
IF OnUnix THEN
t.shell := "/bin/sh";
t.sh_option := "-c";
t.tmp_dir := GetEnv ("TEMP", "/tmp");
ELSE
t.shell := GetEnv ("COMSPEC", "COMMAND.COM");
t.sh_option := "/c";
t.tmp_dir := GetEnv ("TEMP", "C:\\TEMP");
END;
END InitOSEnv;
PROCEDURE GetEnv (variable, default: TEXT): TEXT =
VAR val := Env.Get (variable);
BEGIN
IF (val = NIL) THEN val := default; END;
RETURN val;
END GetEnv;
---------------------------------------------------- builtin procedures ---
TYPE
Builtin = RECORD
name : TEXT;
proc : QCode.BuiltinProc;
n_args : INTEGER;
is_func : BOOLEAN;
END;
CONST
Builtins = ARRAY OF Builtin {
Builtin {"arglist", DoArgList, 2, TRUE},
Builtin {"cp_if", DoCopyIfNew, 2, FALSE},
Builtin {"defined", DoDefined, 1, TRUE},
Builtin {"empty", DoEmpty, 1, TRUE},
Builtin {"equal", DoEqual, 2, TRUE},
Builtin {"error", DoError, 1, FALSE},
Builtin {"escape", DoEscape, 1, TRUE},
Builtin {"exec", DoExec, -1, FALSE},
Builtin {"file", DoFile, 0, TRUE},
Builtin {"format", DoFormat, -1, TRUE},
Builtin {"include", DoInclude, 1, FALSE},
Builtin {"make_dir", DoMakeDir, 1, FALSE},
Builtin {"normalize", DoNormalize, 2, TRUE},
Builtin {"path", DoPath, 0, TRUE},
Builtin {"stale", DoStale, 2, TRUE},
Builtin {"try_exec", DoTryExec, -1, TRUE},
Builtin {"unlink_file", DoUnlink, 1, TRUE},
Builtin {"write", DoWrite, -1, FALSE},
Builtin {"TRACE_INSTR", DoTrace, 0, FALSE}
};
PROCEDURE InitBuiltins (t: T) =
VAR b: QValue.Binding;
BEGIN
FOR i := FIRST (Builtins) TO LAST (Builtins) DO
WITH z = Builtins [i] DO
b := NewBuiltin (t, z.name, z.proc, z.n_args, z.is_func);
EVAL t.globals.put (b.name, b);
END;
END;
b := NewConst (t, "TRUE", t.map.boolean [TRUE]);
EVAL t.globals.put (b.name, b);
b := NewConst (t, "FALSE", t.map.boolean [FALSE]);
EVAL t.globals.put (b.name, b);
END InitBuiltins;
PROCEDURE NewBuiltin (t : T;
nm : TEXT;
handler : QCode.BuiltinProc;
n_args : INTEGER;
isFunc : BOOLEAN): QValue.Binding =
VAR
id := t.map.txt2id (nm);
info := NEW (QCode.ProcInfo, name := id, isFunc := isFunc,
n_args := n_args, builtin := TRUE, handler := handler);
proc := NEW (QValue.Proc, info := info, env := NIL);
bind := NEW (QValue.Binding, name := info.name, readonly := TRUE);
BEGIN
bind.value.kind := QValue.Kind.Proc;
bind.value.int := 0;
bind.value.ref := proc;
RETURN bind;
END NewBuiltin;
PROCEDURE NewConst (t: T; nm: TEXT; val: ID): QValue.Binding =
VAR
id := t.map.txt2id (nm);
bind := NEW (QValue.Binding, name := id, readonly := TRUE);
BEGIN
bind.value.kind := QValue.Kind.String;
bind.value.int := val;
bind.value.ref := NIL;
RETURN bind;
END NewConst;
PROCEDURE DoArgList (t: T; n_args: INTEGER)
RAISES {Error, Thread.Alerted} =
CONST
Max_args = 10;
Max_arg_length = 1024;
VAR
prefix, args : TEXT;
split : TextSeq.T;
val0, val1 : QValue.T;
file : TEXT;
wr : Wr.T;
buf : M3Buf.T;
BEGIN
<*ASSERT n_args = 2 *>
buf := GetBuf (t);
Pop (t, val1);
QVal.ToBuf (t, val1, buf);
args := M3Buf.ToText (buf);
split := SplitArgs (args);
FreeBuf (t, buf);
Pop (t, val0);
prefix := QVal.ToText (t, val0);
(* check for the easy case *)
IF (split.size () <= Max_args)
AND (Text.Length (args) <= Max_arg_length) THEN
Push (t, val1);
RETURN;
END;
TRY
file := UniqueTempFile (t);
wr := FileWr.Open (file);
TRY
FOR i := 0 TO split.size()-1 DO
Wr.PutText (wr, split.get(i));
Wr.PutText (wr, Wr.EOL);
END;
FINALLY
Wr.Close (wr);
END;
PushText (t, prefix & file);
EXCEPT
| Wr.Failure(ec) =>
Err (t, "unable to write on \"" & file & "\"" & OSErr (ec));
| OSError.E(ec) =>
Err (t, "unable to write on \"" & file & "\"" & OSErr (ec));
END;
END DoArgList;
PROCEDURE DoCopyIfNew (t: T; n_args: INTEGER) RAISES {Error} =
VAR val: QValue.T; src, dest: TEXT;
BEGIN
<*ASSERT n_args = 2 *>
Pop (t, val); dest := QVal.ToText (t, val);
Pop (t, val); src := QVal.ToText (t, val);
CopyIfNew (t, src, dest);
END DoCopyIfNew;
PROCEDURE CopyIfNew (t: T; src, dest: TEXT) RAISES {Error} =
VAR equal := FALSE;
BEGIN
IF M3File.IsDirectory (dest) THEN
dest := Pathname.Join (dest, Pathname.Last (src), NIL);
END;
TRY
equal := M3File.IsEqual (src, dest);
EXCEPT OSError.E =>
END;
TRY
IF NOT equal THEN M3File.Copy (src, dest); END;
EXCEPT OSError.E(ec) =>
Err (t, Fmt.F ("unable to copy \"%s\" to \"%s\"%s",
src, dest, OSErr (ec)));
END;
END CopyIfNew;
PROCEDURE DoDefined (t: T; n_args: INTEGER) RAISES {Error} =
VAR val: QValue.T;
BEGIN
<*ASSERT n_args = 1 *>
Pop (t, val);
PushBool (t, LookUp (t, QVal.ToID (t, val)) # NIL);
END DoDefined;
PROCEDURE DoEmpty (t: T; n_args: INTEGER) RAISES {Error} =
VAR empty := FALSE; val: QValue.T;
BEGIN
<*ASSERT n_args = 1 *>
Pop (t, val);
CASE val.kind OF
| QK.Integer => empty := FALSE;
| QK.String => empty := (val.int = t.map.boolean[FALSE]);
| QK.Array => empty := NARROW (val.ref, QVSeq.T).size() = 0;
| QK.Table => empty := NARROW (val.ref, QVTbl.T).size() = 0;
ELSE
Err (t, "\"empty\" not applied to a string, table, or array");
END;
PushBool (t, empty);
END DoEmpty;
PROCEDURE DoEqual (t: T; n_args: INTEGER) RAISES {Error} =
VAR v1, v2: QValue.T; eq := FALSE;
BEGIN
<*ASSERT n_args = 2 *>
Pop (t, v1);
Pop (t, v2);
IF (v1.kind = v2.kind) THEN
CASE v1.kind OF
| QK.Var => eq := (v1.int = v2.int) AND (v1.ref = v2.ref);
| QK.Integer => eq := (v1.int = v2.int);
| QK.String => eq := (v1.int = v2.int);
| QK.Table => eq := (v1.ref = v2.ref);
| QK.Array => eq := (v1.ref = v2.ref);
| QK.Proc => eq := (v1.ref = v2.ref);
END;
END;
PushBool (t, eq);
END DoEqual;
PROCEDURE DoError (t: T; n_args: INTEGER) RAISES {Error} =
VAR val: QValue.T;
BEGIN
<*ASSERT n_args = 1 *>
Pop (t, val);
Err (t, QVal.ToText (t, val));
END DoError;
PROCEDURE DoEscape (t: T; n_args: INTEGER) RAISES {Error} =
VAR
val : QValue.T;
txt : TEXT;
buf : M3Buf.T;
ch : CHAR;
len : INTEGER;
out_len : INTEGER;
out_buf : ARRAY [0..199] OF CHAR;
in_buf : ARRAY [0..199] OF CHAR;
new_ch : BOOLEAN := FALSE;
BEGIN
<*ASSERT n_args = 1 *>
Pop (t, val); txt := QVal.ToText (t, val);
len := Text.Length (txt);
IF (len+len <= NUMBER (out_buf)) THEN
out_len := 0;
Text.SetChars (in_buf, txt);
FOR i := 0 TO len-1 DO
ch := Text.GetChar (txt, i);
IF (ch = '\134') THEN
out_buf[out_len] := ch; INC (out_len);
new_ch := TRUE;
END;
out_buf [out_len] := ch; INC (out_len);
END;
IF (new_ch)
THEN PushText (t, Text.FromChars (SUBARRAY (out_buf, 0, out_len)));
ELSE Push (t, val);
END;
ELSE
buf := GetBuf (t);
FOR i := 0 TO len - 1 DO
ch := Text.GetChar (txt, i);
IF (ch = '\134') THEN M3Buf.PutChar (buf, ch); new_ch := TRUE; END;
M3Buf.PutChar (buf, ch);
END;
txt := M3Buf.ToText (buf);
FreeBuf (t, buf);
IF (new_ch)
THEN PushText (t, txt);
ELSE Push (t, val);
END;
END;
END DoEscape;
PROCEDURE ExecEcho (t: T; b: BOOLEAN): BOOLEAN =
VAR old := t.do_echo;
BEGIN
t.do_echo := b;
RETURN old;
END ExecEcho;
TYPE
ExecInfo = RECORD
command : TEXT;
exit_code : INTEGER;
ignore_errors : BOOLEAN;
END;
PROCEDURE DoExec (t: T; n_args: INTEGER)
RAISES {Error, Thread.Alerted} =
VAR info := ExecCommand (t, n_args);
BEGIN
IF (info.exit_code # 0) AND NOT info.ignore_errors THEN
Err (t, Fmt.F("exit %s: %s", Fmt.Int(info.exit_code), info.command));
END;
END DoExec;
PROCEDURE DoTryExec (t: T; n_args: INTEGER)
RAISES {Error, Thread.Alerted} =
VAR info := ExecCommand (t, n_args);
BEGIN
IF (info.ignore_errors) THEN info.exit_code := 0; END;
PushInt (t, info.exit_code);
END DoTryExec;
PROCEDURE ExecCommand (t: T; n_args: INTEGER): ExecInfo
RAISES {Error, Thread.Alerted} =
VAR
info : ExecInfo;
echo := TRUE;
first := TRUE;
n : INTEGER;
handle : Process.T;
stdin, stdout, stderr: File.T;
args : ARRAY [0..1] OF TEXT;
buf : M3Buf.T;
n_shell_args : INTEGER;
quake_in : Pipe.T;
process_out : Pipe.T;
wr : Wr.T := CurWr (t);
wd : TEXT;
inbuf : ARRAY [0..255] OF CHAR;
BEGIN
info.command := "";
info.exit_code := 0;
info.ignore_errors := FALSE;
IF (n_args <= 0) THEN RETURN info; END;
(* pack the arguments into a single string & pop the stack *)
buf := GetBuf (t);
FOR i := t.reg.sp - n_args TO t.reg.sp - 1 DO
IF (first) THEN first := FALSE; ELSE M3Buf.PutChar (buf, ' '); END;
QVal.ToBuf (t, t.stack[i], buf);
t.stack[i].ref := NIL;
END;
t.reg.sp := t.reg.sp - n_args;
info.command := M3Buf.ToText (buf);
FreeBuf (t, buf);
(* strip the leading magic characters *)
n := 0;
WHILE n < Text.Length (info.command) DO
CASE Text.GetChar (info.command, n) OF
| '@' => echo := FALSE;
| '-' => info.ignore_errors := TRUE;
ELSE EXIT;
END;
INC (n);
END;
info.command := Text.Sub (info.command, n);
(* echo the command & flush any pending output *)
TRY
IF echo OR t.do_echo THEN
Wr.PutText (wr, info.command);
Wr.PutText (wr, Wr.EOL);
END;
FlushIO ();
EXCEPT Wr.Failure (ec) =>
Err (t, "write failed" & OSErr (ec));
END;
wd := ExtractInitialDir (info.command);
args [0] := t.sh_option;
args [1] := info.command;
n_shell_args := 2;
(* finally, execute the command *)
TRY
Process.GetStandardFileHandles (stdin, stdout, stderr);
Pipe.Open (hr := quake_in, hw := process_out);
TRY
(* fire up the subprocess *)
handle := Process.Create (t.shell, SUBARRAY (args, 0, n_shell_args),
stdin := stdin, stdout := process_out,
stderr := process_out, wd := wd);
(* close our copy of the writing end of the output pipe *)
process_out.close ();
LOOP (* send anything coming through the pipe to the quake output file *)
n := M3File.Read (quake_in, inbuf, NUMBER (inbuf));
IF (n <= 0) THEN EXIT; END;
Wr.PutString (wr, SUBARRAY (inbuf, 0, n));
END;
FINALLY
quake_in.close ();
FlushIO ();
END;
EXCEPT
| Thread.Alerted =>
KillProcess (handle);
RAISE Thread.Alerted;
| Wr.Failure (ec) =>
KillProcess (handle);
Err (t, "write failed" & OSErr (ec));
| OSError.E (ec) =>
KillProcess (handle);
Err (t, Fmt.F ("exec failed%s *** %s", OSErr (ec), info.command));
END;
(* wait for everything to shutdown... *)
info.exit_code := Process.Wait (handle);
RETURN info;
END ExecCommand;
PROCEDURE ExtractInitialDir (VAR cmd: TEXT): TEXT =
(* search for "cd <dir> |" or "cd <dir> ;" prefix in "cmd".
If it's found, return "<dir>" and remove the prefix from "cmd".
Otherwise, return "NIL". *)
VAR
len := Text.Length (cmd);
buf : ARRAY [0..99] OF CHAR;
start, stop: INTEGER;
dir: TEXT;
BEGIN
IF (len < 5) THEN RETURN NIL; END;
Text.SetChars (buf, cmd);
start := 0;
WHILE (start < len) AND (buf[start] = ' ') DO INC (start); END;
IF (start+4 >= len) THEN RETURN NIL; END;
IF (buf[start] # 'c') THEN RETURN NIL; END;
IF (buf[start+1] # 'd') THEN RETURN NIL; END;
IF (buf[start+2] # ' ') THEN RETURN NIL; END;
INC (start, 3);
WHILE (start < len) AND (buf[start] = ' ') DO INC (start); END;
stop := start;
WHILE (stop < len) AND (buf[stop] # ' ')
AND (buf[stop] # '|') AND (buf[stop] # ';') DO INC (stop); END;
IF (stop <= start) THEN RETURN NIL; END;
dir := Text.FromChars (SUBARRAY (buf, start, stop - start));
WHILE (stop < len) AND (buf[stop] = ' ') DO INC (stop); END;
IF (stop >= len) THEN RETURN NIL; END;
IF (buf[stop] # '|') AND (buf[stop] # ';') THEN RETURN NIL; END;
cmd := Text.Sub (cmd, stop+1);
RETURN dir;
END ExtractInitialDir;
PROCEDURE KillProcess (handle: Process.T) =
BEGIN
IF (handle # NIL) THEN
TRY
M3Process.Interrupt (handle);
EXCEPT OSError.E =>
(* ignore *)
END;
END;
END KillProcess;
PROCEDURE DoFile (t: T; n_args: INTEGER) =
BEGIN
<*ASSERT n_args = 0 *>
PushText (t, CurFile (t));
END DoFile;
PROCEDURE CurFile (t: T): TEXT =
BEGIN
RETURN t.map.id2txt (t.includes[t.reg.ip-1].file.source_file);
END CurFile;
PROCEDURE DoFormat (t: T; n_args: INTEGER) RAISES {Error} =
VAR
val : QValue.T;
n : INTEGER;
format : TEXT;
strings := NEW (REF ARRAY OF TEXT, n_args - 1);
BEGIN
<*ASSERT n_args > 0 *>
n := 0;
FOR i := t.reg.sp - n_args + 1 TO t.reg.sp - 1 DO
strings [n] := QVal.ToText (t, t.stack[i]); INC (n);
t.stack[i].ref := NIL;
END;
DEC (t.reg.sp, n_args - 1);
Pop (t, val);
format := QVal.ToText (t, val);
PushText (t, Fmt.FN (format, strings^));
END DoFormat;
PROCEDURE DoInclude (t: T; n_args: INTEGER) RAISES {Error, Thread.Alerted} =
VAR path: TEXT; val: QValue.T;
BEGIN
<*ASSERT n_args = 1 *>
Pop (t, val); path := QVal.ToText (t, val);
IncludeFile (t, path, from_code := TRUE);
END DoInclude;
PROCEDURE Include (t: T; path: TEXT) RAISES {Error, Thread.Alerted} =
BEGIN
IncludeFile (t, path, from_code := FALSE);
END Include;
PROCEDURE IncludeFile (t: T; path: TEXT; from_code: BOOLEAN)
RAISES {Error, Thread.Alerted} =
VAR old_path: TEXT; code: QCode.Stream;
BEGIN
IF NOT Pathname.Absolute (path) THEN
old_path := CurFile (t);
path := Pathname.Join (Pathname.Prefix (old_path), path, NIL);
END;
TRY
code := QCompiler.CompileFile (path, t.map);
EXCEPT Error(msg) =>
Err (t, msg);
END;
(****
WITH f = t.frames [t.reg.fp-1] DO
PushInclude (t, code, f.saved);
t.reg.ip := f.saved.ip;
END;
****)
IF (from_code) THEN
EVAL PopFrame (t); (* pop the call to "include()" *)
END;
PushInclude (t, code, t.reg);
Eval (t);
END IncludeFile;
PROCEDURE DoMakeDir (t: T; n_args: INTEGER) RAISES {Error} =
VAR val: QValue.T; dir: TEXT;
BEGIN
<*ASSERT n_args = 1 *>
Pop (t, val); dir := QVal.ToText (t, val);
MakeDir (t, dir);
END DoMakeDir;
PROCEDURE MakeDir (t: T; dir: TEXT) RAISES {Error} =
VAR parent: TEXT;
BEGIN
IF dir = NIL THEN RETURN END;
IF M3File.IsDirectory (dir) THEN RETURN END;
parent := Pathname.Prefix (dir);
IF (parent # NIL) AND NOT PathEqual (parent, dir) THEN
MakeDir (t, parent);
END;
TRY
FS.CreateDirectory (dir);
EXCEPT OSError.E (ec) =>
Err (t, Fmt.F ("unable to create directory \"%s\"%s", dir, OSErr (ec)));
END;
END MakeDir;
PROCEDURE DoNormalize (t: T; n_args: INTEGER) RAISES {Error} =
VAR val: QValue.T; unfixed, prefix: TEXT;
BEGIN
<*ASSERT n_args = 2 *>
Pop (t, val); unfixed := QVal.ToText (t, val);
Pop (t, val); prefix := QVal.ToText (t, val);
PushText (t, Normalize (t, prefix, unfixed));
END DoNormalize;
PROCEDURE Normalize (t: T; prefix, unfixed: TEXT): TEXT RAISES {Error} =
VAR unfixedArcs, prefixArcs: Pathname.Arcs;
BEGIN
TRY
unfixedArcs := Pathname.Decompose(unfixed);
EXCEPT Pathname.Invalid =>
Err (t, Fmt.F ("invalid path (\"%s\") in normalize", unfixed));
END;
TRY
prefixArcs := Pathname.Decompose(prefix);
EXCEPT Pathname.Invalid =>
Err (t, Fmt.F ("invalid path (\"%s\") in normalize", prefix));
END;
TRY
RETURN Pathname.Compose (StripPrefix (t, prefixArcs,
CanonicalizePath (unfixedArcs)));
EXCEPT Pathname.Invalid =>
Err (t, Fmt.F ("invalid path in normalize(\"%s\", \"%s\")",
prefix, unfixed));
END;
RETURN NIL;
END Normalize;
PROCEDURE DoPath (t: T; n_args: INTEGER) =
BEGIN
<*ASSERT n_args = 0 *>
PushText (t, CurPath (t));
END DoPath;
PROCEDURE CurPath (t: T): TEXT =
BEGIN
RETURN Pathname.Prefix (CurFile (t));
END CurPath;
PROCEDURE DoStale (t: T; n_args: INTEGER) RAISES {Error} =
VAR
val, val2 : QValue.T;
arr : QVSeq.T;
dep : TEXT;
target : TEXT;
t_status : File.Status;
d_status : File.Status;
BEGIN
<*ASSERT n_args = 2 *>
Pop (t, val2); (* dependencies *)
Pop (t, val); target := QVal.ToText (t, val);
TRY
t_status := FS.Status (target);
IF (val2.kind = QK.Array) THEN
arr := val2.ref;
FOR i := 0 TO arr.size() - 1 DO
dep := QVal.ToText (t, arr.get (i));
d_status := FS.Status (dep);
IF t_status.modificationTime < d_status.modificationTime THEN
PushBool (t, TRUE);
RETURN;
END;
END;
ELSE
dep := QVal.ToText (t, val2);
d_status := FS.Status (dep);
IF t_status.modificationTime < d_status.modificationTime THEN
PushBool (t, TRUE);
RETURN;
END;
END;
EXCEPT OSError.E =>
PushBool (t, TRUE);
RETURN;
END;
PushBool (t, FALSE);
END DoStale;
PROCEDURE DoUnlink (t: T; n_args: INTEGER) RAISES {Error} =
VAR val: QValue.T; ok := FALSE;
BEGIN
<*ASSERT n_args = 1 *>
Pop (t, val);
TRY
FS.DeleteFile (QVal.ToText (t, val));
ok := TRUE;
EXCEPT OSError.E =>
ok := FALSE;
END;
PushBool (t, ok);
END DoUnlink;
PROCEDURE DoWrite (t: T; n_args: INTEGER)
RAISES {Error, Thread.Alerted} =
VAR wr := CurWr (t); buf := GetBuf (t); txt: TEXT;
BEGIN
(* write the arguments to an internal buffer & pop the stack *)
FOR i := t.reg.sp - n_args TO t.reg.sp - 1 DO
QVal.ToBuf (t, t.stack[i], buf);
t.stack[i].ref := NIL;
END;
t.reg.sp := t.reg.sp - n_args;
txt := M3Buf.ToText (buf);
FreeBuf (t, buf);
TRY Wr.PutText (wr, txt);
EXCEPT Wr.Failure (ec) => Err (t, "write failed" & OSErr (ec));
END;
END DoWrite;
PROCEDURE DoTrace (t: T; n_args: INTEGER) =
BEGIN
<*ASSERT n_args = 0*>
t.tracing := NOT t.tracing;
END DoTrace;
-------------------------------------------------------- memory buffers ---
We don't use TRY/FINALLY or worry about buffers that aren't freed.
In the rare cases when they're not returned, the collector get them.
PROCEDURE GetBuf (t: T): M3Buf.T =
VAR buf: M3Buf.T;
BEGIN
IF (t.buffers.tos > 0) THEN
DEC (t.buffers.tos);
WITH z = t.buffers.bufs [t.buffers.tos] DO buf := z; z := NIL; END;
ELSE
buf := M3Buf.New ();
END;
RETURN buf;
END GetBuf;
PROCEDURE FreeBuf (t: T; buf: M3Buf.T) =
BEGIN
IF (t.buffers.tos < NUMBER (t.buffers.bufs)) THEN
t.buffers.bufs [t.buffers.tos] := buf;
INC (t.buffers.tos);
END;
END FreeBuf;
------------------------------------------------------------ temp files ---
PROCEDURE CleanUp (t: T) =
VAR n: INTEGER; path: TEXT;
BEGIN
IF (t.tmp_files # NIL) THEN
n := t.tmp_files.size ();
WHILE (n > 0) DO
path := t.tmp_files.remlo ();
TRY
FS.DeleteFile (path);
EXCEPT OSError.E =>
(* ignore *)
END;
DEC (n);
END;
END;
END CleanUp;
PROCEDURE UniqueTempFile (t: T): TEXT =
VAR root, file: TEXT; seq := 0;
BEGIN
root := Pathname.Join (t.tmp_dir, "qk", NIL);
file := root;
LOOP
TRY
EVAL FS.Status (file);
EXCEPT OSError.E =>
EXIT;
END;
INC (seq);
file := root & "_" & Fmt.Int (seq);
END;
IF (t.tmp_files = NIL) THEN t.tmp_files := NEW (TextSeq.T).init(); END;
t.tmp_files.addhi (file);
RETURN file;
END UniqueTempFile;
------------------------------------------------------------------ misc ---
PROCEDURE Err (t: T; msg: TEXT) RAISES {Error} =
VAR buf := GetBuf (t); txt: TEXT; line: INTEGER;
BEGIN
IF FindErrorFile (t, txt, line) THEN
M3Buf.PutText (buf, "\"");
M3Buf.PutText (buf, txt);
M3Buf.PutText (buf, "\", line ");
M3Buf.PutInt (buf, line);
M3Buf.PutText (buf, ": ");
END;
M3Buf.PutText (buf, "quake runtime error: ");
M3Buf.PutText (buf, msg);
M3Buf.PutText (buf, Wr.EOL);
M3Buf.PutText (buf, Wr.EOL);
M3Buf.PutText (buf, "--procedure-- -line- -file---");
M3Buf.PutText (buf, Wr.EOL);
DumpFrame (t, buf, t.reg);
FOR i := t.reg.fp-1 TO 0 BY -1 DO
DumpFrame (t, buf, t.frames[i].saved);
END;
txt := M3Buf.ToText (buf);
FreeBuf (t, buf);
RAISE Error (txt);
END Err;
PROCEDURE FindErrorFile (t: T; VAR(*OUT*) file: TEXT;
VAR(*OUT*) line: INTEGER): BOOLEAN =
BEGIN
IF FindErrorFrame (t, t.reg, file, line) THEN RETURN TRUE; END;
FOR i := t.reg.fp-1 TO 0 BY -1 DO
IF FindErrorFrame (t, t.frames[i].saved, file, line) THEN RETURN TRUE; END;
END;
RETURN FALSE;
END FindErrorFile;
PROCEDURE FindErrorFrame (t : T;
READONLY reg : Registers;
VAR(*OUT*) file : TEXT;
VAR(*OUT*) line : INTEGER): BOOLEAN =
BEGIN
IF reg.cp = NIL THEN RETURN FALSE; END;
(* else, we're executing in user-written quake code *)
file := t.map.id2txt (reg.cp.source_file);
line := MAX (1, reg.ln);
RETURN TRUE;
END FindErrorFrame;
PROCEDURE DumpFrame (t: T; buf: M3Buf.T; READONLY reg: Registers) =
BEGIN
IF (reg.pi = NIL)
THEN Out (buf, "", 13);
ELSE Out (buf, t.map.id2txt (reg.pi.name), 13);
END;
M3Buf.PutText (buf, " ");
IF (reg.ln > 0)
THEN Out (buf, Fmt.Int (reg.ln), -6);
ELSE Out (buf, "--", -6);
END;
M3Buf.PutText (buf, " ");
IF (reg.cp = NIL)
THEN M3Buf.PutText (buf, "<builtin>");
ELSE M3Buf.PutText (buf, t.map.id2txt (reg.cp.source_file));
END;
M3Buf.PutText (buf, Wr.EOL);
END DumpFrame;
PROCEDURE Out (buf: M3Buf.T; txt: TEXT; width: INTEGER) =
VAR len := Text.Length (txt);
BEGIN
IF (width < 0) THEN
width := -width;
WHILE (len < width) DO M3Buf.PutChar (buf, ' '); INC (len); END;
M3Buf.PutText (buf, txt);
ELSE
M3Buf.PutText (buf, txt);
WHILE (len < width) DO M3Buf.PutChar (buf, ' '); INC (len); END;
END;
END Out;
PROCEDURE OSErr (args: AtomList.T): TEXT =
VAR msg : TEXT := NIL;
BEGIN
WHILE (args # NIL) DO
IF (msg = NIL) THEN msg := ": "; ELSE msg := msg & " *** "; END;
msg := msg & Atom.ToText (args.head);
args := args.tail;
END;
RETURN msg;
END OSErr;
PROCEDURE CanonicalizePath (path: Pathname.Arcs): Pathname.Arcs =
(* Remove '..' and '.' components from "path". *)
VAR found := FALSE; arc: TEXT; new: Pathname.Arcs; pending: INTEGER;
BEGIN
FOR i := 0 TO path.size () - 1 DO
arc := path.get (i);
IF (arc # NIL) AND
(PathEqual (arc, Pathname.Current)
OR PathEqual (arc, Pathname.Parent)) THEN
found := TRUE;
EXIT;
END;
END;
IF NOT found THEN RETURN path; END;
new := NEW(Pathname.Arcs).init();
pending := 0;
FOR i := 0 TO path.size() - 1 DO
arc := path.get(i);
IF (arc = NIL) THEN
new.addhi (arc); (* leave the NIL arcs in place (?) *)
ELSIF PathEqual(arc, Pathname.Current) THEN
(* skip it *)
ELSIF PathEqual(arc, Pathname.Parent) THEN
INC(pending);
ELSIF pending > 0 THEN
DEC(pending);
ELSE
new.addhi(arc);
END;
END;
WHILE pending > 0 DO new.addhi(Pathname.Parent); DEC(pending); END;
RETURN new;
END CanonicalizePath;
PROCEDURE StripPrefix (t: T; prefix, path: Pathname.Arcs): Pathname.Arcs
RAISES {Error} =
VAR
path_sz, prefix_sz: INTEGER;
path_txt, prefix_txt: TEXT;
result: Pathname.Arcs;
BEGIN
TRY
path_txt := Pathname.Compose (path);
prefix_txt := Pathname.Compose (prefix);
path_sz := path.size ();
prefix_sz := prefix.size ();
IF PathEqual (path_txt, prefix_txt) THEN
result := NEW (Pathname.Arcs).init (1);
result.addhi (NIL);
RETURN result;
END;
IF NOT Pathname.Absolute(path_txt)
OR NOT Pathname.Absolute(prefix_txt) THEN
RETURN path;
END;
EXCEPT Pathname.Invalid =>
Err (t, "internal error: invalid pathname in StripPrefix");
END;
(* make sure "prefix" really is a prefix of "path" *)
IF (prefix_sz > path_sz) THEN RETURN path; END;
FOR i := 0 TO prefix_sz - 1 DO
IF NOT PathEqual (prefix.get(i), path.get(i)) THEN
RETURN path;
END;
END;
result := TextSeq.Sub (path, prefix_sz);
result.addlo (NIL); (* make it a relative path *)
RETURN result;
END StripPrefix;
PROCEDURE PathEqual (a, b: TEXT): BOOLEAN =
BEGIN
IF Text.Equal (a, b) THEN RETURN TRUE; END;
IF OnUnix THEN RETURN FALSE; END;
RETURN CIEqual (a, b);
END PathEqual;
PROCEDURE CIEqual (a, b: TEXT): BOOLEAN =
(* on Win32, try a case-insensitive match... *)
VAR len, nxt: INTEGER; buf_a, buf_b: ARRAY [0..127] OF CHAR;
BEGIN
len := Text.Length (a);
IF (len # Text.Length (b)) THEN RETURN FALSE; END;
nxt := 0;
WHILE (nxt < len) DO
Text.SetChars (buf_a, a, nxt);
Text.SetChars (buf_b, b, nxt);
FOR i := 0 TO MIN (NUMBER (buf_a), len-nxt) - 1 DO
IF lcase[buf_a[i]] # lcase[buf_b[i]] THEN RETURN FALSE; END;
END;
INC (nxt, NUMBER (buf_a));
END;
RETURN TRUE;
END CIEqual;
PROCEDURE SplitArgs (txt: TEXT): TextSeq.T =
VAR
seq := NEW (TextSeq.T).init ();
i := 0;
len := Text.Length (txt);
start : INTEGER;
BEGIN
WHILE i < len DO
WHILE i < len AND QScanner.WhiteSpace [Text.GetChar (txt, i)] DO INC(i); END;
start := i;
WHILE i < len AND NOT QScanner.WhiteSpace [Text.GetChar (txt, i)] DO INC(i); END;
IF i > start THEN seq.addhi (Text.Sub (txt, start, i - start)); END;
END;
RETURN seq;
END SplitArgs;
PROCEDURE Print (a, b, c, d: TEXT := NIL)
RAISES {Wr.Failure, Thread.Alerted} =
VAR wr := Stdio.stdout;
BEGIN
IF (wr = NIL) THEN (*try...*) wr := Stdio.stderr; END;
IF (a # NIL) THEN Wr.PutText (wr, a); END;
IF (b # NIL) THEN Wr.PutText (wr, b); END;
IF (c # NIL) THEN Wr.PutText (wr, c); END;
IF (d # NIL) THEN Wr.PutText (wr, d); END;
END Print;
PROCEDURE FlushIO ()
RAISES {Wr.Failure, Thread.Alerted} =
BEGIN
IF (Stdio.stdout # NIL) THEN Wr.Flush (Stdio.stdout); END;
IF (Stdio.stderr # NIL) THEN Wr.Flush (Stdio.stderr); END;
END FlushIO;
VAR
strict_variables := NOT RTParams.IsPresent ("oldquake");
lcase : ARRAY CHAR OF CHAR;
BEGIN
FOR c := FIRST (lcase) TO LAST (lcase) DO lcase[c] := c; END;
FOR c := 'A' TO 'Z' DO
lcase[c] := VAL (ORD (c) - ORD ('A') + ORD ('a'), CHAR);
END;
END QMachine.