Trurl-based/Dev/Mod/CPS.txt

   1 MODULE DevCPS;
   2
   3         (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPS.odc *)
   4         (* DO NOT EDIT *)
   5         (* SEE XXX *)
   6
   7         IMPORT SYSTEM, Math, DevCPM, DevCPT;
   8
   9         CONST
  10                 MaxIdLen = 256;
  11
  12         TYPE
  13 (*
  14                 Name* = ARRAY MaxIdLen OF SHORTCHAR;
  15                 String* = POINTER TO ARRAY OF SHORTCHAR;
  16 *)
  17
  18         (* name, str, numtyp, intval, realval, realval are implicit results of Get *)
  19
  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;
  27
  28
  29         CONST
  30                 (* numtyp values *)
  31                 char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7;
  32
  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;
  49
  50         VAR
  51                 ch: SHORTCHAR;     (*current character*)
  52
  53         PROCEDURE err(n: SHORTINT);
  54         BEGIN DevCPM.err(n)
  55         END err;
  56
  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;
  89
  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;
 104
 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;
 108
 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;
 116
 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;
 237
 238         PROCEDURE Get*(VAR sym: BYTE);
 239                 VAR s: BYTE; old: INTEGER;
 240
 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;
 256
 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;
 362
 363         PROCEDURE Init*;
 364         BEGIN ch := " "
 365         END Init;
 366
 367 END DevCPS.