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