DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / cpc.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
add ERROR directive
[cpc.git] / src / generic / Dev / Mod / CPM.cp
1 MODULE DevCPM;
2
3 IMPORT SYSTEM, Kernel, Files, Console, Strings;
4
5 CONST
6 ProcSize* = 4; (* PROCEDURE type *)
7 PointerSize* = 4; (* POINTER type *)
8 DArrSizeA* = 8; (* dyn array descriptor *)
9 DArrSizeB* = 4; (* size = A + B * typ.n *)
10
11 MaxSet* = 31;
12 MaxIndex* = 7FFFFFFFH; (* maximal index value for array declaration *)
13
14 MinReal32Pat = 0FF7FFFFFH; (* most positive, 32-bit pattern *)
15 MinReal64PatL = 0FFFFFFFFH; (* most negative, lower 32-bit pattern *)
16 MinReal64PatH = 0FFEFFFFFH; (* most negative, higher 32-bit pattern *)
17 MaxReal32Pat = 07F7FFFFFH; (* most positive, 32-bit pattern *)
18 MaxReal64PatL = 0FFFFFFFFH; (* most positive, lower 32-bit pattern *)
19 MaxReal64PatH = 07FEFFFFFH; (* most positive, higher 32-bit pattern *)
20 InfRealPat = 07F800000H; (* real infinity pattern *)
21
22
23 (* inclusive range of parameter of standard procedure HALT *)
24 MinHaltNr* = 0;
25 MaxHaltNr* = 128;
26
27 (* inclusive range of register number of procedures SYSTEM.GETREG and SYSTEM.PUTREG *)
28 MinRegNr* = 0;
29 MaxRegNr* = 31;
30
31 (* maximal value of flag used to mark interface structures *)
32 MaxSysFlag* = 127; (* shortint *)
33 CProcFlag* = 1; (* code procedures *)
34
35 (* maximal condition value of parameter of SYSTEM.CC *)
36 MaxCC* = 15;
37
38 (* initialization of constant address, must be different from any valid constant address *)
39 ConstNotAlloc* = -1;
40
41 (* whether hidden pointer fields have to be nevertheless exported *)
42 ExpHdPtrFld* = TRUE;
43 HdPtrName* = "@ptr";
44
45 (* whether hidden untagged pointer fields have to be nevertheless exported *)
46 ExpHdUtPtrFld* = TRUE;
47 HdUtPtrName* = "@utptr";
48
49 (* whether hidden procedure fields have to be nevertheless exported (may be used for System.Free) *)
50 ExpHdProcFld* = TRUE;
51 HdProcName* = "@proc";
52
53 (* whether hidden bound procedures have to be nevertheless exported *)
54 ExpHdTProc* = FALSE;
55 HdTProcName* = "@tproc";
56
57 (* maximal number of exported stuctures: *)
58 MaxStruct* = 16000; (* must be < MAX(INTEGER) DIV 2 in object model *)
59
60 (* maximal number of record extensions: *)
61 MaxExts* = 15; (* defined by type descriptor layout *)
62
63 (* whether field leaf of pointer variable p has to be set to FALSE, when NEW(p) or SYSTEM.NEW(p, n) is used *)
64 NEWusingAdr* = FALSE;
65
66 (* special character (< " ") returned by procedure Get, if end of text reached *)
67 Eot* = 0X;
68
69 (* warnings *)
70 longreal* = 0; largeint* = 1; realConst* = 2; copy* = 3; lchr* = 4; lentier* = 5; invar* = 6; outvar* = 7;
71
72 (* language options *)
73 interface* = 1;
74 com* = 2; comAware* = 3;
75 som* = 4; somAware* = 5;
76 oberon* = 6;
77 java* = 7; javaAware* = 8;
78 noCode* = 9;
79 allSysVal* = 14;
80 sysImp* = 15;
81 trap* = 31;
82 sys386 = 10; sys68k = 20; (* processor type in options if system imported *)
83
84 CONST
85 SFdir = "Sym";
86 OFdir = "Code";
87 SYSdir = "System";
88 SFtag = 6F4F5346H; (* symbol file tag *)
89 OFtag = 6F4F4346H; (* object file tag *)
90 maxErrors = 64;
91 errFile = "Errors";
92
93 TYPE
94 Directory* = POINTER TO RECORD
95 path*: Files.Name;
96 legacy*: BOOLEAN;
97 next*: Directory
98 END;
99
100 VAR
101 LEHost*: BOOLEAN; (* little or big endian host *)
102 MinReal32*, MaxReal32*, InfReal*,
103 MinReal64*, MaxReal64*: REAL;
104 noerr*: BOOLEAN; (* no error found until now *)
105 curpos*, startpos*, errpos*: INTEGER; (* character, start, and error position in source file *)
106 searchpos*: INTEGER; (* search position in source file *)
107 errors*: INTEGER;
108 breakpc*: INTEGER; (* set by OPV.Init *)
109 options*: SET; (* language options *)
110 file*: Files.File; (* used for sym file import *)
111 legacy*: BOOLEAN; (* use BlackBox subsystems *)
112 symList*: Directory;
113 codePath*: Files.Name;
114 symPath*: Files.Name;
115 codeDir*: ARRAY 16 OF CHAR;
116 symDir*: ARRAY 16 OF CHAR;
117 name*: Files.Name; (* source name *)
118 checksum*: INTEGER; (* symbol file checksum *)
119 verbose*: INTEGER;
120
121 lastpos: INTEGER;
122 ObjFName: Files.Name;
123
124 in: POINTER TO ARRAY OF CHAR;
125 oldSymFile, symFile, objFile: Files.File;
126 inSym: Files.Reader;
127 outSym, outObj: Files.Writer;
128
129 errNo, errPos: ARRAY maxErrors OF INTEGER;
130
131 crc32tab: ARRAY 256 OF INTEGER;
132
133
134 PROCEDURE^ err* (n: INTEGER);
135
136 PROCEDURE Init* (source: POINTER TO ARRAY OF CHAR);
137 BEGIN
138 in := source;
139 noerr := TRUE; options := {};
140 curpos := 0; errpos := curpos; lastpos := curpos - 11; errors := 0;
141 codePath := ""; symPath := ""; name := "";
142 codeDir := OFdir; symDir := SFdir;
143 END Init;
144
145 PROCEDURE Close*;
146 BEGIN
147 oldSymFile := NIL; inSym := NIL;
148 symFile := NIL; outSym := NIL;
149 objFile := NIL; outObj := NIL;
150 in := NIL
151 END Close;
152
153 PROCEDURE Get* (VAR ch: CHAR);
154 BEGIN
155 ch := in[curpos]; INC(curpos)
156 END Get;
157
158 PROCEDURE LineColOf (pos: INTEGER; OUT line, col, beg, end: INTEGER);
159 VAR i: INTEGER;
160 BEGIN
161 i := 0; line := 1; col := 1; beg := 0; end := 0;
162 WHILE i < pos DO
163 IF in[i] = 0DX THEN
164 INC(i);
165 IF in[i] = 0AX THEN
166 INC(i)
167 END;
168 INC(line);
169 beg := i;
170 col := 1
171 ELSIF in[i] = 0AX THEN
172 INC(i);
173 INC(line);
174 beg := i;
175 col := 1
176 ELSIF in[i] = 09X THEN
177 INC(i); INC(col, 2)
178 ELSE
179 INC(i); INC(col)
180 END;
181 END;
182 WHILE (in[i] # 0DX) & (in[i] # 0AX) & (in[i] # 0X) DO
183 INC(i)
184 END;
185 end := i - 1
186 END LineColOf;
187
188 PROCEDURE LineOf* (pos: INTEGER): INTEGER;
189 VAR line, col, beg, end: INTEGER;
190 BEGIN
191 LineColOf(pos, line, col, beg, end);
192 RETURN line
193 END LineOf;
194
195 PROCEDURE LoWord (r: REAL): INTEGER;
196 VAR x: INTEGER;
197 BEGIN
198 x := SYSTEM.ADR(r);
199 IF ~LEHost THEN INC(x, 4) END;
200 SYSTEM.GET(x, x);
201 RETURN x
202 END LoWord;
203
204 PROCEDURE HiWord (r: REAL): INTEGER;
205 VAR x: INTEGER;
206 BEGIN
207 x := SYSTEM.ADR(r);
208 IF LEHost THEN INC(x, 4) END;
209 SYSTEM.GET(x, x);
210 RETURN x
211 END HiWord;
212
213 PROCEDURE Compound (lo, hi: INTEGER): REAL;
214 VAR r: REAL;
215 BEGIN
216 IF LEHost THEN
217 SYSTEM.PUT(SYSTEM.ADR(r), lo); SYSTEM.PUT(SYSTEM.ADR(r) + 4, hi)
218 ELSE
219 SYSTEM.PUT(SYSTEM.ADR(r) + 4, lo); SYSTEM.PUT(SYSTEM.ADR(r), hi)
220 END;
221 RETURN r
222 END Compound;
223
224
225 (* sysflag control *)
226
227 PROCEDURE ValidGuid* (IN str: ARRAY OF SHORTCHAR): BOOLEAN;
228 VAR i: INTEGER; ch: SHORTCHAR;
229 BEGIN
230 IF (LEN(str$) # 38) OR (str[0] # "{") & (str[37] # "}") THEN RETURN FALSE END;
231 i := 1;
232 WHILE i < 37 DO
233 ch := str[i];
234 IF (i = 9) OR (i = 14) OR (i = 19) OR (i = 24) THEN
235 IF ch # "-" THEN RETURN FALSE END
236 ELSE
237 IF (ch < "0") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z") THEN RETURN FALSE END
238 END;
239 INC(i)
240 END;
241 RETURN TRUE
242 END ValidGuid;
243
244 PROCEDURE GetProcSysFlag* (IN id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
245 BEGIN
246 IF id # "" THEN
247 IF id = "code" THEN num := 1
248 ELSIF id = "callback" THEN num := 2
249 ELSIF id = "nostkchk" THEN num := 4
250 ELSIF id = "ccall" THEN num := -10
251 ELSIF id = "ccall16" THEN num := -12
252 ELSIF id = "guarded" THEN num := 8
253 ELSIF id = "noframe" THEN num := 16
254 ELSIF id = "native" THEN num := -33
255 ELSIF id = "bytecode" THEN num := -35
256 END
257 END;
258 IF (options * {sysImp, sys386, sys68k} # {}) & ((num = 1) OR (num = 2)) THEN INC(flag, num)
259 ELSIF (sys68k IN options) & (num = 4) THEN INC(flag, num)
260 ELSIF (options * {sys386, interface} # {}) & (num = -10) & (flag = 0) THEN flag := -10
261 ELSIF (options * {sys386, interface} # {}) & (num = -12) & (flag = 0) THEN flag := -12
262 ELSIF (options * {sys386, com} # {}) & (num = 8) & (flag = 0) THEN flag := 8
263 ELSIF (options * {sysImp, sys386} # {}) & (num = 16) & (flag = 0) THEN flag := 16
264 ELSIF ({sysImp, java} - options = {}) & ((num= -33) OR (num = -35)) & (flag = 0) THEN flag := num
265 ELSE err(225); flag := 0
266 END
267 END GetProcSysFlag;
268
269 PROCEDURE GetVarParSysFlag* (IN id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
270 VAR old: SHORTINT;
271 BEGIN
272 old := flag; flag := 0;
273 IF (options * {sys386, sys68k, interface, com} # {}) THEN
274 IF (num = 1) OR (id = "nil") THEN
275 IF ~ODD(old) THEN flag := SHORT(old + 1) END
276 ELSIF ((num = 2) OR (id = "in")) & (oberon IN options) THEN
277 IF old <= 1 THEN flag := SHORT(old + 2) END
278 ELSIF ((num = 4) OR (id = "out")) & (oberon IN options) THEN
279 IF old <= 1 THEN flag := SHORT(old + 4) END
280 ELSIF ((num = 8) OR (id = "new")) & (options * {com, interface} # {}) THEN
281 IF old <= 1 THEN flag := SHORT(old + 8) END
282 ELSIF ((num = 16) OR (id = "iid")) & (com IN options) THEN
283 IF old <= 1 THEN flag := SHORT(old + 16) END
284 END
285 END;
286 IF flag = 0 THEN err(225) END
287 END GetVarParSysFlag;
288
289 PROCEDURE GetRecordSysFlag* (IN id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
290 VAR old: SHORTINT;
291 BEGIN
292 old := flag; flag := 0;
293 IF (num = 1) OR (id = "untagged") THEN
294 IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
295 ELSIF (num = 3) OR (id = "noalign") THEN
296 IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 3 END
297 ELSIF (num = 4) OR (id = "align2") THEN
298 IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 4 END
299 ELSIF (num = 5) OR (id = "align4") THEN
300 IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 5 END
301 ELSIF (num = 6) OR (id = "align8") THEN
302 IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 6 END
303 ELSIF (num = 7) OR (id = "union") THEN
304 IF (options * {sys386, sys68k, interface, com} # {}) & (old = 0) THEN flag := 7 END
305 ELSIF (num = 10) OR (id = "interface") OR ValidGuid(id) THEN
306 IF (com IN options) & (old = 0) THEN flag := 10 END
307 ELSIF (num = -11) OR (id = "jint") THEN
308 IF (java IN options) & (old = 0) THEN flag := -11 END
309 ELSIF (num = -13) OR (id = "jstr") THEN
310 IF (java IN options) & (old = 0) THEN flag := -13 END
311 ELSIF (num = 20) OR (id = "som") THEN
312 IF (som IN options) & (old = 0) THEN flag := 20 END
313 END;
314 IF flag = 0 THEN err(225) END
315 END GetRecordSysFlag;
316
317 PROCEDURE GetArraySysFlag* (IN id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
318 VAR old: SHORTINT;
319 BEGIN
320 old := flag; flag := 0;
321 IF (num = 1) OR (id = "untagged") THEN
322 IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
323 ELSIF (num = -12) OR (id = "jarr") THEN
324 IF (java IN options) & (old = 0) THEN flag := -12 END
325 ELSIF (num = -13) OR (id = "jstr") THEN
326 IF (java IN options) & (old = 0) THEN flag := -13 END
327 END;
328 IF flag = 0 THEN err(225) END
329 END GetArraySysFlag;
330
331 PROCEDURE GetPointerSysFlag* (IN id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
332 VAR old: SHORTINT;
333 BEGIN
334 old := flag; flag := 0;
335 IF (num = 1) OR (id = "untagged") THEN
336 IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
337 ELSIF (num = 2) OR (id = "handle") THEN
338 IF (sys68k IN options) & (old = 0) THEN flag := 2 END
339 ELSIF (num = 10) OR (id = "interface") THEN
340 IF (com IN options) & (old = 0) THEN flag := 10 END
341 ELSIF (num = 20) OR (id = "som") THEN
342 IF (som IN options) & (old = 0) THEN flag := 20 END
343 END;
344 IF flag = 0 THEN err(225) END
345 END GetPointerSysFlag;
346
347 PROCEDURE GetProcTypSysFlag* (IN id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
348 BEGIN
349 IF ((num = -10) OR (id = "ccall")) & (options * {sys386, interface} # {}) THEN flag := -10
350 ELSIF ((num = -12) OR (id = "ccall16")) & (options * {sys386, interface} # {}) THEN flag := -12
351 ELSE err(225); flag := 0
352 END
353 END GetProcTypSysFlag;
354
355 PROCEDURE PropagateRecordSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
356 BEGIN
357 IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN (* propagate untagged .. union *)
358 IF flag = 0 THEN flag := baseFlag
359 ELSIF (flag = 6) & (baseFlag < 6) THEN (* OK *) (* special case for 8 byte aligned records *)
360 ELSIF flag # baseFlag THEN err(225); flag := 0
361 END
362 ELSIF (baseFlag # 10) & (flag = 10) THEN err(225)
363 END
364 END PropagateRecordSysFlag;
365
366 PROCEDURE PropagateRecPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
367 BEGIN
368 IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN (* pointer to untagged .. union is untagged *)
369 IF flag = 0 THEN flag := 1
370 ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0
371 END
372 ELSIF baseFlag = 10 THEN (* pointer to interface is interface *)
373 IF flag = 0 THEN flag := 10
374 ELSIF flag # 10 THEN err(225); flag := 0
375 END
376 ELSIF baseFlag = -11 THEN (* pointer to java interface is java interface *)
377 IF flag # 0 THEN err(225) END;
378 flag := -11
379 ELSIF baseFlag = -13 THEN (* pointer to java string is java string *)
380 IF flag # 0 THEN err(225) END;
381 flag := -13
382 END
383 END PropagateRecPtrSysFlag;
384
385 PROCEDURE PropagateArrPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
386 BEGIN
387 IF baseFlag = 1 THEN (* pointer to untagged or guid is untagged *)
388 IF flag = 0 THEN flag := 1
389 ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0
390 END
391 ELSIF baseFlag = -12 THEN (* pointer to java array is java array *)
392 IF flag # 0 THEN err(225) END;
393 flag := -12
394 ELSIF baseFlag = -13 THEN (* pointer to java string is java string *)
395 IF flag # 0 THEN err(225) END;
396 flag := -13
397 END
398 END PropagateArrPtrSysFlag;
399
400
401 (* utf8 strings *)
402
403 PROCEDURE PutUtf8* (VAR str: ARRAY OF SHORTCHAR; val: INTEGER; VAR idx: INTEGER);
404 BEGIN
405 ASSERT((val >= 0) & (val < 65536));
406 IF val < 128 THEN
407 str[idx] := SHORT(CHR(val)); INC(idx)
408 ELSIF val < 2048 THEN
409 str[idx] := SHORT(CHR(val DIV 64 + 192)); INC(idx);
410 str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx)
411 ELSE
412 str[idx] := SHORT(CHR(val DIV 4096 + 224)); INC(idx);
413 str[idx] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(idx);
414 str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx)
415 END
416 END PutUtf8;
417
418 PROCEDURE GetUtf8* (IN str: ARRAY OF SHORTCHAR; VAR val, idx: INTEGER);
419 VAR ch: SHORTCHAR;
420 BEGIN
421 ch := str[idx]; INC(idx);
422 IF ch < 80X THEN
423 val := ORD(ch)
424 ELSIF ch < 0E0X THEN
425 val := ORD(ch) - 192;
426 ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128
427 ELSE
428 val := ORD(ch) - 224;
429 ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128;
430 ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128
431 END
432 END GetUtf8;
433
434
435 (* log output *)
436
437 PROCEDURE LogW* (ch: CHAR);
438 BEGIN
439 Console.WriteChar(ch)
440 END LogW;
441
442 PROCEDURE LogWStr* (IN s: ARRAY OF CHAR);
443 BEGIN
444 Console.WriteStr(s)
445 END LogWStr;
446
447 PROCEDURE LogWPar* (IN key: ARRAY OF CHAR; IN p0, p1: ARRAY OF SHORTCHAR);
448 VAR s, s0, s1: ARRAY 256 OF CHAR; i, res: INTEGER;
449 BEGIN
450 Kernel.Utf8ToString(p0, s0, res);
451 Kernel.Utf8ToString(p1, s1, res);
452 IF key = "#Dev:NotImplementedIn" THEN s := "^0 not implemented in ^1"
453 ELSIF key = "#Dev:NotImplemented" THEN s := "^0 not implemented"
454 ELSIF key = "#Dev:InconsistentImport" THEN s := "^0.^1 is not consistently imported"
455 ELSIF key = "#Dev:ChangedLibFlag" THEN s := "changed library flag"
456 ELSIF key = "#Dev:IsNoLongerInSymFile" THEN s := "^0 is no longer in symbol file"
457 ELSIF key = "#Dev:IsRedefinedInternally" THEN s := "^0 is redefined internally"
458 ELSIF key = "#Dev:IsRedefined" THEN s := "^0 is redefined"
459 ELSIF key = "#Dev:IsNewInSymFile" THEN s := "^0 is new in symbol file"
460 ELSIF key = "#Dev:NewSymFile" THEN s := "new symbol file"
461 ELSE s := key$
462 END;
463 i := 0;
464 WHILE s[i] # 0X DO
465 IF s[i] = "^" THEN
466 CASE s[i + 1] OF
467 | "0": Console.WriteStr(s0)
468 | "1": Console.WriteStr(s1)
469 | "2": (* skip *)
470 ELSE Console.WriteChar("^")
471 END;
472 INC(i, 2)
473 ELSE
474 Console.WriteChar(s[i]);
475 INC(i)
476 END
477 END
478 END LogWPar;
479
480 PROCEDURE LogWNum* (i, len: INTEGER);
481 VAR s: ARRAY 32 OF CHAR;
482 BEGIN
483 Strings.IntToStringForm(i, 10, len, " ", FALSE, s);
484 Console.WriteStr(s)
485 END LogWNum;
486
487 PROCEDURE LogWLn*;
488 BEGIN
489 Console.WriteLn
490 END LogWLn;
491
492 PROCEDURE Mark* (n, pos: INTEGER);
493 BEGIN
494 IF (n >= 0) & ~((oberon IN options) & (n >= 181) & (n <= 190)) THEN
495 noerr := FALSE;
496 IF pos < 0 THEN pos := 0 END;
497 IF (pos < lastpos) OR (lastpos + 9 < pos) THEN
498 lastpos := pos;
499 IF errors < maxErrors THEN
500 errNo[errors] := n; errPos[errors] := pos
501 END;
502 INC(errors)
503 END;
504 IF trap IN options THEN HALT(100) END;
505 ELSIF (n <= -700) & (errors < maxErrors) THEN
506 errNo[errors] := n; errPos[errors] := pos; INC(errors)
507 END
508 END Mark;
509
510 PROCEDURE err* (n: INTEGER);
511 BEGIN
512 Mark(n, errpos)
513 END err;
514
515 PROCEDURE GetErrorMsg (err: INTEGER; OUT msg: ARRAY OF CHAR);
516 BEGIN
517 CASE ABS(err) OF
518 | 0: msg := 'undeclared identifier'
519 | 1: msg := 'multiply defined identifier'
520 | 2: msg := 'illegal character in number'
521 | 3: msg := 'illegal character in string'
522 | 4: msg := 'identifier does not match procedure name'
523 | 5: msg := 'comment not closed'
524 | 9: msg := '"=" expected'
525 | 12: msg := 'type definition starts with incorrect symbol'
526 | 13: msg := 'factor starts with incorrect symbol'
527 | 14: msg := 'statement starts with incorrect symbol'
528 | 15: msg := 'declaration followed by incorrect symbol'
529 | 16: msg := 'MODULE expected'
530 | 19: msg := '"." missing'
531 | 20: msg := '"," missing'
532 | 21: msg := '":" missing'
533 | 23: msg := '")" missing'
534 | 24: msg := '"]" missing'
535 | 25: msg := '"}" missing'
536 | 26: msg := 'OF missing'
537 | 27: msg := 'THEN missing'
538 | 28: msg := 'DO missing'
539 | 29: msg := 'TO missing'
540 | 35: msg := '"," or OF expected'
541 | 36: msg := 'CONST, TYPE, VAR, PROCEDURE, BEGIN, or END missing'
542 | 37: msg := 'PROCEDURE, BEGIN, or END missing'
543 | 38: msg := 'BEGIN or END missing'
544 | 40: msg := '"(" missing'
545 | 41: msg := 'illegally marked identifier'
546 | 42: msg := 'constant not an integer'
547 | 43: msg := 'UNTIL missing'
548 | 44: msg := '":=" missing'
549 | 46: msg := 'EXIT not within loop statement'
550 | 47: msg := 'string expected'
551 | 48: msg := 'identifier expected'
552 | 49: msg := '";" missing'
553 | 50: msg := 'expression should be constant'
554 | 51: msg := 'END missing'
555 | 52: msg := 'identifier does not denote a type'
556 | 53: msg := 'identifier does not denote a record type'
557 | 54: msg := 'result type of procedure is not a basic type'
558 | 55: msg := 'procedure call of a function'
559 | 56: msg := 'assignment to non-variable'
560 | 57: msg := 'pointer not bound to record or array type'
561 | 58: msg := 'recursive type definition'
562 | 59: msg := 'illegal open array parameter'
563 | 60: msg := 'wrong type of case label'
564 | 61: msg := 'inadmissible type of case label'
565 | 62: msg := 'case label defined more than once'
566 | 63: msg := 'illegal value of constant'
567 | 64: msg := 'more actual than formal parameters'
568 | 65: msg := 'fewer actual than formal parameters'
569 | 66: msg := 'element types of actual array and formal open array differ'
570 | 67: msg := 'actual parameter corresponding to open array is not an array'
571 | 68: msg := 'control variable must be integer'
572 | 69: msg := 'parameter must be an integer constant'
573 | 70: msg := 'pointer or VAR / IN record required as formal receiver'
574 | 71: msg := 'pointer expected as actual receiver'
575 | 72: msg := 'procedure must be bound to a record of the same scope'
576 | 73: msg := 'procedure must have level 0'
577 | 74: msg := 'procedure unknown in base type'
578 | 75: msg := 'invalid call of base procedure'
579 | 76: msg := 'this variable (field) is read only'
580 | 77: msg := 'object is not a record'
581 | 78: msg := 'dereferenced object is not a variable'
582 | 79: msg := 'indexed object is not a variable'
583 | 80: msg := 'index expression is not an integer'
584 | 81: msg := 'index out of specified bounds'
585 | 82: msg := 'indexed variable is not an array'
586 | 83: msg := 'undefined record field'
587 | 84: msg := 'dereferenced variable is not a pointer'
588 | 85: msg := 'guard or test type is not an extension of variable type'
589 | 86: msg := 'guard or testtype is not a pointer'
590 | 87: msg := 'guarded or tested variable is neither a pointer nor a VAR- or IN-parameter record'
591 | 88: msg := 'open array not allowed as variable, record field or array element'
592 | 89: msg := 'ANYRECORD may not be allocated'
593 | 90: msg := 'dereferenced variable is not a character array'
594 | 92: msg := 'operand of IN not an integer, or not a set'
595 | 93: msg := 'set element type is not an integer'
596 | 94: msg := 'operand of & is not of type BOOLEAN'
597 | 95: msg := 'operand of OR is not of type BOOLEAN'
598 | 96: msg := 'operand not applicable to (unary) +'
599 | 97: msg := 'operand not applicable to (unary) -'
600 | 98: msg := 'operand of ~ is not of type BOOLEAN'
601 | 99: msg := 'ASSERT fault'
602 | 100: msg := 'incompatible operands of dyadic operator'
603 | 101: msg := 'operand type inapplicable to *'
604 | 102: msg := 'operand type inapplicable to /'
605 | 103: msg := 'operand type inapplicable to DIV'
606 | 104: msg := 'operand type inapplicable to MOD'
607 | 105: msg := 'operand type inapplicable to +'
608 | 106: msg := 'operand type inapplicable to -'
609 | 107: msg := 'operand type inapplicable to = or #'
610 | 108: msg := 'operand type inapplicable to relation'
611 | 109: msg := 'overriding method must be exported'
612 | 110: msg := 'operand is not a type'
613 | 111: msg := 'operand inapplicable to (this) function'
614 | 112: msg := 'operand is not a variable'
615 | 113: msg := 'incompatible assignment'
616 | 114: msg := 'string too long to be assigned'
617 | 115: msg := 'parameter does not match'
618 | 116: msg := 'number of parameters does not match'
619 | 117: msg := 'result type does not match'
620 | 118: msg := 'export mark does not match with forward declaration'
621 | 119: msg := 'redefinition textually precedes procedure bound to base type'
622 | 120: msg := 'type of expression following IF, WHILE, UNTIL or ASSERT is not BOOLEAN'
623 | 121: msg := 'called object is not a procedure'
624 | 122: msg := 'actual VAR-, IN-, or OUT-parameter is not a variable'
625 | 123: msg := 'type is not identical with that of formal VAR-, IN-, or OUT-parameter'
626 | 124: msg := 'type of result expression differs from that of procedure'
627 | 125: msg := 'type of case expression is neither INTEGER nor CHAR'
628 | 126: msg := 'this expression cannot be a type or a procedure'
629 | 127: msg := 'illegal use of object'
630 | 128: msg := 'unsatisfied forward reference'
631 | 129: msg := 'unsatisfied forward procedure'
632 | 130: msg := 'WITH clause does not specify a variable'
633 | 131: msg := 'LEN not applied to array'
634 | 132: msg := 'dimension in LEN too large or negative'
635 | 133: msg := 'function without RETURN'
636 | 135: msg := 'SYSTEM not imported'
637 | 136: msg := 'LEN applied to untagged array'
638 | 137: msg := 'unknown array length'
639 | 138: msg := 'NEW not allowed for untagged structures'
640 | 139: msg := 'Test applied to untagged record'
641 | 140: msg := 'untagged receiver'
642 | 141: msg := 'SYSTEM.NEW not implemented'
643 | 142: msg := 'tagged structures not allowed for NIL compatible var parameters'
644 | 143: msg := 'tagged pointer not allowed in untagged structure'
645 | 144: msg := 'no pointers allowed in BYTES argument'
646 | 145: msg := 'untagged open array not allowed as value parameter'
647 | 150: msg := 'key inconsistency of imported module'
648 | 151: msg := 'incorrect symbol file'
649 | 152: msg := 'symbol file of imported module not found'
650 | 153: msg := 'object or symbol file not opened (disk full?)'
651 | 154: msg := 'recursive import not allowed'
652 | 155: msg := 'generation of new symbol file not allowed'
653 | 160: msg := 'interfaces must be extensions of IUnknown'
654 | 161: msg := 'interfaces must not have fields'
655 | 162: msg := 'interface procedures must be abstract'
656 | 163: msg := 'interface records must be abstract'
657 | 164: msg := 'pointer must be extension of queried interface type'
658 | 165: msg := 'illegal guid constant'
659 | 166: msg := 'AddRef & Release may not be used'
660 | 167: msg := 'illegal assignment to [new] parameter'
661 | 168: msg := 'wrong [iid] - [new] pair'
662 | 169: msg := 'must be an interface pointer'
663 | 177: msg := 'IN only allowed for records and arrays'
664 | 178: msg := 'illegal attribute'
665 | 179: msg := 'abstract methods of exported records must be exported'
666 | 180: msg := 'illegal receiver type'
667 | 181: msg := 'base type is not extensible'
668 | 182: msg := 'base procedure is not extensible'
669 | 183: msg := 'non-matching export'
670 | 184: msg := 'Attribute does not match with forward declaration'
671 | 185: msg := 'missing NEW attribute'
672 | 186: msg := 'illegal NEW attribute'
673 | 187: msg := 'new empty procedure in non extensible record'
674 | 188: msg := 'extensible procedure in non extensible record'
675 | 189: msg := 'illegal attribute change'
676 | 190: msg := 'record must be abstract'
677 | 191: msg := 'base type must be abstract'
678 | 192: msg := 'unimplemented abstract procedures in base types'
679 | 193: msg := 'abstract or limited records may not be allocated'
680 | 194: msg := 'no supercall allowed to abstract or empty procedures'
681 | 195: msg := 'empty procedures may not have out parameters or return a value'
682 | 196: msg := 'procedure is implement-only exported'
683 | 197: msg := 'extension of limited type must be limited'
684 | 198: msg := 'obsolete oberon type'
685 | 199: msg := 'obsolete oberon function'
686 | 200: msg := 'not yet implemented'
687 | 201: msg := 'lower bound of set range greater than higher bound'
688 | 202: msg := 'set element greater than MAX(SET) or less than 0'
689 | 203: msg := 'number too large'
690 | 204: msg := 'product too large'
691 | 205: msg := 'division by zero'
692 | 206: msg := 'sum too large'
693 | 207: msg := 'difference too large'
694 | 208: msg := 'overflow in arithmetic shift'
695 | 209: msg := 'case range too large'
696 | 210: msg := 'code too long'
697 | 211: msg := 'jump distance too large'
698 | 212: msg := 'illegal real operation'
699 | 213: msg := 'too many cases in case statement'
700 | 214: msg := 'structure too large'
701 | 215: msg := 'not enough registers: simplify expression'
702 | 216: msg := 'not enough floating-point registers: simplify expression'
703 | 217: msg := 'unimplemented SYSTEM function'
704 | 218: msg := 'illegal value of parameter (0 <= p < 128)'
705 | 219: msg := 'illegal value of parameter (0 <= p < 16)'
706 | 220: msg := 'illegal value of parameter'
707 | 221: msg := 'too many pointers in a record'
708 | 222: msg := 'too many global pointers'
709 | 223: msg := 'too many record types'
710 | 224: msg := 'too many pointer types'
711 | 225: msg := 'illegal sys flag'
712 | 226: msg := 'too many exported procedures'
713 | 227: msg := 'too many imported modules'
714 | 228: msg := 'too many exported structures'
715 | 229: msg := 'too many nested records for import'
716 | 230: msg := 'too many constants (strings) in module'
717 | 231: msg := 'too many link table entries (external procedures)'
718 | 232: msg := 'too many commands in module'
719 | 233: msg := 'record extension hierarchy too high'
720 | 235: msg := 'too many modifiers '
721 | 240: msg := 'identifier too long'
722 | 241: msg := 'string too long'
723 | 242: msg := 'too many meta names'
724 | 243: msg := 'too many imported variables'
725 | 249: msg := 'inconsistent import'
726 | 250: msg := 'code proc must not be exported'
727 | 251: msg := 'too many nested function calls'
728 | 254: msg := 'debug position not found'
729 | 255: msg := 'debug position'
730 | 260: msg := 'illegal LONGINT operation'
731 | 261: msg := 'unsupported mode or size of second argument of SYSTEM.VAL'
732 | 265: msg := 'unsupported string operation'
733 | 270: msg := 'interface pointer reference counting restriction violated'
734 | 301: msg := 'implicit type cast'
735 | 302: msg := 'guarded variable can be side-effected'
736 | 303: msg := 'open array (or pointer to array) containing pointers'
737 | 401: msg := 'bytecode restriction: no structured assignment'
738 | 402: msg := 'bytecode restriction: no procedure types'
739 | 403: msg := 'bytecode restriction: no nested procedures'
740 | 404: msg := 'bytecode restriction: illegal SYSTEM function'
741 | 410: msg := 'variable may not have been assigned'
742 | 411: msg := 'no proofable return'
743 | 412: msg := 'illegal constructor call'
744 | 413: msg := 'missing constructor call'
745 | 501: msg := 'user defined error'
746 (* COM-related
747 | 700: msg := '700'
748 | 701: msg := '701'
749 | 702: msg := '702'
750 | 703: msg := '703'
751 *)
752 | 777: msg := 'register not released'
753 | 778: msg := 'float register not released'
754 | 779: msg := 'float register overallocated'
755 | 900: msg := 'never used'
756 | 901: msg := 'never set'
757 | 902: msg := 'used before set'
758 | 903: msg := 'set but never used'
759 | 904: msg := 'used as varpar, possibly not set'
760 | 905: msg := 'also declared in outer scope'
761 | 906: msg := 'access/assignment to intermediate'
762 | 907: msg := 'redefinition'
763 | 908: msg := 'new definition'
764 | 909: msg := 'statement after RETURN/EXIT'
765 | 910: msg := 'for loop variable set'
766 | 911: msg := 'implied type guard'
767 | 912: msg := 'superfluous type guard'
768 | 913: msg := 'call might depend on evaluation sequence of params.'
769 | 930: msg := 'superfluous semicolon'
770 ELSE Strings.IntToString(err, msg)
771 END
772 END GetErrorMsg;
773
774 PROCEDURE InsertMarks*;
775 VAR i, j, x, y, n, line, col, beg, end: INTEGER; s: ARRAY 128 OF CHAR;
776 BEGIN
777 n := errors;
778 IF n > maxErrors THEN n := maxErrors END;
779 (* sort *)
780 i := 1;
781 WHILE i < n DO
782 x := errPos[i]; y := errNo[i]; j := i-1;
783 WHILE (j >= 0) & (errPos[j] < x) DO
784 errPos[j+1] := errPos[j];
785 errNo[j+1] := errNo[j];
786 DEC(j)
787 END;
788 errPos[j+1] := x; errNo[j+1] := y; INC(i)
789 END;
790 (* insert *)
791 IF n > 0 THEN
792 WHILE n > 0 DO DEC(n);
793 LineColOf(errPos[n], line, col, beg, end);
794 IF name = "" THEN Console.WriteStr("???")
795 ELSE Console.WriteStr(name)
796 END;
797 Console.WriteChar(":");
798 Strings.IntToString(line, s); Console.WriteStr(s);
799 Console.WriteChar(":");
800 Strings.IntToString(col, s); Console.WriteStr(s);
801 Console.WriteChar(":");
802 Strings.IntToString(errPos[n], s); Console.WriteStr(s);
803 Console.WriteStr(": ");
804 IF errNo[n] >= 0 THEN Console.WriteStr("error: ")
805 ELSE Console.WriteStr("warning: ")
806 END;
807 GetErrorMsg(errNo[n], s);
808 Console.WriteStr(s);
809 Console.WriteLn;
810 Console.WriteStr(" ");
811 FOR i := beg TO end DO
812 IF in[i] = 09X THEN Console.WriteStr(" ")
813 ELSE Console.WriteChar(in[i])
814 END
815 END;
816 Console.WriteLn;
817 Console.WriteStr(" ");
818 FOR i := 1 TO col - 2 DO
819 Console.WriteChar(" ")
820 END;
821 Console.WriteChar("^");
822 Console.WriteLn;
823 Console.WriteLn
824 END;
825 END
826 END InsertMarks;
827
828
829 (* fingerprinting *)
830
831 PROCEDURE InitCrcTab;
832 (* CRC32, high bit first, pre & post inverted *)
833 CONST poly = {0, 1, 2, 4, 5, 7, 8, 10, 11, 12, 16, 22, 23, 26}; (* CRC32 polynom *)
834 VAR x, c, i: INTEGER;
835 BEGIN
836 x := 0;
837 WHILE x < 256 DO
838 c := x * 1000000H; i := 0;
839 WHILE i < 8 DO
840 IF c < 0 THEN c := ORD(BITS(c * 2) / poly)
841 ELSE c := c * 2
842 END;
843 INC(i)
844 END;
845 crc32tab[ORD(BITS(x) / BITS(255))] := ORD(BITS(c) / BITS(255));
846 INC(x)
847 END
848 END InitCrcTab;
849
850 PROCEDURE FPrint* (VAR fp: INTEGER; val: INTEGER);
851 VAR c: INTEGER;
852 BEGIN
853 (*
854 fp := SYSTEM.ROT(ORD(BITS(fp) / BITS(val)), 1) (* bad collision detection *)
855 *)
856 (* CRC32, high bit first, pre & post inverted *)
857 c := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val DIV 1000000H)) MOD 256]));
858 c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 10000H)) MOD 256]));
859 c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 100H)) MOD 256]));
860 fp := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val)) MOD 256]));
861 END FPrint;
862
863 PROCEDURE FPrintSet* (VAR fp: INTEGER; set: SET);
864 BEGIN FPrint(fp, ORD(set))
865 END FPrintSet;
866
867 PROCEDURE FPrintReal* (VAR fp: INTEGER; real: SHORTREAL);
868 BEGIN FPrint(fp, SYSTEM.VAL(INTEGER, real))
869 END FPrintReal;
870
871 PROCEDURE FPrintLReal* (VAR fp: INTEGER; lr: REAL);
872 BEGIN
873 FPrint(fp, LoWord(lr)); FPrint(fp, HiWord(lr))
874 END FPrintLReal;
875
876 PROCEDURE ChkSum (VAR fp: INTEGER; val: INTEGER); (* symbolfile checksum *)
877 BEGIN
878 (* same as FPrint, 8 bit only *)
879 fp := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val)) MOD 256]))
880 END ChkSum;
881
882
883
884 (* compact format *)
885
886 PROCEDURE WriteLInt (w: Files.Writer; i: INTEGER);
887 BEGIN
888 ChkSum(checksum, i);
889 w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
890 ChkSum(checksum, i);
891 w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
892 ChkSum(checksum, i);
893 w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
894 ChkSum(checksum, i);
895 w.WriteByte(SHORT(SHORT(i MOD 256)))
896 END WriteLInt;
897
898 PROCEDURE ReadLInt (r: Files.Reader; VAR i: INTEGER);
899 VAR b: BYTE; x: INTEGER;
900 BEGIN
901 r.ReadByte(b); x := b MOD 256;
902 ChkSum(checksum, b);
903 r.ReadByte(b); x := x + 100H * (b MOD 256);
904 ChkSum(checksum, b);
905 r.ReadByte(b); x := x + 10000H * (b MOD 256);
906 ChkSum(checksum, b);
907 r.ReadByte(b); i := x + 1000000H * b;
908 ChkSum(checksum, b)
909 END ReadLInt;
910
911 PROCEDURE WriteNum (w: Files.Writer; i: INTEGER);
912 BEGIN (* old format of Oberon *)
913 WHILE (i < -64) OR (i > 63) DO ChkSum(checksum, i MOD 128 - 128); w.WriteByte(SHORT(SHORT(i MOD 128 - 128))); i := i DIV 128 END;
914 ChkSum(checksum, i MOD 128);
915 w.WriteByte(SHORT(SHORT(i MOD 128)))
916 END WriteNum;
917
918 PROCEDURE ReadNum (r: Files.Reader; VAR i: INTEGER);
919 VAR b: BYTE; s, y: INTEGER;
920 BEGIN
921 s := 0; y := 0; r.ReadByte(b);
922 IF ~r.eof THEN ChkSum(checksum, b) END;
923 WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); r.ReadByte(b); ChkSum(checksum, b) END;
924 i := ASH((b + 64) MOD 128 - 64, s) + y;
925 END ReadNum;
926
927 PROCEDURE WriteNumSet (w: Files.Writer; x: SET);
928 BEGIN
929 WriteNum(w, ORD(x))
930 END WriteNumSet;
931
932 PROCEDURE ReadNumSet (r: Files.Reader; VAR x: SET);
933 VAR i: INTEGER;
934 BEGIN
935 ReadNum(r, i); x := BITS(i)
936 END ReadNumSet;
937
938 PROCEDURE WriteReal (w: Files.Writer; x: SHORTREAL);
939 BEGIN
940 WriteLInt(w, SYSTEM.VAL(INTEGER, x))
941 END WriteReal;
942
943 PROCEDURE ReadReal (r: Files.Reader; VAR x: SHORTREAL);
944 VAR i: INTEGER;
945 BEGIN
946 ReadLInt(r, i); x := SYSTEM.VAL(SHORTREAL, i)
947 END ReadReal;
948
949 PROCEDURE WriteLReal (w: Files.Writer; x: REAL);
950 BEGIN
951 WriteLInt(w, LoWord(x)); WriteLInt(w, HiWord(x))
952 END WriteLReal;
953
954 PROCEDURE ReadLReal (r: Files.Reader; VAR x: REAL);
955 VAR h, l: INTEGER;
956 BEGIN
957 ReadLInt(r, l); ReadLInt(r, h); x := Compound(l, h)
958 END ReadLReal;
959
960
961 (* read symbol file *)
962
963 PROCEDURE SymRCh* (VAR ch: SHORTCHAR);
964 VAR b: BYTE;
965 BEGIN
966 inSym.ReadByte(b); ch := SHORT(CHR(b));
967 ChkSum(checksum, b)
968 END SymRCh;
969
970 PROCEDURE SymRInt* (): INTEGER;
971 VAR k: INTEGER;
972 BEGIN
973 ReadNum(inSym, k); RETURN k
974 END SymRInt;
975
976 PROCEDURE SymRSet* (VAR s: SET);
977 BEGIN
978 ReadNumSet(inSym, s)
979 END SymRSet;
980
981 PROCEDURE SymRReal* (VAR r: SHORTREAL);
982 BEGIN
983 ReadReal(inSym, r)
984 END SymRReal;
985
986 PROCEDURE SymRLReal* (VAR lr: REAL);
987 BEGIN
988 ReadLReal(inSym, lr)
989 END SymRLReal;
990
991 PROCEDURE eofSF* (): BOOLEAN;
992 BEGIN
993 RETURN inSym.eof
994 END eofSF;
995
996 PROCEDURE OldSym* (IN modName: ARRAY OF SHORTCHAR; VAR done: BOOLEAN);
997 VAR tag: INTEGER; d: Directory;
998
999 PROCEDURE Old (IN path: Files.Name; IN modName: ARRAY OF SHORTCHAR; legacy: BOOLEAN): Files.File;
1000 VAR f: Files.File; res: INTEGER; loc: Files.Locator; dir, name: Files.Name;
1001 BEGIN
1002 Kernel.Utf8ToString(modName, name, res);
1003 loc := Files.dir.This(path);
1004 IF legacy THEN
1005 Kernel.SplitName(name, dir, name);
1006 Kernel.MakeFileName(name, Kernel.symType);
1007 loc := loc.This(dir).This(symDir);
1008 f := Files.dir.Old(loc, name, Files.shared);
1009 IF (f = NIL) & (dir = "") THEN
1010 loc := Files.dir.This(path).This(SYSdir).This(symDir);
1011 f := Files.dir.Old(loc, name, Files.shared)
1012 END
1013 ELSE
1014 Kernel.MakeFileName(name, Kernel.symType);
1015 f := Files.dir.Old(loc, name, Files.shared)
1016 END;
1017 RETURN f
1018 END Old;
1019
1020 BEGIN
1021 done := FALSE;
1022 IF modName = "@file" THEN
1023 oldSymFile := file
1024 ELSE
1025 oldSymFile := Old(symPath, modName, legacy);
1026 d := symList;
1027 WHILE (oldSymFile = NIL) & (d # NIL) DO
1028 oldSymFile := Old(d.path, modName, d.legacy);
1029 d := d.next
1030 END
1031 END;
1032 IF oldSymFile # NIL THEN
1033 inSym := oldSymFile.NewReader(inSym);
1034 IF inSym # NIL THEN
1035 ReadLInt(inSym, tag);
1036 IF tag = SFtag THEN done := TRUE ELSE err(151) END
1037 END
1038 END
1039 END OldSym;
1040
1041 PROCEDURE CloseOldSym*;
1042 BEGIN
1043 IF oldSymFile # NIL THEN oldSymFile.Close; oldSymFile := NIL END
1044 END CloseOldSym;
1045
1046
1047 (* write symbol file *)
1048
1049 PROCEDURE SymWCh* (ch: SHORTCHAR);
1050 BEGIN
1051 ChkSum(checksum, ORD(ch));
1052 outSym.WriteByte(SHORT(ORD(ch)))
1053 END SymWCh;
1054
1055 PROCEDURE SymWInt* (i: INTEGER);
1056 BEGIN
1057 WriteNum(outSym, i)
1058 END SymWInt;
1059
1060 PROCEDURE SymWSet* (s: SET);
1061 BEGIN
1062 WriteNumSet(outSym, s)
1063 END SymWSet;
1064
1065 PROCEDURE SymWReal* (r: SHORTREAL);
1066 BEGIN
1067 WriteReal(outSym, r)
1068 END SymWReal;
1069
1070 PROCEDURE SymWLReal* (r: REAL);
1071 BEGIN
1072 WriteLReal(outSym, r)
1073 END SymWLReal;
1074
1075 PROCEDURE SymReset*;
1076 BEGIN
1077 outSym.SetPos(4)
1078 END SymReset;
1079
1080 PROCEDURE NewSym* (IN modName: ARRAY OF SHORTCHAR);
1081 VAR res: INTEGER; loc: Files.Locator; dir: Files.Name;
1082 BEGIN
1083 Kernel.Utf8ToString(modName, ObjFName, res);
1084 loc := Files.dir.This(symPath);
1085 IF legacy THEN
1086 Kernel.SplitName(ObjFName, dir, ObjFName);
1087 loc := loc.This(dir).This(symDir)
1088 END;
1089 symFile := Files.dir.New(loc, Files.ask);
1090 IF symFile # NIL THEN
1091 outSym := symFile.NewWriter(NIL);
1092 WriteLInt(outSym, SFtag)
1093 ELSE
1094 err(153)
1095 END
1096 END NewSym;
1097
1098 PROCEDURE RegisterNewSym*;
1099 VAR res: INTEGER; name: Files.Name;
1100 BEGIN
1101 IF symFile # NIL THEN
1102 name := ObjFName$;
1103 Kernel.MakeFileName(name, Kernel.symType);
1104 symFile.Register(name, Kernel.symType, Files.ask, res);
1105 symFile := NIL
1106 END
1107 END RegisterNewSym;
1108
1109 PROCEDURE DeleteNewSym*;
1110 BEGIN
1111 IF symFile # NIL THEN symFile.Close; symFile := NIL END
1112 END DeleteNewSym;
1113
1114
1115 (* write object file *)
1116
1117 PROCEDURE ObjW* (ch: SHORTCHAR);
1118 BEGIN
1119 outObj.WriteByte(SHORT(ORD(ch)))
1120 END ObjW;
1121
1122 PROCEDURE ObjWNum* (i: INTEGER);
1123 BEGIN
1124 WriteNum(outObj, i)
1125 END ObjWNum;
1126
1127 PROCEDURE ObjWInt (i: SHORTINT);
1128 BEGIN
1129 outObj.WriteByte(SHORT(SHORT(i MOD 256)));
1130 outObj.WriteByte(SHORT(SHORT(i DIV 256)))
1131 END ObjWInt;
1132
1133 PROCEDURE ObjWLInt* (i: INTEGER);
1134 BEGIN
1135 ObjWInt(SHORT(i MOD 65536));
1136 ObjWInt(SHORT(i DIV 65536))
1137 END ObjWLInt;
1138
1139 PROCEDURE ObjWBytes* (IN bytes: ARRAY OF SHORTCHAR; n: INTEGER);
1140 TYPE P = POINTER TO ARRAY [untagged] 100000H OF BYTE;
1141 VAR p: P;
1142 BEGIN
1143 p := SYSTEM.VAL(P, SYSTEM.ADR(bytes));
1144 outObj.WriteBytes(p^, 0, n)
1145 END ObjWBytes;
1146
1147 PROCEDURE ObjLen* (): INTEGER;
1148 BEGIN
1149 RETURN outObj.Pos()
1150 END ObjLen;
1151
1152 PROCEDURE ObjSet* (pos: INTEGER);
1153 BEGIN
1154 outObj.SetPos(pos)
1155 END ObjSet;
1156
1157 PROCEDURE NewObj* (IN modName: ARRAY OF SHORTCHAR);
1158 VAR res: INTEGER; loc: Files.Locator; dir: Files.Name;
1159 BEGIN
1160 errpos := 0;
1161 Kernel.Utf8ToString(modName, ObjFName, res);
1162 loc := Files.dir.This(codePath);
1163 IF legacy THEN
1164 Kernel.SplitName(ObjFName, dir, ObjFName);
1165 loc := loc.This(dir).This(codeDir)
1166 END;
1167 objFile := Files.dir.New(loc, Files.ask);
1168 IF objFile # NIL THEN
1169 outObj := objFile.NewWriter(NIL);
1170 WriteLInt(outObj, OFtag)
1171 ELSE
1172 err(153)
1173 END
1174 END NewObj;
1175
1176 PROCEDURE RegisterObj*;
1177 VAR res: INTEGER; name: Files.Name;
1178 BEGIN
1179 IF objFile # NIL THEN
1180 name := ObjFName$;
1181 Kernel.MakeFileName(name, Kernel.objType);
1182 objFile.Register(name, Kernel.objType, Files.ask, res);
1183 objFile := NIL; outObj := NIL
1184 END
1185 END RegisterObj;
1186
1187 PROCEDURE DeleteObj*;
1188 BEGIN
1189 IF objFile # NIL THEN objFile.Close; objFile := NIL END
1190 END DeleteObj;
1191
1192
1193 PROCEDURE InitHost;
1194 VAR test: SHORTINT; lo: SHORTCHAR;
1195 BEGIN
1196 test := 1; SYSTEM.GET(SYSTEM.ADR(test), lo); LEHost := lo = 1X;
1197 InfReal := SYSTEM.VAL(SHORTREAL, InfRealPat);
1198 MinReal32 := SYSTEM.VAL(SHORTREAL, MinReal32Pat);
1199 MaxReal32 := SYSTEM.VAL(SHORTREAL, MaxReal32Pat);
1200 MinReal64 := Compound(MinReal64PatL, MinReal64PatH);
1201 MaxReal64 := Compound(MaxReal64PatL, MaxReal64PatH)
1202 END InitHost;
1203
1204 BEGIN
1205 InitCrcTab;
1206 InitHost
1207 END DevCPM.
A command line Component Pascal Compiler
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024