gpcp/LitValue.cp

   1 (* ==================================================================== *)
   2 (*                                                                      *)
   3 (*  Literal Valuehandler Module for the Gardens Point Component         *)
   4 (*  Pascal Compiler. Exports the open character array type CharOpen     *)
   5 (*      Copyright (c) John Gough 1999, 2000.                            *)
   6 (*                                                                      *)
   7 (* ==================================================================== *)
   8
   9 MODULE LitValue;
  10
  11   IMPORT
  12     ASCII,
  13         GPCPcopyright,
  14         Console,
  15         GPText,
  16         CPascalS;
  17
  18 (* ============================================================ *)
  19
  20   TYPE
  21     CharOpen*    = POINTER TO ARRAY OF CHAR;
  22     CharOpenSeq* = RECORD
  23                      high  : INTEGER;
  24                      tide- : INTEGER;
  25                      a-    : POINTER TO ARRAY OF CharOpen;
  26                    END;
  27
  28     CharVector*  = VECTOR OF CHAR;
  29
  30 (* ============================================================ *)
  31
  32   TYPE
  33     Value*    = POINTER TO RECORD               (* All opaque.  *)
  34                   ord : LONGINT;
  35                   flt : REAL;
  36                   str : CharOpen;
  37                 END;
  38
  39 (* ================================================================= *)
  40 (*                      FORWARD DECLARATIONS                         *)
  41 (* ================================================================= *)
  42   PROCEDURE^ strToCharOpen*(IN str : ARRAY OF CHAR) : CharOpen;
  43   PROCEDURE^ arrToCharOpen*(str : CharOpen; len : INTEGER) : CharOpen;
  44   PROCEDURE^ subStrToCharOpen*(pos,len : INTEGER) : CharOpen;
  45   PROCEDURE^ chrVecToCharOpen*(vec : CharVector) : CharOpen;
  46 (* ================================================================= *)
  47
  48   PROCEDURE  newChrVal*(ch : CHAR) : Value;
  49     VAR val : Value;
  50   BEGIN
  51     NEW(val); val.ord := ORD(ch); RETURN val;
  52   END newChrVal;
  53
  54   PROCEDURE  newIntVal*(nm : LONGINT) : Value;
  55     VAR val : Value;
  56   BEGIN
  57     NEW(val); val.ord := nm; RETURN val;
  58   END newIntVal;
  59
  60   PROCEDURE  newFltVal*(rv : REAL) : Value;
  61     VAR val : Value;
  62   BEGIN
  63     NEW(val); val.flt := rv; RETURN val;
  64   END newFltVal;
  65
  66   PROCEDURE  newSetVal*(st : SET) : Value;
  67     VAR val : Value;
  68   BEGIN
  69     NEW(val); val.ord := ORD(st); RETURN val;
  70   END newSetVal;
  71
  72   PROCEDURE  newStrVal*(IN sv : ARRAY OF CHAR) : Value;
  73     VAR val : Value;
  74   BEGIN
  75     NEW(val);
  76     val.ord := LEN(sv$);
  77     val.str := strToCharOpen(sv);
  78     RETURN val;
  79   END newStrVal;
  80
  81   PROCEDURE  newStrLenVal*(str : CharOpen; len : INTEGER) : Value;
  82     VAR val : Value;
  83   BEGIN
  84     NEW(val);
  85     val.ord := len;
  86     val.str := arrToCharOpen(str, len);
  87     RETURN val;
  88   END newStrLenVal;
  89
  90   PROCEDURE  newBufVal*(p,l : INTEGER) : Value;
  91     VAR val : Value;
  92   BEGIN
  93     NEW(val);
  94     val.ord := l;
  95     val.str := subStrToCharOpen(p,l);
  96     RETURN val;
  97   END newBufVal;
  98
  99   PROCEDURE  escapedString*(pos,len : INTEGER) : Value;
 100     VAR value  : Value;
 101             vector : CharVector;
 102                 count  : INTEGER;
 103                 theCh  : CHAR;
 104                 cdPnt  : INTEGER;
 105     (* ----------------------- *)
 106     PROCEDURE ReportBadHex(code, offset : INTEGER);
 107       VAR tok : CPascalS.Token;
 108     BEGIN
 109       tok := CPascalS.prevTok;
 110           CPascalS.SemError.Report(code, tok.lin, tok.col + offset);
 111     END ReportBadHex;
 112     (* ----------------------- *)
 113   BEGIN
 114     count := 0;
 115     NEW(value);
 116         NEW(vector, len * 2);
 117         WHILE count < len DO
 118           theCh :=  CPascalS.charAt(pos+count); INC(count);
 119           IF theCh = '\' THEN
 120             theCh := CPascalS.charAt(pos+count); INC(count);
 121                 CASE theCh OF
 122                 |  '0' : APPEND(vector, 0X);
 123                 |  '\' : APPEND(vector, '\');
 124                 |  'a' : APPEND(vector, ASCII.BEL);
 125                 |  'b' : APPEND(vector, ASCII.BS);
 126                 |  'f' : APPEND(vector, ASCII.FF);
 127                 |  'n' : APPEND(vector, ASCII.LF);
 128                 |  'r' : APPEND(vector, ASCII.CR);
 129                 |  't' : APPEND(vector, ASCII.HT);
 130                 |  'v' : APPEND(vector, ASCII.VT);
 131                 |  'u' : cdPnt := CPascalS.getHex(pos+count, 4);
 132                          IF cdPnt < 0 THEN ReportBadHex(-cdPnt, count); cdPnt := 0 END;
 133                                  APPEND(vector, CHR(cdPnt)); INC(count, 4);
 134                 |  'x' : cdPnt := CPascalS.getHex(pos+count, 2);
 135                          IF cdPnt < 0 THEN ReportBadHex(-cdPnt, count); cdPnt := 0 END;
 136                          APPEND(vector, CHR(cdPnt)); INC(count, 2);
 137                 ELSE APPEND(vector, theCh);
 138                 END;
 139       ELSE
 140             APPEND(vector, theCh);
 141           END;
 142     END;
 143     value.ord := LEN(vector);
 144         value.str := chrVecToCharOpen(vector);
 145     RETURN value;
 146   END escapedString;
 147
 148 (* ============================================================ *)
 149
 150   PROCEDURE (v : Value)char*() : CHAR,NEW;      (* final method *)
 151   BEGIN
 152     RETURN CHR(v.ord);
 153   END char;
 154
 155   PROCEDURE (v : Value)int*() : INTEGER,NEW;    (* final method *)
 156   BEGIN
 157     RETURN SHORT(v.ord);
 158   END int;
 159
 160   PROCEDURE (v : Value)set*() : SET,NEW;        (* final method *)
 161   BEGIN
 162     RETURN BITS(SHORT(v.ord));
 163   END set;
 164
 165   PROCEDURE (v : Value)long*() : LONGINT,NEW;   (* final method *)
 166   BEGIN
 167     RETURN v.ord;
 168   END long;
 169
 170   PROCEDURE (v : Value)real*() : REAL,NEW;      (* final method *)
 171   BEGIN
 172     RETURN v.flt;
 173   END real;
 174
 175   PROCEDURE (v : Value)chOpen*() : CharOpen,NEW;        (*final *)
 176   BEGIN
 177     RETURN v.str;
 178   END chOpen;
 179
 180   PROCEDURE (v : Value)len*() : INTEGER,NEW;    (* final method *)
 181   BEGIN
 182     RETURN SHORT(v.ord);
 183   END len;
 184
 185   PROCEDURE (v : Value)chr0*() : CHAR,NEW;      (* final method *)
 186   BEGIN
 187     RETURN v.str[0];
 188   END chr0;
 189
 190   PROCEDURE (v : Value)GetStr*(OUT str : ARRAY OF CHAR),NEW;
 191   BEGIN                                         (* final method *)
 192     GPText.Assign(v.str^, str);
 193   END GetStr;
 194
 195 (* ============================================================ *)
 196
 197   PROCEDURE isShortStr*(in : Value) : BOOLEAN;
 198     VAR idx : INTEGER;
 199         chr : CHAR;
 200   BEGIN
 201     FOR idx := 0 TO LEN(in.str$) - 1 DO
 202       chr := in.str[idx];
 203       IF chr > 0FFX THEN RETURN FALSE END;
 204     END;
 205     RETURN TRUE;
 206   END isShortStr;
 207
 208 (* ============================================================ *)
 209 (*                   Various CharOpen Utilities                 *)
 210 (* ============================================================ *)
 211
 212   PROCEDURE InitCharOpenSeq*(VAR seq : CharOpenSeq; capacity : INTEGER);
 213   BEGIN
 214     NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
 215   END InitCharOpenSeq;
 216
 217 (* -------------------------------------------- *)
 218
 219   PROCEDURE ResetCharOpenSeq*(VAR seq : CharOpenSeq);
 220     VAR index : INTEGER;
 221   BEGIN
 222     FOR index := 0 TO seq.tide - 1 DO seq.a[index] := NIL END;
 223     seq.tide := 0;
 224   END ResetCharOpenSeq;
 225
 226 (* -------------------------------------------- *)
 227
 228   PROCEDURE AppendCharOpen*(VAR seq : CharOpenSeq; elem : CharOpen);
 229     VAR temp : POINTER TO ARRAY OF CharOpen;
 230         i    : INTEGER;
 231   BEGIN
 232     IF seq.a = NIL THEN
 233       InitCharOpenSeq(seq, 8);
 234     ELSIF seq.tide > seq.high THEN (* must expand *)
 235       temp := seq.a;
 236       seq.high := seq.high * 2 + 1;
 237       NEW(seq.a, seq.high+1);
 238       FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
 239     END;
 240     seq.a[seq.tide] := elem; INC(seq.tide);
 241   END AppendCharOpen;
 242
 243  (* -------------------------------------------- *
 244   * This function trims the string asciiz style.
 245   * -------------------------------------------- *)
 246   PROCEDURE strToCharOpen*(IN str : ARRAY OF CHAR) : CharOpen;
 247     VAR i : INTEGER;
 248         h : INTEGER;
 249         p : CharOpen;
 250   BEGIN
 251     h := LEN(str$); (* Length NOT including NUL *)
 252     NEW(p,h+1);     (* Including space for NUL *)
 253     FOR i := 0 TO h DO
 254       p[i] := str[i];
 255     END;
 256     RETURN p;
 257   END strToCharOpen;
 258
 259  (* -------------------------------------------- *
 260   * This function uses ALL of the characters
 261   * which may include embedded NUL characters.
 262   * -------------------------------------------- *)
 263   PROCEDURE arrToCharOpen*(str : CharOpen;
 264                            len : INTEGER) : CharOpen;
 265     VAR i : INTEGER;
 266         p : CharOpen;
 267   BEGIN
 268     NEW(p,len+1);
 269     FOR i := 0 TO len DO
 270       p[i] := str[i];
 271     END;
 272     RETURN p;
 273   END arrToCharOpen;
 274
 275 (* -------------------------------------------- *)
 276
 277   PROCEDURE subChOToChO*(str : CharOpen;
 278                          off : INTEGER;
 279                          len : INTEGER) : CharOpen;
 280     VAR i : INTEGER;
 281         h : INTEGER;
 282         p : CharOpen;
 283   BEGIN
 284     NEW(p, len+1);
 285     FOR i := 0 TO len-1 DO
 286       p[i] := str[i+off];
 287     END;
 288     RETURN p;
 289   END subChOToChO;
 290
 291 (* -------------------------------------------- *)
 292
 293   PROCEDURE posOf*(ch : CHAR; op : CharOpen) : INTEGER;
 294     VAR i : INTEGER;
 295   BEGIN
 296     FOR i := 0 TO LEN(op) - 1 DO
 297       IF op[i] = ch THEN RETURN i END;
 298     END;
 299     RETURN LEN(op);
 300   END posOf;
 301
 302 (* -------------------------------------------- *)
 303
 304   PROCEDURE chrVecToCharOpen(vec : CharVector) : CharOpen;
 305     VAR i, len : INTEGER;
 306             cOpen  : CharOpen;
 307   BEGIN
 308     len := LEN(vec);
 309     NEW(cOpen,len + 1);
 310         FOR i := 0 TO len -1 DO
 311           cOpen[i] := vec[i];
 312     END;
 313         cOpen[len] := 0X;
 314         RETURN cOpen;
 315   END chrVecToCharOpen;
 316
 317 (* -------------------------------------------- *)
 318
 319   PROCEDURE subStrToCharOpen*(pos,len : INTEGER) : CharOpen;
 320     VAR i : INTEGER;
 321         p : CharOpen;
 322   BEGIN
 323     NEW(p,len+1);
 324     FOR i := 0 TO len-1 DO
 325       p[i] := CPascalS.charAt(pos+i);
 326     END;
 327     p[len] := 0X;
 328     RETURN p;
 329   END subStrToCharOpen;
 330
 331 (* -------------------------------------------- *)
 332
 333   PROCEDURE intToCharOpen*(i : INTEGER) : CharOpen;
 334     VAR arr : ARRAY 16 OF CHAR;
 335   BEGIN
 336     GPText.IntToStr(i, arr);
 337     RETURN strToCharOpen(arr);
 338   END intToCharOpen;
 339
 340 (* -------------------------------------------- *)
 341
 342   PROCEDURE ToStr*(in : CharOpen; OUT out : ARRAY OF CHAR);
 343   BEGIN
 344     IF in = NIL THEN out := "<NIL>" ELSE GPText.Assign(in^, out) END;
 345   END ToStr;
 346
 347 (* -------------------------------------------- *)
 348
 349   PROCEDURE arrayCat*(IN in : CharOpenSeq) : CharOpen;
 350     VAR i,j,k : INTEGER;
 351         len : INTEGER;
 352         chO : CharOpen;
 353         ret : CharOpen;
 354         chr : CHAR;
 355   BEGIN
 356     len := 1;
 357     FOR i := 0 TO in.tide-1 DO INC(len, LEN(in.a[i]) - 1) END;
 358     NEW(ret, len);
 359     k := 0;
 360     FOR i := 0 TO in.tide-1 DO
 361       chO := in.a[i];
 362       j := 0;
 363       WHILE (j < LEN(chO)-1) & (chO[j] # 0X) DO
 364         ret[k] := chO[j]; INC(k); INC(j);
 365       END;
 366     END;
 367     ret[k] := 0X;
 368     RETURN ret;
 369   END arrayCat;
 370
 371 (* -------------------------------------------- *)
 372
 373   PROCEDURE vectorCat*(vec : VECTOR OF CharOpen) : CharOpen;
 374     VAR i,j,k : INTEGER;
 375         len : INTEGER;
 376         chO : CharOpen;
 377         ret : CharOpen;
 378         chr : CHAR;
 379   BEGIN
 380     len := 1;
 381     FOR i := 0 TO LEN(vec) - 1 DO INC(len, LEN(vec[i]) - 1) END;
 382     NEW(ret, len);
 383     k := 0;
 384     FOR i := 0 TO LEN(vec) - 1 DO
 385       chO := vec[i];
 386       j := 0;
 387       WHILE (j < LEN(chO)-1) & (chO[j] # 0X) DO
 388         ret[k] := chO[j]; INC(k); INC(j);
 389       END;
 390     END;
 391     ret[k] := 0X;
 392     RETURN ret;
 393   END vectorCat;
 394
 395
 396
 397 (* ============================================================ *)
 398 (*                   Safe Operations on Values                  *)
 399 (* ============================================================ *)
 400 (*                   Well, will be safe later!                  *)
 401 (* ============================================================ *)
 402
 403   PROCEDURE concat*(a,b : Value) : Value;
 404     VAR c : Value;
 405         i : INTEGER;
 406         j : INTEGER;
 407   BEGIN
 408     j := SHORT(a.ord);
 409     NEW(c);
 410     c.ord := a.ord + b.ord;
 411     NEW(c.str, SHORT(c.ord) + 1);
 412     FOR i := 0 TO j - 1 DO
 413       c.str[i] := a.str[i];
 414     END;
 415     FOR i := 0 TO SHORT(b.ord) DO
 416       c.str[i+j] := b.str[i];
 417     END;
 418     RETURN c;
 419   END concat;
 420
 421 (* -------------------------------------------- *)
 422
 423   PROCEDURE entV*(a : Value) : Value;
 424     VAR c : Value;
 425   BEGIN
 426     IF (a.flt >= MAX(LONGINT) + 1.0) OR
 427        (a.flt < MIN(LONGINT)) THEN RETURN NIL;
 428     ELSE NEW(c); c.ord := ENTIER(a.flt); RETURN c;
 429     END;
 430   END entV;
 431
 432 (* -------------------------------------------- *)
 433
 434   PROCEDURE absV*(a : Value) : Value;
 435     VAR c : Value;
 436   BEGIN
 437     IF a.ord = MIN(LONGINT) THEN RETURN NIL;
 438     ELSE NEW(c); c.ord := ABS(a.ord); RETURN c;
 439     END;
 440   END absV;
 441
 442 (* -------------------------------------------- *)
 443
 444   PROCEDURE negV*(a : Value) : Value;
 445     VAR c : Value;
 446   BEGIN
 447     IF a.ord = MIN(LONGINT) THEN RETURN NIL;
 448     ELSE NEW(c); c.ord := -a.ord; RETURN c;
 449     END;
 450   END negV;
 451
 452 (* -------------------------------------------- *)
 453
 454   PROCEDURE addV*(a,b : Value) : Value;
 455     VAR c : Value;
 456   BEGIN
 457     NEW(c); c.ord := a.ord + b.ord; RETURN c;
 458   END addV;
 459
 460 (* -------------------------------------------- *)
 461
 462   PROCEDURE subV*(a,b : Value) : Value;
 463     VAR c : Value;
 464   BEGIN
 465     NEW(c); c.ord := a.ord - b.ord; RETURN c;
 466   END subV;
 467
 468 (* -------------------------------------------- *)
 469
 470   PROCEDURE mulV*(a,b : Value) : Value;
 471     VAR c : Value;
 472   BEGIN
 473     NEW(c); c.ord := a.ord * b.ord; RETURN c;
 474   END mulV;
 475
 476 (* -------------------------------------------- *)
 477
 478   PROCEDURE slashV*(a,b : Value) : Value;
 479     VAR c : Value;
 480   BEGIN
 481     NEW(c); c.flt := a.ord / b.ord; RETURN c;
 482   END slashV;
 483
 484 (* -------------------------------------------- *)
 485
 486   PROCEDURE divV*(a,b : Value) : Value;
 487     VAR c : Value;
 488   BEGIN
 489     NEW(c); c.ord := a.ord DIV b.ord; RETURN c;
 490   END divV;
 491
 492 (* -------------------------------------------- *)
 493
 494   PROCEDURE modV*(a,b : Value) : Value;
 495     VAR c : Value;
 496   BEGIN
 497     NEW(c); c.ord := a.ord MOD b.ord; RETURN c;
 498   END modV;
 499
 500 (* -------------------------------------------- *)
 501
 502   PROCEDURE div0V*(a,b : Value) : Value;
 503     VAR c : Value;
 504   BEGIN
 505     NEW(c); c.ord := a.ord DIV0 b.ord; RETURN c;
 506   END div0V;
 507
 508 (* -------------------------------------------- *)
 509
 510   PROCEDURE rem0V*(a,b : Value) : Value;
 511     VAR c : Value;
 512   BEGIN
 513     NEW(c); c.ord := a.ord REM0 b.ord; RETURN c;
 514   END rem0V;
 515
 516 (* -------------------------------------------- *)
 517
 518   PROCEDURE strCmp*(l,r : Value) : INTEGER;
 519    (* warning: this routine is not unicode aware *)
 520     VAR index   : INTEGER;
 521         lch,rch : CHAR;
 522   BEGIN
 523     FOR index := 0 TO MIN(SHORT(l.ord), SHORT(r.ord)) + 1 DO
 524       lch := l.str[index];
 525       rch := r.str[index];
 526       IF lch < rch    THEN RETURN -1
 527       ELSIF lch > rch THEN RETURN 1
 528       ELSIF lch = 0X  THEN RETURN 0
 529       END;
 530     END;
 531     RETURN 0;
 532   END strCmp;
 533
 534 (* -------------------------------------------- *)
 535
 536   PROCEDURE DiagCharOpen*(ptr : CharOpen);
 537   BEGIN
 538     IF ptr = NIL THEN
 539       Console.WriteString("<nil>");
 540     ELSE
 541       Console.WriteString(ptr);
 542     END;
 543   END DiagCharOpen;
 544
 545 (* ============================================================ *)
 546 BEGIN (* ====================================================== *)
 547 END LitValue. (* ============================================== *)
 548 (* ============================================================ *)
 549