mirror of
https://github.com/vishapoberon/compiler.git
synced 2026-04-06 23:52:25 +00:00
331 lines
10 KiB
Modula-2
331 lines
10 KiB
Modula-2
MODULE Modules; (* jt 6.1.96 *)
|
|
|
|
(* access to list of modules and commands, based on ETH Oberon *)
|
|
|
|
|
|
IMPORT SYSTEM, Platform, Heap; (* Note, must import Platform before Heap *)
|
|
|
|
CONST
|
|
ModNameLen* = 20;
|
|
|
|
TYPE
|
|
ModuleName* = Heap.ModuleName;
|
|
Module* = Heap.Module;
|
|
Cmd* = Heap.Cmd;
|
|
Command* = Heap.Command;
|
|
VAR
|
|
res*: INTEGER;
|
|
resMsg*: ARRAY 256 OF CHAR;
|
|
imported*: ModuleName;
|
|
importing*: ModuleName;
|
|
|
|
MainStackFrame-: SYSTEM.ADDRESS;
|
|
ArgCount-: INTEGER;
|
|
ArgVector-: SYSTEM.ADDRESS;
|
|
BinaryDir-: ARRAY 1024 OF CHAR;
|
|
|
|
|
|
(* Program startup *)
|
|
|
|
PROCEDURE -ExternInitHeap "extern void Heap_InitHeap();";
|
|
PROCEDURE -InitHeap "Heap_InitHeap()";
|
|
PROCEDURE -ExternInitModulesInit "extern void *Modules__init(void);";
|
|
PROCEDURE -ModulesInit() "Modules__init()";
|
|
|
|
PROCEDURE Init*(argc: SYSTEM.INT32; argvadr: SYSTEM.ADDRESS);
|
|
(* This start code is called by the __INIT macro generated by the compiler
|
|
as the C main program. *)
|
|
BEGIN
|
|
MainStackFrame := argvadr;
|
|
ArgCount := SYSTEM.VAL(INTEGER, argc);
|
|
SYSTEM.GET(argvadr, ArgVector);
|
|
|
|
InitHeap; (* Initialse heap variables needed for compiler generated *__inits *)
|
|
ModulesInit(); (* Our own __init code will run Platform__init and Heap__init. *)
|
|
END Init;
|
|
|
|
|
|
PROCEDURE GetArg*(n: INTEGER; VAR val: ARRAY OF CHAR);
|
|
TYPE argptr = POINTER TO ARRAY 1024 OF CHAR;
|
|
VAR arg: argptr;
|
|
BEGIN
|
|
IF n < ArgCount THEN
|
|
SYSTEM.GET(ArgVector + n*SIZE(SYSTEM.ADDRESS), arg); (* Address of nth argument. *)
|
|
COPY(arg^, val);
|
|
END
|
|
END GetArg;
|
|
|
|
PROCEDURE GetIntArg*(n: INTEGER; VAR val: LONGINT);
|
|
VAR s: ARRAY 64 OF CHAR; k, d, i: LONGINT;
|
|
BEGIN
|
|
s := ""; GetArg(n, s); i := 0;
|
|
IF s[0] = "-" THEN i := 1 END ;
|
|
k := 0; d := ORD(s[i]) - ORD("0");
|
|
WHILE (d >= 0 ) & (d <= 9) DO k := k*10 + d; INC(i); d := ORD(s[i]) - ORD("0") END ;
|
|
IF s[0] = "-" THEN k := -k; DEC(i) END ;
|
|
IF i > 0 THEN val := k END
|
|
END GetIntArg;
|
|
|
|
PROCEDURE ArgPos*(s: ARRAY OF CHAR): INTEGER;
|
|
VAR i: INTEGER; arg: ARRAY 256 OF CHAR;
|
|
BEGIN
|
|
i := 0; GetArg(i, arg);
|
|
WHILE (i < ArgCount) & (s # arg) DO INC(i); GetArg(i, arg) END ;
|
|
RETURN i
|
|
END ArgPos;
|
|
|
|
|
|
(* Determine directory from which this executable was loaded *)
|
|
|
|
PROCEDURE CharCount(s: ARRAY OF CHAR): INTEGER;
|
|
VAR i: INTEGER;
|
|
BEGIN
|
|
i := 0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END;
|
|
RETURN i;
|
|
END CharCount;
|
|
|
|
PROCEDURE Append(s: ARRAY OF CHAR; VAR d: ARRAY OF CHAR);
|
|
VAR i,j: INTEGER;
|
|
BEGIN
|
|
i := 0; j := CharCount(d);
|
|
WHILE s[i] # 0X DO d[j] := s[i]; INC(i); INC(j) END;
|
|
d[j] := 0X;
|
|
END Append;
|
|
|
|
PROCEDURE AppendPart(c: CHAR; s: ARRAY OF CHAR; VAR d: ARRAY OF CHAR);
|
|
VAR i,j: INTEGER;
|
|
BEGIN
|
|
i := 0; j := CharCount(d);
|
|
(* Append delimiter c to d only if d is either empty or doesn not
|
|
already end in c. *)
|
|
IF (j > 0) & (d[j-1] # c) THEN d[j] := c; INC(j) END;
|
|
(* Append s to d *)
|
|
WHILE s[i] # 0X DO d[j] := s[i]; INC(i); INC(j) END;
|
|
d[j] := 0X;
|
|
END AppendPart;
|
|
|
|
PROCEDURE IsOneOf(c: CHAR; s: ARRAY OF CHAR): BOOLEAN;
|
|
VAR i: INTEGER;
|
|
BEGIN
|
|
IF c = 0X THEN RETURN FALSE END;
|
|
i := 0; WHILE (s[i] # c) & (s[i] # 0X) DO INC(i) END;
|
|
RETURN s[i] = c
|
|
END IsOneOf;
|
|
|
|
PROCEDURE IsAbsolute(d: ARRAY OF CHAR): BOOLEAN;
|
|
BEGIN
|
|
IF d = '' THEN RETURN FALSE END;
|
|
IF IsOneOf(d[0], '/\') THEN RETURN TRUE END;
|
|
IF d[1] = ':' THEN RETURN TRUE END;
|
|
RETURN FALSE;
|
|
END IsAbsolute;
|
|
|
|
PROCEDURE Canonify(s: ARRAY OF CHAR; VAR d: ARRAY OF CHAR);
|
|
BEGIN
|
|
IF IsAbsolute(s) THEN
|
|
COPY(s, d)
|
|
ELSE
|
|
COPY(Platform.CWD, d); AppendPart('/', s, d);
|
|
END;
|
|
END Canonify;
|
|
|
|
PROCEDURE IsFilePresent(s: ARRAY OF CHAR): BOOLEAN;
|
|
VAR identity: Platform.FileIdentity;
|
|
BEGIN
|
|
(*Out.String("IsFilePresent("); Out.String(s); Out.String(")."); Out.Ln;*)
|
|
RETURN Platform.IdentifyByName(s, identity) = 0
|
|
END IsFilePresent;
|
|
|
|
PROCEDURE ExtractPart(s: ARRAY OF CHAR; VAR i: INTEGER; p: ARRAY OF CHAR; VAR d: ARRAY OF CHAR);
|
|
(* Extracts from s starting at i up to any character in p.
|
|
Result string in d.
|
|
Returns i skipped passed found string and any number of delimiters from p.
|
|
*)
|
|
VAR j: INTEGER;
|
|
BEGIN
|
|
j := 0;
|
|
WHILE (s[i] # 0X) & ~IsOneOf(s[i], p) DO
|
|
d[j] := s[i]; INC(i); INC(j)
|
|
END;
|
|
d[j] := 0X;
|
|
WHILE IsOneOf(s[i], p) DO INC(i) END
|
|
END ExtractPart;
|
|
|
|
PROCEDURE Trim(s: ARRAY OF CHAR; VAR d: ARRAY OF CHAR);
|
|
(* Remove redundant '.'s and '/'s. Convert '\'s to '/'.
|
|
Note, does not remove 'x/..'. This cannot safely be removed because if
|
|
x is a link then 'x/..' means the parent of what x links to rather than
|
|
the directory containing link x.
|
|
*)
|
|
VAR i,j: INTEGER; part: ARRAY 1024 OF CHAR;
|
|
BEGIN
|
|
i := 0; j := 0;
|
|
(* Retain any leading single or pair of '/' (filesystem root or network root). *)
|
|
WHILE (i<2) & IsOneOf(s[i], "/\") DO INC(i); d[j] := '/'; INC(j) END;
|
|
d[j] := 0X;
|
|
(* Append path parts omitting empty or '.' parts. *)
|
|
WHILE s[i] # 0X DO
|
|
ExtractPart(s, i, "/\", part);
|
|
IF (part # '') & (part # '.') THEN AppendPart('/', part, d) END
|
|
END;
|
|
END Trim;
|
|
|
|
PROCEDURE FindBinaryDir(VAR binarydir: ARRAY OF CHAR);
|
|
TYPE pathstring = ARRAY 4096 OF CHAR;
|
|
VAR
|
|
arg0: pathstring; (* The command exactly as passed by the shell *)
|
|
pathlist: pathstring; (* The whole PATH environment variable *)
|
|
pathdir: pathstring; (* A single directory from the PATH *)
|
|
tempstr: pathstring;
|
|
i, j, k: INTEGER;
|
|
present: BOOLEAN;
|
|
BEGIN
|
|
IF ArgCount < 1 THEN
|
|
(* The caller is misbehaving: Shells and GUIs always pass the command
|
|
as ARGV[0]. *)
|
|
binarydir[0] := 0X;
|
|
RETURN;
|
|
END;
|
|
|
|
GetArg(0, arg0); (* arg0 is the command binary file name passed by the shell. *)
|
|
i := 0; WHILE (arg0[i] # 0X) & (arg0[i] # '/') & (arg0[i] # '\') DO INC(i) END;
|
|
IF (arg0[i] = '/') OR (arg0[i] = '\') THEN
|
|
(* The argument contains a '/', we expect it to work without reference
|
|
to the path. *)
|
|
Trim(arg0, tempstr); Canonify(tempstr, binarydir);
|
|
present := IsFilePresent(binarydir)
|
|
ELSE
|
|
(* There are no '/'s in arg0, so search through the path. *)
|
|
Platform.GetEnv("PATH", pathlist);
|
|
i := 0; present := FALSE;
|
|
WHILE (~present) & (pathlist[i] # 0X) DO
|
|
ExtractPart(pathlist, i, ":;", pathdir);
|
|
AppendPart('/', arg0, pathdir);
|
|
Trim(pathdir, tempstr); Canonify(tempstr, binarydir);
|
|
present := IsFilePresent(binarydir)
|
|
END
|
|
END;
|
|
|
|
IF present THEN
|
|
(* Remove trailing binarydir file name *)
|
|
k := CharCount(binarydir);
|
|
WHILE (k > 0) & ~IsOneOf(binarydir[k-1], '/\') DO DEC(k) END;
|
|
(* Chop off binarydir file name *)
|
|
IF k = 0 THEN binarydir[k] := 0X ELSE binarydir[k-1] := 0X END;
|
|
ELSE
|
|
binarydir[0] := 0X (* Couldn't determine binary directory. *)
|
|
END
|
|
END FindBinaryDir;
|
|
|
|
|
|
(* Module and command lookup by name *)
|
|
|
|
PROCEDURE -modules(): Module "(Heap_Module)Heap_modules";
|
|
(*PROCEDURE -setmodules(m: Module) "Heap_modules = m";*)
|
|
|
|
PROCEDURE ThisMod* (name: ARRAY OF CHAR): Module;
|
|
VAR m: Module; bodyname: ARRAY 64 OF CHAR; body: Command;
|
|
BEGIN m := modules();
|
|
WHILE (m # NIL) & (m.name # name) DO m := m.next END ;
|
|
IF m # NIL THEN res := 0; resMsg := ""
|
|
ELSE res := 1; COPY(name, importing);
|
|
resMsg := ' module "'; Append(name, resMsg); Append('" not found', resMsg);
|
|
END ;
|
|
RETURN m
|
|
END ThisMod;
|
|
|
|
PROCEDURE ThisCommand* (mod: Module; name: ARRAY OF CHAR): Command;
|
|
VAR c: Cmd;
|
|
BEGIN c := mod.cmds;
|
|
WHILE (c # NIL) & (c.name # name) DO c := c.next END ;
|
|
IF c # NIL THEN res := 0; resMsg := ""; RETURN c.cmd
|
|
ELSE res := 2; resMsg := ' command "'; COPY(name, importing);
|
|
Append(mod.name, resMsg); Append(".", resMsg); Append(name, resMsg); Append('" not found', resMsg);
|
|
RETURN NIL
|
|
END
|
|
END ThisCommand;
|
|
|
|
PROCEDURE Free*(name: ARRAY OF CHAR; all: BOOLEAN);
|
|
VAR m, p: Module; refcount: LONGINT;
|
|
BEGIN m := modules();
|
|
IF all THEN
|
|
res := 1; resMsg := 'unloading "all" not yet supported'
|
|
ELSE
|
|
refcount := Heap.FreeModule(name);
|
|
IF refcount = 0 THEN
|
|
res := 0
|
|
ELSE
|
|
IF refcount < 0 THEN resMsg := "module not found"
|
|
ELSE resMsg := "clients of this module exist"
|
|
END;
|
|
res := 1
|
|
END
|
|
END
|
|
END Free;
|
|
|
|
|
|
|
|
(* Run time error reporting. *)
|
|
|
|
PROCEDURE errch(c: CHAR); (* Here we favour simplicity over efficiency, so no buffering. *)
|
|
VAR e: Platform.ErrorCode;
|
|
BEGIN e := Platform.Write(Platform.StdOut, SYSTEM.ADR(c), 1)
|
|
END errch;
|
|
|
|
PROCEDURE errstring(s: ARRAY OF CHAR);
|
|
VAR i: LONGINT;
|
|
BEGIN
|
|
i := 0; WHILE (i<LEN(s)) & (s[i] # 0X) DO errch(s[i]); INC(i) END
|
|
END errstring;
|
|
|
|
PROCEDURE errint(l: SYSTEM.INT32);
|
|
BEGIN
|
|
IF l < 0 THEN errch('-'); l := -l END;
|
|
IF l >= 10 THEN errint(l DIV 10) END;
|
|
errch(CHR(l MOD 10 + 30H))
|
|
END errint;
|
|
|
|
PROCEDURE DisplayHaltCode(code: SYSTEM.INT32);
|
|
BEGIN
|
|
CASE code OF
|
|
| -1: errstring("Assertion failure.")
|
|
| -2: errstring("Index out of range.")
|
|
| -3: errstring("Reached end of function without reaching RETURN.")
|
|
| -4: errstring("CASE statement: no matching label and no ELSE.")
|
|
| -5: errstring("Type guard failed.")
|
|
| -6: errstring("Implicit type guard in record assignment failed.")
|
|
| -7: errstring("Invalid case in WITH statement.")
|
|
| -8: errstring("Value out of range.")
|
|
| -9: errstring("Heap interrupted while locked, but lockdepth = 0 at unlock.")
|
|
|-10: errstring("NIL access.");
|
|
|-11: errstring("Alignment error.");
|
|
|-12: errstring("Divide by zero.");
|
|
|-13: errstring("Arithmetic overflow/underflow.");
|
|
|-14: errstring("Invalid function argument.");
|
|
|-15: errstring("Internal error, e.g. Type descriptor size mismatch.")
|
|
|-20: errstring("Too many, or negative number of, elements in dynamic array.")
|
|
ELSE
|
|
END
|
|
END DisplayHaltCode;
|
|
|
|
PROCEDURE Halt*(code: SYSTEM.INT32);
|
|
BEGIN
|
|
Heap.FINALL;
|
|
errstring("Terminated by Halt("); errint(code); errstring("). ");
|
|
IF code < 0 THEN DisplayHaltCode(code) END;
|
|
errstring(Platform.NL);
|
|
Platform.Exit(code);
|
|
END Halt;
|
|
|
|
PROCEDURE AssertFail*(code: SYSTEM.INT32);
|
|
BEGIN
|
|
Heap.FINALL;
|
|
errstring("Assertion failure.");
|
|
IF code # 0 THEN errstring(" ASSERT code "); errint(code); errstring("."); END;
|
|
errstring(Platform.NL);
|
|
IF code > 0 THEN Platform.Exit(code) ELSE Platform.Exit(-1) END;
|
|
END AssertFail;
|
|
|
|
BEGIN
|
|
FindBinaryDir(BinaryDir);
|
|
END Modules.
|