DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / cpc.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
errors and warnings marked explicitly
[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 | 900: msg := 'never used'
738 | 901: msg := 'never set'
739 | 902: msg := 'used before set'
740 | 903: msg := 'set but never used'
741 | 904: msg := 'used as varpar, possibly not set'
742 | 905: msg := 'also declared in outer scope'
743 | 906: msg := 'access/assignment to intermediate'
744 | 907: msg := 'redefinition'
745 | 908: msg := 'new definition'
746 | 909: msg := 'statement after RETURN/EXIT'
747 | 910: msg := 'for loop variable set'
748 | 911: msg := 'implied type guard'
749 | 912: msg := 'superfluous type guard'
750 | 913: msg := 'call might depend on evaluation sequence of params.'
751 | 930: msg := 'superfluous semicolon'
752 | 401: msg := 'bytecode restriction: no structured assignment'
753 | 402: msg := 'bytecode restriction: no procedure types'
754 | 403: msg := 'bytecode restriction: no nested procedures'
755 | 404: msg := 'bytecode restriction: illegal SYSTEM function'
756 | 410: msg := 'variable may not have been assigned'
757 | 411: msg := 'no proofable return'
758 | 412: msg := 'illegal constructor call'
759 | 413: msg := 'missing constructor call'
760 (* COM-related
761 | 700: msg := '700'
762 | 701: msg := '701'
763 | 702: msg := '702'
764 | 703: msg := '703'
765 *)
766 | 777: msg := 'register not released'
767 | 778: msg := 'float register not released'
768 | 779: msg := 'float register overallocated'
769 ELSE Strings.IntToString(err, msg)
770 END
771 END GetErrorMsg;
772
773 PROCEDURE InsertMarks*;
774 VAR i, j, x, y, n, line, col, beg, end: INTEGER; s: ARRAY 128 OF CHAR;
775 BEGIN
776 n := errors;
777 IF n > maxErrors THEN n := maxErrors END;
778 (* sort *)
779 i := 1;
780 WHILE i < n DO
781 x := errPos[i]; y := errNo[i]; j := i-1;
782 WHILE (j >= 0) & (errPos[j] < x) DO
783 errPos[j+1] := errPos[j];
784 errNo[j+1] := errNo[j];
785 DEC(j)
786 END;
787 errPos[j+1] := x; errNo[j+1] := y; INC(i)
788 END;
789 (* insert *)
790 IF n > 0 THEN
791 WHILE n > 0 DO DEC(n);
792 LineColOf(errPos[n], line, col, beg, end);
793 IF name = "" THEN Console.WriteStr("???")
794 ELSE Console.WriteStr(name)
795 END;
796 Console.WriteChar(":");
797 Strings.IntToString(line, s); Console.WriteStr(s);
798 Console.WriteChar(":");
799 Strings.IntToString(col, s); Console.WriteStr(s);
800 Console.WriteChar(":");
801 Strings.IntToString(errPos[n], s); Console.WriteStr(s);
802 Console.WriteStr(": ");
803 IF errNo[n] >= 0 THEN Console.WriteStr("error: ")
804 ELSE Console.WriteStr("warning: ")
805 END;
806 GetErrorMsg(errNo[n], s);
807 Console.WriteStr(s);
808 Console.WriteLn;
809 Console.WriteStr(" ");
810 FOR i := beg TO end DO
811 IF in[i] = 09X THEN Console.WriteStr(" ")
812 ELSE Console.WriteChar(in[i])
813 END
814 END;
815 Console.WriteLn;
816 Console.WriteStr(" ");
817 FOR i := 1 TO col - 2 DO
818 Console.WriteChar(" ")
819 END;
820 Console.WriteChar("^");
821 Console.WriteLn;
822 Console.WriteLn
823 END;
824 END
825 END InsertMarks;
826
827
828 (* fingerprinting *)
829
830 PROCEDURE InitCrcTab;
831 (* CRC32, high bit first, pre & post inverted *)
832 CONST poly = {0, 1, 2, 4, 5, 7, 8, 10, 11, 12, 16, 22, 23, 26}; (* CRC32 polynom *)
833 VAR x, c, i: INTEGER;
834 BEGIN
835 x := 0;
836 WHILE x < 256 DO
837 c := x * 1000000H; i := 0;
838 WHILE i < 8 DO
839 IF c < 0 THEN c := ORD(BITS(c * 2) / poly)
840 ELSE c := c * 2
841 END;
842 INC(i)
843 END;
844 crc32tab[ORD(BITS(x) / BITS(255))] := ORD(BITS(c) / BITS(255));
845 INC(x)
846 END
847 END InitCrcTab;
848
849 PROCEDURE FPrint* (VAR fp: INTEGER; val: INTEGER);
850 VAR c: INTEGER;
851 BEGIN
852 (*
853 fp := SYSTEM.ROT(ORD(BITS(fp) / BITS(val)), 1) (* bad collision detection *)
854 *)
855 (* CRC32, high bit first, pre & post inverted *)
856 c := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val DIV 1000000H)) MOD 256]));
857 c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 10000H)) MOD 256]));
858 c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 100H)) MOD 256]));
859 fp := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val)) MOD 256]));
860 END FPrint;
861
862 PROCEDURE FPrintSet* (VAR fp: INTEGER; set: SET);
863 BEGIN FPrint(fp, ORD(set))
864 END FPrintSet;
865
866 PROCEDURE FPrintReal* (VAR fp: INTEGER; real: SHORTREAL);
867 BEGIN FPrint(fp, SYSTEM.VAL(INTEGER, real))
868 END FPrintReal;
869
870 PROCEDURE FPrintLReal* (VAR fp: INTEGER; lr: REAL);
871 BEGIN
872 FPrint(fp, LoWord(lr)); FPrint(fp, HiWord(lr))
873 END FPrintLReal;
874
875 PROCEDURE ChkSum (VAR fp: INTEGER; val: INTEGER); (* symbolfile checksum *)
876 BEGIN
877 (* same as FPrint, 8 bit only *)
878 fp := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val)) MOD 256]))
879 END ChkSum;
880
881
882
883 (* compact format *)
884
885 PROCEDURE WriteLInt (w: Files.Writer; i: INTEGER);
886 BEGIN
887 ChkSum(checksum, i);
888 w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
889 ChkSum(checksum, i);
890 w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
891 ChkSum(checksum, i);
892 w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
893 ChkSum(checksum, i);
894 w.WriteByte(SHORT(SHORT(i MOD 256)))
895 END WriteLInt;
896
897 PROCEDURE ReadLInt (r: Files.Reader; VAR i: INTEGER);
898 VAR b: BYTE; x: INTEGER;
899 BEGIN
900 r.ReadByte(b); x := b MOD 256;
901 ChkSum(checksum, b);
902 r.ReadByte(b); x := x + 100H * (b MOD 256);
903 ChkSum(checksum, b);
904 r.ReadByte(b); x := x + 10000H * (b MOD 256);
905 ChkSum(checksum, b);
906 r.ReadByte(b); i := x + 1000000H * b;
907 ChkSum(checksum, b)
908 END ReadLInt;
909
910 PROCEDURE WriteNum (w: Files.Writer; i: INTEGER);
911 BEGIN (* old format of Oberon *)
912 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;
913 ChkSum(checksum, i MOD 128);
914 w.WriteByte(SHORT(SHORT(i MOD 128)))
915 END WriteNum;
916
917 PROCEDURE ReadNum (r: Files.Reader; VAR i: INTEGER);
918 VAR b: BYTE; s, y: INTEGER;
919 BEGIN
920 s := 0; y := 0; r.ReadByte(b);
921 IF ~r.eof THEN ChkSum(checksum, b) END;
922 WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); r.ReadByte(b); ChkSum(checksum, b) END;
923 i := ASH((b + 64) MOD 128 - 64, s) + y;
924 END ReadNum;
925
926 PROCEDURE WriteNumSet (w: Files.Writer; x: SET);
927 BEGIN
928 WriteNum(w, ORD(x))
929 END WriteNumSet;
930
931 PROCEDURE ReadNumSet (r: Files.Reader; VAR x: SET);
932 VAR i: INTEGER;
933 BEGIN
934 ReadNum(r, i); x := BITS(i)
935 END ReadNumSet;
936
937 PROCEDURE WriteReal (w: Files.Writer; x: SHORTREAL);
938 BEGIN
939 WriteLInt(w, SYSTEM.VAL(INTEGER, x))
940 END WriteReal;
941
942 PROCEDURE ReadReal (r: Files.Reader; VAR x: SHORTREAL);
943 VAR i: INTEGER;
944 BEGIN
945 ReadLInt(r, i); x := SYSTEM.VAL(SHORTREAL, i)
946 END ReadReal;
947
948 PROCEDURE WriteLReal (w: Files.Writer; x: REAL);
949 BEGIN
950 WriteLInt(w, LoWord(x)); WriteLInt(w, HiWord(x))
951 END WriteLReal;
952
953 PROCEDURE ReadLReal (r: Files.Reader; VAR x: REAL);
954 VAR h, l: INTEGER;
955 BEGIN
956 ReadLInt(r, l); ReadLInt(r, h); x := Compound(l, h)
957 END ReadLReal;
958
959
960 (* read symbol file *)
961
962 PROCEDURE SymRCh* (VAR ch: SHORTCHAR);
963 VAR b: BYTE;
964 BEGIN
965 inSym.ReadByte(b); ch := SHORT(CHR(b));
966 ChkSum(checksum, b)
967 END SymRCh;
968
969 PROCEDURE SymRInt* (): INTEGER;
970 VAR k: INTEGER;
971 BEGIN
972 ReadNum(inSym, k); RETURN k
973 END SymRInt;
974
975 PROCEDURE SymRSet* (VAR s: SET);
976 BEGIN
977 ReadNumSet(inSym, s)
978 END SymRSet;
979
980 PROCEDURE SymRReal* (VAR r: SHORTREAL);
981 BEGIN
982 ReadReal(inSym, r)
983 END SymRReal;
984
985 PROCEDURE SymRLReal* (VAR lr: REAL);
986 BEGIN
987 ReadLReal(inSym, lr)
988 END SymRLReal;
989
990 PROCEDURE eofSF* (): BOOLEAN;
991 BEGIN
992 RETURN inSym.eof
993 END eofSF;
994
995 PROCEDURE OldSym* (IN modName: ARRAY OF SHORTCHAR; VAR done: BOOLEAN);
996 VAR tag: INTEGER; d: Directory;
997
998 PROCEDURE Old (IN path: Files.Name; IN modName: ARRAY OF SHORTCHAR; legacy: BOOLEAN): Files.File;
999 VAR f: Files.File; res: INTEGER; loc: Files.Locator; dir, name: Files.Name;
1000 BEGIN
1001 Kernel.Utf8ToString(modName, name, res);
1002 loc := Files.dir.This(path);
1003 IF legacy THEN
1004 Kernel.SplitName(name, dir, name);
1005 Kernel.MakeFileName(name, Kernel.symType);
1006 loc := loc.This(dir).This(symDir);
1007 f := Files.dir.Old(loc, name, Files.shared);
1008 IF (f = NIL) & (dir = "") THEN
1009 loc := Files.dir.This(path).This(SYSdir).This(symDir);
1010 f := Files.dir.Old(loc, name, Files.shared)
1011 END
1012 ELSE
1013 Kernel.MakeFileName(name, Kernel.symType);
1014 f := Files.dir.Old(loc, name, Files.shared)
1015 END;
1016 RETURN f
1017 END Old;
1018
1019 BEGIN
1020 done := FALSE;
1021 IF modName = "@file" THEN
1022 oldSymFile := file
1023 ELSE
1024 oldSymFile := Old(symPath, modName, legacy);
1025 d := symList;
1026 WHILE (oldSymFile = NIL) & (d # NIL) DO
1027 oldSymFile := Old(d.path, modName, d.legacy);
1028 d := d.next
1029 END
1030 END;
1031 IF oldSymFile # NIL THEN
1032 inSym := oldSymFile.NewReader(inSym);
1033 IF inSym # NIL THEN
1034 ReadLInt(inSym, tag);
1035 IF tag = SFtag THEN done := TRUE ELSE err(151) END
1036 END
1037 END
1038 END OldSym;
1039
1040 PROCEDURE CloseOldSym*;
1041 BEGIN
1042 IF oldSymFile # NIL THEN oldSymFile.Close; oldSymFile := NIL END
1043 END CloseOldSym;
1044
1045
1046 (* write symbol file *)
1047
1048 PROCEDURE SymWCh* (ch: SHORTCHAR);
1049 BEGIN
1050 ChkSum(checksum, ORD(ch));
1051 outSym.WriteByte(SHORT(ORD(ch)))
1052 END SymWCh;
1053
1054 PROCEDURE SymWInt* (i: INTEGER);
1055 BEGIN
1056 WriteNum(outSym, i)
1057 END SymWInt;
1058
1059 PROCEDURE SymWSet* (s: SET);
1060 BEGIN
1061 WriteNumSet(outSym, s)
1062 END SymWSet;
1063
1064 PROCEDURE SymWReal* (r: SHORTREAL);
1065 BEGIN
1066 WriteReal(outSym, r)
1067 END SymWReal;
1068
1069 PROCEDURE SymWLReal* (r: REAL);
1070 BEGIN
1071 WriteLReal(outSym, r)
1072 END SymWLReal;
1073
1074 PROCEDURE SymReset*;
1075 BEGIN
1076 outSym.SetPos(4)
1077 END SymReset;
1078
1079 PROCEDURE NewSym* (IN modName: ARRAY OF SHORTCHAR);
1080 VAR res: INTEGER; loc: Files.Locator; dir: Files.Name;
1081 BEGIN
1082 Kernel.Utf8ToString(modName, ObjFName, res);
1083 loc := Files.dir.This(symPath);
1084 IF legacy THEN
1085 Kernel.SplitName(ObjFName, dir, ObjFName);
1086 loc := loc.This(dir).This(symDir)
1087 END;
1088 symFile := Files.dir.New(loc, Files.ask);
1089 IF symFile # NIL THEN
1090 outSym := symFile.NewWriter(NIL);
1091 WriteLInt(outSym, SFtag)
1092 ELSE
1093 err(153)
1094 END
1095 END NewSym;
1096
1097 PROCEDURE RegisterNewSym*;
1098 VAR res: INTEGER; name: Files.Name;
1099 BEGIN
1100 IF symFile # NIL THEN
1101 name := ObjFName$;
1102 Kernel.MakeFileName(name, Kernel.symType);
1103 symFile.Register(name, Kernel.symType, Files.ask, res);
1104 symFile := NIL
1105 END
1106 END RegisterNewSym;
1107
1108 PROCEDURE DeleteNewSym*;
1109 BEGIN
1110 IF symFile # NIL THEN symFile.Close; symFile := NIL END
1111 END DeleteNewSym;
1112
1113
1114 (* write object file *)
1115
1116 PROCEDURE ObjW* (ch: SHORTCHAR);
1117 BEGIN
1118 outObj.WriteByte(SHORT(ORD(ch)))
1119 END ObjW;
1120
1121 PROCEDURE ObjWNum* (i: INTEGER);
1122 BEGIN
1123 WriteNum(outObj, i)
1124 END ObjWNum;
1125
1126 PROCEDURE ObjWInt (i: SHORTINT);
1127 BEGIN
1128 outObj.WriteByte(SHORT(SHORT(i MOD 256)));
1129 outObj.WriteByte(SHORT(SHORT(i DIV 256)))
1130 END ObjWInt;
1131
1132 PROCEDURE ObjWLInt* (i: INTEGER);
1133 BEGIN
1134 ObjWInt(SHORT(i MOD 65536));
1135 ObjWInt(SHORT(i DIV 65536))
1136 END ObjWLInt;
1137
1138 PROCEDURE ObjWBytes* (IN bytes: ARRAY OF SHORTCHAR; n: INTEGER);
1139 TYPE P = POINTER TO ARRAY [untagged] 100000H OF BYTE;
1140 VAR p: P;
1141 BEGIN
1142 p := SYSTEM.VAL(P, SYSTEM.ADR(bytes));
1143 outObj.WriteBytes(p^, 0, n)
1144 END ObjWBytes;
1145
1146 PROCEDURE ObjLen* (): INTEGER;
1147 BEGIN
1148 RETURN outObj.Pos()
1149 END ObjLen;
1150
1151 PROCEDURE ObjSet* (pos: INTEGER);
1152 BEGIN
1153 outObj.SetPos(pos)
1154 END ObjSet;
1155
1156 PROCEDURE NewObj* (IN modName: ARRAY OF SHORTCHAR);
1157 VAR res: INTEGER; loc: Files.Locator; dir: Files.Name;
1158 BEGIN
1159 errpos := 0;
1160 Kernel.Utf8ToString(modName, ObjFName, res);
1161 loc := Files.dir.This(codePath);
1162 IF legacy THEN
1163 Kernel.SplitName(ObjFName, dir, ObjFName);
1164 loc := loc.This(dir).This(codeDir)
1165 END;
1166 objFile := Files.dir.New(loc, Files.ask);
1167 IF objFile # NIL THEN
1168 outObj := objFile.NewWriter(NIL);
1169 WriteLInt(outObj, OFtag)
1170 ELSE
1171 err(153)
1172 END
1173 END NewObj;
1174
1175 PROCEDURE RegisterObj*;
1176 VAR res: INTEGER; name: Files.Name;
1177 BEGIN
1178 IF objFile # NIL THEN
1179 name := ObjFName$;
1180 Kernel.MakeFileName(name, Kernel.objType);
1181 objFile.Register(name, Kernel.objType, Files.ask, res);
1182 objFile := NIL; outObj := NIL
1183 END
1184 END RegisterObj;
1185
1186 PROCEDURE DeleteObj*;
1187 BEGIN
1188 IF objFile # NIL THEN objFile.Close; objFile := NIL END
1189 END DeleteObj;
1190
1191
1192 PROCEDURE InitHost;
1193 VAR test: SHORTINT; lo: SHORTCHAR;
1194 BEGIN
1195 test := 1; SYSTEM.GET(SYSTEM.ADR(test), lo); LEHost := lo = 1X;
1196 InfReal := SYSTEM.VAL(SHORTREAL, InfRealPat);
1197 MinReal32 := SYSTEM.VAL(SHORTREAL, MinReal32Pat);
1198 MaxReal32 := SYSTEM.VAL(SHORTREAL, MaxReal32Pat);
1199 MinReal64 := Compound(MinReal64PatL, MinReal64PatH);
1200 MaxReal64 := Compound(MaxReal64PatL, MaxReal64PatH)
1201 END InitHost;
1202
1203 BEGIN
1204 InitCrcTab;
1205 InitHost
1206 END DevCPM.
A command line Component Pascal Compiler
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024