rts-internal.c
1 //! @file rts-internal.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 //! Transput routines.
25
26 #include "a68g.h"
27 #include "a68g-genie.h"
28 #include "a68g-prelude.h"
29 #include "a68g-transput.h"
30
31 // These routines use A68G's RR transput routines,
32 // essentially mimicking code of the form
33 // PROC puts = (REF STRING s, [] SIMPLOUT items) VOID:
34 // BEGIN FILE f;
35 // associate (f, s);
36 // put (f, items);
37 // close (f)
38 // END
39 // which is not the most efficient, though practical.
40
41 static void associate (A68_FILE *f, A68_REF s)
42 {
43 STATUS (f) = INIT_MASK;
44 FILE_ENTRY (f) = -1;
45 CHANNEL (f) = A68 (associate_channel);
46 OPENED (f) = A68_TRUE;
47 OPEN_EXCLUSIVE (f) = A68_FALSE;
48 READ_MOOD (f) = A68_FALSE;
49 WRITE_MOOD (f) = A68_FALSE;
50 CHAR_MOOD (f) = A68_FALSE;
51 DRAW_MOOD (f) = A68_FALSE;
52 TMP_FILE (f) = A68_FALSE;
53 IDENTIFICATION (f) = nil_ref;
54 TERMINATOR (f) = nil_ref;
55 FORMAT (f) = nil_format;
56 FD (f) = A68_NO_FILE;
57 STRING (f) = s;
58 STRPOS (f) = 0;
59 DEVICE_MADE (&DEVICE (f)) = A68_FALSE;
60 STREAM (&DEVICE (f)) = NO_STREAM;
61 set_default_event_procedures (f);
62 }
63
64 //! @brief PROC (REF STRING, [] SIMPLIN) VOID gets
65
66 void genie_get_text (NODE_T * p)
67 {
68 // Block GC momentarily.
69 A68_GC (sema)++;
70 // Pop [] SIMPLIN.
71 A68_REF row;
72 POP_REF (p, &row);
73 CHECK_REF (p, row, M_ROW_SIMPLIN);
74 // Pop REF STRING.
75 A68_REF ref_string;
76 POP_REF (p, &ref_string);
77 CHECK_REF (p, ref_string, M_REF_STRING);
78 // Associate a temp file with argument string.
79 A68_REF ref_file = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
80 A68_FILE *file = FILE_DEREF (&ref_file);
81 associate (file, ref_string);
82 open_for_reading (p, ref_file);
83 // Read.
84 A68_ARRAY *arr; A68_TUPLE *tup;
85 GET_DESCRIPTOR (arr, tup, &row);
86 int elems = ROW_SIZE (tup);
87 if (elems > 0) {
88 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
89 int elem_index = 0;
90 for (int k = 0; k < elems; k++) {
91 A68_UNION *z = (A68_UNION *) & base_address[elem_index];
92 MOID_T *mode = (MOID_T *) (VALUE (z));
93 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
94 genie_read_standard (p, mode, item, ref_file);
95 elem_index += SIZE (M_SIMPLIN);
96 }
97 }
98 // Discard temp file.
99 unblock_transput_buffer (TRANSPUT_BUFFER (file));
100 A68_GC (sema)--;
101 }
102
103 //! @brief PROC (REF STRING, [] SIMPLOUT) VOID puts
104
105 void genie_put_text (NODE_T * p)
106 {
107 // Block GC momentarily.
108 A68_GC (sema)++;
109 // Pop [] SIMPLOUT.
110 A68_REF row;
111 POP_REF (p, &row);
112 CHECK_REF (p, row, M_ROW_SIMPLOUT);
113 // Pop REF STRING.
114 A68_REF ref_string;
115 POP_REF (p, &ref_string);
116 CHECK_REF (p, ref_string, M_REF_STRING);
117 // Associate a temp file with argument string.
118 A68_REF ref_file = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
119 A68_FILE *file = FILE_DEREF (&ref_file);
120 associate (file, ref_string);
121 open_for_writing (p, ref_file);
122 // Write.
123 A68_ARRAY *arr; A68_TUPLE *tup;
124 GET_DESCRIPTOR (arr, tup, &row);
125 int elems = ROW_SIZE (tup);
126 if (elems > 0) {
127 reset_transput_buffer (UNFORMATTED_BUFFER);
128 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
129 int elem_index = 0;
130 for (int k = 0; k < elems; k++) {
131 A68_UNION *z = (A68_UNION *) & base_address[elem_index];
132 MOID_T *mode = (MOID_T *) (VALUE (z));
133 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
134 genie_write_standard (p, mode, item, ref_file);
135 elem_index += SIZE (M_SIMPLOUT);
136 }
137 * DEREF (A68_REF, &ref_string) = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
138 }
139 // Discard temp file.
140 unblock_transput_buffer (TRANSPUT_BUFFER (file));
141 A68_GC (sema)--;
142 }
143
144 //! @brief PROC (REF STRING, [] SIMPLIN) VOID getsf
145
146 void genie_getf_text (NODE_T * p)
147 {
148 // Block GC momentarily.
149 A68_GC (sema)++;
150 // Pop [] SIMPLIN.
151 A68_REF row;
152 POP_REF (p, &row);
153 CHECK_REF (p, row, M_ROW_SIMPLIN);
154 // Pop REF STRING.
155 A68_REF ref_string;
156 POP_REF (p, &ref_string);
157 CHECK_REF (p, ref_string, M_REF_STRING);
158 // Associate a temp file with argument string.
159 A68_REF ref_file = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
160 A68_FILE *file = FILE_DEREF (&ref_file);
161 associate (file, ref_string);
162 open_for_reading (p, ref_file);
163 // Save stack state since formats have frames.
164 ADDR_T pop_fp = FRAME_POINTER (file);
165 ADDR_T pop_sp = STACK_POINTER (file);
166 FRAME_POINTER (file) = A68_FP;
167 STACK_POINTER (file) = A68_SP;
168 // Process [] SIMPLIN.
169 if (BODY (&FORMAT (file)) != NO_NODE) {
170 open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE);
171 }
172 int formats = 0;
173 // Read.
174 A68_ARRAY *arr; A68_TUPLE *tup;
175 GET_DESCRIPTOR (arr, tup, &row);
176 int elems = ROW_SIZE (tup);
177 if (elems > 0) {
178 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
179 int elem_index = 0;
180 for (int k = 0; k < elems; k++) {
181 A68_UNION *z = (A68_UNION *) & base_address[elem_index];
182 MOID_T *mode = (MOID_T *) (VALUE (z));
183 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
184 genie_read_standard_format (p, mode, item, ref_file, &formats);
185 elem_index += SIZE (M_SIMPLIN);
186 }
187 }
188 // Empty the format to purge insertions.
189 purge_format_read (p, ref_file);
190 BODY (&FORMAT (file)) = NO_NODE;
191 // Forget about active formats.
192 A68_FP = FRAME_POINTER (file);
193 A68_SP = STACK_POINTER (file);
194 FRAME_POINTER (file) = pop_fp;
195 STACK_POINTER (file) = pop_sp;
196 // Discard temp file.
197 unblock_transput_buffer (TRANSPUT_BUFFER (file));
198 A68_GC (sema)--;
199 }
200
201 //! @brief PROC (REF STRING, [] SIMPLOUT) VOID putsf
202
203 void genie_putf_text (NODE_T * p)
204 {
205 // Block GC momentarily.
206 A68_GC (sema)++;
207 // Pop [] SIMPLOUT.
208 A68_REF row;
209 POP_REF (p, &row);
210 CHECK_REF (p, row, M_ROW_SIMPLOUT);
211 // Pop REF STRING.
212 A68_REF ref_string;
213 POP_REF (p, &ref_string);
214 CHECK_REF (p, ref_string, M_REF_STRING);
215 // Associate a temp file with argument string.
216 A68_REF ref_file = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
217 A68_FILE *file = FILE_DEREF (&ref_file);
218 associate (file, ref_string);
219 open_for_writing (p, ref_file);
220 // Save stack state since formats have frames.
221 ADDR_T pop_fp = FRAME_POINTER (file);
222 ADDR_T pop_sp = STACK_POINTER (file);
223 FRAME_POINTER (file) = A68_FP;
224 STACK_POINTER (file) = A68_SP;
225 // Process [] SIMPLIN.
226 if (BODY (&FORMAT (file)) != NO_NODE) {
227 open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE);
228 }
229 int formats = 0;
230 // Write.
231 A68_ARRAY *arr; A68_TUPLE *tup;
232 GET_DESCRIPTOR (arr, tup, &row);
233 int elems = ROW_SIZE (tup);
234 if (elems > 0) {
235 reset_transput_buffer (FORMATTED_BUFFER);
236 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
237 int elem_index = 0;
238 for (int k = 0; k < elems; k++) {
239 A68_UNION *z = (A68_UNION *) & base_address[elem_index];
240 MOID_T *mode = (MOID_T *) (VALUE (z));
241 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
242 genie_write_standard_format (p, mode, item, ref_file, &formats);
243 elem_index += SIZE (M_SIMPLOUT);
244 }
245 }
246 // Empty the format to purge insertions.
247 purge_format_write (p, ref_file);
248 write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
249 BODY (&FORMAT (file)) = NO_NODE;
250 // Forget about active formats.
251 A68_FP = FRAME_POINTER (file);
252 A68_SP = STACK_POINTER (file);
253 FRAME_POINTER (file) = pop_fp;
254 STACK_POINTER (file) = pop_sp;
255 // Discard temp file.
256 unblock_transput_buffer (TRANSPUT_BUFFER (file));
257 A68_GC (sema)--;
258 }
259
260 //! @brief PROC (REF STRING, [] SIMPLOUT) REF STRING string
261
262 void genie_string (NODE_T * p)
263 {
264 // Block GC momentarily.
265 A68_GC (sema)++;
266 // Pop [] SIMPLOUT.
267 A68_REF row;
268 POP_REF (p, &row);
269 CHECK_REF (p, row, M_ROW_SIMPLOUT);
270 // Pop REF STRING.
271 A68_REF ref_string;
272 POP_REF (p, &ref_string);
273 CHECK_REF (p, ref_string, M_REF_STRING);
274 // Associate a temp file with argument string.
275 A68_REF ref_file = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
276 A68_FILE *file = FILE_DEREF (&ref_file);
277 associate (file, ref_string);
278 open_for_writing (p, ref_file);
279 // Write.
280 A68_ARRAY *arr; A68_TUPLE *tup;
281 GET_DESCRIPTOR (arr, tup, &row);
282 int elems = ROW_SIZE (tup);
283 if (elems > 0) {
284 reset_transput_buffer (UNFORMATTED_BUFFER);
285 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
286 int elem_index = 0;
287 for (int k = 0; k < elems; k++) {
288 A68_UNION *z = (A68_UNION *) & base_address[elem_index];
289 MOID_T *mode = (MOID_T *) (VALUE (z));
290 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
291 genie_write_standard (p, mode, item, ref_file);
292 elem_index += SIZE (M_SIMPLOUT);
293 }
294 * DEREF (A68_REF, &ref_string) = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
295 }
296 PUSH_REF (p, ref_string);
297 // Discard temp file.
298 unblock_transput_buffer (TRANSPUT_BUFFER (file));
299 A68_GC (sema)--;
300 }
301
302 //! @brief PROC (REF STRING, [] SIMPLOUT) REF STRING stringf
303
304 void genie_stringf (NODE_T * p)
305 {
306 // Block GC momentarily.
307 A68_GC (sema)++;
308 // Pop [] SIMPLOUT.
309 A68_REF row;
310 POP_REF (p, &row);
311 CHECK_REF (p, row, M_ROW_SIMPLOUT);
312 // Pop REF STRING.
313 A68_REF ref_string;
314 POP_REF (p, &ref_string);
315 CHECK_REF (p, ref_string, M_REF_STRING);
316 // Associate a temp file with argument string.
317 A68_REF ref_file = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
318 A68_FILE *file = FILE_DEREF (&ref_file);
319 associate (file, ref_string);
320 open_for_writing (p, ref_file);
321 // Save stack state since formats have frames.
322 ADDR_T pop_fp = FRAME_POINTER (file);
323 ADDR_T pop_sp = STACK_POINTER (file);
324 FRAME_POINTER (file) = A68_FP;
325 STACK_POINTER (file) = A68_SP;
326 // Process [] SIMPLIN.
327 if (BODY (&FORMAT (file)) != NO_NODE) {
328 open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE);
329 }
330 int formats = 0;
331 // Write.
332 A68_ARRAY *arr; A68_TUPLE *tup;
333 GET_DESCRIPTOR (arr, tup, &row);
334 int elems = ROW_SIZE (tup);
335 if (elems > 0) {
336 reset_transput_buffer (FORMATTED_BUFFER);
337 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
338 int elem_index = 0;
339 for (int k = 0; k < elems; k++) {
340 A68_UNION *z = (A68_UNION *) & base_address[elem_index];
341 MOID_T *mode = (MOID_T *) (VALUE (z));
342 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
343 genie_write_standard_format (p, mode, item, ref_file, &formats);
344 elem_index += SIZE (M_SIMPLOUT);
345 }
346 }
347 // Empty the format to purge insertions.
348 purge_format_write (p, ref_file);
349 write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
350 BODY (&FORMAT (file)) = NO_NODE;
351 // Forget about active formats.
352 A68_FP = FRAME_POINTER (file);
353 A68_SP = STACK_POINTER (file);
354 FRAME_POINTER (file) = pop_fp;
355 STACK_POINTER (file) = pop_sp;
356 PUSH_REF (p, ref_string);
357 // Discard temp file.
358 unblock_transput_buffer (TRANSPUT_BUFFER (file));
359 A68_GC (sema)--;
360 }
