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