genie-denotation.c
1 //! @file genie-denotation.c
2 //! @author J. Marcel van der Veer
3
4 //! @section Copyright
5 //!
6 //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
7 //! Copyright 2001-2024 J. Marcel van der Veer [algol68g@xs4all.nl].
8
9 //! @section License
10 //!
11 //! This program is free software; you can redistribute it and/or modify it
12 //! under the terms of the GNU General Public License as published by the
13 //! Free Software Foundation; either version 3 of the License, or
14 //! (at your option) any later version.
15 //!
16 //! This program is distributed in the hope that it will be useful, but
17 //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 //! more details. You should have received a copy of the GNU General Public
20 //! License along with this program. If not, see [http://www.gnu.org/licenses/].
21
22 //! @section Synopsis
23 //!
24 //! Interpreter routines for denotations.
25
26 #include "a68g.h"
27 #include "a68g-genie.h"
28 #include "a68g-frames.h"
29 #include "a68g-prelude.h"
30 #include "a68g-mp.h"
31 #include "a68g-transput.h"
32
33 //! @brief Push routine text.
34
35 PROP_T genie_routine_text (NODE_T * p)
36 {
37 static PROP_T self;
38 A68_PROCEDURE z = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (p))));
39 PUSH_PROCEDURE (p, z);
40 UNIT (&self) = genie_routine_text;
41 SOURCE (&self) = p;
42 return self;
43 }
44
45 //! @brief Push format text.
46
47 PROP_T genie_format_text (NODE_T * p)
48 {
49 static PROP_T self;
50 A68_FORMAT z = *(A68_FORMAT *) (FRAME_OBJECT (OFFSET (TAX (p))));
51 PUSH_FORMAT (p, z);
52 UNIT (&self) = genie_format_text;
53 SOURCE (&self) = p;
54 return self;
55 }
56
57 //! @brief Push NIL.
58
59 PROP_T genie_nihil (NODE_T * p)
60 {
61 PROP_T self;
62 PUSH_REF (p, nil_ref);
63 UNIT (&self) = genie_nihil;
64 SOURCE (&self) = p;
65 return self;
66 }
67
68 //! @brief Push constant stored in the tree.
69
70 PROP_T genie_constant (NODE_T * p)
71 {
72 PUSH (p, CONSTANT (GINFO (p)), SIZE (GINFO (p)));
73 return GPROP (p);
74 }
75
76 //! @brief Push value of denotation.
77
78 PROP_T genie_denotation (NODE_T * p)
79 {
80 MOID_T *moid = MOID (p);
81 PROP_T self;
82 UNIT (&self) = genie_denotation;
83 SOURCE (&self) = p;
84 if (moid == M_INT) {
85 // INT denotation.
86 A68_INT z;
87 NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
88 if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
89 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
90 exit_genie (p, A68_RUNTIME_ERROR);
91 }
92 UNIT (&self) = genie_constant;
93 STATUS (&z) = INIT_MASK;
94 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE (M_INT));
95 SIZE (GINFO (p)) = SIZE (M_INT);
96 COPY (CONSTANT (GINFO (p)), &z, SIZE (M_INT));
97 PUSH_VALUE (p, VALUE ((A68_INT *) (CONSTANT (GINFO (p)))), A68_INT);
98 return self;
99 }
100 if (moid == M_REAL) {
101 // REAL denotation.
102 A68_REAL z;
103 NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
104 if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
105 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
106 exit_genie (p, A68_RUNTIME_ERROR);
107 }
108 STATUS (&z) = INIT_MASK;
109 UNIT (&self) = genie_constant;
110 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE_ALIGNED (A68_REAL));
111 SIZE (GINFO (p)) = SIZE_ALIGNED (A68_REAL);
112 COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_REAL));
113 PUSH_VALUE (p, VALUE ((A68_REAL *) (CONSTANT (GINFO (p)))), A68_REAL);
114 return self;
115 }
116 #if (A68_LEVEL >= 3)
117 if (moid == M_LONG_INT) {
118 // LONG INT denotation.
119 A68_LONG_INT z;
120 size_t len = (size_t) SIZE_ALIGNED (A68_LONG_INT);
121 NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p);
122 if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
123 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
124 exit_genie (p, A68_RUNTIME_ERROR);
125 }
126 UNIT (&self) = genie_constant;
127 STATUS (&z) = INIT_MASK;
128 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) len);
129 SIZE (GINFO (p)) = len;
130 COPY (CONSTANT (GINFO (p)), &z, len);
131 PUSH_VALUE (p, VALUE ((A68_LONG_INT *) (CONSTANT (GINFO (p)))), A68_LONG_INT);
132 return self;
133 }
134 if (moid == M_LONG_REAL) {
135 // LONG REAL denotation.
136 A68_LONG_REAL z;
137 NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p);
138 if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
139 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
140 exit_genie (p, A68_RUNTIME_ERROR);
141 }
142 STATUS (&z) = INIT_MASK;
143 UNIT (&self) = genie_constant;
144 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE_ALIGNED (A68_LONG_REAL));
145 SIZE (GINFO (p)) = SIZE_ALIGNED (A68_LONG_REAL);
146 COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_LONG_REAL));
147 PUSH_VALUE (p, VALUE ((A68_LONG_REAL *) (CONSTANT (GINFO (p)))), A68_LONG_REAL);
148 return self;
149 }
150 // LONG BITS denotation.
151 if (moid == M_LONG_BITS) {
152 A68_LONG_BITS z;
153 NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p);
154 if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
155 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
156 exit_genie (p, A68_RUNTIME_ERROR);
157 }
158 UNIT (&self) = genie_constant;
159 STATUS (&z) = INIT_MASK;
160 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE_ALIGNED (A68_LONG_BITS));
161 SIZE (GINFO (p)) = SIZE_ALIGNED (A68_LONG_BITS);
162 COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_LONG_BITS));
163 PUSH_VALUE (p, VALUE ((A68_LONG_BITS *) (CONSTANT (GINFO (p)))), A68_LONG_BITS);
164 return self;
165 }
166 #endif
167 if (moid == M_LONG_INT || moid == M_LONG_LONG_INT) {
168 // [LONG] LONG INT denotation.
169 int digits = DIGITS (moid);
170 int size = SIZE (moid);
171 NODE_T *number;
172 if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) {
173 number = NEXT_SUB (p);
174 } else {
175 number = SUB (p);
176 }
177 MP_T *z = nil_mp (p, digits);
178 if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) {
179 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
180 exit_genie (p, A68_RUNTIME_ERROR);
181 }
182 MP_STATUS (z) = (MP_T) INIT_MASK;
183 UNIT (&self) = genie_constant;
184 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size);
185 SIZE (GINFO (p)) = size;
186 COPY (CONSTANT (GINFO (p)), z, size);
187 return self;
188 }
189 if (moid == M_LONG_REAL || moid == M_LONG_LONG_REAL) {
190 // [LONG] LONG REAL denotation.
191 int digits = DIGITS (moid);
192 int size = SIZE (moid);
193 NODE_T *number;
194 if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) {
195 number = NEXT_SUB (p);
196 } else {
197 number = SUB (p);
198 }
199 MP_T *z = nil_mp (p, digits);
200 if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) {
201 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
202 exit_genie (p, A68_RUNTIME_ERROR);
203 }
204 MP_STATUS (z) = (MP_T) INIT_MASK;
205 UNIT (&self) = genie_constant;
206 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size);
207 SIZE (GINFO (p)) = size;
208 COPY (CONSTANT (GINFO (p)), z, size);
209 return self;
210 }
211 if (moid == M_BITS) {
212 // BITS denotation.
213 A68_BITS z;
214 NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
215 if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
216 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
217 exit_genie (p, A68_RUNTIME_ERROR);
218 }
219 UNIT (&self) = genie_constant;
220 STATUS (&z) = INIT_MASK;
221 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE_ALIGNED (A68_BITS));
222 SIZE (GINFO (p)) = SIZE_ALIGNED (A68_BITS);
223 COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_BITS));
224 PUSH_VALUE (p, VALUE ((A68_BITS *) (CONSTANT (GINFO (p)))), A68_BITS);
225 }
226 if (moid == M_LONG_BITS || moid == M_LONG_LONG_BITS) {
227 // [LONG] LONG BITS denotation.
228 int digits = DIGITS (moid);
229 int size = SIZE (moid);
230 NODE_T *number;
231 if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) {
232 number = NEXT_SUB (p);
233 } else {
234 number = SUB (p);
235 }
236 MP_T *z = nil_mp (p, digits);
237 if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) {
238 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
239 exit_genie (p, A68_RUNTIME_ERROR);
240 }
241 MP_STATUS (z) = (MP_T) INIT_MASK;
242 UNIT (&self) = genie_constant;
243 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size);
244 SIZE (GINFO (p)) = size;
245 COPY (CONSTANT (GINFO (p)), z, size);
246 return self;
247 }
248 if (moid == M_BOOL) {
249 // BOOL denotation.
250 A68_BOOL z;
251 ASSERT (genie_string_to_value_internal (p, M_BOOL, NSYMBOL (p), (BYTE_T *) & z) == A68_TRUE);
252 PUSH_VALUE (p, VALUE (&z), A68_BOOL);
253 return self;
254 } else if (moid == M_CHAR) {
255 // CHAR denotation.
256 PUSH_VALUE (p, TO_UCHAR (NSYMBOL (p)[0]), A68_CHAR);
257 return self;
258 } else if (moid == M_ROW_CHAR) {
259 // [] CHAR denotation - permanent string in the heap.
260 A68_REF z;
261 A68_ARRAY *arr;
262 A68_TUPLE *tup;
263 z = c_to_a_string (p, NSYMBOL (p), DEFAULT_WIDTH);
264 GET_DESCRIPTOR (arr, tup, &z);
265 BLOCK_GC_HANDLE (&z);
266 BLOCK_GC_HANDLE (&(ARRAY (arr)));
267 UNIT (&self) = genie_constant;
268 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) A68_REF_SIZE);
269 SIZE (GINFO (p)) = A68_REF_SIZE;
270 COPY (CONSTANT (GINFO (p)), &z, A68_REF_SIZE);
271 PUSH_REF (p, *(A68_REF *) (CONSTANT (GINFO (p))));
272 (void) tup;
273 return self;
274 }
275 if (moid == M_VOID) {
276 // VOID denotation: EMPTY.
277 return self;
278 }
279 return self;
280 }
