-
Notifications
You must be signed in to change notification settings - Fork 2
/
CPS.cp
375 lines (354 loc) · 12.8 KB
/
CPS.cp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
MODULE DevCPS;
(**
project = "BlackBox"
organization = "www.oberon.ch"
contributors = "Oberon microsystems"
version = "System/Rsrc/About"
copyright = "System/Rsrc/About"
license = "Docu/BB-License"
references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps"
changes = ""
issues = ""
**)
IMPORT SYSTEM, Math, DevCPM, DevCPT;
CONST
MaxIdLen = 256;
TYPE
(*
Name* = ARRAY MaxIdLen OF SHORTCHAR;
String* = POINTER TO ARRAY OF SHORTCHAR;
*)
(* name, str, numtyp, intval, realval, realval are implicit results of Get *)
VAR
name*: DevCPT.Name;
str*: DevCPT.String;
lstr*: POINTER TO ARRAY OF CHAR;
numtyp*: SHORTINT; (* 1 = char, 2 = integer, 4 = real, 5 = int64, 6 = real32, 7 = real64 *)
intval*: INTEGER; (* integer value or string length (incl. 0X) *)
realval*: REAL;
CONST
(* numtyp values *)
char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7;
(*symbol values*)
null = 0; times = 1; slash = 2; div = 3; mod = 4;
and = 5; plus = 6; minus = 7; or = 8; eql = 9;
neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
in = 15; is = 16; arrow = 17; dollar = 18; period = 19;
comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24;
rbrace = 25; of = 26; then = 27; do = 28; to = 29;
by = 30; not = 33;
lparen = 40; lbrak = 41; lbrace = 42; becomes = 44;
number = 45; nil = 46; string = 47; ident = 48; semicolon = 49;
bar = 50; end = 51; else = 52; elsif = 53; until = 54;
if = 55; case = 56; while = 57; repeat = 58; for = 59;
loop = 60; with = 61; exit = 62; return = 63; array = 64;
record = 65; pointer = 66; begin = 67; const = 68; type = 69;
var = 70; out = 71; procedure = 72; close = 73; import = 74;
module = 75; eof = 76;
VAR
ch: SHORTCHAR; (*current character*)
PROCEDURE err(n: SHORTINT);
BEGIN DevCPM.err(n)
END err;
PROCEDURE Str(VAR sym: BYTE);
VAR i: SHORTINT; och: SHORTCHAR; lch: CHAR; long: BOOLEAN;
s: ARRAY 256 OF CHAR; t: POINTER TO ARRAY OF CHAR;
BEGIN i := 0; och := ch; long := FALSE;
LOOP DevCPM.GetL(lch);
IF lch = och THEN EXIT END ;
IF (lch < " ") & (lch # 9X) THEN err(3); EXIT END;
IF lch > 0FFX THEN long := TRUE END;
IF i < LEN(s) - 1 THEN s[i] := lch
ELSIF i = LEN(s) - 1 THEN s[i] := 0X; NEW(lstr, 2 * LEN(s)); lstr^ := s$; lstr[i] := lch
ELSIF i < LEN(lstr^) - 1 THEN lstr[i] := lch
ELSE t := lstr; t[i] := 0X; NEW(lstr, 2 * LEN(t^)); lstr^ := t^$; lstr[i] := lch
END;
INC(i)
END ;
IF i = 1 THEN sym := number; numtyp := 1; intval := ORD(s[0])
ELSE
sym := string; numtyp := 0; intval := i + 1; NEW(str, intval);
IF long THEN
IF i < LEN(s) THEN s[i] := 0X; NEW(lstr, intval); lstr^ := s$
ELSE lstr[i] := 0X
END;
str^ := SHORT(lstr$)
ELSE
IF i < LEN(s) THEN s[i] := 0X; str^ := SHORT(s$);
ELSE lstr[i] := 0X; str^ := SHORT(lstr$)
END;
lstr := NIL
END
END;
DevCPM.Get(ch)
END Str;
PROCEDURE Identifier(VAR sym: BYTE);
VAR i: SHORTINT;
BEGIN i := 0;
REPEAT
name[i] := ch; INC(i); DevCPM.Get(ch)
UNTIL (ch < "0")
OR ("9" < ch) & (CAP(ch) < "A")
OR ("Z" < CAP(ch)) & (ch # "_") & (ch < "À")
OR (ch = "×")
OR (ch = "÷")
OR (i = MaxIdLen);
IF i = MaxIdLen THEN err(240); DEC(i) END ;
name[i] := 0X; sym := ident
END Identifier;
PROCEDURE Number;
VAR i, j, m, n, d, e, a: INTEGER; f, g, x: REAL; expCh, tch: SHORTCHAR; neg: BOOLEAN; r: SHORTREAL;
dig: ARRAY 30 OF SHORTCHAR; arr: ARRAY 2 OF INTEGER;
PROCEDURE Ord(ch: SHORTCHAR; hex: BOOLEAN): SHORTINT;
BEGIN (* ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") *)
IF ch <= "9" THEN RETURN SHORT(ORD(ch) - ORD("0"))
ELSIF hex THEN RETURN SHORT(ORD(ch) - ORD("A") + 10)
ELSE err(2); RETURN 0
END
END Ord;
BEGIN (* ("0" <= ch) & (ch <= "9") *)
i := 0; m := 0; n := 0; d := 0;
LOOP (* read mantissa *)
IF ("0" <= ch) & (ch <= "9") OR (d = 0) & ("A" <= ch) & (ch <= "F") THEN
IF (m > 0) OR (ch # "0") THEN (* ignore leading zeros *)
IF n < LEN(dig) THEN dig[n] := ch; INC(n) END;
INC(m)
END;
DevCPM.Get(ch); INC(i)
ELSIF ch = "." THEN DevCPM.Get(ch);
IF ch = "." THEN (* ellipsis *) ch := 7FX; EXIT
ELSIF d = 0 THEN (* i > 0 *) d := i
ELSE err(2)
END
ELSE EXIT
END
END; (* 0 <= n <= m <= i, 0 <= d <= i *)
IF d = 0 THEN (* integer *) realval := 0; numtyp := integer;
IF n = m THEN intval := 0; i := 0;
IF ch = "X" THEN (* character *) DevCPM.Get(ch); numtyp := char;
IF n <= 4 THEN
WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END
ELSE err(203)
END
ELSIF (ch = "H") OR (ch = "S") THEN (* hex 32bit *)
tch := ch; DevCPM.Get(ch);
IF (ch = "L") & (DevCPM.oberon IN DevCPM.options) THEN (* old syntax: hex 64bit *)
DevCPM.searchpos := DevCPM.curpos - 2; DevCPM.Get(ch);
IF n <= 16 THEN
IF (n = 16) & (dig[0] > "7") THEN realval := -1 END;
WHILE (i < n) & (i < 10) DO realval := realval * 10H + Ord(dig[i], TRUE); INC(i) END;
WHILE i < n DO realval := realval * 10H; intval := intval * 10H + Ord(dig[i], TRUE); INC(i) END;
numtyp := int64
ELSE err(203)
END
ELSIF n <= 8 THEN
IF (n = 8) & (dig[0] > "7") THEN (* prevent overflow *) intval := -1 END;
WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END;
IF tch = "S" THEN (* 32 bit hex float *)
r := SYSTEM.VAL(SHORTREAL, intval);
realval := r; intval := 0; numtyp := real32
END
ELSE err(203)
END
ELSIF ch = "L" THEN (* hex 64bit *)
DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch);
IF n <= 16 THEN
IF (n = 16) & (dig[0] > "7") THEN realval := -1 END;
WHILE (i < n) & (i < 10) DO realval := realval * 10H + Ord(dig[i], TRUE); INC(i) END;
WHILE i < n DO realval := realval * 10H; intval := intval * 10H + Ord(dig[i], TRUE); INC(i) END;
numtyp := int64
ELSE err(203)
END
ELSIF ch = "R" THEN (* hex float 64bit *)
DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch);
IF n <= 16 THEN
a := 0; IF (n = 16) & (dig[0] > "7") THEN (* prevent overflow *) a := -1 END;
WHILE i < n-8 DO a := a*10H + Ord(dig[i], TRUE); INC(i) END;
IF DevCPM.LEHost THEN arr[1] := a ELSE arr[0] := a END;
a := 0; IF (n >= 8) & (dig[i] > "7") THEN (* prevent overflow *) a := -1 END;
WHILE i < n DO a := a*10H + Ord(dig[i], TRUE); INC(i) END;
IF DevCPM.LEHost THEN arr[0] := a ELSE arr[1] := a END;
realval := SYSTEM.VAL(REAL, arr);
intval := 0; numtyp := real64
ELSE err(203)
END
ELSE (* decimal *)
WHILE i < n DO d := Ord(dig[i], FALSE); INC(i);
a := (MAX(INTEGER) - d) DIV 10;
IF intval > a THEN
a := (intval - a + 65535) DIV 65536 * 65536;
realval := realval + a; intval := intval - a
END;
realval := realval * 10; intval := intval * 10 + d
END;
IF realval = 0 THEN numtyp := integer
ELSIF intval < 9223372036854775808.0E0 - realval THEN numtyp := int64 (* 2^63 *)
ELSE intval := 0; err(203)
END
END
ELSE err(203)
END
ELSE (* fraction *)
f := 0; g := 0; e := 0; j := 0; expCh := "E";
WHILE (j < 15) & (j < n) DO g := g * 10 + Ord(dig[j], FALSE); INC(j) END; (* !!! *)
WHILE n > j DO (* 0 <= f < 1 *) DEC(n); f := (Ord(dig[n], FALSE) + f)/10 END;
IF (ch = "E") OR (ch = "D") & (DevCPM.oberon IN DevCPM.options) THEN
expCh := ch; DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch); neg := FALSE;
IF ch = "-" THEN neg := TRUE; DevCPM.Get(ch)
ELSIF ch = "+" THEN DevCPM.Get(ch)
END;
IF ("0" <= ch) & (ch <= "9") THEN
REPEAT n := Ord(ch, FALSE); DevCPM.Get(ch);
IF e <= (MAX(SHORTINT) - n) DIV 10 THEN e := SHORT(e*10 + n)
ELSE err(203)
END
UNTIL (ch < "0") OR ("9" < ch);
IF neg THEN e := -e END
ELSE err(2)
END
END;
DEC(e, i-d-m); (* decimal point shift *)
IF e < -308 - 16 THEN
realval := 0.0
ELSIF e < -308 + 14 THEN
realval := (f + g) / Math.IntPower(10, j-e-30) / 1.0E15 / 1.0E15
ELSIF e < j THEN
realval := (f + g) / Math.IntPower(10, j-e) (* Ten(j-e) *)
ELSIF e <= 308 THEN
realval := (f + g) * Math.IntPower(10, e-j) (* Ten(e-j) *)
ELSIF e = 308 + 1 THEN
realval := (f + g) * (Math.IntPower(10, e-j) / 16);
IF realval <= DevCPM.MaxReal64 / 16 THEN realval := realval * 16
ELSE err(203)
END
ELSE err(203)
END;
numtyp := real
END
END Number;
PROCEDURE Get*(VAR sym: BYTE);
VAR s: BYTE; old: INTEGER;
PROCEDURE Comment; (* do not read after end of file *)
BEGIN DevCPM.Get(ch);
LOOP
LOOP
WHILE ch = "(" DO DevCPM.Get(ch);
IF ch = "*" THEN Comment END
END ;
IF ch = "*" THEN DevCPM.Get(ch); EXIT END ;
IF ch = DevCPM.Eot THEN EXIT END ;
DevCPM.Get(ch)
END ;
IF ch = ")" THEN DevCPM.Get(ch); EXIT END ;
IF ch = DevCPM.Eot THEN err(5); EXIT END
END
END Comment;
BEGIN
DevCPM.errpos := DevCPM.curpos-1;
WHILE (ch <= " ") OR (ch = 0A0X) DO (*ignore control characters*)
IF ch = DevCPM.Eot THEN sym := eof; RETURN
ELSE DevCPM.Get(ch)
END
END ;
DevCPM.startpos := DevCPM.curpos - 1;
CASE ch OF (* ch > " " *)
| 22X, 27X : Str(s)
| "#" : s := neq; DevCPM.Get(ch)
| "&" : s := and; DevCPM.Get(ch)
| "(" : DevCPM.Get(ch);
IF ch = "*" THEN Comment; old := DevCPM.errpos; Get(s); DevCPM.errpos := old;
ELSE s := lparen
END
| ")" : s := rparen; DevCPM.Get(ch)
| "*" : s := times; DevCPM.Get(ch)
| "+" : s := plus; DevCPM.Get(ch)
| "," : s := comma; DevCPM.Get(ch)
| "-" : s := minus; DevCPM.Get(ch)
| "." : DevCPM.Get(ch);
IF ch = "." THEN DevCPM.Get(ch); s := upto ELSE s := period END
| "/" : s := slash; DevCPM.Get(ch)
| "0".."9": Number; s := number
| ":" : DevCPM.Get(ch);
IF ch = "=" THEN DevCPM.Get(ch); s := becomes ELSE s := colon END
| ";" : s := semicolon; DevCPM.Get(ch)
| "<" : DevCPM.Get(ch);
IF ch = "=" THEN DevCPM.Get(ch); s := leq ELSE s := lss END
| "=" : s := eql; DevCPM.Get(ch)
| ">" : DevCPM.Get(ch);
IF ch = "=" THEN DevCPM.Get(ch); s := geq ELSE s := gtr END
| "A": Identifier(s); IF name = "ARRAY" THEN s := array END
| "B": Identifier(s);
IF name = "BEGIN" THEN s := begin
ELSIF name = "BY" THEN s := by
END
| "C": Identifier(s);
IF name = "CASE" THEN s := case
ELSIF name = "CONST" THEN s := const
ELSIF name = "CLOSE" THEN s := close
END
| "D": Identifier(s);
IF name = "DO" THEN s := do
ELSIF name = "DIV" THEN s := div
END
| "E": Identifier(s);
IF name = "END" THEN s := end
ELSIF name = "ELSE" THEN s := else
ELSIF name = "ELSIF" THEN s := elsif
ELSIF name = "EXIT" THEN s := exit
END
| "F": Identifier(s); IF name = "FOR" THEN s := for END
| "I": Identifier(s);
IF name = "IF" THEN s := if
ELSIF name = "IN" THEN s := in
ELSIF name = "IS" THEN s := is
ELSIF name = "IMPORT" THEN s := import
END
| "L": Identifier(s); IF name = "LOOP" THEN s := loop END
| "M": Identifier(s);
IF name = "MOD" THEN s := mod
ELSIF name = "MODULE" THEN s := module
END
| "N": Identifier(s); IF name = "NIL" THEN s := nil END
| "O": Identifier(s);
IF name = "OR" THEN s := or
ELSIF name = "OF" THEN s := of
ELSIF name = "OUT" THEN s := out
END
| "P": Identifier(s);
IF name = "PROCEDURE" THEN s := procedure
ELSIF name = "POINTER" THEN s := pointer
END
| "R": Identifier(s);
IF name = "RECORD" THEN s := record
ELSIF name = "REPEAT" THEN s := repeat
ELSIF name = "RETURN" THEN s := return
END
| "T": Identifier(s);
IF name = "THEN" THEN s := then
ELSIF name = "TO" THEN s := to
ELSIF name = "TYPE" THEN s := type
END
| "U": Identifier(s); IF name = "UNTIL" THEN s := until END
| "V": Identifier(s); IF name = "VAR" THEN s := var END
| "W": Identifier(s);
IF name = "WHILE" THEN s := while
ELSIF name = "WITH" THEN s := with
END
| "G".."H", "J", "K", "Q", "S", "X".."Z", "a".."z", "_", "À".."Ö", "Ø".."ö", "ø".."ÿ": Identifier(s)
| "[" : s := lbrak; DevCPM.Get(ch)
| "]" : s := rbrak; DevCPM.Get(ch)
| "^" : s := arrow; DevCPM.Get(ch)
| "$" : s := dollar; DevCPM.Get(ch)
| "{" : s := lbrace; DevCPM.Get(ch);
| "|" : s := bar; DevCPM.Get(ch)
| "}" : s := rbrace; DevCPM.Get(ch)
| "~" : s := not; DevCPM.Get(ch)
| 7FX : s := upto; DevCPM.Get(ch)
ELSE s := null; DevCPM.Get(ch)
END ;
sym := s
END Get;
PROCEDURE Init*;
BEGIN ch := " "
END Init;
END DevCPS.