1 (* ==================================================================== *)
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. *)
7 (* ==================================================================== *)
18 (* ============================================================ *)
21 CharOpen
* = POINTER TO ARRAY OF CHAR;
25 a
- : POINTER TO ARRAY OF CharOpen
;
28 CharVector
* = VECTOR
OF CHAR;
30 (* ============================================================ *)
33 Value
* = POINTER TO RECORD (* All opaque. *)
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 (* ================================================================= *)
48 PROCEDURE newChrVal
*(ch
: CHAR) : Value
;
51 NEW(val
); val
.ord
:= ORD(ch
); RETURN val
;
54 PROCEDURE newIntVal
*(nm
: LONGINT) : Value
;
57 NEW(val
); val
.ord
:= nm
; RETURN val
;
60 PROCEDURE newFltVal
*(rv
: REAL) : Value
;
63 NEW(val
); val
.flt
:= rv
; RETURN val
;
66 PROCEDURE newSetVal
*(st
: SET) : Value
;
69 NEW(val
); val
.ord
:= ORD(st
); RETURN val
;
72 PROCEDURE newStrVal
*(IN sv
: ARRAY OF CHAR) : Value
;
77 val
.str
:= strToCharOpen(sv
);
81 PROCEDURE newStrLenVal
*(str
: CharOpen
; len
: INTEGER) : Value
;
86 val
.str
:= arrToCharOpen(str
, len
);
90 PROCEDURE newBufVal
*(p
,l
: INTEGER) : Value
;
95 val
.str
:= subStrToCharOpen(p
,l
);
99 PROCEDURE escapedString
*(pos
,len
: INTEGER) : Value
;
105 (* ----------------------- *)
106 PROCEDURE ReportBadHex(code
, offset
: INTEGER);
107 VAR tok
: CPascalS
.Token
;
109 tok
:= CPascalS
.prevTok
;
110 CPascalS
.SemError
.Report(code
, tok
.lin
, tok
.col
+ offset
);
112 (* ----------------------- *)
116 NEW(vector
, len
* 2);
118 theCh
:= CPascalS
.charAt(pos
+count
); INC(count
);
120 theCh
:= CPascalS
.charAt(pos
+count
); INC(count
);
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
);
140 APPEND(vector
, theCh
);
143 value
.ord
:= LEN(vector
);
144 value
.str
:= chrVecToCharOpen(vector
);
148 (* ============================================================ *)
150 PROCEDURE (v
: Value
)char
*() : CHAR,NEW; (* final method *)
155 PROCEDURE (v
: Value
)int
*() : INTEGER,NEW; (* final method *)
160 PROCEDURE (v
: Value
)set
*() : SET,NEW; (* final method *)
162 RETURN BITS(SHORT(v
.ord
));
165 PROCEDURE (v
: Value
)long
*() : LONGINT,NEW; (* final method *)
170 PROCEDURE (v
: Value
)real
*() : REAL,NEW; (* final method *)
175 PROCEDURE (v
: Value
)chOpen
*() : CharOpen
,NEW; (*final *)
180 PROCEDURE (v
: Value
)len
*() : INTEGER,NEW; (* final method *)
185 PROCEDURE (v
: Value
)chr0
*() : CHAR,NEW; (* final method *)
190 PROCEDURE (v
: Value
)GetStr
*(OUT str
: ARRAY OF CHAR),NEW;
191 BEGIN (* final method *)
192 GPText
.Assign(v
.str^
, str
);
195 (* ============================================================ *)
197 PROCEDURE isShortStr
*(in
: Value
) : BOOLEAN;
201 FOR idx
:= 0 TO LEN(in
.str$
) - 1 DO
203 IF chr
> 0FFX
THEN RETURN FALSE
END;
208 (* ============================================================ *)
209 (* Various CharOpen Utilities *)
210 (* ============================================================ *)
212 PROCEDURE InitCharOpenSeq
*(VAR seq
: CharOpenSeq
; capacity
: INTEGER);
214 NEW(seq
.a
, capacity
); seq
.tide
:= 0; seq
.high
:= capacity
-1;
217 (* -------------------------------------------- *)
219 PROCEDURE ResetCharOpenSeq
*(VAR seq
: CharOpenSeq
);
222 FOR index
:= 0 TO seq
.tide
- 1 DO seq
.a
[index
] := NIL END;
224 END ResetCharOpenSeq
;
226 (* -------------------------------------------- *)
228 PROCEDURE AppendCharOpen
*(VAR seq
: CharOpenSeq
; elem
: CharOpen
);
229 VAR temp
: POINTER TO ARRAY OF CharOpen
;
233 InitCharOpenSeq(seq
, 8);
234 ELSIF seq
.tide
> seq
.high
THEN (* must expand *)
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;
240 seq
.a
[seq
.tide
] := elem
; INC(seq
.tide
);
243 (* -------------------------------------------- *
244 * This function trims the string asciiz style.
245 * -------------------------------------------- *)
246 PROCEDURE strToCharOpen
*(IN str
: ARRAY OF CHAR) : CharOpen
;
251 h
:= LEN(str$
); (* Length NOT including NUL *)
252 NEW(p
,h
+1); (* Including space for NUL *)
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
;
275 (* -------------------------------------------- *)
277 PROCEDURE subChOToChO
*(str
: CharOpen
;
279 len
: INTEGER) : CharOpen
;
285 FOR i
:= 0 TO len
-1 DO
291 (* -------------------------------------------- *)
293 PROCEDURE posOf
*(ch
: CHAR; op
: CharOpen
) : INTEGER;
296 FOR i
:= 0 TO LEN(op
) - 1 DO
297 IF op
[i
] = ch
THEN RETURN i
END;
302 (* -------------------------------------------- *)
304 PROCEDURE chrVecToCharOpen(vec
: CharVector
) : CharOpen
;
305 VAR i
, len
: INTEGER;
310 FOR i
:= 0 TO len
-1 DO
315 END chrVecToCharOpen
;
317 (* -------------------------------------------- *)
319 PROCEDURE subStrToCharOpen
*(pos
,len
: INTEGER) : CharOpen
;
324 FOR i
:= 0 TO len
-1 DO
325 p
[i
] := CPascalS
.charAt(pos
+i
);
329 END subStrToCharOpen
;
331 (* -------------------------------------------- *)
333 PROCEDURE intToCharOpen
*(i
: INTEGER) : CharOpen
;
334 VAR arr
: ARRAY 16 OF CHAR;
336 GPText
.IntToStr(i
, arr
);
337 RETURN strToCharOpen(arr
);
340 (* -------------------------------------------- *)
342 PROCEDURE ToStr
*(in
: CharOpen
; OUT out
: ARRAY OF CHAR);
344 IF in
= NIL THEN out
:= "<NIL>" ELSE GPText
.Assign(in^
, out
) END;
347 (* -------------------------------------------- *)
349 PROCEDURE arrayCat
*(IN in
: CharOpenSeq
) : CharOpen
;
357 FOR i
:= 0 TO in
.tide
-1 DO INC(len
, LEN(in
.a
[i
]) - 1) END;
360 FOR i
:= 0 TO in
.tide
-1 DO
363 WHILE (j
< LEN(chO
)-1) & (chO
[j
] # 0X
) DO
364 ret
[k
] := chO
[j
]; INC(k
); INC(j
);
371 (* -------------------------------------------- *)
373 PROCEDURE vectorCat
*(vec
: VECTOR
OF CharOpen
) : CharOpen
;
381 FOR i
:= 0 TO LEN(vec
) - 1 DO INC(len
, LEN(vec
[i
]) - 1) END;
384 FOR i
:= 0 TO LEN(vec
) - 1 DO
387 WHILE (j
< LEN(chO
)-1) & (chO
[j
] # 0X
) DO
388 ret
[k
] := chO
[j
]; INC(k
); INC(j
);
397 (* ============================================================ *)
398 (* Safe Operations on Values *)
399 (* ============================================================ *)
400 (* Well, will be safe later! *)
401 (* ============================================================ *)
403 PROCEDURE concat
*(a
,b
: Value
) : Value
;
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
];
415 FOR i
:= 0 TO SHORT(b
.ord
) DO
416 c
.str
[i
+j
] := b
.str
[i
];
421 (* -------------------------------------------- *)
423 PROCEDURE entV
*(a
: Value
) : Value
;
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
;
432 (* -------------------------------------------- *)
434 PROCEDURE absV
*(a
: Value
) : Value
;
437 IF a
.ord
= MIN(LONGINT) THEN RETURN NIL;
438 ELSE NEW(c
); c
.ord
:= ABS(a
.ord
); RETURN c
;
442 (* -------------------------------------------- *)
444 PROCEDURE negV
*(a
: Value
) : Value
;
447 IF a
.ord
= MIN(LONGINT) THEN RETURN NIL;
448 ELSE NEW(c
); c
.ord
:= -a
.ord
; RETURN c
;
452 (* -------------------------------------------- *)
454 PROCEDURE addV
*(a
,b
: Value
) : Value
;
457 NEW(c
); c
.ord
:= a
.ord
+ b
.ord
; RETURN c
;
460 (* -------------------------------------------- *)
462 PROCEDURE subV
*(a
,b
: Value
) : Value
;
465 NEW(c
); c
.ord
:= a
.ord
- b
.ord
; RETURN c
;
468 (* -------------------------------------------- *)
470 PROCEDURE mulV
*(a
,b
: Value
) : Value
;
473 NEW(c
); c
.ord
:= a
.ord
* b
.ord
; RETURN c
;
476 (* -------------------------------------------- *)
478 PROCEDURE slashV
*(a
,b
: Value
) : Value
;
481 NEW(c
); c
.flt
:= a
.ord
/ b
.ord
; RETURN c
;
484 (* -------------------------------------------- *)
486 PROCEDURE divV
*(a
,b
: Value
) : Value
;
489 NEW(c
); c
.ord
:= a
.ord
DIV b
.ord
; RETURN c
;
492 (* -------------------------------------------- *)
494 PROCEDURE modV
*(a
,b
: Value
) : Value
;
497 NEW(c
); c
.ord
:= a
.ord
MOD b
.ord
; RETURN c
;
500 (* -------------------------------------------- *)
502 PROCEDURE div0V
*(a
,b
: Value
) : Value
;
505 NEW(c
); c
.ord
:= a
.ord DIV0 b
.ord
; RETURN c
;
508 (* -------------------------------------------- *)
510 PROCEDURE rem0V
*(a
,b
: Value
) : Value
;
513 NEW(c
); c
.ord
:= a
.ord REM0 b
.ord
; RETURN c
;
516 (* -------------------------------------------- *)
518 PROCEDURE strCmp
*(l
,r
: Value
) : INTEGER;
519 (* warning: this routine is not unicode aware *)
523 FOR index
:= 0 TO MIN(SHORT(l
.ord
), SHORT(r
.ord
)) + 1 DO
526 IF lch
< rch
THEN RETURN -1
527 ELSIF lch
> rch
THEN RETURN 1
528 ELSIF lch
= 0X
THEN RETURN 0
534 (* -------------------------------------------- *)
536 PROCEDURE DiagCharOpen
*(ptr
: CharOpen
);
539 Console
.WriteString("<nil>");
541 Console
.WriteString(ptr
);
545 (* ============================================================ *)
546 BEGIN (* ====================================================== *)
547 END LitValue
. (* ============================================== *)
548 (* ============================================================ *)