1 /**
2 @file environ.c
3 @author J. Marcel van der Veer.
4 @brief Standard prelude implementation.
5 @section Copyright
6 
7 This file is part of Algol68G - an Algol 68 compiler-interpreter.
8 Copyright 2001-2016 J. Marcel van der Veer <algol68g@xs4all.nl>.
9 
10 @section License
11 
12 This program is free software; you can redistribute it and/or modify it under
13 the terms of the GNU General Public License as published by the Free Software
14 Foundation; either version 3 of the License, or (at your option) any later
15 version.
16 
17 This program is distributed in the hope that it will be useful, but WITHOUT ANY
18 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
19 PARTICULAR PURPOSE. See the GNU General Public License for more details.
20 
21 You should have received a copy of the GNU General Public License along with
22 this program. If not, see <http://www.gnu.org/licenses/>.
23 
24 @section Description
25 
26 This file implements the standard environ, both as required by the Revised Report as well as the Algol 68 Genie extensions.
27 
28 **/
29 
30 #if defined HAVE_CONFIG_H
31 #include "a68g-config.h"
32 #endif
33 
34 #include "a68g.h"
35 
36 #define A68_STD A68_TRUE
37 #define A68_EXT A68_FALSE
38 
39 TABLE_T *a68g_standenv;
40 
41 static MOID_T *proc_int, *proc_real, *proc_real_real, *proc_real_real_real, *proc_real_real_real_real, *proc_complex_complex, *proc_bool, *proc_char, *proc_void;
42 
43 /**
44 @brief Enter tag in standenv symbol table.
45 @param portable Whether portable.
46 @param a Attribute.
47 @param n Node where defined.
48 @param c Name of token.
49 @param m Moid of token.
50 @param p Priority, if applicable.
51 @param q Interpreter routine that executes this token.
52 **/
53 
54 static void
add_a68g_standenv(BOOL_T portable,int a,NODE_T * n,char * c,MOID_T * m,int p,GPROC * q)55 add_a68g_standenv (BOOL_T portable, int a, NODE_T * n, char *c, MOID_T * m, int p, GPROC * q)
56 {
57 #define INSERT_TAG(l, n) {\
58   NEXT (n) = *(l);\
59   *(l) = (n);\
60   }
61   TAG_T *new_one = new_tag ();
62   PROCEDURE_LEVEL (INFO (n)) = 0;
63   USE (new_one) = A68_FALSE;
64   HEAP (new_one) = HEAP_SYMBOL;
65   TAG_TABLE (new_one) = a68g_standenv;
66   NODE (new_one) = n;
67   VALUE (new_one) = (c != NO_TEXT ? TEXT (add_token (&top_token, c)) : NO_TEXT);
68   PRIO (new_one) = p;
69   PROCEDURE (new_one) = q;
70   A68G_STANDENV_PROC (new_one) = (BOOL_T) (q != NO_GPROC);
71   UNIT (new_one) = NULL;
72   PORTABLE (new_one) = portable;
73   MOID (new_one) = m;
74   NEXT (new_one) = NO_TAG;
75   if (a == IDENTIFIER) {
76     INSERT_TAG (&IDENTIFIERS (a68g_standenv), new_one);
77   } else if (a == OP_SYMBOL) {
78     INSERT_TAG (&OPERATORS (a68g_standenv), new_one);
79   } else if (a == PRIO_SYMBOL) {
80     INSERT_TAG (&PRIO (a68g_standenv), new_one);
81   } else if (a == INDICANT) {
82     INSERT_TAG (&INDICANTS (a68g_standenv), new_one);
83   } else if (a == LABEL) {
84     INSERT_TAG (&LABELS (a68g_standenv), new_one);
85   }
86 #undef INSERT_TAG
87 }
88 
89 /**
90 @brief Compose PROC moid from arguments - first result, than arguments.
91 @param m Result moid.
92 @return Entry in mode table.
93 **/
94 
95 static MOID_T *
a68_proc(MOID_T * m,...)96 a68_proc (MOID_T * m, ...)
97 {
98   MOID_T *y, **z = &TOP_MOID (&program);
99   PACK_T *p = NO_PACK, *q = NO_PACK;
100   va_list attribute;
101   va_start (attribute, m);
102   while ((y = va_arg (attribute, MOID_T *)) != NO_MOID) {
103     PACK_T *new_one = new_pack ();
104     MOID (new_one) = y;
105     TEXT (new_one) = NO_TEXT;
106     NEXT (new_one) = NO_PACK;
107     if (q != NO_PACK) {
108       NEXT (q) = new_one;
109     } else {
110       p = new_one;
111     }
112     q = new_one;
113   }
114   va_end (attribute);
115   return (add_mode (z, PROC_SYMBOL, count_pack_members (p), NO_NODE, m, p));
116 }
117 
118 /**
119 @brief Enter an identifier in standenv.
120 @param portable Whether item is portable.
121 @param n Name of identifier.
122 @param m Mode of identifier.
123 @param q Interpreter routine that executes this token.
124 **/
125 
126 static void
a68_idf(BOOL_T portable,char * n,MOID_T * m,GPROC * q)127 a68_idf (BOOL_T portable, char *n, MOID_T * m, GPROC * q)
128 {
129   add_a68g_standenv (portable, IDENTIFIER, some_node (TEXT (add_token (&top_token, n))), NO_TEXT, m, 0, q);
130 }
131 
132 /**
133 @brief Enter a moid in standenv.
134 @param p Sizety.
135 @param t Name of moid.
136 @param m Will point to entry in mode table.
137 **/
138 
139 static void
a68_mode(int p,char * t,MOID_T ** m)140 a68_mode (int p, char *t, MOID_T ** m)
141 {
142   (*m) = add_mode (&TOP_MOID (&program), STANDARD, p, some_node (TEXT (find_keyword (top_keyword, t))), NO_MOID, NO_PACK);
143 }
144 
145 /**
146 @brief Enter a priority in standenv.
147 @param p Name of operator.
148 @param b Priority of operator.
149 **/
150 
151 static void
a68_prio(char * p,int b)152 a68_prio (char *p, int b)
153 {
154   add_a68g_standenv (A68_TRUE, PRIO_SYMBOL, some_node (TEXT (add_token (&top_token, p))), NO_TEXT, NO_MOID, b, NO_GPROC);
155 }
156 
157 /**
158 @brief Enter operator in standenv.
159 @param portable Whether item is portable.
160 @param n Name of operator.
161 @param m Mode of operator.
162 @param q Interpreter routine that executes this token.
163 **/
164 
165 static void
a68_op(BOOL_T portable,char * n,MOID_T * m,GPROC * q)166 a68_op (BOOL_T portable, char *n, MOID_T * m, GPROC * q)
167 {
168   add_a68g_standenv (portable, OP_SYMBOL, some_node (TEXT (add_token (&top_token, n))), NO_TEXT, m, 0, q);
169 }
170 
171 /**
172 @brief Enter standard modes in standenv.
173 **/
174 
175 static void
stand_moids(void)176 stand_moids (void)
177 {
178   MOID_T *m;
179   PACK_T *z;
180 /* Primitive A68 moids */
181   a68_mode (0, "VOID", &MODE (VOID));
182 /* Standard precision */
183   a68_mode (0, "INT", &MODE (INT));
184   a68_mode (0, "REAL", &MODE (REAL));
185   a68_mode (0, "COMPLEX", &MODE (COMPLEX));
186   a68_mode (0, "COMPL", &MODE (COMPL));
187   a68_mode (0, "BITS", &MODE (BITS));
188   a68_mode (0, "BYTES", &MODE (BYTES));
189 /* Multiple precision */
190   a68_mode (1, "INT", &MODE (LONG_INT));
191   a68_mode (1, "REAL", &MODE (LONG_REAL));
192   a68_mode (1, "COMPLEX", &MODE (LONG_COMPLEX));
193   a68_mode (1, "COMPL", &MODE (LONG_COMPL));
194   a68_mode (1, "BITS", &MODE (LONG_BITS));
195   a68_mode (1, "BYTES", &MODE (LONG_BYTES));
196   a68_mode (2, "REAL", &MODE (LONGLONG_REAL));
197   a68_mode (2, "INT", &MODE (LONGLONG_INT));
198   a68_mode (2, "COMPLEX", &MODE (LONGLONG_COMPLEX));
199   a68_mode (2, "COMPL", &MODE (LONGLONG_COMPL));
200   a68_mode (2, "BITS", &MODE (LONGLONG_BITS));
201 /* Other */
202   a68_mode (0, "BOOL", &MODE (BOOL));
203   a68_mode (0, "CHAR", &MODE (CHAR));
204   a68_mode (0, "STRING", &MODE (STRING));
205   a68_mode (0, "FILE", &MODE (FILE));
206   a68_mode (0, "CHANNEL", &MODE (CHANNEL));
207   a68_mode (0, "PIPE", &MODE (PIPE));
208   a68_mode (0, "FORMAT", &MODE (FORMAT));
209   a68_mode (0, "SEMA", &MODE (SEMA));
210   a68_mode (0, "SOUND", &MODE (SOUND));
211   PORTABLE (MODE (PIPE)) = A68_FALSE;
212   HAS_ROWS (MODE (SOUND)) = A68_TRUE;
213   PORTABLE (MODE (SOUND)) = A68_FALSE;
214 /* ROWS */
215   MODE (ROWS) = add_mode (&TOP_MOID (&program), ROWS_SYMBOL, 0, NO_NODE, NO_MOID, NO_PACK);
216 /* REFs */
217   MODE (REF_INT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (INT), NO_PACK);
218   MODE (REF_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (REAL), NO_PACK);
219   MODE (REF_COMPLEX) = MODE (REF_COMPL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (COMPLEX), NO_PACK);
220   MODE (REF_BITS) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (BITS), NO_PACK);
221   MODE (REF_BYTES) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (BYTES), NO_PACK);
222   MODE (REF_FORMAT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (FORMAT), NO_PACK);
223   MODE (REF_PIPE) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (PIPE), NO_PACK);
224 /* Multiple precision */
225   MODE (REF_LONG_INT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_INT), NO_PACK);
226   MODE (REF_LONG_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_REAL), NO_PACK);
227   MODE (REF_LONG_COMPLEX) = MODE (REF_LONG_COMPL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_COMPLEX), NO_PACK);
228   MODE (REF_LONGLONG_INT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONGLONG_INT), NO_PACK);
229   MODE (REF_LONGLONG_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONGLONG_REAL), NO_PACK);
230   MODE (REF_LONGLONG_COMPLEX) = MODE (REF_LONGLONG_COMPL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONGLONG_COMPLEX), NO_PACK);
231   MODE (REF_LONG_BITS) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_BITS), NO_PACK);
232   MODE (REF_LONGLONG_BITS) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONGLONG_BITS), NO_PACK);
233   MODE (REF_LONG_BYTES) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_BYTES), NO_PACK);
234 /* Other */
235   MODE (REF_BOOL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (BOOL), NO_PACK);
236   MODE (REF_CHAR) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (CHAR), NO_PACK);
237   MODE (REF_FILE) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (FILE), NO_PACK);
238   MODE (REF_REF_FILE) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (REF_FILE), NO_PACK);
239   MODE (REF_SOUND) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (SOUND), NO_PACK);
240 /* [] INT */
241   MODE (ROW_INT) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (INT), NO_PACK);
242   HAS_ROWS (MODE (ROW_INT)) = A68_TRUE;
243   SLICE (MODE (ROW_INT)) = MODE (INT);
244   MODE (REF_ROW_INT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROW_INT), NO_PACK);
245   NAME (MODE (REF_ROW_INT)) = MODE (REF_INT);
246 /* [] REAL */
247   MODE (ROW_REAL) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (REAL), NO_PACK);
248   HAS_ROWS (MODE (ROW_REAL)) = A68_TRUE;
249   SLICE (MODE (ROW_REAL)) = MODE (REAL);
250   MODE (REF_ROW_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROW_REAL), NO_PACK);
251   NAME (MODE (REF_ROW_REAL)) = MODE (REF_REAL);
252 /* [,] REAL */
253   MODE (ROWROW_REAL) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 2, NO_NODE, MODE (REAL), NO_PACK);
254   HAS_ROWS (MODE (ROWROW_REAL)) = A68_TRUE;
255   SLICE (MODE (ROWROW_REAL)) = MODE (ROW_REAL);
256   MODE (REF_ROWROW_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROWROW_REAL), NO_PACK);
257   NAME (MODE (REF_ROWROW_REAL)) = MODE (REF_ROW_REAL);
258 /* [] COMPLEX */
259   MODE (ROW_COMPLEX) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (COMPLEX), NO_PACK);
260   HAS_ROWS (MODE (ROW_COMPLEX)) = A68_TRUE;
261   SLICE (MODE (ROW_COMPLEX)) = MODE (COMPLEX);
262   MODE (REF_ROW_COMPLEX) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROW_COMPLEX), NO_PACK);
263   NAME (MODE (REF_ROW_COMPLEX)) = MODE (REF_COMPLEX);
264 /* [,] COMPLEX */
265   MODE (ROWROW_COMPLEX) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 2, NO_NODE, MODE (COMPLEX), NO_PACK);
266   HAS_ROWS (MODE (ROWROW_COMPLEX)) = A68_TRUE;
267   SLICE (MODE (ROWROW_COMPLEX)) = MODE (ROW_COMPLEX);
268   MODE (REF_ROWROW_COMPLEX) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROWROW_COMPLEX), NO_PACK);
269   NAME (MODE (REF_ROWROW_COMPLEX)) = MODE (REF_ROW_COMPLEX);
270 /* [] BOOL */
271   MODE (ROW_BOOL) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (BOOL), NO_PACK);
272   HAS_ROWS (MODE (ROW_BOOL)) = A68_TRUE;
273   SLICE (MODE (ROW_BOOL)) = MODE (BOOL);
274 /* FLEX [] BOOL */
275   m = add_mode (&TOP_MOID (&program), FLEX_SYMBOL, 0, NO_NODE, MODE (ROW_BOOL), NO_PACK);
276   HAS_ROWS (m) = A68_TRUE;
277   MODE (FLEX_ROW_BOOL) = m;
278 /* [] BITS */
279   MODE (ROW_BITS) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (BITS), NO_PACK);
280   HAS_ROWS (MODE (ROW_BITS)) = A68_TRUE;
281   SLICE (MODE (ROW_BITS)) = MODE (BITS);
282 /* [] LONG BITS */
283   MODE (ROW_LONG_BITS) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (LONG_BITS), NO_PACK);
284   HAS_ROWS (MODE (ROW_LONG_BITS)) = A68_TRUE;
285   SLICE (MODE (ROW_LONG_BITS)) = MODE (LONG_BITS);
286 /* [] LONG LONG BITS */
287   MODE (ROW_LONGLONG_BITS) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (LONGLONG_BITS), NO_PACK);
288   HAS_ROWS (MODE (ROW_LONGLONG_BITS)) = A68_TRUE;
289   SLICE (MODE (ROW_LONGLONG_BITS)) = MODE (LONGLONG_BITS);
290 /* [] CHAR */
291   MODE (ROW_CHAR) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (CHAR), NO_PACK);
292   HAS_ROWS (MODE (ROW_CHAR)) = A68_TRUE;
293   SLICE (MODE (ROW_CHAR)) = MODE (CHAR);
294 /* [][] CHAR */
295   MODE (ROW_ROW_CHAR) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (ROW_CHAR), NO_PACK);
296   HAS_ROWS (MODE (ROW_ROW_CHAR)) = A68_TRUE;
297   SLICE (MODE (ROW_ROW_CHAR)) = MODE (ROW_CHAR);
298 /* MODE STRING = FLEX [] CHAR */
299   m = add_mode (&TOP_MOID (&program), FLEX_SYMBOL, 0, NO_NODE, MODE (ROW_CHAR), NO_PACK);
300   HAS_ROWS (m) = A68_TRUE;
301   MODE (FLEX_ROW_CHAR) = m;
302   EQUIVALENT (MODE (STRING)) = m;
303 /* REF [] CHAR */
304   MODE (REF_ROW_CHAR) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROW_CHAR), NO_PACK);
305   NAME (MODE (REF_ROW_CHAR)) = MODE (REF_CHAR);
306 /* PROC [] CHAR */
307   MODE (PROC_ROW_CHAR) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, 0, NO_NODE, MODE (ROW_CHAR), NO_PACK);
308 /* REF STRING = REF FLEX [] CHAR */
309   MODE (REF_STRING) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, EQUIVALENT (MODE (STRING)), NO_PACK);
310   NAME (MODE (REF_STRING)) = MODE (REF_CHAR);
311   DEFLEXED (MODE (REF_STRING)) = MODE (REF_ROW_CHAR);
312 /* [] STRING */
313   MODE (ROW_STRING) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (STRING), NO_PACK);
314   HAS_ROWS (MODE (ROW_STRING)) = A68_TRUE;
315   SLICE (MODE (ROW_STRING)) = MODE (STRING);
316   DEFLEXED (MODE (ROW_STRING)) = MODE (ROW_ROW_CHAR);
317 /* PROC STRING */
318   MODE (PROC_STRING) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, 0, NO_NODE, MODE (STRING), NO_PACK);
319   DEFLEXED (MODE (PROC_STRING)) = MODE (PROC_ROW_CHAR);
320 /* COMPLEX */
321   z = NO_PACK;
322   (void) add_mode_to_pack (&z, MODE (REAL), TEXT (add_token (&top_token, "im")), NO_NODE);
323   (void) add_mode_to_pack (&z, MODE (REAL), TEXT (add_token (&top_token, "re")), NO_NODE);
324   m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z);
325   EQUIVALENT (MODE (COMPLEX)) = EQUIVALENT (MODE (COMPL)) = m;
326   z = NO_PACK;
327   (void) add_mode_to_pack (&z, MODE (REF_REAL), TEXT (add_token (&top_token, "im")), NO_NODE);
328   (void) add_mode_to_pack (&z, MODE (REF_REAL), TEXT (add_token (&top_token, "re")), NO_NODE);
329   m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z);
330   NAME (MODE (REF_COMPLEX)) = NAME (MODE (REF_COMPL)) = m;
331 /* LONG COMPLEX */
332   z = NO_PACK;
333   (void) add_mode_to_pack (&z, MODE (LONG_REAL), TEXT (add_token (&top_token, "im")), NO_NODE);
334   (void) add_mode_to_pack (&z, MODE (LONG_REAL), TEXT (add_token (&top_token, "re")), NO_NODE);
335   m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z);
336   EQUIVALENT (MODE (LONG_COMPLEX)) = EQUIVALENT (MODE (LONG_COMPL)) = m;
337   z = NO_PACK;
338   (void) add_mode_to_pack (&z, MODE (REF_LONG_REAL), TEXT (add_token (&top_token, "im")), NO_NODE);
339   (void) add_mode_to_pack (&z, MODE (REF_LONG_REAL), TEXT (add_token (&top_token, "re")), NO_NODE);
340   m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z);
341   NAME (MODE (REF_LONG_COMPLEX)) = NAME (MODE (REF_LONG_COMPL)) = m;
342 /* LONG_LONG COMPLEX */
343   z = NO_PACK;
344   (void) add_mode_to_pack (&z, MODE (LONGLONG_REAL), TEXT (add_token (&top_token, "im")), NO_NODE);
345   (void) add_mode_to_pack (&z, MODE (LONGLONG_REAL), TEXT (add_token (&top_token, "re")), NO_NODE);
346   m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z);
347   EQUIVALENT (MODE (LONGLONG_COMPLEX)) = EQUIVALENT (MODE (LONGLONG_COMPL)) = m;
348   z = NO_PACK;
349   (void) add_mode_to_pack (&z, MODE (REF_LONGLONG_REAL), TEXT (add_token (&top_token, "im")), NO_NODE);
350   (void) add_mode_to_pack (&z, MODE (REF_LONGLONG_REAL), TEXT (add_token (&top_token, "re")), NO_NODE);
351   m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z);
352   NAME (MODE (REF_LONGLONG_COMPLEX)) = NAME (MODE (REF_LONGLONG_COMPL)) = m;
353 /* NUMBER */
354   z = NO_PACK;
355   (void) add_mode_to_pack (&z, MODE (INT), NO_TEXT, NO_NODE);
356   (void) add_mode_to_pack (&z, MODE (LONG_INT), NO_TEXT, NO_NODE);
357   (void) add_mode_to_pack (&z, MODE (LONGLONG_INT), NO_TEXT, NO_NODE);
358   (void) add_mode_to_pack (&z, MODE (REAL), NO_TEXT, NO_NODE);
359   (void) add_mode_to_pack (&z, MODE (LONG_REAL), NO_TEXT, NO_NODE);
360   (void) add_mode_to_pack (&z, MODE (LONGLONG_REAL), NO_TEXT, NO_NODE);
361   MODE (NUMBER) = add_mode (&TOP_MOID (&program), UNION_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z);
362 /* SEMA */
363   z = NO_PACK;
364   (void) add_mode_to_pack (&z, MODE (REF_INT), NO_TEXT, NO_NODE);
365   EQUIVALENT (MODE (SEMA)) = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z);
366 /* PROC VOID */
367   z = NO_PACK;
368   MODE (PROC_VOID) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (z), NO_NODE, MODE (VOID), z);
369 /* PROC (REAL) REAL */
370   z = NO_PACK;
371   (void) add_mode_to_pack (&z, MODE (REAL), NO_TEXT, NO_NODE);
372   MODE (PROC_REAL_REAL) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (z), NO_NODE, MODE (REAL), z);
373 /* IO: PROC (REF FILE) BOOL */
374   z = NO_PACK;
375   (void) add_mode_to_pack (&z, MODE (REF_FILE), NO_TEXT, NO_NODE);
376   MODE (PROC_REF_FILE_BOOL) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (z), NO_NODE, MODE (BOOL), z);
377 /* IO: PROC (REF FILE) VOID */
378   z = NO_PACK;
379   (void) add_mode_to_pack (&z, MODE (REF_FILE), NO_TEXT, NO_NODE);
380   MODE (PROC_REF_FILE_VOID) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (z), NO_NODE, MODE (VOID), z);
381 /* IO: SIMPLIN and SIMPLOUT */
382   MODE (SIMPLIN) = add_mode (&TOP_MOID (&program), IN_TYPE_MODE, 0, NO_NODE, NO_MOID, NO_PACK);
383   MODE (ROW_SIMPLIN) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (SIMPLIN), NO_PACK);
384   SLICE (MODE (ROW_SIMPLIN)) = MODE (SIMPLIN);
385   MODE (SIMPLOUT) = add_mode (&TOP_MOID (&program), OUT_TYPE_MODE, 0, NO_NODE, NO_MOID, NO_PACK);
386   MODE (ROW_SIMPLOUT) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (SIMPLOUT), NO_PACK);
387   SLICE (MODE (ROW_SIMPLOUT)) = MODE (SIMPLOUT);
388 /* PIPE */
389   z = NO_PACK;
390   (void) add_mode_to_pack (&z, MODE (INT), TEXT (add_token (&top_token, "pid")), NO_NODE);
391   (void) add_mode_to_pack (&z, MODE (REF_FILE), TEXT (add_token (&top_token, "write")), NO_NODE);
392   (void) add_mode_to_pack (&z, MODE (REF_FILE), TEXT (add_token (&top_token, "read")), NO_NODE);
393   EQUIVALENT (MODE (PIPE)) = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z);
394   z = NO_PACK;
395   (void) add_mode_to_pack (&z, MODE (REF_INT), TEXT (add_token (&top_token, "pid")), NO_NODE);
396   (void) add_mode_to_pack (&z, MODE (REF_REF_FILE), TEXT (add_token (&top_token, "write")), NO_NODE);
397   (void) add_mode_to_pack (&z, MODE (REF_REF_FILE), TEXT (add_token (&top_token, "read")), NO_NODE);
398   NAME (MODE (REF_PIPE)) = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z);
399 }
400 
401 /**
402 @brief Set up standenv - general RR but not transput.
403 **/
404 
405 static void
stand_prelude(void)406 stand_prelude (void)
407 {
408   MOID_T *m;
409 /* Identifiers */
410   a68_idf (A68_STD, "intlengths", MODE (INT), genie_int_lengths);
411   a68_idf (A68_STD, "intshorths", MODE (INT), genie_int_shorths);
412   a68_idf (A68_STD, "maxint", MODE (INT), genie_max_int);
413   a68_idf (A68_STD, "maxreal", MODE (REAL), genie_max_real);
414   a68_idf (A68_STD, "minreal", MODE (REAL), genie_min_real);
415   a68_idf (A68_STD, "smallreal", MODE (REAL), genie_small_real);
416   a68_idf (A68_STD, "reallengths", MODE (INT), genie_real_lengths);
417   a68_idf (A68_STD, "realshorths", MODE (INT), genie_real_shorths);
418   a68_idf (A68_STD, "compllengths", MODE (INT), genie_complex_lengths);
419   a68_idf (A68_STD, "complshorths", MODE (INT), genie_complex_shorths);
420   a68_idf (A68_STD, "bitslengths", MODE (INT), genie_bits_lengths);
421   a68_idf (A68_STD, "bitsshorths", MODE (INT), genie_bits_shorths);
422   a68_idf (A68_STD, "bitswidth", MODE (INT), genie_bits_width);
423   a68_idf (A68_STD, "longbitswidth", MODE (INT), genie_long_bits_width);
424   a68_idf (A68_STD, "longlongbitswidth", MODE (INT), genie_longlong_bits_width);
425   a68_idf (A68_STD, "maxbits", MODE (BITS), genie_max_bits);
426   a68_idf (A68_STD, "longmaxbits", MODE (LONG_BITS), genie_long_max_bits);
427   a68_idf (A68_STD, "longlongmaxbits", MODE (LONGLONG_BITS), genie_longlong_max_bits);
428   a68_idf (A68_STD, "byteslengths", MODE (INT), genie_bytes_lengths);
429   a68_idf (A68_STD, "bytesshorths", MODE (INT), genie_bytes_shorths);
430   a68_idf (A68_STD, "byteswidth", MODE (INT), genie_bytes_width);
431   a68_idf (A68_STD, "maxabschar", MODE (INT), genie_max_abs_char);
432   a68_idf (A68_STD, "pi", MODE (REAL), genie_pi);
433   a68_idf (A68_STD, "dpi", MODE (LONG_REAL), genie_pi_long_mp);
434   a68_idf (A68_STD, "longpi", MODE (LONG_REAL), genie_pi_long_mp);
435   a68_idf (A68_STD, "qpi", MODE (LONGLONG_REAL), genie_pi_long_mp);
436   a68_idf (A68_STD, "longlongpi", MODE (LONGLONG_REAL), genie_pi_long_mp);
437   a68_idf (A68_STD, "intwidth", MODE (INT), genie_int_width);
438   a68_idf (A68_STD, "realwidth", MODE (INT), genie_real_width);
439   a68_idf (A68_STD, "expwidth", MODE (INT), genie_exp_width);
440   a68_idf (A68_STD, "longintwidth", MODE (INT), genie_long_int_width);
441   a68_idf (A68_STD, "longlongintwidth", MODE (INT), genie_longlong_int_width);
442   a68_idf (A68_STD, "longrealwidth", MODE (INT), genie_long_real_width);
443   a68_idf (A68_STD, "longlongrealwidth", MODE (INT), genie_longlong_real_width);
444   a68_idf (A68_STD, "longexpwidth", MODE (INT), genie_long_exp_width);
445   a68_idf (A68_STD, "longlongexpwidth", MODE (INT), genie_longlong_exp_width);
446   a68_idf (A68_STD, "longmaxint", MODE (LONG_INT), genie_long_max_int);
447   a68_idf (A68_STD, "longlongmaxint", MODE (LONGLONG_INT), genie_longlong_max_int);
448   a68_idf (A68_STD, "longsmallreal", MODE (LONG_REAL), genie_long_small_real);
449   a68_idf (A68_STD, "longlongsmallreal", MODE (LONGLONG_REAL), genie_longlong_small_real);
450   a68_idf (A68_STD, "longmaxreal", MODE (LONG_REAL), genie_long_max_real);
451   a68_idf (A68_STD, "longminreal", MODE (LONG_REAL), genie_long_min_real);
452   a68_idf (A68_STD, "longlongmaxreal", MODE (LONGLONG_REAL), genie_longlong_max_real);
453   a68_idf (A68_STD, "longlongminreal", MODE (LONGLONG_REAL), genie_longlong_min_real);
454   a68_idf (A68_STD, "longbyteswidth", MODE (INT), genie_long_bytes_width);
455   a68_idf (A68_EXT, "seconds", MODE (REAL), genie_cputime);
456   a68_idf (A68_EXT, "clock", MODE (REAL), genie_cputime);
457   a68_idf (A68_EXT, "cputime", MODE (REAL), genie_cputime);
458   a68_idf (A68_EXT, "collections", proc_int, genie_garbage_collections);
459   a68_idf (A68_EXT, "blocks", proc_int, genie_block);
460   m = a68_proc (MODE (VOID), proc_void, NO_MOID);
461   a68_idf (A68_EXT, "ongcevent", m, genie_on_gc_event);
462   m = a68_proc (MODE (LONG_INT), NO_MOID);
463   a68_idf (A68_EXT, "garbage", m, genie_garbage_freed);
464   a68_idf (A68_EXT, "collectseconds", proc_real, genie_garbage_seconds);
465   a68_idf (A68_EXT, "stackpointer", MODE (INT), genie_stack_pointer);
466   a68_idf (A68_EXT, "systemstackpointer", MODE (INT), genie_system_stack_pointer);
467   a68_idf (A68_EXT, "systemstacksize", MODE (INT), genie_system_stack_size);
468   a68_idf (A68_EXT, "actualstacksize", MODE (INT), genie_stack_pointer);
469   a68_idf (A68_EXT, "systemheappointer", MODE (INT), genie_system_heap_pointer);
470   m = proc_void;
471   a68_idf (A68_EXT, "gcheap", m, genie_gc_heap);
472   a68_idf (A68_EXT, "sweepheap", m, genie_gc_heap);
473   a68_idf (A68_EXT, "preemptivegc", m, genie_preemptive_gc_heap);
474   a68_idf (A68_EXT, "preemptivesweep", m, genie_preemptive_gc_heap);
475   a68_idf (A68_EXT, "preemptivesweepheap", m, genie_preemptive_gc_heap);
476   a68_idf (A68_EXT, "break", m, genie_break);
477   a68_idf (A68_EXT, "debug", m, genie_debug);
478   a68_idf (A68_EXT, "monitor", m, genie_debug);
479   m = a68_proc (MODE (VOID), MODE (STRING), NO_MOID);
480   a68_idf (A68_EXT, "abend", m, genie_abend);
481   m = a68_proc (MODE (STRING), MODE (STRING), NO_MOID);
482   a68_idf (A68_EXT, "evaluate", m, genie_evaluate);
483   m = a68_proc (MODE (INT), MODE (STRING), NO_MOID);
484   a68_idf (A68_EXT, "system", m, genie_system);
485   m = a68_proc (MODE (STRING), MODE (STRING), NO_MOID);
486   a68_idf (A68_EXT, "acronym", m, genie_acronym);
487   a68_idf (A68_EXT, "vmsacronym", m, genie_acronym);
488   m = a68_proc (MODE (INT), MODE (INT), NO_MOID);
489   a68_idf (A68_EXT, "sleep", m, genie_sleep);
490 /* BITS procedures */
491   m = a68_proc (MODE (BITS), MODE (ROW_BOOL), NO_MOID);
492   a68_idf (A68_STD, "bitspack", m, genie_bits_pack);
493   m = a68_proc (MODE (LONG_BITS), MODE (ROW_BOOL), NO_MOID);
494   a68_idf (A68_STD, "longbitspack", m, genie_long_bits_pack);
495   m = a68_proc (MODE (LONGLONG_BITS), MODE (ROW_BOOL), NO_MOID);
496   a68_idf (A68_STD, "longlongbitspack", m, genie_long_bits_pack);
497 /* RNG procedures */
498   m = a68_proc (MODE (VOID), MODE (INT), NO_MOID);
499   a68_idf (A68_STD, "firstrandom", m, genie_first_random);
500   m = proc_real;
501   a68_idf (A68_STD, "nextrandom", m, genie_next_random);
502   a68_idf (A68_STD, "random", m, genie_next_random);
503   a68_idf (A68_STD, "rnd", m, genie_next_rnd);
504   m = a68_proc (MODE (LONG_REAL), NO_MOID);
505   a68_idf (A68_STD, "longnextrandom", m, genie_long_next_random);
506   a68_idf (A68_STD, "longrandom", m, genie_long_next_random);
507   m = a68_proc (MODE (LONGLONG_REAL), NO_MOID);
508   a68_idf (A68_STD, "longlongnextrandom", m, genie_long_next_random);
509   a68_idf (A68_STD, "longlongrandom", m, genie_long_next_random);
510 /* Priorities */
511   a68_prio ("+:=", 1);
512   a68_prio ("-:=", 1);
513   a68_prio ("*:=", 1);
514   a68_prio ("/:=", 1);
515   a68_prio ("%:=", 1);
516   a68_prio ("%*:=", 1);
517   a68_prio ("+=:", 1);
518   a68_prio ("PLUSAB", 1);
519   a68_prio ("MINUSAB", 1);
520   a68_prio ("TIMESAB", 1);
521   a68_prio ("DIVAB", 1);
522   a68_prio ("OVERAB", 1);
523   a68_prio ("MODAB", 1);
524   a68_prio ("PLUSTO", 1);
525   a68_prio ("OR", 2);
526   a68_prio ("AND", 3);
527   a68_prio ("&", 3);
528   a68_prio ("XOR", 3);
529   a68_prio ("=", 4);
530   a68_prio ("/=", 4);
531   a68_prio ("~=", 4);
532   a68_prio ("^=", 4);
533   a68_prio ("<", 5);
534   a68_prio ("<=", 5);
535   a68_prio (">", 5);
536   a68_prio (">=", 5);
537   a68_prio ("EQ", 4);
538   a68_prio ("NE", 4);
539   a68_prio ("LT", 5);
540   a68_prio ("LE", 5);
541   a68_prio ("GT", 5);
542   a68_prio ("GE", 5);
543   a68_prio ("+", 6);
544   a68_prio ("-", 6);
545   a68_prio ("*", 7);
546   a68_prio ("/", 7);
547   a68_prio ("OVER", 7);
548   a68_prio ("%", 7);
549   a68_prio ("MOD", 7);
550   a68_prio ("%*", 7);
551   a68_prio ("ELEM", 7);
552   a68_prio ("SET", 7);
553   a68_prio ("CLEAR", 7);
554   a68_prio ("**", 8);
555   a68_prio ("SHL", 8);
556   a68_prio ("SHR", 8);
557   a68_prio ("UP", 8);
558   a68_prio ("DOWN", 8);
559   a68_prio ("^", 8);
560   a68_prio ("ELEMS", 8);
561   a68_prio ("LWB", 8);
562   a68_prio ("UPB", 8);
563   a68_prio ("SORT", 8);
564   a68_prio ("I", 9);
565   a68_prio ("+*", 9);
566 /* INT ops */
567   m = a68_proc (MODE (INT), MODE (INT), NO_MOID);
568   a68_op (A68_STD, "+", m, genie_idle);
569   a68_op (A68_STD, "-", m, genie_minus_int);
570   a68_op (A68_STD, "ABS", m, genie_abs_int);
571   a68_op (A68_STD, "SIGN", m, genie_sign_int);
572   m = a68_proc (MODE (BOOL), MODE (INT), NO_MOID);
573   a68_op (A68_STD, "ODD", m, genie_odd_int);
574   m = a68_proc (MODE (BOOL), MODE (INT), MODE (INT), NO_MOID);
575   a68_op (A68_STD, "=", m, genie_eq_int);
576   a68_op (A68_STD, "/=", m, genie_ne_int);
577   a68_op (A68_STD, "~=", m, genie_ne_int);
578   a68_op (A68_STD, "^=", m, genie_ne_int);
579   a68_op (A68_STD, "<", m, genie_lt_int);
580   a68_op (A68_STD, "<=", m, genie_le_int);
581   a68_op (A68_STD, ">", m, genie_gt_int);
582   a68_op (A68_STD, ">=", m, genie_ge_int);
583   a68_op (A68_STD, "EQ", m, genie_eq_int);
584   a68_op (A68_STD, "NE", m, genie_ne_int);
585   a68_op (A68_STD, "LT", m, genie_lt_int);
586   a68_op (A68_STD, "LE", m, genie_le_int);
587   a68_op (A68_STD, "GT", m, genie_gt_int);
588   a68_op (A68_STD, "GE", m, genie_ge_int);
589   m = a68_proc (MODE (INT), MODE (INT), MODE (INT), NO_MOID);
590   a68_op (A68_STD, "+", m, genie_add_int);
591   a68_op (A68_STD, "-", m, genie_sub_int);
592   a68_op (A68_STD, "*", m, genie_mul_int);
593   a68_op (A68_STD, "OVER", m, genie_over_int);
594   a68_op (A68_STD, "%", m, genie_over_int);
595   a68_op (A68_STD, "MOD", m, genie_mod_int);
596   a68_op (A68_STD, "%*", m, genie_mod_int);
597   a68_op (A68_STD, "**", m, genie_pow_int);
598   a68_op (A68_STD, "UP", m, genie_pow_int);
599   a68_op (A68_STD, "^", m, genie_pow_int);
600   m = a68_proc (MODE (REAL), MODE (INT), MODE (INT), NO_MOID);
601   a68_op (A68_STD, "/", m, genie_div_int);
602   m = a68_proc (MODE (REF_INT), MODE (REF_INT), MODE (INT), NO_MOID);
603   a68_op (A68_STD, "+:=", m, genie_plusab_int);
604   a68_op (A68_STD, "-:=", m, genie_minusab_int);
605   a68_op (A68_STD, "*:=", m, genie_timesab_int);
606   a68_op (A68_STD, "%:=", m, genie_overab_int);
607   a68_op (A68_STD, "%*:=", m, genie_modab_int);
608   a68_op (A68_STD, "PLUSAB", m, genie_plusab_int);
609   a68_op (A68_STD, "MINUSAB", m, genie_minusab_int);
610   a68_op (A68_STD, "TIMESAB", m, genie_timesab_int);
611   a68_op (A68_STD, "OVERAB", m, genie_overab_int);
612   a68_op (A68_STD, "MODAB", m, genie_modab_int);
613 /* REAL ops */
614   m = proc_real_real;
615   a68_op (A68_STD, "+", m, genie_idle);
616   a68_op (A68_STD, "-", m, genie_minus_real);
617   a68_op (A68_STD, "ABS", m, genie_abs_real);
618   m = a68_proc (MODE (INT), MODE (REAL), NO_MOID);
619   a68_op (A68_STD, "SIGN", m, genie_sign_real);
620   a68_op (A68_STD, "ROUND", m, genie_round_real);
621   a68_op (A68_STD, "ENTIER", m, genie_entier_real);
622   m = a68_proc (MODE (BOOL), MODE (REAL), MODE (REAL), NO_MOID);
623   a68_op (A68_STD, "=", m, genie_eq_real);
624   a68_op (A68_STD, "/=", m, genie_ne_real);
625   a68_op (A68_STD, "~=", m, genie_ne_real);
626   a68_op (A68_STD, "^=", m, genie_ne_real);
627   a68_op (A68_STD, "<", m, genie_lt_real);
628   a68_op (A68_STD, "<=", m, genie_le_real);
629   a68_op (A68_STD, ">", m, genie_gt_real);
630   a68_op (A68_STD, ">=", m, genie_ge_real);
631   a68_op (A68_STD, "EQ", m, genie_eq_real);
632   a68_op (A68_STD, "NE", m, genie_ne_real);
633   a68_op (A68_STD, "LT", m, genie_lt_real);
634   a68_op (A68_STD, "LE", m, genie_le_real);
635   a68_op (A68_STD, "GT", m, genie_gt_real);
636   a68_op (A68_STD, "GE", m, genie_ge_real);
637   m = proc_real_real_real;
638   a68_op (A68_STD, "+", m, genie_add_real);
639   a68_op (A68_STD, "-", m, genie_sub_real);
640   a68_op (A68_STD, "*", m, genie_mul_real);
641   a68_op (A68_STD, "/", m, genie_div_real);
642   a68_op (A68_STD, "**", m, genie_pow_real);
643   a68_op (A68_STD, "UP", m, genie_pow_real);
644   a68_op (A68_STD, "^", m, genie_pow_real);
645   m = a68_proc (MODE (REAL), MODE (REAL), MODE (INT), NO_MOID);
646   a68_op (A68_STD, "**", m, genie_pow_real_int);
647   a68_op (A68_STD, "UP", m, genie_pow_real_int);
648   a68_op (A68_STD, "^", m, genie_pow_real_int);
649   m = a68_proc (MODE (REF_REAL), MODE (REF_REAL), MODE (REAL), NO_MOID);
650   a68_op (A68_STD, "+:=", m, genie_plusab_real);
651   a68_op (A68_STD, "-:=", m, genie_minusab_real);
652   a68_op (A68_STD, "*:=", m, genie_timesab_real);
653   a68_op (A68_STD, "/:=", m, genie_divab_real);
654   a68_op (A68_STD, "PLUSAB", m, genie_plusab_real);
655   a68_op (A68_STD, "MINUSAB", m, genie_minusab_real);
656   a68_op (A68_STD, "TIMESAB", m, genie_timesab_real);
657   a68_op (A68_STD, "DIVAB", m, genie_divab_real);
658   m = proc_real_real;
659   a68_idf (A68_STD, "sqrt", m, genie_sqrt_real);
660   a68_idf (A68_EXT, "cbrt", m, genie_curt_real);
661   a68_idf (A68_EXT, "curt", m, genie_curt_real);
662   a68_idf (A68_STD, "exp", m, genie_exp_real);
663   a68_idf (A68_STD, "ln", m, genie_ln_real);
664   a68_idf (A68_STD, "log", m, genie_log_real);
665   a68_idf (A68_STD, "sin", m, genie_sin_real);
666   a68_idf (A68_STD, "cos", m, genie_cos_real);
667   a68_idf (A68_STD, "tan", m, genie_tan_real);
668   a68_idf (A68_STD, "asin", m, genie_arcsin_real);
669   a68_idf (A68_STD, "acos", m, genie_arccos_real);
670   a68_idf (A68_STD, "atan", m, genie_arctan_real);
671   a68_idf (A68_STD, "arcsin", m, genie_arcsin_real);
672   a68_idf (A68_STD, "arccos", m, genie_arccos_real);
673   a68_idf (A68_STD, "arctan", m, genie_arctan_real);
674   a68_idf (A68_EXT, "sinh", m, genie_sinh_real);
675   a68_idf (A68_EXT, "cosh", m, genie_cosh_real);
676   a68_idf (A68_EXT, "tanh", m, genie_tanh_real);
677   a68_idf (A68_EXT, "asinh", m, genie_arcsinh_real);
678   a68_idf (A68_EXT, "acosh", m, genie_arccosh_real);
679   a68_idf (A68_EXT, "atanh", m, genie_arctanh_real);
680   a68_idf (A68_EXT, "arcsinh", m, genie_arcsinh_real);
681   a68_idf (A68_EXT, "arccosh", m, genie_arccosh_real);
682   a68_idf (A68_EXT, "arctanh", m, genie_arctanh_real);
683   a68_idf (A68_EXT, "inverseerf", m, genie_inverf_real);
684   a68_idf (A68_EXT, "inverseerfc", m, genie_inverfc_real);
685   m = proc_real_real_real;
686   a68_idf (A68_EXT, "arctan2", m, genie_atan2_real);
687   m = proc_real_real_real_real;
688   a68_idf (A68_EXT, "lje126", m, genie_lj_e_12_6);
689   a68_idf (A68_EXT, "ljf126", m, genie_lj_f_12_6);
690 /* COMPLEX ops */
691   m = a68_proc (MODE (COMPLEX), MODE (REAL), MODE (REAL), NO_MOID);
692   a68_op (A68_STD, "I", m, genie_icomplex);
693   a68_op (A68_STD, "+*", m, genie_icomplex);
694   m = a68_proc (MODE (COMPLEX), MODE (INT), MODE (INT), NO_MOID);
695   a68_op (A68_STD, "I", m, genie_iint_complex);
696   a68_op (A68_STD, "+*", m, genie_iint_complex);
697   m = a68_proc (MODE (REAL), MODE (COMPLEX), NO_MOID);
698   a68_op (A68_STD, "RE", m, genie_re_complex);
699   a68_op (A68_STD, "IM", m, genie_im_complex);
700   a68_op (A68_STD, "ABS", m, genie_abs_complex);
701   a68_op (A68_STD, "ARG", m, genie_arg_complex);
702   m = proc_complex_complex;
703   a68_op (A68_STD, "+", m, genie_idle);
704   a68_op (A68_STD, "-", m, genie_minus_complex);
705   a68_op (A68_STD, "CONJ", m, genie_conj_complex);
706   m = a68_proc (MODE (BOOL), MODE (COMPLEX), MODE (COMPLEX), NO_MOID);
707   a68_op (A68_STD, "=", m, genie_eq_complex);
708   a68_op (A68_STD, "/=", m, genie_ne_complex);
709   a68_op (A68_STD, "~=", m, genie_ne_complex);
710   a68_op (A68_STD, "^=", m, genie_ne_complex);
711   a68_op (A68_STD, "EQ", m, genie_eq_complex);
712   a68_op (A68_STD, "NE", m, genie_ne_complex);
713   m = a68_proc (MODE (COMPLEX), MODE (COMPLEX), MODE (COMPLEX), NO_MOID);
714   a68_op (A68_STD, "+", m, genie_add_complex);
715   a68_op (A68_STD, "-", m, genie_sub_complex);
716   a68_op (A68_STD, "*", m, genie_mul_complex);
717   a68_op (A68_STD, "/", m, genie_div_complex);
718   m = a68_proc (MODE (COMPLEX), MODE (COMPLEX), MODE (INT), NO_MOID);
719   a68_op (A68_STD, "**", m, genie_pow_complex_int);
720   a68_op (A68_STD, "UP", m, genie_pow_complex_int);
721   a68_op (A68_STD, "^", m, genie_pow_complex_int);
722   m = a68_proc (MODE (REF_COMPLEX), MODE (REF_COMPLEX), MODE (COMPLEX), NO_MOID);
723   a68_op (A68_STD, "+:=", m, genie_plusab_complex);
724   a68_op (A68_STD, "-:=", m, genie_minusab_complex);
725   a68_op (A68_STD, "*:=", m, genie_timesab_complex);
726   a68_op (A68_STD, "/:=", m, genie_divab_complex);
727   a68_op (A68_STD, "PLUSAB", m, genie_plusab_complex);
728   a68_op (A68_STD, "MINUSAB", m, genie_minusab_complex);
729   a68_op (A68_STD, "TIMESAB", m, genie_timesab_complex);
730   a68_op (A68_STD, "DIVAB", m, genie_divab_complex);
731 /* BOOL ops */
732   m = a68_proc (MODE (BOOL), MODE (BOOL), NO_MOID);
733   a68_op (A68_STD, "NOT", m, genie_not_bool);
734   a68_op (A68_STD, "~", m, genie_not_bool);
735   m = a68_proc (MODE (INT), MODE (BOOL), NO_MOID);
736   a68_op (A68_STD, "ABS", m, genie_abs_bool);
737   m = a68_proc (MODE (BOOL), MODE (BOOL), MODE (BOOL), NO_MOID);
738   a68_op (A68_STD, "OR", m, genie_or_bool);
739   a68_op (A68_STD, "AND", m, genie_and_bool);
740   a68_op (A68_STD, "&", m, genie_and_bool);
741   a68_op (A68_EXT, "XOR", m, genie_xor_bool);
742   a68_op (A68_STD, "=", m, genie_eq_bool);
743   a68_op (A68_STD, "/=", m, genie_ne_bool);
744   a68_op (A68_STD, "~=", m, genie_ne_bool);
745   a68_op (A68_STD, "^=", m, genie_ne_bool);
746   a68_op (A68_STD, "EQ", m, genie_eq_bool);
747   a68_op (A68_STD, "NE", m, genie_ne_bool);
748 /* CHAR ops */
749   m = a68_proc (MODE (BOOL), MODE (CHAR), MODE (CHAR), NO_MOID);
750   a68_op (A68_STD, "=", m, genie_eq_char);
751   a68_op (A68_STD, "/=", m, genie_ne_char);
752   a68_op (A68_STD, "~=", m, genie_ne_char);
753   a68_op (A68_STD, "^=", m, genie_ne_char);
754   a68_op (A68_STD, "<", m, genie_lt_char);
755   a68_op (A68_STD, "<=", m, genie_le_char);
756   a68_op (A68_STD, ">", m, genie_gt_char);
757   a68_op (A68_STD, ">=", m, genie_ge_char);
758   a68_op (A68_STD, "EQ", m, genie_eq_char);
759   a68_op (A68_STD, "NE", m, genie_ne_char);
760   a68_op (A68_STD, "LT", m, genie_lt_char);
761   a68_op (A68_STD, "LE", m, genie_le_char);
762   a68_op (A68_STD, "GT", m, genie_gt_char);
763   a68_op (A68_STD, "GE", m, genie_ge_char);
764   m = a68_proc (MODE (INT), MODE (CHAR), NO_MOID);
765   a68_op (A68_STD, "ABS", m, genie_abs_char);
766   m = a68_proc (MODE (CHAR), MODE (INT), NO_MOID);
767   a68_op (A68_STD, "REPR", m, genie_repr_char);
768   m = a68_proc (MODE (BOOL), MODE (CHAR), NO_MOID);
769   a68_idf (A68_EXT, "isalnum", m, genie_is_alnum);
770   a68_idf (A68_EXT, "isalpha", m, genie_is_alpha);
771   a68_idf (A68_EXT, "iscntrl", m, genie_is_cntrl);
772   a68_idf (A68_EXT, "isdigit", m, genie_is_digit);
773   a68_idf (A68_EXT, "isgraph", m, genie_is_graph);
774   a68_idf (A68_EXT, "islower", m, genie_is_lower);
775   a68_idf (A68_EXT, "isprint", m, genie_is_print);
776   a68_idf (A68_EXT, "ispunct", m, genie_is_punct);
777   a68_idf (A68_EXT, "isspace", m, genie_is_space);
778   a68_idf (A68_EXT, "isupper", m, genie_is_upper);
779   a68_idf (A68_EXT, "isxdigit", m, genie_is_xdigit);
780   m = a68_proc (MODE (CHAR), MODE (CHAR), NO_MOID);
781   a68_idf (A68_EXT, "tolower", m, genie_to_lower);
782   a68_idf (A68_EXT, "toupper", m, genie_to_upper);
783 /* BITS ops */
784   m = a68_proc (MODE (INT), MODE (BITS), NO_MOID);
785   a68_op (A68_STD, "ABS", m, genie_abs_bits);
786   m = a68_proc (MODE (BITS), MODE (INT), NO_MOID);
787   a68_op (A68_STD, "BIN", m, genie_bin_int);
788   m = a68_proc (MODE (BITS), MODE (BITS), NO_MOID);
789   a68_op (A68_STD, "NOT", m, genie_not_bits);
790   a68_op (A68_STD, "~", m, genie_not_bits);
791   m = a68_proc (MODE (BOOL), MODE (BITS), MODE (BITS), NO_MOID);
792   a68_op (A68_STD, "=", m, genie_eq_bits);
793   a68_op (A68_STD, "/=", m, genie_ne_bits);
794   a68_op (A68_STD, "~=", m, genie_ne_bits);
795   a68_op (A68_STD, "^=", m, genie_ne_bits);
796   a68_op (A68_STD, "<=", m, genie_le_bits);
797   a68_op (A68_STD, ">=", m, genie_ge_bits);
798   a68_op (A68_STD, "EQ", m, genie_eq_bits);
799   a68_op (A68_STD, "NE", m, genie_ne_bits);
800   a68_op (A68_STD, "LE", m, genie_le_bits);
801   a68_op (A68_STD, "GE", m, genie_ge_bits);
802   m = a68_proc (MODE (BITS), MODE (BITS), MODE (BITS), NO_MOID);
803   a68_op (A68_STD, "AND", m, genie_and_bits);
804   a68_op (A68_STD, "&", m, genie_and_bits);
805   a68_op (A68_STD, "OR", m, genie_or_bits);
806   a68_op (A68_EXT, "XOR", m, genie_xor_bits);
807   m = a68_proc (MODE (BITS), MODE (BITS), MODE (INT), NO_MOID);
808   a68_op (A68_STD, "SHL", m, genie_shl_bits);
809   a68_op (A68_STD, "UP", m, genie_shl_bits);
810   a68_op (A68_STD, "SHR", m, genie_shr_bits);
811   a68_op (A68_STD, "DOWN", m, genie_shr_bits);
812   m = a68_proc (MODE (BOOL), MODE (INT), MODE (BITS), NO_MOID);
813   a68_op (A68_STD, "ELEM", m, genie_elem_bits);
814   m = a68_proc (MODE (BITS), MODE (INT), MODE (BITS), NO_MOID);
815   a68_op (A68_STD, "SET", m, genie_set_bits);
816   a68_op (A68_STD, "CLEAR", m, genie_clear_bits);
817 /* BYTES ops */
818   m = a68_proc (MODE (BYTES), MODE (STRING), NO_MOID);
819   a68_idf (A68_STD, "bytespack", m, genie_bytespack);
820   m = a68_proc (MODE (CHAR), MODE (INT), MODE (BYTES), NO_MOID);
821   a68_op (A68_STD, "ELEM", m, genie_elem_bytes);
822   m = a68_proc (MODE (BYTES), MODE (BYTES), MODE (BYTES), NO_MOID);
823   a68_op (A68_STD, "+", m, genie_add_bytes);
824   m = a68_proc (MODE (REF_BYTES), MODE (REF_BYTES), MODE (BYTES), NO_MOID);
825   a68_op (A68_STD, "+:=", m, genie_plusab_bytes);
826   a68_op (A68_STD, "PLUSAB", m, genie_plusab_bytes);
827   m = a68_proc (MODE (REF_BYTES), MODE (BYTES), MODE (REF_BYTES), NO_MOID);
828   a68_op (A68_STD, "+=:", m, genie_plusto_bytes);
829   a68_op (A68_STD, "PLUSTO", m, genie_plusto_bytes);
830   m = a68_proc (MODE (BOOL), MODE (BYTES), MODE (BYTES), NO_MOID);
831   a68_op (A68_STD, "=", m, genie_eq_bytes);
832   a68_op (A68_STD, "/=", m, genie_ne_bytes);
833   a68_op (A68_STD, "~=", m, genie_ne_bytes);
834   a68_op (A68_STD, "^=", m, genie_ne_bytes);
835   a68_op (A68_STD, "<", m, genie_lt_bytes);
836   a68_op (A68_STD, "<=", m, genie_le_bytes);
837   a68_op (A68_STD, ">", m, genie_gt_bytes);
838   a68_op (A68_STD, ">=", m, genie_ge_bytes);
839   a68_op (A68_STD, "EQ", m, genie_eq_bytes);
840   a68_op (A68_STD, "NE", m, genie_ne_bytes);
841   a68_op (A68_STD, "LT", m, genie_lt_bytes);
842   a68_op (A68_STD, "LE", m, genie_le_bytes);
843   a68_op (A68_STD, "GT", m, genie_gt_bytes);
844   a68_op (A68_STD, "GE", m, genie_ge_bytes);
845 /* LONG BYTES ops */
846   m = a68_proc (MODE (LONG_BYTES), MODE (BYTES), NO_MOID);
847   a68_op (A68_STD, "LENG", m, genie_leng_bytes);
848   m = a68_proc (MODE (BYTES), MODE (LONG_BYTES), NO_MOID);
849   a68_idf (A68_STD, "SHORTEN", m, genie_shorten_bytes);
850   m = a68_proc (MODE (LONG_BYTES), MODE (STRING), NO_MOID);
851   a68_idf (A68_STD, "longbytespack", m, genie_long_bytespack);
852   m = a68_proc (MODE (CHAR), MODE (INT), MODE (LONG_BYTES), NO_MOID);
853   a68_op (A68_STD, "ELEM", m, genie_elem_long_bytes);
854   m = a68_proc (MODE (LONG_BYTES), MODE (LONG_BYTES), MODE (LONG_BYTES), NO_MOID);
855   a68_op (A68_STD, "+", m, genie_add_long_bytes);
856   m = a68_proc (MODE (REF_LONG_BYTES), MODE (REF_LONG_BYTES), MODE (LONG_BYTES), NO_MOID);
857   a68_op (A68_STD, "+:=", m, genie_plusab_long_bytes);
858   a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_bytes);
859   m = a68_proc (MODE (REF_LONG_BYTES), MODE (LONG_BYTES), MODE (REF_LONG_BYTES), NO_MOID);
860   a68_op (A68_STD, "+=:", m, genie_plusto_long_bytes);
861   a68_op (A68_STD, "PLUSTO", m, genie_plusto_long_bytes);
862   m = a68_proc (MODE (BOOL), MODE (LONG_BYTES), MODE (LONG_BYTES), NO_MOID);
863   a68_op (A68_STD, "=", m, genie_eq_long_bytes);
864   a68_op (A68_STD, "/=", m, genie_ne_long_bytes);
865   a68_op (A68_STD, "~=", m, genie_ne_long_bytes);
866   a68_op (A68_STD, "^=", m, genie_ne_long_bytes);
867   a68_op (A68_STD, "<", m, genie_lt_long_bytes);
868   a68_op (A68_STD, "<=", m, genie_le_long_bytes);
869   a68_op (A68_STD, ">", m, genie_gt_long_bytes);
870   a68_op (A68_STD, ">=", m, genie_ge_long_bytes);
871   a68_op (A68_STD, "EQ", m, genie_eq_long_bytes);
872   a68_op (A68_STD, "NE", m, genie_ne_long_bytes);
873   a68_op (A68_STD, "LT", m, genie_lt_long_bytes);
874   a68_op (A68_STD, "LE", m, genie_le_long_bytes);
875   a68_op (A68_STD, "GT", m, genie_gt_long_bytes);
876   a68_op (A68_STD, "GE", m, genie_ge_long_bytes);
877 /* STRING ops */
878   m = a68_proc (MODE (BOOL), MODE (STRING), MODE (STRING), NO_MOID);
879   a68_op (A68_STD, "=", m, genie_eq_string);
880   a68_op (A68_STD, "/=", m, genie_ne_string);
881   a68_op (A68_STD, "~=", m, genie_ne_string);
882   a68_op (A68_STD, "^=", m, genie_ne_string);
883   a68_op (A68_STD, "<", m, genie_lt_string);
884   a68_op (A68_STD, "<=", m, genie_le_string);
885   a68_op (A68_STD, ">=", m, genie_ge_string);
886   a68_op (A68_STD, ">", m, genie_gt_string);
887   a68_op (A68_STD, "EQ", m, genie_eq_string);
888   a68_op (A68_STD, "NE", m, genie_ne_string);
889   a68_op (A68_STD, "LT", m, genie_lt_string);
890   a68_op (A68_STD, "LE", m, genie_le_string);
891   a68_op (A68_STD, "GE", m, genie_ge_string);
892   a68_op (A68_STD, "GT", m, genie_gt_string);
893   m = a68_proc (MODE (STRING), MODE (CHAR), MODE (CHAR), NO_MOID);
894   a68_op (A68_STD, "+", m, genie_add_char);
895   m = a68_proc (MODE (STRING), MODE (STRING), MODE (STRING), NO_MOID);
896   a68_op (A68_STD, "+", m, genie_add_string);
897   m = a68_proc (MODE (REF_STRING), MODE (REF_STRING), MODE (STRING), NO_MOID);
898   a68_op (A68_STD, "+:=", m, genie_plusab_string);
899   a68_op (A68_STD, "PLUSAB", m, genie_plusab_string);
900   m = a68_proc (MODE (REF_STRING), MODE (REF_STRING), MODE (INT), NO_MOID);
901   a68_op (A68_STD, "*:=", m, genie_timesab_string);
902   a68_op (A68_STD, "TIMESAB", m, genie_timesab_string);
903   m = a68_proc (MODE (REF_STRING), MODE (STRING), MODE (REF_STRING), NO_MOID);
904   a68_op (A68_STD, "+=:", m, genie_plusto_string);
905   a68_op (A68_STD, "PLUSTO", m, genie_plusto_string);
906   m = a68_proc (MODE (STRING), MODE (STRING), MODE (INT), NO_MOID);
907   a68_op (A68_STD, "*", m, genie_times_string_int);
908   m = a68_proc (MODE (STRING), MODE (INT), MODE (STRING), NO_MOID);
909   a68_op (A68_STD, "*", m, genie_times_int_string);
910   m = a68_proc (MODE (STRING), MODE (INT), MODE (CHAR), NO_MOID);
911   a68_op (A68_STD, "*", m, genie_times_int_char);
912   m = a68_proc (MODE (STRING), MODE (CHAR), MODE (INT), NO_MOID);
913   a68_op (A68_STD, "*", m, genie_times_char_int);
914   m = a68_proc (MODE (CHAR), MODE (INT), MODE (ROW_CHAR), NO_MOID);
915   a68_op (A68_STD, "ELEM", m, genie_elem_string);
916 /* SEMA ops */
917 #if defined HAVE_PARALLEL_CLAUSE
918   m = a68_proc (MODE (SEMA), MODE (INT), NO_MOID);
919   a68_op (A68_STD, "LEVEL", m, genie_level_sema_int);
920   m = a68_proc (MODE (INT), MODE (SEMA), NO_MOID);
921   a68_op (A68_STD, "LEVEL", m, genie_level_int_sema);
922   m = a68_proc (MODE (VOID), MODE (SEMA), NO_MOID);
923   a68_op (A68_STD, "UP", m, genie_up_sema);
924   a68_op (A68_STD, "DOWN", m, genie_down_sema);
925 #else
926   m = a68_proc (MODE (SEMA), MODE (INT), NO_MOID);
927   a68_op (A68_STD, "LEVEL", m, genie_unimplemented);
928   m = a68_proc (MODE (INT), MODE (SEMA), NO_MOID);
929   a68_op (A68_STD, "LEVEL", m, genie_unimplemented);
930   m = a68_proc (MODE (VOID), MODE (SEMA), NO_MOID);
931   a68_op (A68_STD, "UP", m, genie_unimplemented);
932   a68_op (A68_STD, "DOWN", m, genie_unimplemented);
933 #endif
934 /* ROWS ops */
935   m = a68_proc (MODE (INT), MODE (ROWS), NO_MOID);
936   a68_op (A68_EXT, "ELEMS", m, genie_monad_elems);
937   a68_op (A68_STD, "LWB", m, genie_monad_lwb);
938   a68_op (A68_STD, "UPB", m, genie_monad_upb);
939   m = a68_proc (MODE (INT), MODE (INT), MODE (ROWS), NO_MOID);
940   a68_op (A68_EXT, "ELEMS", m, genie_dyad_elems);
941   a68_op (A68_STD, "LWB", m, genie_dyad_lwb);
942   a68_op (A68_STD, "UPB", m, genie_dyad_upb);
943   m = a68_proc (MODE (ROW_STRING), MODE (ROW_STRING), NO_MOID);
944   a68_op (A68_EXT, "SORT", m, genie_sort_row_string);
945 /* Binding for the multiple-precision library */
946 /* LONG INT */
947   m = a68_proc (MODE (LONG_INT), MODE (INT), NO_MOID);
948   a68_op (A68_STD, "LENG", m, genie_lengthen_int_to_long_mp);
949   m = a68_proc (MODE (LONG_INT), MODE (LONG_INT), NO_MOID);
950   a68_op (A68_STD, "+", m, genie_idle);
951   a68_op (A68_STD, "-", m, genie_minus_long_mp);
952   a68_op (A68_STD, "ABS", m, genie_abs_long_mp);
953   m = a68_proc (MODE (INT), MODE (LONG_INT), NO_MOID);
954   a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_mp_to_int);
955   a68_op (A68_STD, "SIGN", m, genie_sign_long_mp);
956   m = a68_proc (MODE (BOOL), MODE (LONG_INT), NO_MOID);
957   a68_op (A68_STD, "ODD", m, genie_odd_long_mp);
958   m = a68_proc (MODE (LONG_INT), MODE (LONG_REAL), NO_MOID);
959   a68_op (A68_STD, "ENTIER", m, genie_entier_long_mp);
960   a68_op (A68_STD, "ROUND", m, genie_round_long_mp);
961   m = a68_proc (MODE (LONG_INT), MODE (LONG_INT), MODE (LONG_INT), NO_MOID);
962   a68_op (A68_STD, "+", m, genie_add_long_int);
963   a68_op (A68_STD, "-", m, genie_sub_long_int);
964   a68_op (A68_STD, "*", m, genie_mul_long_int);
965   a68_op (A68_STD, "OVER", m, genie_over_long_mp);
966   a68_op (A68_STD, "%", m, genie_over_long_mp);
967   a68_op (A68_STD, "MOD", m, genie_mod_long_mp);
968   a68_op (A68_STD, "%*", m, genie_mod_long_mp);
969   m = a68_proc (MODE (REF_LONG_INT), MODE (REF_LONG_INT), MODE (LONG_INT), NO_MOID);
970   a68_op (A68_STD, "+:=", m, genie_plusab_long_int);
971   a68_op (A68_STD, "-:=", m, genie_minusab_long_int);
972   a68_op (A68_STD, "*:=", m, genie_timesab_long_int);
973   a68_op (A68_STD, "%:=", m, genie_overab_long_mp);
974   a68_op (A68_STD, "%*:=", m, genie_modab_long_mp);
975   a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_int);
976   a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_int);
977   a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_int);
978   a68_op (A68_STD, "OVERAB", m, genie_overab_long_mp);
979   a68_op (A68_STD, "MODAB", m, genie_modab_long_mp);
980   m = a68_proc (MODE (BOOL), MODE (LONG_INT), MODE (LONG_INT), NO_MOID);
981   a68_op (A68_STD, "=", m, genie_eq_long_mp);
982   a68_op (A68_STD, "EQ", m, genie_eq_long_mp);
983   a68_op (A68_STD, "/=", m, genie_ne_long_mp);
984   a68_op (A68_STD, "~=", m, genie_ne_long_mp);
985   a68_op (A68_STD, "^=", m, genie_ne_long_mp);
986   a68_op (A68_STD, "NE", m, genie_ne_long_mp);
987   a68_op (A68_STD, "<", m, genie_lt_long_mp);
988   a68_op (A68_STD, "LT", m, genie_lt_long_mp);
989   a68_op (A68_STD, "<=", m, genie_le_long_mp);
990   a68_op (A68_STD, "LE", m, genie_le_long_mp);
991   a68_op (A68_STD, ">", m, genie_gt_long_mp);
992   a68_op (A68_STD, "GT", m, genie_gt_long_mp);
993   a68_op (A68_STD, ">=", m, genie_ge_long_mp);
994   a68_op (A68_STD, "GE", m, genie_ge_long_mp);
995   m = a68_proc (MODE (LONG_REAL), MODE (LONG_INT), MODE (LONG_INT), NO_MOID);
996   a68_op (A68_STD, "/", m, genie_div_long_mp);
997   m = a68_proc (MODE (LONG_INT), MODE (LONG_INT), MODE (INT), NO_MOID);
998   a68_op (A68_STD, "**", m, genie_pow_long_mp_int_int);
999   a68_op (A68_STD, "^", m, genie_pow_long_mp_int_int);
1000   m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_INT), MODE (LONG_INT), NO_MOID);
1001   a68_op (A68_STD, "I", m, genie_idle);
1002   a68_op (A68_STD, "+*", m, genie_idle);
1003 /* LONG REAL */
1004   m = a68_proc (MODE (LONG_REAL), MODE (REAL), NO_MOID);
1005   a68_op (A68_STD, "LENG", m, genie_lengthen_real_to_long_mp);
1006   m = a68_proc (MODE (REAL), MODE (LONG_REAL), NO_MOID);
1007   a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_mp_to_real);
1008   m = a68_proc (MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID);
1009   a68_op (A68_STD, "+", m, genie_idle);
1010   a68_op (A68_STD, "-", m, genie_minus_long_mp);
1011   a68_op (A68_STD, "ABS", m, genie_abs_long_mp);
1012   a68_idf (A68_STD, "longsqrt", m, genie_sqrt_long_mp);
1013   a68_idf (A68_EXT, "longcbrt", m, genie_curt_long_mp);
1014   a68_idf (A68_EXT, "longcurt", m, genie_curt_long_mp);
1015   a68_idf (A68_STD, "longexp", m, genie_exp_long_mp);
1016   a68_idf (A68_STD, "longln", m, genie_ln_long_mp);
1017   a68_idf (A68_STD, "longlog", m, genie_log_long_mp);
1018   a68_idf (A68_STD, "longsin", m, genie_sin_long_mp);
1019   a68_idf (A68_STD, "longcos", m, genie_cos_long_mp);
1020   a68_idf (A68_STD, "longtan", m, genie_tan_long_mp);
1021   a68_idf (A68_STD, "longasin", m, genie_asin_long_mp);
1022   a68_idf (A68_STD, "longacos", m, genie_acos_long_mp);
1023   a68_idf (A68_STD, "longatan", m, genie_atan_long_mp);
1024   a68_idf (A68_STD, "longarcsin", m, genie_asin_long_mp);
1025   a68_idf (A68_STD, "longarccos", m, genie_acos_long_mp);
1026   a68_idf (A68_STD, "longarctan", m, genie_atan_long_mp);
1027   a68_idf (A68_EXT, "longsinh", m, genie_sinh_long_mp);
1028   a68_idf (A68_EXT, "longcosh", m, genie_cosh_long_mp);
1029   a68_idf (A68_EXT, "longtanh", m, genie_tanh_long_mp);
1030   a68_idf (A68_EXT, "longasinh", m, genie_arcsinh_long_mp);
1031   a68_idf (A68_EXT, "longacosh", m, genie_arccosh_long_mp);
1032   a68_idf (A68_EXT, "longatanh", m, genie_arctanh_long_mp);
1033   a68_idf (A68_EXT, "longarcsinh", m, genie_arcsinh_long_mp);
1034   a68_idf (A68_EXT, "longarccosh", m, genie_arccosh_long_mp);
1035   a68_idf (A68_EXT, "longarctanh", m, genie_arctanh_long_mp);
1036   a68_idf (A68_EXT, "dsqrt", m, genie_sqrt_long_mp);
1037   a68_idf (A68_EXT, "dcbrt", m, genie_curt_long_mp);
1038   a68_idf (A68_EXT, "dcurt", m, genie_curt_long_mp);
1039   a68_idf (A68_EXT, "dexp", m, genie_exp_long_mp);
1040   a68_idf (A68_EXT, "dln", m, genie_ln_long_mp);
1041   a68_idf (A68_EXT, "dlog", m, genie_log_long_mp);
1042   a68_idf (A68_EXT, "dsin", m, genie_sin_long_mp);
1043   a68_idf (A68_EXT, "dcos", m, genie_cos_long_mp);
1044   a68_idf (A68_EXT, "dtan", m, genie_tan_long_mp);
1045   a68_idf (A68_EXT, "dasin", m, genie_asin_long_mp);
1046   a68_idf (A68_EXT, "dacos", m, genie_acos_long_mp);
1047   a68_idf (A68_EXT, "datan", m, genie_atan_long_mp);
1048   a68_idf (A68_EXT, "dsinh", m, genie_sinh_long_mp);
1049   a68_idf (A68_EXT, "dcosh", m, genie_cosh_long_mp);
1050   a68_idf (A68_EXT, "dtanh", m, genie_tanh_long_mp);
1051   a68_idf (A68_EXT, "dasinh", m, genie_arcsinh_long_mp);
1052   a68_idf (A68_EXT, "dacosh", m, genie_arccosh_long_mp);
1053   a68_idf (A68_EXT, "datanh", m, genie_arctanh_long_mp);
1054   m = a68_proc (MODE (LONG_REAL), MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID);
1055   a68_idf (A68_STD, "longarctan2", m, genie_atan2_long_mp);
1056   a68_idf (A68_STD, "darctan2", m, genie_atan2_long_mp);
1057   m = a68_proc (MODE (INT), MODE (LONG_REAL), NO_MOID);
1058   a68_op (A68_STD, "SIGN", m, genie_sign_long_mp);
1059   m = a68_proc (MODE (LONG_REAL), MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID);
1060   a68_op (A68_STD, "+", m, genie_add_long_mp);
1061   a68_op (A68_STD, "-", m, genie_sub_long_mp);
1062   a68_op (A68_STD, "*", m, genie_mul_long_mp);
1063   a68_op (A68_STD, "/", m, genie_div_long_mp);
1064   a68_op (A68_STD, "**", m, genie_pow_long_mp);
1065   a68_op (A68_STD, "UP", m, genie_pow_long_mp);
1066   a68_op (A68_STD, "^", m, genie_pow_long_mp);
1067   m = a68_proc (MODE (REF_LONG_REAL), MODE (REF_LONG_REAL), MODE (LONG_REAL), NO_MOID);
1068   a68_op (A68_STD, "+:=", m, genie_plusab_long_mp);
1069   a68_op (A68_STD, "-:=", m, genie_minusab_long_mp);
1070   a68_op (A68_STD, "*:=", m, genie_timesab_long_mp);
1071   a68_op (A68_STD, "/:=", m, genie_divab_long_mp);
1072   a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_mp);
1073   a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_mp);
1074   a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_mp);
1075   a68_op (A68_STD, "DIVAB", m, genie_divab_long_mp);
1076   m = a68_proc (MODE (BOOL), MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID);
1077   a68_op (A68_STD, "=", m, genie_eq_long_mp);
1078   a68_op (A68_STD, "EQ", m, genie_eq_long_mp);
1079   a68_op (A68_STD, "/=", m, genie_ne_long_mp);
1080   a68_op (A68_STD, "~=", m, genie_ne_long_mp);
1081   a68_op (A68_STD, "^=", m, genie_ne_long_mp);
1082   a68_op (A68_STD, "NE", m, genie_ne_long_mp);
1083   a68_op (A68_STD, "<", m, genie_lt_long_mp);
1084   a68_op (A68_STD, "LT", m, genie_lt_long_mp);
1085   a68_op (A68_STD, "<=", m, genie_le_long_mp);
1086   a68_op (A68_STD, "LE", m, genie_le_long_mp);
1087   a68_op (A68_STD, ">", m, genie_gt_long_mp);
1088   a68_op (A68_STD, "GT", m, genie_gt_long_mp);
1089   a68_op (A68_STD, ">=", m, genie_ge_long_mp);
1090   a68_op (A68_STD, "GE", m, genie_ge_long_mp);
1091   m = a68_proc (MODE (LONG_REAL), MODE (LONG_REAL), MODE (INT), NO_MOID);
1092   a68_op (A68_STD, "**", m, genie_pow_long_mp_int);
1093   a68_op (A68_STD, "UP", m, genie_pow_long_mp_int);
1094   a68_op (A68_STD, "^", m, genie_pow_long_mp_int);
1095   m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID);
1096   a68_op (A68_STD, "I", m, genie_idle);
1097   a68_op (A68_STD, "+*", m, genie_idle);
1098 /* LONG COMPLEX */
1099   m = a68_proc (MODE (LONG_COMPLEX), MODE (COMPLEX), NO_MOID);
1100   a68_op (A68_STD, "LENG", m, genie_lengthen_complex_to_long_complex);
1101   m = a68_proc (MODE (COMPLEX), MODE (LONG_COMPLEX), NO_MOID);
1102   a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_complex_to_complex);
1103   m = a68_proc (MODE (LONG_REAL), MODE (LONG_COMPLEX), NO_MOID);
1104   a68_op (A68_STD, "RE", m, genie_re_long_complex);
1105   a68_op (A68_STD, "IM", m, genie_im_long_complex);
1106   a68_op (A68_STD, "ARG", m, genie_arg_long_complex);
1107   a68_op (A68_STD, "ABS", m, genie_abs_long_complex);
1108   m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID);
1109   a68_op (A68_STD, "+", m, genie_idle);
1110   a68_op (A68_STD, "-", m, genie_minus_long_complex);
1111   a68_op (A68_STD, "CONJ", m, genie_conj_long_complex);
1112   m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID);
1113   a68_op (A68_STD, "+", m, genie_add_long_complex);
1114   a68_op (A68_STD, "-", m, genie_sub_long_complex);
1115   a68_op (A68_STD, "*", m, genie_mul_long_complex);
1116   a68_op (A68_STD, "/", m, genie_div_long_complex);
1117   m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), MODE (INT), NO_MOID);
1118   a68_op (A68_STD, "**", m, genie_pow_long_complex_int);
1119   a68_op (A68_STD, "UP", m, genie_pow_long_complex_int);
1120   a68_op (A68_STD, "^", m, genie_pow_long_complex_int);
1121   m = a68_proc (MODE (BOOL), MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID);
1122   a68_op (A68_STD, "=", m, genie_eq_long_complex);
1123   a68_op (A68_STD, "EQ", m, genie_eq_long_complex);
1124   a68_op (A68_STD, "/=", m, genie_ne_long_complex);
1125   a68_op (A68_STD, "~=", m, genie_ne_long_complex);
1126   a68_op (A68_STD, "^=", m, genie_ne_long_complex);
1127   a68_op (A68_STD, "NE", m, genie_ne_long_complex);
1128   m = a68_proc (MODE (REF_LONG_COMPLEX), MODE (REF_LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID);
1129   a68_op (A68_STD, "+:=", m, genie_plusab_long_complex);
1130   a68_op (A68_STD, "-:=", m, genie_minusab_long_complex);
1131   a68_op (A68_STD, "*:=", m, genie_timesab_long_complex);
1132   a68_op (A68_STD, "/:=", m, genie_divab_long_complex);
1133   a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_complex);
1134   a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_complex);
1135   a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_complex);
1136   a68_op (A68_STD, "DIVAB", m, genie_divab_long_complex);
1137 /* LONG BITS ops */
1138   m = a68_proc (MODE (LONG_INT), MODE (LONG_BITS), NO_MOID);
1139   a68_op (A68_STD, "ABS", m, genie_idle);
1140   m = a68_proc (MODE (LONG_BITS), MODE (LONG_INT), NO_MOID);
1141   a68_op (A68_STD, "BIN", m, genie_bin_long_mp);
1142   m = a68_proc (MODE (BITS), MODE (LONG_BITS), NO_MOID);
1143   a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_mp_to_bits);
1144   m = a68_proc (MODE (LONG_BITS), MODE (BITS), NO_MOID);
1145   a68_op (A68_STD, "LENG", m, genie_lengthen_unsigned_to_long_mp);
1146   m = a68_proc (MODE (LONGLONG_BITS), MODE (LONG_BITS), NO_MOID);
1147   a68_op (A68_STD, "LENG", m, genie_lengthen_long_mp_to_longlong_mp);
1148   m = a68_proc (MODE (LONG_BITS), MODE (LONG_BITS), NO_MOID);
1149   a68_op (A68_STD, "NOT", m, genie_not_long_mp);
1150   a68_op (A68_STD, "~", m, genie_not_long_mp);
1151   m = a68_proc (MODE (BOOL), MODE (LONG_BITS), MODE (LONG_BITS), NO_MOID);
1152   a68_op (A68_STD, "=", m, genie_eq_long_mp);
1153   a68_op (A68_STD, "EQ", m, genie_eq_long_mp);
1154   a68_op (A68_STD, "/=", m, genie_ne_long_mp);
1155   a68_op (A68_STD, "~=", m, genie_ne_long_mp);
1156   a68_op (A68_STD, "^=", m, genie_ne_long_mp);
1157   a68_op (A68_STD, "NE", m, genie_ne_long_mp);
1158   a68_op (A68_STD, "<=", m, genie_le_long_bits);
1159   a68_op (A68_STD, "LE", m, genie_le_long_bits);
1160   a68_op (A68_STD, ">=", m, genie_ge_long_bits);
1161   a68_op (A68_STD, "GE", m, genie_ge_long_bits);
1162   m = a68_proc (MODE (LONG_BITS), MODE (LONG_BITS), MODE (LONG_BITS), NO_MOID);
1163   a68_op (A68_STD, "AND", m, genie_and_long_mp);
1164   a68_op (A68_STD, "&", m, genie_and_long_mp);
1165   a68_op (A68_STD, "OR", m, genie_or_long_mp);
1166   a68_op (A68_EXT, "XOR", m, genie_xor_long_mp);
1167   m = a68_proc (MODE (LONG_BITS), MODE (LONG_BITS), MODE (INT), NO_MOID);
1168   a68_op (A68_STD, "SHL", m, genie_shl_long_mp);
1169   a68_op (A68_STD, "UP", m, genie_shl_long_mp);
1170   a68_op (A68_STD, "SHR", m, genie_shr_long_mp);
1171   a68_op (A68_STD, "DOWN", m, genie_shr_long_mp);
1172   m = a68_proc (MODE (BOOL), MODE (INT), MODE (LONG_BITS), NO_MOID);
1173   a68_op (A68_STD, "ELEM", m, genie_elem_long_bits);
1174   m = a68_proc (MODE (LONG_BITS), MODE (INT), MODE (LONG_BITS), NO_MOID);
1175   a68_op (A68_STD, "SET", m, genie_set_long_bits);
1176   a68_op (A68_STD, "CLEAR", m, genie_clear_long_bits);
1177 /* LONG LONG INT */
1178   m = a68_proc (MODE (LONGLONG_INT), MODE (LONG_INT), NO_MOID);
1179   a68_op (A68_STD, "LENG", m, genie_lengthen_long_mp_to_longlong_mp);
1180   m = a68_proc (MODE (LONG_INT), MODE (LONGLONG_INT), NO_MOID);
1181   a68_op (A68_STD, "SHORTEN", m, genie_shorten_longlong_mp_to_long_mp);
1182   m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID);
1183   a68_op (A68_STD, "+", m, genie_idle);
1184   a68_op (A68_STD, "-", m, genie_minus_long_mp);
1185   a68_op (A68_STD, "ABS", m, genie_abs_long_mp);
1186   m = a68_proc (MODE (INT), MODE (LONGLONG_INT), NO_MOID);
1187   a68_op (A68_STD, "SIGN", m, genie_sign_long_mp);
1188   m = a68_proc (MODE (BOOL), MODE (LONGLONG_INT), NO_MOID);
1189   a68_op (A68_STD, "ODD", m, genie_odd_long_mp);
1190   m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_REAL), NO_MOID);
1191   a68_op (A68_STD, "ENTIER", m, genie_entier_long_mp);
1192   a68_op (A68_STD, "ROUND", m, genie_round_long_mp);
1193   m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID);
1194   a68_op (A68_STD, "+", m, genie_add_long_int);
1195   a68_op (A68_STD, "-", m, genie_sub_long_int);
1196   a68_op (A68_STD, "*", m, genie_mul_long_int);
1197   a68_op (A68_STD, "OVER", m, genie_over_long_mp);
1198   a68_op (A68_STD, "%", m, genie_over_long_mp);
1199   a68_op (A68_STD, "MOD", m, genie_mod_long_mp);
1200   a68_op (A68_STD, "%*", m, genie_mod_long_mp);
1201   m = a68_proc (MODE (REF_LONGLONG_INT), MODE (REF_LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID);
1202   a68_op (A68_STD, "+:=", m, genie_plusab_long_int);
1203   a68_op (A68_STD, "-:=", m, genie_minusab_long_int);
1204   a68_op (A68_STD, "*:=", m, genie_timesab_long_int);
1205   a68_op (A68_STD, "%:=", m, genie_overab_long_mp);
1206   a68_op (A68_STD, "%*:=", m, genie_modab_long_mp);
1207   a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_int);
1208   a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_int);
1209   a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_int);
1210   a68_op (A68_STD, "OVERAB", m, genie_overab_long_mp);
1211   a68_op (A68_STD, "MODAB", m, genie_modab_long_mp);
1212   m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID);
1213   a68_op (A68_STD, "/", m, genie_div_long_mp);
1214   m = a68_proc (MODE (BOOL), MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID);
1215   a68_op (A68_STD, "=", m, genie_eq_long_mp);
1216   a68_op (A68_STD, "EQ", m, genie_eq_long_mp);
1217   a68_op (A68_STD, "/=", m, genie_ne_long_mp);
1218   a68_op (A68_STD, "~=", m, genie_ne_long_mp);
1219   a68_op (A68_STD, "^=", m, genie_ne_long_mp);
1220   a68_op (A68_STD, "NE", m, genie_ne_long_mp);
1221   a68_op (A68_STD, "<", m, genie_lt_long_mp);
1222   a68_op (A68_STD, "LT", m, genie_lt_long_mp);
1223   a68_op (A68_STD, "<=", m, genie_le_long_mp);
1224   a68_op (A68_STD, "LE", m, genie_le_long_mp);
1225   a68_op (A68_STD, ">", m, genie_gt_long_mp);
1226   a68_op (A68_STD, "GT", m, genie_gt_long_mp);
1227   a68_op (A68_STD, ">=", m, genie_ge_long_mp);
1228   a68_op (A68_STD, "GE", m, genie_ge_long_mp);
1229   m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_INT), MODE (INT), NO_MOID);
1230   a68_op (A68_STD, "**", m, genie_pow_long_mp_int_int);
1231   a68_op (A68_STD, "^", m, genie_pow_long_mp_int_int);
1232   m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID);
1233   a68_op (A68_STD, "I", m, genie_idle);
1234   a68_op (A68_STD, "+*", m, genie_idle);
1235 /* LONG LONG REAL */
1236   m = a68_proc (MODE (LONGLONG_REAL), MODE (LONG_REAL), NO_MOID);
1237   a68_op (A68_STD, "LENG", m, genie_lengthen_long_mp_to_longlong_mp);
1238   m = a68_proc (MODE (LONG_REAL), MODE (LONGLONG_REAL), NO_MOID);
1239   a68_op (A68_STD, "SHORTEN", m, genie_shorten_longlong_mp_to_long_mp);
1240   m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID);
1241   a68_op (A68_STD, "+", m, genie_idle);
1242   a68_op (A68_STD, "-", m, genie_minus_long_mp);
1243   a68_op (A68_STD, "ABS", m, genie_abs_long_mp);
1244   a68_idf (A68_STD, "longlongsqrt", m, genie_sqrt_long_mp);
1245   a68_idf (A68_EXT, "longlongcbrt", m, genie_curt_long_mp);
1246   a68_idf (A68_EXT, "longlongcurt", m, genie_curt_long_mp);
1247   a68_idf (A68_STD, "longlongexp", m, genie_exp_long_mp);
1248   a68_idf (A68_STD, "longlongln", m, genie_ln_long_mp);
1249   a68_idf (A68_STD, "longlonglog", m, genie_log_long_mp);
1250   a68_idf (A68_STD, "longlongsin", m, genie_sin_long_mp);
1251   a68_idf (A68_STD, "longlongcos", m, genie_cos_long_mp);
1252   a68_idf (A68_STD, "longlongtan", m, genie_tan_long_mp);
1253   a68_idf (A68_STD, "longlongasin", m, genie_asin_long_mp);
1254   a68_idf (A68_STD, "longlongacos", m, genie_acos_long_mp);
1255   a68_idf (A68_STD, "longlongatan", m, genie_atan_long_mp);
1256   a68_idf (A68_STD, "longlongarcsin", m, genie_asin_long_mp);
1257   a68_idf (A68_STD, "longlongarccos", m, genie_acos_long_mp);
1258   a68_idf (A68_STD, "longlongarctan", m, genie_atan_long_mp);
1259   a68_idf (A68_EXT, "longlongsinh", m, genie_sinh_long_mp);
1260   a68_idf (A68_EXT, "longlongcosh", m, genie_cosh_long_mp);
1261   a68_idf (A68_EXT, "longlongtanh", m, genie_tanh_long_mp);
1262   a68_idf (A68_EXT, "longlongasinh", m, genie_arcsinh_long_mp);
1263   a68_idf (A68_EXT, "longlongacosh", m, genie_arccosh_long_mp);
1264   a68_idf (A68_EXT, "longlongatanh", m, genie_arctanh_long_mp);
1265   a68_idf (A68_EXT, "longlongarcsinh", m, genie_arcsinh_long_mp);
1266   a68_idf (A68_EXT, "longlongarccosh", m, genie_arccosh_long_mp);
1267   a68_idf (A68_EXT, "longlongarctanh", m, genie_arctanh_long_mp);
1268   a68_idf (A68_EXT, "qsqrt", m, genie_sqrt_long_mp);
1269   a68_idf (A68_EXT, "qcbrt", m, genie_curt_long_mp);
1270   a68_idf (A68_EXT, "qcurt", m, genie_curt_long_mp);
1271   a68_idf (A68_EXT, "qexp", m, genie_exp_long_mp);
1272   a68_idf (A68_EXT, "qln", m, genie_ln_long_mp);
1273   a68_idf (A68_EXT, "qlog", m, genie_log_long_mp);
1274   a68_idf (A68_EXT, "qsin", m, genie_sin_long_mp);
1275   a68_idf (A68_EXT, "qcos", m, genie_cos_long_mp);
1276   a68_idf (A68_EXT, "qtan", m, genie_tan_long_mp);
1277   a68_idf (A68_EXT, "qasin", m, genie_asin_long_mp);
1278   a68_idf (A68_EXT, "qacos", m, genie_acos_long_mp);
1279   a68_idf (A68_EXT, "qatan", m, genie_atan_long_mp);
1280   a68_idf (A68_EXT, "qsinh", m, genie_sinh_long_mp);
1281   a68_idf (A68_EXT, "qcosh", m, genie_cosh_long_mp);
1282   a68_idf (A68_EXT, "qtanh", m, genie_tanh_long_mp);
1283   a68_idf (A68_EXT, "qasinh", m, genie_arcsinh_long_mp);
1284   a68_idf (A68_EXT, "qacosh", m, genie_arccosh_long_mp);
1285   a68_idf (A68_EXT, "qatanh", m, genie_arctanh_long_mp);
1286   m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID);
1287   a68_idf (A68_STD, "longlongarctan2", m, genie_atan2_long_mp);
1288   a68_idf (A68_STD, "qarctan2", m, genie_atan2_long_mp);
1289   m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID);
1290   a68_op (A68_STD, "+", m, genie_add_long_mp);
1291   a68_op (A68_STD, "-", m, genie_sub_long_mp);
1292   a68_op (A68_STD, "*", m, genie_mul_long_mp);
1293   a68_op (A68_STD, "/", m, genie_div_long_mp);
1294   a68_op (A68_STD, "**", m, genie_pow_long_mp);
1295   a68_op (A68_STD, "UP", m, genie_pow_long_mp);
1296   a68_op (A68_STD, "^", m, genie_pow_long_mp);
1297   m = a68_proc (MODE (REF_LONGLONG_REAL), MODE (REF_LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID);
1298   a68_op (A68_STD, "+:=", m, genie_plusab_long_mp);
1299   a68_op (A68_STD, "-:=", m, genie_minusab_long_mp);
1300   a68_op (A68_STD, "*:=", m, genie_timesab_long_mp);
1301   a68_op (A68_STD, "/:=", m, genie_divab_long_mp);
1302   a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_mp);
1303   a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_mp);
1304   a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_mp);
1305   a68_op (A68_STD, "DIVAB", m, genie_divab_long_mp);
1306   m = a68_proc (MODE (BOOL), MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID);
1307   a68_op (A68_STD, "=", m, genie_eq_long_mp);
1308   a68_op (A68_STD, "EQ", m, genie_eq_long_mp);
1309   a68_op (A68_STD, "/=", m, genie_ne_long_mp);
1310   a68_op (A68_STD, "~=", m, genie_ne_long_mp);
1311   a68_op (A68_STD, "^=", m, genie_ne_long_mp);
1312   a68_op (A68_STD, "NE", m, genie_ne_long_mp);
1313   a68_op (A68_STD, "<", m, genie_lt_long_mp);
1314   a68_op (A68_STD, "LT", m, genie_lt_long_mp);
1315   a68_op (A68_STD, "<=", m, genie_le_long_mp);
1316   a68_op (A68_STD, "LE", m, genie_le_long_mp);
1317   a68_op (A68_STD, ">", m, genie_gt_long_mp);
1318   a68_op (A68_STD, "GT", m, genie_gt_long_mp);
1319   a68_op (A68_STD, ">=", m, genie_ge_long_mp);
1320   a68_op (A68_STD, "GE", m, genie_ge_long_mp);
1321   m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), MODE (INT), NO_MOID);
1322   a68_op (A68_STD, "**", m, genie_pow_long_mp_int);
1323   a68_op (A68_STD, "UP", m, genie_pow_long_mp_int);
1324   a68_op (A68_STD, "^", m, genie_pow_long_mp_int);
1325   m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID);
1326   a68_op (A68_STD, "I", m, genie_idle);
1327   a68_op (A68_STD, "+*", m, genie_idle);
1328 /* LONGLONG COMPLEX */
1329   m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID);
1330   a68_op (A68_STD, "LENG", m, genie_lengthen_long_complex_to_longlong_complex);
1331   m = a68_proc (MODE (LONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID);
1332   a68_op (A68_STD, "SHORTEN", m, genie_shorten_longlong_complex_to_long_complex);
1333   m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_COMPLEX), NO_MOID);
1334   a68_op (A68_STD, "RE", m, genie_re_long_complex);
1335   a68_op (A68_STD, "IM", m, genie_im_long_complex);
1336   a68_op (A68_STD, "ARG", m, genie_arg_long_complex);
1337   a68_op (A68_STD, "ABS", m, genie_abs_long_complex);
1338   m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID);
1339   a68_op (A68_STD, "+", m, genie_idle);
1340   a68_op (A68_STD, "-", m, genie_minus_long_complex);
1341   a68_op (A68_STD, "CONJ", m, genie_conj_long_complex);
1342   m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID);
1343   a68_op (A68_STD, "+", m, genie_add_long_complex);
1344   a68_op (A68_STD, "-", m, genie_sub_long_complex);
1345   a68_op (A68_STD, "*", m, genie_mul_long_complex);
1346   a68_op (A68_STD, "/", m, genie_div_long_complex);
1347   m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), MODE (INT), NO_MOID);
1348   a68_op (A68_STD, "**", m, genie_pow_long_complex_int);
1349   a68_op (A68_STD, "UP", m, genie_pow_long_complex_int);
1350   a68_op (A68_STD, "^", m, genie_pow_long_complex_int);
1351   m = a68_proc (MODE (BOOL), MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID);
1352   a68_op (A68_STD, "=", m, genie_eq_long_complex);
1353   a68_op (A68_STD, "EQ", m, genie_eq_long_complex);
1354   a68_op (A68_STD, "/=", m, genie_ne_long_complex);
1355   a68_op (A68_STD, "~=", m, genie_ne_long_complex);
1356   a68_op (A68_STD, "^=", m, genie_ne_long_complex);
1357   a68_op (A68_STD, "NE", m, genie_ne_long_complex);
1358   m = a68_proc (MODE (REF_LONGLONG_COMPLEX), MODE (REF_LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID);
1359   a68_op (A68_STD, "+:=", m, genie_plusab_long_complex);
1360   a68_op (A68_STD, "-:=", m, genie_minusab_long_complex);
1361   a68_op (A68_STD, "*:=", m, genie_timesab_long_complex);
1362   a68_op (A68_STD, "/:=", m, genie_divab_long_complex);
1363   a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_complex);
1364   a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_complex);
1365   a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_complex);
1366   a68_op (A68_STD, "DIVAB", m, genie_divab_long_complex);
1367 /* LONG LONG BITS */
1368   m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_BITS), NO_MOID);
1369   a68_op (A68_STD, "ABS", m, genie_idle);
1370   m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_INT), NO_MOID);
1371   a68_op (A68_STD, "BIN", m, genie_bin_long_mp);
1372   m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), NO_MOID);
1373   a68_op (A68_STD, "NOT", m, genie_not_long_mp);
1374   a68_op (A68_STD, "~", m, genie_not_long_mp);
1375   m = a68_proc (MODE (LONG_BITS), MODE (LONGLONG_BITS), NO_MOID);
1376   a68_op (A68_STD, "SHORTEN", m, genie_shorten_longlong_mp_to_long_mp);
1377   m = a68_proc (MODE (BOOL), MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), NO_MOID);
1378   a68_op (A68_STD, "=", m, genie_eq_long_mp);
1379   a68_op (A68_STD, "EQ", m, genie_eq_long_mp);
1380   a68_op (A68_STD, "/=", m, genie_ne_long_mp);
1381   a68_op (A68_STD, "~=", m, genie_ne_long_mp);
1382   a68_op (A68_STD, "^=", m, genie_ne_long_mp);
1383   a68_op (A68_STD, "NE", m, genie_ne_long_mp);
1384   a68_op (A68_STD, "<=", m, genie_le_long_mp);
1385   a68_op (A68_STD, "LE", m, genie_le_long_mp);
1386   a68_op (A68_STD, ">=", m, genie_ge_long_mp);
1387   a68_op (A68_STD, "GE", m, genie_ge_long_mp);
1388   m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), NO_MOID);
1389   a68_op (A68_STD, "AND", m, genie_and_long_mp);
1390   a68_op (A68_STD, "&", m, genie_and_long_mp);
1391   a68_op (A68_STD, "OR", m, genie_or_long_mp);
1392   a68_op (A68_EXT, "XOR", m, genie_xor_long_mp);
1393   m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), MODE (INT), NO_MOID);
1394   a68_op (A68_STD, "SHL", m, genie_shl_long_mp);
1395   a68_op (A68_STD, "UP", m, genie_shl_long_mp);
1396   a68_op (A68_STD, "SHR", m, genie_shr_long_mp);
1397   a68_op (A68_STD, "DOWN", m, genie_shr_long_mp);
1398   m = a68_proc (MODE (BOOL), MODE (INT), MODE (LONGLONG_BITS), NO_MOID);
1399   a68_op (A68_STD, "ELEM", m, genie_elem_longlong_bits);
1400   m = a68_proc (MODE (LONGLONG_BITS), MODE (INT), MODE (LONGLONG_BITS), NO_MOID);
1401   a68_op (A68_STD, "SET", m, genie_set_longlong_bits);
1402   a68_op (A68_STD, "CLEAR", m, genie_clear_longlong_bits);
1403 /* Some "terminators" to handle the mapping of very short or very long modes.
1404    This allows you to write SHORT REAL z = SHORTEN pi while everything is
1405    silently mapped onto REAL */
1406   m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID);
1407   a68_op (A68_STD, "LENG", m, genie_idle);
1408   m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID);
1409   a68_op (A68_STD, "LENG", m, genie_idle);
1410   m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID);
1411   a68_op (A68_STD, "LENG", m, genie_idle);
1412   m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), NO_MOID);
1413   a68_op (A68_STD, "LENG", m, genie_idle);
1414   m = a68_proc (MODE (INT), MODE (INT), NO_MOID);
1415   a68_op (A68_STD, "SHORTEN", m, genie_idle);
1416   m = a68_proc (MODE (REAL), MODE (REAL), NO_MOID);
1417   a68_op (A68_STD, "SHORTEN", m, genie_idle);
1418   m = a68_proc (MODE (COMPLEX), MODE (COMPLEX), NO_MOID);
1419   a68_op (A68_STD, "SHORTEN", m, genie_idle);
1420   m = a68_proc (MODE (BITS), MODE (BITS), NO_MOID);
1421   a68_op (A68_STD, "SHORTEN", m, genie_idle);
1422   m = proc_complex_complex;
1423   a68_idf (A68_EXT, "complexsqrt", m, genie_sqrt_complex);
1424   a68_idf (A68_EXT, "csqrt", m, genie_sqrt_complex);
1425   a68_idf (A68_EXT, "complexexp", m, genie_exp_complex);
1426   a68_idf (A68_EXT, "cexp", m, genie_exp_complex);
1427   a68_idf (A68_EXT, "complexln", m, genie_ln_complex);
1428   a68_idf (A68_EXT, "cln", m, genie_ln_complex);
1429   a68_idf (A68_EXT, "complexsin", m, genie_sin_complex);
1430   a68_idf (A68_EXT, "csin", m, genie_sin_complex);
1431   a68_idf (A68_EXT, "complexcos", m, genie_cos_complex);
1432   a68_idf (A68_EXT, "ccos", m, genie_cos_complex);
1433   a68_idf (A68_EXT, "complextan", m, genie_tan_complex);
1434   a68_idf (A68_EXT, "ctan", m, genie_tan_complex);
1435   a68_idf (A68_EXT, "complexasin", m, genie_arcsin_complex);
1436   a68_idf (A68_EXT, "casin", m, genie_arcsin_complex);
1437   a68_idf (A68_EXT, "complexacos", m, genie_arccos_complex);
1438   a68_idf (A68_EXT, "cacos", m, genie_arccos_complex);
1439   a68_idf (A68_EXT, "complexatan", m, genie_arctan_complex);
1440   a68_idf (A68_EXT, "catan", m, genie_arctan_complex);
1441   a68_idf (A68_EXT, "complexarcsin", m, genie_arcsin_complex);
1442   a68_idf (A68_EXT, "carcsin", m, genie_arcsin_complex);
1443   a68_idf (A68_EXT, "complexarccos", m, genie_arccos_complex);
1444   a68_idf (A68_EXT, "carccos", m, genie_arccos_complex);
1445   a68_idf (A68_EXT, "complexarctan", m, genie_arctan_complex);
1446   a68_idf (A68_EXT, "carctan", m, genie_arctan_complex);
1447 #if defined HAVE_GNU_GSL
1448   a68_idf (A68_EXT, "complexsinh", m, genie_sinh_complex);
1449   a68_idf (A68_EXT, "csinh", m, genie_sinh_complex);
1450   a68_idf (A68_EXT, "complexcosh", m, genie_cosh_complex);
1451   a68_idf (A68_EXT, "ccosh", m, genie_cosh_complex);
1452   a68_idf (A68_EXT, "complextanh", m, genie_tanh_complex);
1453   a68_idf (A68_EXT, "ctanh", m, genie_tanh_complex);
1454   a68_idf (A68_EXT, "complexasinh", m, genie_arcsinh_complex);
1455   a68_idf (A68_EXT, "casinh", m, genie_arcsinh_complex);
1456   a68_idf (A68_EXT, "complexacosh", m, genie_arccosh_complex);
1457   a68_idf (A68_EXT, "cacosh", m, genie_arccosh_complex);
1458   a68_idf (A68_EXT, "complexatanh", m, genie_arctanh_complex);
1459   a68_idf (A68_EXT, "catanh", m, genie_arctanh_complex);
1460   a68_idf (A68_EXT, "complexarcsinh", m, genie_arcsinh_complex);
1461   a68_idf (A68_EXT, "carcsinh", m, genie_arcsinh_complex);
1462   a68_idf (A68_EXT, "complexarccosh", m, genie_arccosh_complex);
1463   a68_idf (A68_EXT, "carccosh", m, genie_arccosh_complex);
1464   a68_idf (A68_EXT, "complexarctanh", m, genie_arctanh_complex);
1465   a68_idf (A68_EXT, "carctanh", m, genie_arctanh_complex);
1466   m = a68_proc (MODE (REAL), proc_real_real, MODE (REAL), MODE (REF_REAL), NO_MOID);
1467   a68_idf (A68_EXT, "laplace", m, genie_laplace);
1468 #endif
1469   m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID);
1470   a68_idf (A68_EXT, "longcomplexsqrt", m, genie_sqrt_long_complex);
1471   a68_idf (A68_EXT, "dcsqrt", m, genie_sqrt_long_complex);
1472   a68_idf (A68_EXT, "longcomplexexp", m, genie_exp_long_complex);
1473   a68_idf (A68_EXT, "dcexp", m, genie_exp_long_complex);
1474   a68_idf (A68_EXT, "longcomplexln", m, genie_ln_long_complex);
1475   a68_idf (A68_EXT, "dcln", m, genie_ln_long_complex);
1476   a68_idf (A68_EXT, "longcomplexsin", m, genie_sin_long_complex);
1477   a68_idf (A68_EXT, "dcsin", m, genie_sin_long_complex);
1478   a68_idf (A68_EXT, "longcomplexcos", m, genie_cos_long_complex);
1479   a68_idf (A68_EXT, "dccos", m, genie_cos_long_complex);
1480   a68_idf (A68_EXT, "longcomplextan", m, genie_tan_long_complex);
1481   a68_idf (A68_EXT, "dctan", m, genie_tan_long_complex);
1482   a68_idf (A68_EXT, "longcomplexarcsin", m, genie_asin_long_complex);
1483   a68_idf (A68_EXT, "dcasin", m, genie_asin_long_complex);
1484   a68_idf (A68_EXT, "longcomplexarccos", m, genie_acos_long_complex);
1485   a68_idf (A68_EXT, "dcacos", m, genie_acos_long_complex);
1486   a68_idf (A68_EXT, "longcomplexarctan", m, genie_atan_long_complex);
1487   a68_idf (A68_EXT, "dcatan", m, genie_atan_long_complex);
1488   m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID);
1489   a68_idf (A68_EXT, "longlongcomplexsqrt", m, genie_sqrt_long_complex);
1490   a68_idf (A68_EXT, "qcsqrt", m, genie_sqrt_long_complex);
1491   a68_idf (A68_EXT, "longlongcomplexexp", m, genie_exp_long_complex);
1492   a68_idf (A68_EXT, "qcexp", m, genie_exp_long_complex);
1493   a68_idf (A68_EXT, "longlongcomplexln", m, genie_ln_long_complex);
1494   a68_idf (A68_EXT, "qcln", m, genie_ln_long_complex);
1495   a68_idf (A68_EXT, "longlongcomplexsin", m, genie_sin_long_complex);
1496   a68_idf (A68_EXT, "qcsin", m, genie_sin_long_complex);
1497   a68_idf (A68_EXT, "longlongcomplexcos", m, genie_cos_long_complex);
1498   a68_idf (A68_EXT, "qccos", m, genie_cos_long_complex);
1499   a68_idf (A68_EXT, "longlongcomplextan", m, genie_tan_long_complex);
1500   a68_idf (A68_EXT, "qctan", m, genie_tan_long_complex);
1501   a68_idf (A68_EXT, "longlongcomplexarcsin", m, genie_asin_long_complex);
1502   a68_idf (A68_EXT, "qcasin", m, genie_asin_long_complex);
1503   a68_idf (A68_EXT, "longlongcomplexarccos", m, genie_acos_long_complex);
1504   a68_idf (A68_EXT, "qcacos", m, genie_acos_long_complex);
1505   a68_idf (A68_EXT, "longlongcomplexarctan", m, genie_atan_long_complex);
1506   a68_idf (A68_EXT, "qcatan", m, genie_atan_long_complex);
1507 /* SOUND/RIFF procs */
1508   m = a68_proc (MODE (SOUND), MODE (INT), MODE (INT), MODE (INT), MODE (INT), NO_MOID);
1509   a68_idf (A68_EXT, "newsound", m, genie_new_sound);
1510   m = a68_proc (MODE (INT), MODE (SOUND), MODE (INT), MODE (INT), NO_MOID);
1511   a68_idf (A68_EXT, "getsound", m, genie_get_sound);
1512   m = a68_proc (MODE (VOID), MODE (SOUND), MODE (INT), MODE (INT), MODE (INT), NO_MOID);
1513   a68_idf (A68_EXT, "setsound", m, genie_set_sound);
1514   m = a68_proc (MODE (INT), MODE (SOUND), NO_MOID);
1515   a68_op (A68_EXT, "RESOLUTION", m, genie_sound_resolution);
1516   a68_op (A68_EXT, "CHANNELS", m, genie_sound_channels);
1517   a68_op (A68_EXT, "RATE", m, genie_sound_rate);
1518   a68_op (A68_EXT, "SAMPLES", m, genie_sound_samples);
1519 }
1520 
1521 /**
1522 @brief Set up standenv - transput.
1523 **/
1524 
1525 static void
stand_transput(void)1526 stand_transput (void)
1527 {
1528   MOID_T *m;
1529   a68_idf (A68_STD, "errorchar", MODE (CHAR), genie_error_char);
1530   a68_idf (A68_STD, "expchar", MODE (CHAR), genie_exp_char);
1531   a68_idf (A68_STD, "flip", MODE (CHAR), genie_flip_char);
1532   a68_idf (A68_STD, "flop", MODE (CHAR), genie_flop_char);
1533   a68_idf (A68_EXT, "blankcharacter", MODE (CHAR), genie_blank_char);
1534   a68_idf (A68_STD, "blankchar", MODE (CHAR), genie_blank_char);
1535   a68_idf (A68_STD, "blank", MODE (CHAR), genie_blank_char);
1536   a68_idf (A68_EXT, "nullcharacter", MODE (CHAR), genie_null_char);
1537   a68_idf (A68_STD, "nullchar", MODE (CHAR), genie_null_char);
1538   a68_idf (A68_EXT, "newlinecharacter", MODE (CHAR), genie_newline_char);
1539   a68_idf (A68_EXT, "newlinechar", MODE (CHAR), genie_newline_char);
1540   a68_idf (A68_EXT, "formfeedcharacter", MODE (CHAR), genie_formfeed_char);
1541   a68_idf (A68_EXT, "formfeedchar", MODE (CHAR), genie_formfeed_char);
1542   a68_idf (A68_EXT, "tabcharacter", MODE (CHAR), genie_tab_char);
1543   a68_idf (A68_EXT, "tabchar", MODE (CHAR), genie_tab_char);
1544   m = a68_proc (MODE (STRING), MODE (NUMBER), MODE (INT), NO_MOID);
1545   a68_idf (A68_STD, "whole", m, genie_whole);
1546   m = a68_proc (MODE (STRING), MODE (NUMBER), MODE (INT), MODE (INT), NO_MOID);
1547   a68_idf (A68_STD, "fixed", m, genie_fixed);
1548   m = a68_proc (MODE (STRING), MODE (NUMBER), MODE (INT), MODE (INT), MODE (INT), NO_MOID);
1549   a68_idf (A68_STD, "float", m, genie_float);
1550   m = a68_proc (MODE (STRING), MODE (NUMBER), MODE (INT), MODE (INT), MODE (INT), MODE (INT), NO_MOID);
1551   a68_idf (A68_STD, "real", m, genie_real);
1552   a68_idf (A68_STD, "standin", MODE (REF_FILE), genie_stand_in);
1553   a68_idf (A68_STD, "standout", MODE (REF_FILE), genie_stand_out);
1554   a68_idf (A68_STD, "standback", MODE (REF_FILE), genie_stand_back);
1555   a68_idf (A68_EXT, "standerror", MODE (REF_FILE), genie_stand_error);
1556   a68_idf (A68_STD, "standinchannel", MODE (CHANNEL), genie_stand_in_channel);
1557   a68_idf (A68_STD, "standoutchannel", MODE (CHANNEL), genie_stand_out_channel);
1558   a68_idf (A68_EXT, "standdrawchannel", MODE (CHANNEL), genie_stand_draw_channel);
1559   a68_idf (A68_STD, "standbackchannel", MODE (CHANNEL), genie_stand_back_channel);
1560   a68_idf (A68_EXT, "standerrorchannel", MODE (CHANNEL), genie_stand_error_channel);
1561   m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (STRING), NO_MOID);
1562   a68_idf (A68_STD, "maketerm", m, genie_make_term);
1563   m = a68_proc (MODE (BOOL), MODE (CHAR), MODE (REF_INT), MODE (STRING), NO_MOID);
1564   a68_idf (A68_STD, "charinstring", m, genie_char_in_string);
1565   a68_idf (A68_EXT, "lastcharinstring", m, genie_last_char_in_string);
1566   m = a68_proc (MODE (BOOL), MODE (STRING), MODE (REF_INT), MODE (STRING), NO_MOID);
1567   a68_idf (A68_EXT, "stringinstring", m, genie_string_in_string);
1568   m = a68_proc (MODE (STRING), MODE (REF_FILE), NO_MOID);
1569   a68_idf (A68_EXT, "idf", m, genie_idf);
1570   a68_idf (A68_EXT, "term", m, genie_term);
1571   m = a68_proc (MODE (STRING), NO_MOID);
1572   a68_idf (A68_EXT, "programidf", m, genie_program_idf);
1573 /* Event routines */
1574   m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (PROC_REF_FILE_BOOL), NO_MOID);
1575   a68_idf (A68_STD, "onfileend", m, genie_on_file_end);
1576   a68_idf (A68_STD, "onpageend", m, genie_on_page_end);
1577   a68_idf (A68_STD, "onlineend", m, genie_on_line_end);
1578   a68_idf (A68_STD, "onlogicalfileend", m, genie_on_file_end);
1579   a68_idf (A68_STD, "onphysicalfileend", m, genie_on_file_end);
1580   a68_idf (A68_STD, "onformatend", m, genie_on_format_end);
1581   a68_idf (A68_STD, "onformaterror", m, genie_on_format_error);
1582   a68_idf (A68_STD, "onvalueerror", m, genie_on_value_error);
1583   a68_idf (A68_STD, "onopenerror", m, genie_on_open_error);
1584   a68_idf (A68_EXT, "ontransputerror", m, genie_on_transput_error);
1585 /* Enquiries on files */
1586   a68_idf (A68_STD, "putpossible", MODE (PROC_REF_FILE_BOOL), genie_put_possible);
1587   a68_idf (A68_STD, "getpossible", MODE (PROC_REF_FILE_BOOL), genie_get_possible);
1588   a68_idf (A68_STD, "binpossible", MODE (PROC_REF_FILE_BOOL), genie_bin_possible);
1589   a68_idf (A68_STD, "setpossible", MODE (PROC_REF_FILE_BOOL), genie_set_possible);
1590   a68_idf (A68_STD, "resetpossible", MODE (PROC_REF_FILE_BOOL), genie_reset_possible);
1591   a68_idf (A68_EXT, "rewindpossible", MODE (PROC_REF_FILE_BOOL), genie_reset_possible);
1592   a68_idf (A68_STD, "reidfpossible", MODE (PROC_REF_FILE_BOOL), genie_reidf_possible);
1593   a68_idf (A68_EXT, "drawpossible", MODE (PROC_REF_FILE_BOOL), genie_draw_possible);
1594   a68_idf (A68_STD, "compressible", MODE (PROC_REF_FILE_BOOL), genie_compressible);
1595   a68_idf (A68_EXT, "endoffile", MODE (PROC_REF_FILE_BOOL), genie_eof);
1596   a68_idf (A68_EXT, "eof", MODE (PROC_REF_FILE_BOOL), genie_eof);
1597   a68_idf (A68_EXT, "endofline", MODE (PROC_REF_FILE_BOOL), genie_eoln);
1598   a68_idf (A68_EXT, "eoln", MODE (PROC_REF_FILE_BOOL), genie_eoln);
1599 /* Handling of files */
1600   m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (STRING), MODE (CHANNEL), NO_MOID);
1601   a68_idf (A68_STD, "open", m, genie_open);
1602   a68_idf (A68_STD, "establish", m, genie_establish);
1603   m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (REF_STRING), NO_MOID);
1604   a68_idf (A68_STD, "associate", m, genie_associate);
1605   m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (CHANNEL), NO_MOID);
1606   a68_idf (A68_STD, "create", m, genie_create);
1607   a68_idf (A68_STD, "close", MODE (PROC_REF_FILE_VOID), genie_close);
1608   a68_idf (A68_STD, "lock", MODE (PROC_REF_FILE_VOID), genie_lock);
1609   a68_idf (A68_STD, "scratch", MODE (PROC_REF_FILE_VOID), genie_erase);
1610   a68_idf (A68_STD, "erase", MODE (PROC_REF_FILE_VOID), genie_erase);
1611   a68_idf (A68_STD, "reset", MODE (PROC_REF_FILE_VOID), genie_reset);
1612   a68_idf (A68_EXT, "rewind", MODE (PROC_REF_FILE_VOID), genie_reset);
1613   a68_idf (A68_STD, "scratch", MODE (PROC_REF_FILE_VOID), genie_erase);
1614   a68_idf (A68_STD, "newline", MODE (PROC_REF_FILE_VOID), genie_new_line);
1615   a68_idf (A68_STD, "newpage", MODE (PROC_REF_FILE_VOID), genie_new_page);
1616   a68_idf (A68_STD, "space", MODE (PROC_REF_FILE_VOID), genie_space);
1617   a68_idf (A68_STD, "backspace", MODE (PROC_REF_FILE_VOID), genie_backspace);
1618   m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (INT), NO_MOID);
1619   a68_idf (A68_STD, "set", m, genie_set);
1620   a68_idf (A68_STD, "seek", m, genie_set);
1621   m = a68_proc (MODE (VOID), MODE (ROW_SIMPLIN), NO_MOID);
1622   a68_idf (A68_STD, "read", m, genie_read);
1623   a68_idf (A68_STD, "readbin", m, genie_read_bin);
1624   a68_idf (A68_STD, "readf", m, genie_read_format);
1625   m = a68_proc (MODE (VOID), MODE (ROW_SIMPLOUT), NO_MOID);
1626   a68_idf (A68_STD, "print", m, genie_write);
1627   a68_idf (A68_STD, "write", m, genie_write);
1628   a68_idf (A68_STD, "printbin", m, genie_write_bin);
1629   a68_idf (A68_STD, "writebin", m, genie_write_bin);
1630   a68_idf (A68_STD, "printf", m, genie_write_format);
1631   a68_idf (A68_STD, "writef", m, genie_write_format);
1632   m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (ROW_SIMPLIN), NO_MOID);
1633   a68_idf (A68_STD, "get", m, genie_read_file);
1634   a68_idf (A68_STD, "getf", m, genie_read_file_format);
1635   a68_idf (A68_STD, "getbin", m, genie_read_bin_file);
1636   m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (ROW_SIMPLOUT), NO_MOID);
1637   a68_idf (A68_STD, "put", m, genie_write_file);
1638   a68_idf (A68_STD, "putf", m, genie_write_file_format);
1639   a68_idf (A68_STD, "putbin", m, genie_write_bin_file);
1640 /* ALGOL68C type procs */
1641 #define A68C_DEFIO(name, pname, mode)\
1642   m = a68_proc (MODE (mode), MODE (REF_FILE), NO_MOID);\
1643   a68_idf (A68_EXT, "get" #name, m, genie_get_##pname);\
1644   m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (mode), NO_MOID);\
1645   a68_idf (A68_EXT, "put" #name, m, genie_put_##pname);\
1646   m = a68_proc (MODE (mode), NO_MOID);\
1647   a68_idf (A68_EXT, "read" #name, m, genie_read_##pname);\
1648   m = a68_proc (MODE (VOID), MODE (mode), NO_MOID);\
1649   a68_idf (A68_EXT, "print" #name, m, genie_print_##pname);
1650 
1651   A68C_DEFIO (int, int, INT)
1652     A68C_DEFIO (longint, long_int, LONG_INT)
1653     A68C_DEFIO (longlongint, longlong_int, LONGLONG_INT)
1654     A68C_DEFIO (real, real, REAL)
1655     A68C_DEFIO (longreal, long_real, LONG_REAL)
1656     A68C_DEFIO (double, long_real, LONG_REAL)
1657     A68C_DEFIO (longlongreal, longlong_real, LONGLONG_REAL)
1658     A68C_DEFIO (quad, longlong_real, LONGLONG_REAL)
1659     A68C_DEFIO (compl, complex, COMPLEX)
1660     A68C_DEFIO (longcompl, long_complex, LONG_COMPLEX)
1661     A68C_DEFIO (longlongcompl, longlong_complex, LONGLONG_COMPLEX)
1662     A68C_DEFIO (complex, complex, COMPLEX)
1663     A68C_DEFIO (longcomplex, long_complex, LONG_COMPLEX)
1664     A68C_DEFIO (longlongcomplex, longlong_complex, LONGLONG_COMPLEX)
1665     A68C_DEFIO (bits, bits, BITS)
1666     A68C_DEFIO (longbits, long_bits, LONG_BITS)
1667     A68C_DEFIO (longlongbits, longlong_bits, LONGLONG_BITS)
1668     A68C_DEFIO (bool, bool, BOOL);
1669   A68C_DEFIO (char, char, CHAR);
1670   A68C_DEFIO (string, string, STRING);
1671 #undef A68C_DEFIO
1672 
1673   a68_idf (A68_EXT, "readline", MODE (PROC_STRING), genie_read_line);
1674 /* Constants ex GSL */
1675   a68_idf (A68_EXT, "cgsspeedoflight", MODE (REAL), genie_cgs_speed_of_light);
1676   a68_idf (A68_EXT, "cgsgravitationalconstant", MODE (REAL), genie_cgs_gravitational_constant);
1677   a68_idf (A68_EXT, "cgsplanckconstant", MODE (REAL), genie_cgs_planck_constant_h);
1678   a68_idf (A68_EXT, "cgsplanckconstantbar", MODE (REAL), genie_cgs_planck_constant_hbar);
1679   a68_idf (A68_EXT, "cgsastronomicalunit", MODE (REAL), genie_cgs_astronomical_unit);
1680   a68_idf (A68_EXT, "cgslightyear", MODE (REAL), genie_cgs_light_year);
1681   a68_idf (A68_EXT, "cgsparsec", MODE (REAL), genie_cgs_parsec);
1682   a68_idf (A68_EXT, "cgsgravaccel", MODE (REAL), genie_cgs_grav_accel);
1683   a68_idf (A68_EXT, "cgselectronvolt", MODE (REAL), genie_cgs_electron_volt);
1684   a68_idf (A68_EXT, "cgsmasselectron", MODE (REAL), genie_cgs_mass_electron);
1685   a68_idf (A68_EXT, "cgsmassmuon", MODE (REAL), genie_cgs_mass_muon);
1686   a68_idf (A68_EXT, "cgsmassproton", MODE (REAL), genie_cgs_mass_proton);
1687   a68_idf (A68_EXT, "cgsmassneutron", MODE (REAL), genie_cgs_mass_neutron);
1688   a68_idf (A68_EXT, "cgsrydberg", MODE (REAL), genie_cgs_rydberg);
1689   a68_idf (A68_EXT, "cgsboltzmann", MODE (REAL), genie_cgs_boltzmann);
1690   a68_idf (A68_EXT, "cgsbohrmagneton", MODE (REAL), genie_cgs_bohr_magneton);
1691   a68_idf (A68_EXT, "cgsnuclearmagneton", MODE (REAL), genie_cgs_nuclear_magneton);
1692   a68_idf (A68_EXT, "cgselectronmagneticmoment", MODE (REAL), genie_cgs_electron_magnetic_moment);
1693   a68_idf (A68_EXT, "cgsprotonmagneticmoment", MODE (REAL), genie_cgs_proton_magnetic_moment);
1694   a68_idf (A68_EXT, "cgsmolargas", MODE (REAL), genie_cgs_molar_gas);
1695   a68_idf (A68_EXT, "cgsstandardgasvolume", MODE (REAL), genie_cgs_standard_gas_volume);
1696   a68_idf (A68_EXT, "cgsminute", MODE (REAL), genie_cgs_minute);
1697   a68_idf (A68_EXT, "cgshour", MODE (REAL), genie_cgs_hour);
1698   a68_idf (A68_EXT, "cgsday", MODE (REAL), genie_cgs_day);
1699   a68_idf (A68_EXT, "cgsweek", MODE (REAL), genie_cgs_week);
1700   a68_idf (A68_EXT, "cgsinch", MODE (REAL), genie_cgs_inch);
1701   a68_idf (A68_EXT, "cgsfoot", MODE (REAL), genie_cgs_foot);
1702   a68_idf (A68_EXT, "cgsyard", MODE (REAL), genie_cgs_yard);
1703   a68_idf (A68_EXT, "cgsmile", MODE (REAL), genie_cgs_mile);
1704   a68_idf (A68_EXT, "cgsnauticalmile", MODE (REAL), genie_cgs_nautical_mile);
1705   a68_idf (A68_EXT, "cgsfathom", MODE (REAL), genie_cgs_fathom);
1706   a68_idf (A68_EXT, "cgsmil", MODE (REAL), genie_cgs_mil);
1707   a68_idf (A68_EXT, "cgspoint", MODE (REAL), genie_cgs_point);
1708   a68_idf (A68_EXT, "cgstexpoint", MODE (REAL), genie_cgs_texpoint);
1709   a68_idf (A68_EXT, "cgsmicron", MODE (REAL), genie_cgs_micron);
1710   a68_idf (A68_EXT, "cgsangstrom", MODE (REAL), genie_cgs_angstrom);
1711   a68_idf (A68_EXT, "cgshectare", MODE (REAL), genie_cgs_hectare);
1712   a68_idf (A68_EXT, "cgsacre", MODE (REAL), genie_cgs_acre);
1713   a68_idf (A68_EXT, "cgsbarn", MODE (REAL), genie_cgs_barn);
1714   a68_idf (A68_EXT, "cgsliter", MODE (REAL), genie_cgs_liter);
1715   a68_idf (A68_EXT, "cgsusgallon", MODE (REAL), genie_cgs_us_gallon);
1716   a68_idf (A68_EXT, "cgsquart", MODE (REAL), genie_cgs_quart);
1717   a68_idf (A68_EXT, "cgspint", MODE (REAL), genie_cgs_pint);
1718   a68_idf (A68_EXT, "cgscup", MODE (REAL), genie_cgs_cup);
1719   a68_idf (A68_EXT, "cgsfluidounce", MODE (REAL), genie_cgs_fluid_ounce);
1720   a68_idf (A68_EXT, "cgstablespoon", MODE (REAL), genie_cgs_tablespoon);
1721   a68_idf (A68_EXT, "cgsteaspoon", MODE (REAL), genie_cgs_teaspoon);
1722   a68_idf (A68_EXT, "cgscanadiangallon", MODE (REAL), genie_cgs_canadian_gallon);
1723   a68_idf (A68_EXT, "cgsukgallon", MODE (REAL), genie_cgs_uk_gallon);
1724   a68_idf (A68_EXT, "cgsmilesperhour", MODE (REAL), genie_cgs_miles_per_hour);
1725   a68_idf (A68_EXT, "cgskilometersperhour", MODE (REAL), genie_cgs_kilometers_per_hour);
1726   a68_idf (A68_EXT, "cgsknot", MODE (REAL), genie_cgs_knot);
1727   a68_idf (A68_EXT, "cgspoundmass", MODE (REAL), genie_cgs_pound_mass);
1728   a68_idf (A68_EXT, "cgsouncemass", MODE (REAL), genie_cgs_ounce_mass);
1729   a68_idf (A68_EXT, "cgston", MODE (REAL), genie_cgs_ton);
1730   a68_idf (A68_EXT, "cgsmetricton", MODE (REAL), genie_cgs_metric_ton);
1731   a68_idf (A68_EXT, "cgsukton", MODE (REAL), genie_cgs_uk_ton);
1732   a68_idf (A68_EXT, "cgstroyounce", MODE (REAL), genie_cgs_troy_ounce);
1733   a68_idf (A68_EXT, "cgscarat", MODE (REAL), genie_cgs_carat);
1734   a68_idf (A68_EXT, "cgsunifiedatomicmass", MODE (REAL), genie_cgs_unified_atomic_mass);
1735   a68_idf (A68_EXT, "cgsgramforce", MODE (REAL), genie_cgs_gram_force);
1736   a68_idf (A68_EXT, "cgspoundforce", MODE (REAL), genie_cgs_pound_force);
1737   a68_idf (A68_EXT, "cgskilopoundforce", MODE (REAL), genie_cgs_kilopound_force);
1738   a68_idf (A68_EXT, "cgspoundal", MODE (REAL), genie_cgs_poundal);
1739   a68_idf (A68_EXT, "cgscalorie", MODE (REAL), genie_cgs_calorie);
1740   a68_idf (A68_EXT, "cgsbtu", MODE (REAL), genie_cgs_btu);
1741   a68_idf (A68_EXT, "cgstherm", MODE (REAL), genie_cgs_therm);
1742   a68_idf (A68_EXT, "cgshorsepower", MODE (REAL), genie_cgs_horsepower);
1743   a68_idf (A68_EXT, "cgsbar", MODE (REAL), genie_cgs_bar);
1744   a68_idf (A68_EXT, "cgsstdatmosphere", MODE (REAL), genie_cgs_std_atmosphere);
1745   a68_idf (A68_EXT, "cgstorr", MODE (REAL), genie_cgs_torr);
1746   a68_idf (A68_EXT, "cgsmeterofmercury", MODE (REAL), genie_cgs_meter_of_mercury);
1747   a68_idf (A68_EXT, "cgsinchofmercury", MODE (REAL), genie_cgs_inch_of_mercury);
1748   a68_idf (A68_EXT, "cgsinchofwater", MODE (REAL), genie_cgs_inch_of_water);
1749   a68_idf (A68_EXT, "cgspsi", MODE (REAL), genie_cgs_psi);
1750   a68_idf (A68_EXT, "cgspoise", MODE (REAL), genie_cgs_poise);
1751   a68_idf (A68_EXT, "cgsstokes", MODE (REAL), genie_cgs_stokes);
1752   a68_idf (A68_EXT, "cgsfaraday", MODE (REAL), genie_cgs_faraday);
1753   a68_idf (A68_EXT, "cgselectroncharge", MODE (REAL), genie_cgs_electron_charge);
1754   a68_idf (A68_EXT, "cgsgauss", MODE (REAL), genie_cgs_gauss);
1755   a68_idf (A68_EXT, "cgsstilb", MODE (REAL), genie_cgs_stilb);
1756   a68_idf (A68_EXT, "cgslumen", MODE (REAL), genie_cgs_lumen);
1757   a68_idf (A68_EXT, "cgslux", MODE (REAL), genie_cgs_lux);
1758   a68_idf (A68_EXT, "cgsphot", MODE (REAL), genie_cgs_phot);
1759   a68_idf (A68_EXT, "cgsfootcandle", MODE (REAL), genie_cgs_footcandle);
1760   a68_idf (A68_EXT, "cgslambert", MODE (REAL), genie_cgs_lambert);
1761   a68_idf (A68_EXT, "cgsfootlambert", MODE (REAL), genie_cgs_footlambert);
1762   a68_idf (A68_EXT, "cgscurie", MODE (REAL), genie_cgs_curie);
1763   a68_idf (A68_EXT, "cgsroentgen", MODE (REAL), genie_cgs_roentgen);
1764   a68_idf (A68_EXT, "cgsrad", MODE (REAL), genie_cgs_rad);
1765   a68_idf (A68_EXT, "cgssolarmass", MODE (REAL), genie_cgs_solar_mass);
1766   a68_idf (A68_EXT, "cgsbohrradius", MODE (REAL), genie_cgs_bohr_radius);
1767   a68_idf (A68_EXT, "cgsnewton", MODE (REAL), genie_cgs_newton);
1768   a68_idf (A68_EXT, "cgsdyne", MODE (REAL), genie_cgs_dyne);
1769   a68_idf (A68_EXT, "cgsjoule", MODE (REAL), genie_cgs_joule);
1770   a68_idf (A68_EXT, "cgserg", MODE (REAL), genie_cgs_erg);
1771   a68_idf (A68_EXT, "mksaspeedoflight", MODE (REAL), genie_mks_speed_of_light);
1772   a68_idf (A68_EXT, "mksagravitationalconstant", MODE (REAL), genie_mks_gravitational_constant);
1773   a68_idf (A68_EXT, "mksaplanckconstant", MODE (REAL), genie_mks_planck_constant_h);
1774   a68_idf (A68_EXT, "mksaplanckconstantbar", MODE (REAL), genie_mks_planck_constant_hbar);
1775   a68_idf (A68_EXT, "mksavacuumpermeability", MODE (REAL), genie_mks_vacuum_permeability);
1776   a68_idf (A68_EXT, "mksaastronomicalunit", MODE (REAL), genie_mks_astronomical_unit);
1777   a68_idf (A68_EXT, "mksalightyear", MODE (REAL), genie_mks_light_year);
1778   a68_idf (A68_EXT, "mksaparsec", MODE (REAL), genie_mks_parsec);
1779   a68_idf (A68_EXT, "mksagravaccel", MODE (REAL), genie_mks_grav_accel);
1780   a68_idf (A68_EXT, "mksaelectronvolt", MODE (REAL), genie_mks_electron_volt);
1781   a68_idf (A68_EXT, "mksamasselectron", MODE (REAL), genie_mks_mass_electron);
1782   a68_idf (A68_EXT, "mksamassmuon", MODE (REAL), genie_mks_mass_muon);
1783   a68_idf (A68_EXT, "mksamassproton", MODE (REAL), genie_mks_mass_proton);
1784   a68_idf (A68_EXT, "mksamassneutron", MODE (REAL), genie_mks_mass_neutron);
1785   a68_idf (A68_EXT, "mksarydberg", MODE (REAL), genie_mks_rydberg);
1786   a68_idf (A68_EXT, "mksaboltzmann", MODE (REAL), genie_mks_boltzmann);
1787   a68_idf (A68_EXT, "mksabohrmagneton", MODE (REAL), genie_mks_bohr_magneton);
1788   a68_idf (A68_EXT, "mksanuclearmagneton", MODE (REAL), genie_mks_nuclear_magneton);
1789   a68_idf (A68_EXT, "mksaelectronmagneticmoment", MODE (REAL), genie_mks_electron_magnetic_moment);
1790   a68_idf (A68_EXT, "mksaprotonmagneticmoment", MODE (REAL), genie_mks_proton_magnetic_moment);
1791   a68_idf (A68_EXT, "mksamolargas", MODE (REAL), genie_mks_molar_gas);
1792   a68_idf (A68_EXT, "mksastandardgasvolume", MODE (REAL), genie_mks_standard_gas_volume);
1793   a68_idf (A68_EXT, "mksaminute", MODE (REAL), genie_mks_minute);
1794   a68_idf (A68_EXT, "mksahour", MODE (REAL), genie_mks_hour);
1795   a68_idf (A68_EXT, "mksaday", MODE (REAL), genie_mks_day);
1796   a68_idf (A68_EXT, "mksaweek", MODE (REAL), genie_mks_week);
1797   a68_idf (A68_EXT, "mksainch", MODE (REAL), genie_mks_inch);
1798   a68_idf (A68_EXT, "mksafoot", MODE (REAL), genie_mks_foot);
1799   a68_idf (A68_EXT, "mksayard", MODE (REAL), genie_mks_yard);
1800   a68_idf (A68_EXT, "mksamile", MODE (REAL), genie_mks_mile);
1801   a68_idf (A68_EXT, "mksanauticalmile", MODE (REAL), genie_mks_nautical_mile);
1802   a68_idf (A68_EXT, "mksafathom", MODE (REAL), genie_mks_fathom);
1803   a68_idf (A68_EXT, "mksamil", MODE (REAL), genie_mks_mil);
1804   a68_idf (A68_EXT, "mksapoint", MODE (REAL), genie_mks_point);
1805   a68_idf (A68_EXT, "mksatexpoint", MODE (REAL), genie_mks_texpoint);
1806   a68_idf (A68_EXT, "mksamicron", MODE (REAL), genie_mks_micron);
1807   a68_idf (A68_EXT, "mksaangstrom", MODE (REAL), genie_mks_angstrom);
1808   a68_idf (A68_EXT, "mksahectare", MODE (REAL), genie_mks_hectare);
1809   a68_idf (A68_EXT, "mksaacre", MODE (REAL), genie_mks_acre);
1810   a68_idf (A68_EXT, "mksabarn", MODE (REAL), genie_mks_barn);
1811   a68_idf (A68_EXT, "mksaliter", MODE (REAL), genie_mks_liter);
1812   a68_idf (A68_EXT, "mksausgallon", MODE (REAL), genie_mks_us_gallon);
1813   a68_idf (A68_EXT, "mksaquart", MODE (REAL), genie_mks_quart);
1814   a68_idf (A68_EXT, "mksapint", MODE (REAL), genie_mks_pint);
1815   a68_idf (A68_EXT, "mksacup", MODE (REAL), genie_mks_cup);
1816   a68_idf (A68_EXT, "mksafluidounce", MODE (REAL), genie_mks_fluid_ounce);
1817   a68_idf (A68_EXT, "mksatablespoon", MODE (REAL), genie_mks_tablespoon);
1818   a68_idf (A68_EXT, "mksateaspoon", MODE (REAL), genie_mks_teaspoon);
1819   a68_idf (A68_EXT, "mksacanadiangallon", MODE (REAL), genie_mks_canadian_gallon);
1820   a68_idf (A68_EXT, "mksaukgallon", MODE (REAL), genie_mks_uk_gallon);
1821   a68_idf (A68_EXT, "mksamilesperhour", MODE (REAL), genie_mks_miles_per_hour);
1822   a68_idf (A68_EXT, "mksakilometersperhour", MODE (REAL), genie_mks_kilometers_per_hour);
1823   a68_idf (A68_EXT, "mksaknot", MODE (REAL), genie_mks_knot);
1824   a68_idf (A68_EXT, "mksapoundmass", MODE (REAL), genie_mks_pound_mass);
1825   a68_idf (A68_EXT, "mksaouncemass", MODE (REAL), genie_mks_ounce_mass);
1826   a68_idf (A68_EXT, "mksaton", MODE (REAL), genie_mks_ton);
1827   a68_idf (A68_EXT, "mksametricton", MODE (REAL), genie_mks_metric_ton);
1828   a68_idf (A68_EXT, "mksaukton", MODE (REAL), genie_mks_uk_ton);
1829   a68_idf (A68_EXT, "mksatroyounce", MODE (REAL), genie_mks_troy_ounce);
1830   a68_idf (A68_EXT, "mksacarat", MODE (REAL), genie_mks_carat);
1831   a68_idf (A68_EXT, "mksaunifiedatomicmass", MODE (REAL), genie_mks_unified_atomic_mass);
1832   a68_idf (A68_EXT, "mksagramforce", MODE (REAL), genie_mks_gram_force);
1833   a68_idf (A68_EXT, "mksapoundforce", MODE (REAL), genie_mks_pound_force);
1834   a68_idf (A68_EXT, "mksakilopoundforce", MODE (REAL), genie_mks_kilopound_force);
1835   a68_idf (A68_EXT, "mksapoundal", MODE (REAL), genie_mks_poundal);
1836   a68_idf (A68_EXT, "mksacalorie", MODE (REAL), genie_mks_calorie);
1837   a68_idf (A68_EXT, "mksabtu", MODE (REAL), genie_mks_btu);
1838   a68_idf (A68_EXT, "mksatherm", MODE (REAL), genie_mks_therm);
1839   a68_idf (A68_EXT, "mksahorsepower", MODE (REAL), genie_mks_horsepower);
1840   a68_idf (A68_EXT, "mksabar", MODE (REAL), genie_mks_bar);
1841   a68_idf (A68_EXT, "mksastdatmosphere", MODE (REAL), genie_mks_std_atmosphere);
1842   a68_idf (A68_EXT, "mksatorr", MODE (REAL), genie_mks_torr);
1843   a68_idf (A68_EXT, "mksameterofmercury", MODE (REAL), genie_mks_meter_of_mercury);
1844   a68_idf (A68_EXT, "mksainchofmercury", MODE (REAL), genie_mks_inch_of_mercury);
1845   a68_idf (A68_EXT, "mksainchofwater", MODE (REAL), genie_mks_inch_of_water);
1846   a68_idf (A68_EXT, "mksapsi", MODE (REAL), genie_mks_psi);
1847   a68_idf (A68_EXT, "mksapoise", MODE (REAL), genie_mks_poise);
1848   a68_idf (A68_EXT, "mksastokes", MODE (REAL), genie_mks_stokes);
1849   a68_idf (A68_EXT, "mksafaraday", MODE (REAL), genie_mks_faraday);
1850   a68_idf (A68_EXT, "mksaelectroncharge", MODE (REAL), genie_mks_electron_charge);
1851   a68_idf (A68_EXT, "mksagauss", MODE (REAL), genie_mks_gauss);
1852   a68_idf (A68_EXT, "mksastilb", MODE (REAL), genie_mks_stilb);
1853   a68_idf (A68_EXT, "mksalumen", MODE (REAL), genie_mks_lumen);
1854   a68_idf (A68_EXT, "mksalux", MODE (REAL), genie_mks_lux);
1855   a68_idf (A68_EXT, "mksaphot", MODE (REAL), genie_mks_phot);
1856   a68_idf (A68_EXT, "mksafootcandle", MODE (REAL), genie_mks_footcandle);
1857   a68_idf (A68_EXT, "mksalambert", MODE (REAL), genie_mks_lambert);
1858   a68_idf (A68_EXT, "mksafootlambert", MODE (REAL), genie_mks_footlambert);
1859   a68_idf (A68_EXT, "mksacurie", MODE (REAL), genie_mks_curie);
1860   a68_idf (A68_EXT, "mksaroentgen", MODE (REAL), genie_mks_roentgen);
1861   a68_idf (A68_EXT, "mksarad", MODE (REAL), genie_mks_rad);
1862   a68_idf (A68_EXT, "mksasolarmass", MODE (REAL), genie_mks_solar_mass);
1863   a68_idf (A68_EXT, "mksabohrradius", MODE (REAL), genie_mks_bohr_radius);
1864   a68_idf (A68_EXT, "mksavacuumpermittivity", MODE (REAL), genie_mks_vacuum_permittivity);
1865   a68_idf (A68_EXT, "mksanewton", MODE (REAL), genie_mks_newton);
1866   a68_idf (A68_EXT, "mksadyne", MODE (REAL), genie_mks_dyne);
1867   a68_idf (A68_EXT, "mksajoule", MODE (REAL), genie_mks_joule);
1868   a68_idf (A68_EXT, "mksaerg", MODE (REAL), genie_mks_erg);
1869   a68_idf (A68_EXT, "numfinestructure", MODE (REAL), genie_num_fine_structure);
1870   a68_idf (A68_EXT, "numavogadro", MODE (REAL), genie_num_avogadro);
1871   a68_idf (A68_EXT, "numyotta", MODE (REAL), genie_num_yotta);
1872   a68_idf (A68_EXT, "numzetta", MODE (REAL), genie_num_zetta);
1873   a68_idf (A68_EXT, "numexa", MODE (REAL), genie_num_exa);
1874   a68_idf (A68_EXT, "numpeta", MODE (REAL), genie_num_peta);
1875   a68_idf (A68_EXT, "numtera", MODE (REAL), genie_num_tera);
1876   a68_idf (A68_EXT, "numgiga", MODE (REAL), genie_num_giga);
1877   a68_idf (A68_EXT, "nummega", MODE (REAL), genie_num_mega);
1878   a68_idf (A68_EXT, "numkilo", MODE (REAL), genie_num_kilo);
1879   a68_idf (A68_EXT, "nummilli", MODE (REAL), genie_num_milli);
1880   a68_idf (A68_EXT, "nummicro", MODE (REAL), genie_num_micro);
1881   a68_idf (A68_EXT, "numnano", MODE (REAL), genie_num_nano);
1882   a68_idf (A68_EXT, "numpico", MODE (REAL), genie_num_pico);
1883   a68_idf (A68_EXT, "numfemto", MODE (REAL), genie_num_femto);
1884   a68_idf (A68_EXT, "numatto", MODE (REAL), genie_num_atto);
1885   a68_idf (A68_EXT, "numzepto", MODE (REAL), genie_num_zepto);
1886   a68_idf (A68_EXT, "numyocto", MODE (REAL), genie_num_yocto);
1887 }
1888 
1889 /**
1890 @brief Set up standenv - extensions.
1891 **/
1892 
1893 static void
stand_extensions(void)1894 stand_extensions (void)
1895 {
1896   MOID_T *m = NO_MOID;
1897   (void) m;                     /* To fool cc in case we have none of the libraries */
1898 #if defined HAVE_GNU_PLOTUTILS
1899 /* Drawing */
1900   m = a68_proc (MODE (BOOL), MODE (REF_FILE), MODE (STRING), MODE (STRING), NO_MOID);
1901   a68_idf (A68_EXT, "drawdevice", m, genie_make_device);
1902   a68_idf (A68_EXT, "makedevice", m, genie_make_device);
1903   m = a68_proc (MODE (REAL), MODE (REF_FILE), NO_MOID);
1904   a68_idf (A68_EXT, "drawaspect", m, genie_draw_aspect);
1905   m = a68_proc (MODE (VOID), MODE (REF_FILE), NO_MOID);
1906   a68_idf (A68_EXT, "drawclear", m, genie_draw_clear);
1907   a68_idf (A68_EXT, "drawerase", m, genie_draw_clear);
1908   a68_idf (A68_EXT, "drawflush", m, genie_draw_show);
1909   a68_idf (A68_EXT, "drawshow", m, genie_draw_show);
1910   m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (INT), NO_MOID);
1911   a68_idf (A68_EXT, "drawfillstyle", m, genie_draw_fillstyle);
1912   m = a68_proc (MODE (STRING), MODE (INT), NO_MOID);
1913   a68_idf (A68_EXT, "drawgetcolourname", m, genie_draw_get_colour_name);
1914   a68_idf (A68_EXT, "drawgetcolorname", m, genie_draw_get_colour_name);
1915   m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID);
1916   a68_idf (A68_EXT, "drawcolor", m, genie_draw_colour);
1917   a68_idf (A68_EXT, "drawcolour", m, genie_draw_colour);
1918   a68_idf (A68_EXT, "drawbackgroundcolor", m, genie_draw_background_colour);
1919   a68_idf (A68_EXT, "drawbackgroundcolour", m, genie_draw_background_colour);
1920   a68_idf (A68_EXT, "drawcircle", m, genie_draw_circle);
1921   a68_idf (A68_EXT, "drawball", m, genie_draw_atom);
1922   a68_idf (A68_EXT, "drawstar", m, genie_draw_star);
1923   m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (REAL), MODE (REAL), NO_MOID);
1924   a68_idf (A68_EXT, "drawpoint", m, genie_draw_point);
1925   a68_idf (A68_EXT, "drawline", m, genie_draw_line);
1926   a68_idf (A68_EXT, "drawmove", m, genie_draw_move);
1927   a68_idf (A68_EXT, "drawrect", m, genie_draw_rect);
1928   m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (CHAR), MODE (CHAR), MODE (ROW_CHAR), NO_MOID);
1929   a68_idf (A68_EXT, "drawtext", m, genie_draw_text);
1930   m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (ROW_CHAR), NO_MOID);
1931   a68_idf (A68_EXT, "drawlinestyle", m, genie_draw_linestyle);
1932   a68_idf (A68_EXT, "drawfontname", m, genie_draw_fontname);
1933   m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (REAL), NO_MOID);
1934   a68_idf (A68_EXT, "drawlinewidth", m, genie_draw_linewidth);
1935   m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (INT), NO_MOID);
1936   a68_idf (A68_EXT, "drawfontsize", m, genie_draw_fontsize);
1937   a68_idf (A68_EXT, "drawtextangle", m, genie_draw_textangle);
1938   m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (STRING), NO_MOID);
1939   a68_idf (A68_EXT, "drawcolorname", m, genie_draw_colour_name);
1940   a68_idf (A68_EXT, "drawcolourname", m, genie_draw_colour_name);
1941   a68_idf (A68_EXT, "drawbackgroundcolorname", m, genie_draw_background_colour_name);
1942   a68_idf (A68_EXT, "drawbackgroundcolourname", m, genie_draw_background_colour_name);
1943 #endif
1944 #if defined HAVE_GNU_GSL
1945   m = proc_real_real;
1946   a68_idf (A68_EXT, "erf", m, genie_erf_real);
1947   a68_idf (A68_EXT, "erfc", m, genie_erfc_real);
1948   a68_idf (A68_EXT, "gamma", m, genie_gamma_real);
1949   a68_idf (A68_EXT, "lngamma", m, genie_lngamma_real);
1950   a68_idf (A68_EXT, "factorial", m, genie_factorial_real);
1951   a68_idf (A68_EXT, "airyai", m, genie_airy_ai_real);
1952   a68_idf (A68_EXT, "airybi", m, genie_airy_bi_real);
1953   a68_idf (A68_EXT, "airyaiderivative", m, genie_airy_ai_deriv_real);
1954   a68_idf (A68_EXT, "airybiderivative", m, genie_airy_bi_deriv_real);
1955   a68_idf (A68_EXT, "ellipticintegralk", m, genie_elliptic_integral_k_real);
1956   a68_idf (A68_EXT, "ellipticintegrale", m, genie_elliptic_integral_e_real);
1957   m = proc_real_real_real;
1958   a68_idf (A68_EXT, "beta", m, genie_beta_real);
1959   a68_idf (A68_EXT, "besseljn", m, genie_bessel_jn_real);
1960   a68_idf (A68_EXT, "besselyn", m, genie_bessel_yn_real);
1961   a68_idf (A68_EXT, "besselin", m, genie_bessel_in_real);
1962   a68_idf (A68_EXT, "besselexpin", m, genie_bessel_exp_in_real);
1963   a68_idf (A68_EXT, "besselkn", m, genie_bessel_kn_real);
1964   a68_idf (A68_EXT, "besselexpkn", m, genie_bessel_exp_kn_real);
1965   a68_idf (A68_EXT, "besseljl", m, genie_bessel_jl_real);
1966   a68_idf (A68_EXT, "besselyl", m, genie_bessel_yl_real);
1967   a68_idf (A68_EXT, "besselexpil", m, genie_bessel_exp_il_real);
1968   a68_idf (A68_EXT, "besselexpkl", m, genie_bessel_exp_kl_real);
1969   a68_idf (A68_EXT, "besseljnu", m, genie_bessel_jnu_real);
1970   a68_idf (A68_EXT, "besselynu", m, genie_bessel_ynu_real);
1971   a68_idf (A68_EXT, "besselinu", m, genie_bessel_inu_real);
1972   a68_idf (A68_EXT, "besselexpinu", m, genie_bessel_exp_inu_real);
1973   a68_idf (A68_EXT, "besselknu", m, genie_bessel_knu_real);
1974   a68_idf (A68_EXT, "besselexpknu", m, genie_bessel_exp_knu_real);
1975   a68_idf (A68_EXT, "ellipticintegralrc", m, genie_elliptic_integral_rc_real);
1976   a68_idf (A68_EXT, "incompletegamma", m, genie_gamma_inc_real);
1977   m = a68_proc (MODE (REAL), MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID);
1978   a68_idf (A68_EXT, "incompletebeta", m, genie_beta_inc_real);
1979   a68_idf (A68_EXT, "ellipticintegralrf", m, genie_elliptic_integral_rf_real);
1980   a68_idf (A68_EXT, "ellipticintegralrd", m, genie_elliptic_integral_rd_real);
1981   m = a68_proc (MODE (REAL), MODE (REAL), MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID);
1982   a68_idf (A68_EXT, "ellipticintegralrj", m, genie_elliptic_integral_rj_real);
1983 /* Vector and matrix monadic */
1984   m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID);
1985   a68_op (A68_EXT, "+", m, genie_idle);
1986   a68_op (A68_EXT, "-", m, genie_vector_minus);
1987   m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID);
1988   a68_op (A68_EXT, "+", m, genie_idle);
1989   a68_op (A68_EXT, "-", m, genie_matrix_minus);
1990   a68_op (A68_EXT, "T", m, genie_matrix_transpose);
1991   a68_op (A68_EXT, "INV", m, genie_matrix_inv);
1992   m = a68_proc (MODE (REAL), MODE (ROWROW_REAL), NO_MOID);
1993   a68_op (A68_EXT, "DET", m, genie_matrix_det);
1994   a68_op (A68_EXT, "TRACE", m, genie_matrix_trace);
1995   m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID);
1996   a68_op (A68_EXT, "+", m, genie_idle);
1997   a68_op (A68_EXT, "-", m, genie_vector_complex_minus);
1998   m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID);
1999   a68_op (A68_EXT, "+", m, genie_idle);
2000   a68_op (A68_EXT, "-", m, genie_matrix_complex_minus);
2001   a68_op (A68_EXT, "T", m, genie_matrix_complex_transpose);
2002   a68_op (A68_EXT, "INV", m, genie_matrix_complex_inv);
2003   m = a68_proc (MODE (COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID);
2004   a68_op (A68_EXT, "DET", m, genie_matrix_complex_det);
2005   a68_op (A68_EXT, "TRACE", m, genie_matrix_complex_trace);
2006 /* Vector and matrix dyadic */
2007   m = a68_proc (MODE (BOOL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID);
2008   a68_op (A68_EXT, "=", m, genie_vector_eq);
2009   a68_op (A68_EXT, "/=", m, genie_vector_ne);
2010   m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID);
2011   a68_op (A68_EXT, "+", m, genie_vector_add);
2012   a68_op (A68_EXT, "-", m, genie_vector_sub);
2013   m = a68_proc (MODE (REF_ROW_REAL), MODE (REF_ROW_REAL), MODE (ROW_REAL), NO_MOID);
2014   a68_op (A68_EXT, "+:=", m, genie_vector_plusab);
2015   a68_op (A68_EXT, "PLUSAB", m, genie_vector_plusab);
2016   a68_op (A68_EXT, "-:=", m, genie_vector_minusab);
2017   a68_op (A68_EXT, "MINUSAB", m, genie_vector_minusab);
2018   m = a68_proc (MODE (BOOL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID);
2019   a68_op (A68_EXT, "=", m, genie_matrix_eq);
2020   a68_op (A68_EXT, "/-", m, genie_matrix_ne);
2021   m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID);
2022   a68_op (A68_EXT, "+", m, genie_matrix_add);
2023   a68_op (A68_EXT, "-", m, genie_matrix_sub);
2024   m = a68_proc (MODE (REF_ROWROW_REAL), MODE (REF_ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID);
2025   a68_op (A68_EXT, "+:=", m, genie_matrix_plusab);
2026   a68_op (A68_EXT, "PLUSAB", m, genie_matrix_plusab);
2027   a68_op (A68_EXT, "-:=", m, genie_matrix_minusab);
2028   a68_op (A68_EXT, "MINUSAB", m, genie_matrix_minusab);
2029   m = a68_proc (MODE (BOOL), MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID);
2030   a68_op (A68_EXT, "=", m, genie_vector_complex_eq);
2031   a68_op (A68_EXT, "/=", m, genie_vector_complex_ne);
2032   m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID);
2033   a68_op (A68_EXT, "+", m, genie_vector_complex_add);
2034   a68_op (A68_EXT, "-", m, genie_vector_complex_sub);
2035   m = a68_proc (MODE (REF_ROW_COMPLEX), MODE (REF_ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID);
2036   a68_op (A68_EXT, "+:=", m, genie_vector_complex_plusab);
2037   a68_op (A68_EXT, "PLUSAB", m, genie_vector_complex_plusab);
2038   a68_op (A68_EXT, "-:=", m, genie_vector_complex_minusab);
2039   a68_op (A68_EXT, "MINUSAB", m, genie_vector_complex_minusab);
2040   m = a68_proc (MODE (BOOL), MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID);
2041   a68_op (A68_EXT, "=", m, genie_matrix_complex_eq);
2042   a68_op (A68_EXT, "/=", m, genie_matrix_complex_ne);
2043   m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID);
2044   a68_op (A68_EXT, "+", m, genie_matrix_complex_add);
2045   a68_op (A68_EXT, "-", m, genie_matrix_complex_sub);
2046   m = a68_proc (MODE (REF_ROWROW_COMPLEX), MODE (REF_ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID);
2047   a68_op (A68_EXT, "+:=", m, genie_matrix_complex_plusab);
2048   a68_op (A68_EXT, "PLUSAB", m, genie_matrix_complex_plusab);
2049   a68_op (A68_EXT, "-:=", m, genie_matrix_complex_minusab);
2050   a68_op (A68_EXT, "MINUSAB", m, genie_matrix_complex_minusab);
2051 /* Vector and matrix scaling */
2052   m = a68_proc (MODE (ROW_REAL), MODE (REAL), MODE (ROW_REAL), NO_MOID);
2053   a68_op (A68_EXT, "*", m, genie_real_scale_vector);
2054   m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), MODE (REAL), NO_MOID);
2055   a68_op (A68_EXT, "*", m, genie_vector_scale_real);
2056   a68_op (A68_EXT, "/", m, genie_vector_div_real);
2057   m = a68_proc (MODE (ROWROW_REAL), MODE (REAL), MODE (ROWROW_REAL), NO_MOID);
2058   a68_op (A68_EXT, "*", m, genie_real_scale_matrix);
2059   m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (REAL), NO_MOID);
2060   a68_op (A68_EXT, "*", m, genie_matrix_scale_real);
2061   a68_op (A68_EXT, "/", m, genie_matrix_div_real);
2062   m = a68_proc (MODE (ROW_COMPLEX), MODE (COMPLEX), MODE (ROW_COMPLEX), NO_MOID);
2063   a68_op (A68_EXT, "*", m, genie_complex_scale_vector_complex);
2064   m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), MODE (COMPLEX), NO_MOID);
2065   a68_op (A68_EXT, "*", m, genie_vector_complex_scale_complex);
2066   a68_op (A68_EXT, "/", m, genie_vector_complex_div_complex);
2067   m = a68_proc (MODE (ROWROW_COMPLEX), MODE (COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID);
2068   a68_op (A68_EXT, "*", m, genie_complex_scale_matrix_complex);
2069   m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (COMPLEX), NO_MOID);
2070   a68_op (A68_EXT, "*", m, genie_matrix_complex_scale_complex);
2071   a68_op (A68_EXT, "/", m, genie_matrix_complex_div_complex);
2072   m = a68_proc (MODE (REF_ROW_REAL), MODE (REF_ROW_REAL), MODE (REAL), NO_MOID);
2073   a68_op (A68_EXT, "*:=", m, genie_vector_scale_real_ab);
2074   a68_op (A68_EXT, "/:=", m, genie_vector_div_real_ab);
2075   m = a68_proc (MODE (REF_ROWROW_REAL), MODE (REF_ROWROW_REAL), MODE (REAL), NO_MOID);
2076   a68_op (A68_EXT, "*:=", m, genie_matrix_scale_real_ab);
2077   a68_op (A68_EXT, "/:=", m, genie_matrix_div_real_ab);
2078   m = a68_proc (MODE (REF_ROW_COMPLEX), MODE (REF_ROW_COMPLEX), MODE (COMPLEX), NO_MOID);
2079   a68_op (A68_EXT, "*:=", m, genie_vector_complex_scale_complex_ab);
2080   a68_op (A68_EXT, "/:=", m, genie_vector_complex_div_complex_ab);
2081   m = a68_proc (MODE (REF_ROWROW_COMPLEX), MODE (REF_ROWROW_COMPLEX), MODE (COMPLEX), NO_MOID);
2082   a68_op (A68_EXT, "*:=", m, genie_matrix_complex_scale_complex_ab);
2083   a68_op (A68_EXT, "/:=", m, genie_matrix_complex_div_complex_ab);
2084   m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), MODE (ROWROW_REAL), NO_MOID);
2085   a68_op (A68_EXT, "*", m, genie_vector_times_matrix);
2086   m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID);
2087   a68_op (A68_EXT, "*", m, genie_vector_complex_times_matrix);
2088 /* Matrix times vector or matrix */
2089   m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROW_REAL), NO_MOID);
2090   a68_op (A68_EXT, "*", m, genie_matrix_times_vector);
2091   m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID);
2092   a68_op (A68_EXT, "*", m, genie_matrix_times_matrix);
2093   m = a68_proc (MODE (ROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID);
2094   a68_op (A68_EXT, "*", m, genie_matrix_complex_times_vector);
2095   m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID);
2096   a68_op (A68_EXT, "*", m, genie_matrix_complex_times_matrix);
2097 /* Vector and matrix miscellaneous */
2098   m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID);
2099   a68_idf (A68_EXT, "vectorecho", m, genie_vector_echo);
2100   m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID);
2101   a68_idf (A68_EXT, "matrixecho", m, genie_matrix_echo);
2102   m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID);
2103   a68_idf (A68_EXT, "complvectorecho", m, genie_vector_complex_echo);
2104   m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID);
2105   a68_idf (A68_EXT, "complmatrixecho", m, genie_matrix_complex_echo);
2106    /**/ m = a68_proc (MODE (REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID);
2107   a68_op (A68_EXT, "*", m, genie_vector_dot);
2108   m = a68_proc (MODE (COMPLEX), MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID);
2109   a68_op (A68_EXT, "*", m, genie_vector_complex_dot);
2110   m = a68_proc (MODE (REAL), MODE (ROW_REAL), NO_MOID);
2111   a68_op (A68_EXT, "NORM", m, genie_vector_norm);
2112   m = a68_proc (MODE (REAL), MODE (ROW_COMPLEX), NO_MOID);
2113   a68_op (A68_EXT, "NORM", m, genie_vector_complex_norm);
2114   m = a68_proc (MODE (ROWROW_REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID);
2115   a68_op (A68_EXT, "DYAD", m, genie_vector_dyad);
2116   m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID);
2117   a68_op (A68_EXT, "DYAD", m, genie_vector_complex_dyad);
2118   a68_prio ("DYAD", 3);
2119 /* LU decomposition */
2120   m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (REF_ROW_INT), MODE (REF_INT), NO_MOID);
2121   a68_idf (A68_EXT, "ludecomp", m, genie_matrix_lu);
2122   m = a68_proc (MODE (REAL), MODE (ROWROW_REAL), MODE (INT), NO_MOID);
2123   a68_idf (A68_EXT, "ludet", m, genie_matrix_lu_det);
2124   m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROW_INT), NO_MOID);
2125   a68_idf (A68_EXT, "luinv", m, genie_matrix_lu_inv);
2126   m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROW_INT), MODE (ROW_REAL), NO_MOID);
2127   a68_idf (A68_EXT, "lusolve", m, genie_matrix_lu_solve);
2128   m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (REF_ROW_INT), MODE (REF_INT), NO_MOID);
2129   a68_idf (A68_EXT, "complexludecomp", m, genie_matrix_complex_lu);
2130   m = a68_proc (MODE (COMPLEX), MODE (ROWROW_COMPLEX), MODE (INT), NO_MOID);
2131   a68_idf (A68_EXT, "complexludet", m, genie_matrix_complex_lu_det);
2132   m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROW_INT), NO_MOID);
2133   a68_idf (A68_EXT, "complexluinv", m, genie_matrix_complex_lu_inv);
2134   m = a68_proc (MODE (ROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROW_INT), MODE (ROW_COMPLEX), NO_MOID);
2135   a68_idf (A68_EXT, "complexlusolve", m, genie_matrix_complex_lu_solve);
2136 /* SVD decomposition */
2137   m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (REF_ROWROW_REAL), MODE (REF_ROW_REAL), NO_MOID);
2138   a68_idf (A68_EXT, "svdecomp", m, genie_matrix_svd);
2139   a68_idf (A68_EXT, "svddecomp", m, genie_matrix_svd);
2140   m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID);
2141   a68_idf (A68_EXT, "svdsolve", m, genie_matrix_svd_solve);
2142 /* QR decomposition */
2143   m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (REF_ROW_REAL), NO_MOID);
2144   a68_idf (A68_EXT, "qrdecomp", m, genie_matrix_qr);
2145   m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID);
2146   a68_idf (A68_EXT, "qrsolve", m, genie_matrix_qr_solve);
2147   a68_idf (A68_EXT, "qrlssolve", m, genie_matrix_qr_ls_solve);
2148 /* Cholesky decomposition */
2149   m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID);
2150   a68_idf (A68_EXT, "choleskydecomp", m, genie_matrix_ch);
2151   m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROW_REAL), NO_MOID);
2152   a68_idf (A68_EXT, "choleskysolve", m, genie_matrix_ch_solve);
2153 /* FFT */
2154   m = a68_proc (MODE (ROW_INT), MODE (INT), NO_MOID);
2155   a68_idf (A68_EXT, "primefactors", m, genie_prime_factors);
2156   m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID);
2157   a68_idf (A68_EXT, "fftcomplexforward", m, genie_fft_complex_forward);
2158   a68_idf (A68_EXT, "fftcomplexbackward", m, genie_fft_complex_backward);
2159   a68_idf (A68_EXT, "fftcomplexinverse", m, genie_fft_complex_inverse);
2160   m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_REAL), NO_MOID);
2161   a68_idf (A68_EXT, "fftforward", m, genie_fft_forward);
2162   m = a68_proc (MODE (ROW_REAL), MODE (ROW_COMPLEX), NO_MOID);
2163   a68_idf (A68_EXT, "fftbackward", m, genie_fft_backward);
2164   a68_idf (A68_EXT, "fftinverse", m, genie_fft_inverse);
2165 #endif
2166 /* UNIX things */
2167   m = proc_int;
2168   a68_idf (A68_EXT, "rows", m, genie_rows);
2169   a68_idf (A68_EXT, "columns", m, genie_columns);
2170   a68_idf (A68_EXT, "argc", m, genie_argc);
2171   a68_idf (A68_EXT, "a68gargc", m, genie_a68g_argc);
2172   a68_idf (A68_EXT, "errno", m, genie_errno);
2173   a68_idf (A68_EXT, "fork", m, genie_fork);
2174   m = a68_proc (MODE (STRING), NO_MOID);
2175   a68_idf (A68_EXT, "getpwd", m, genie_pwd);
2176   m = a68_proc (MODE (INT), MODE (STRING), NO_MOID);
2177   a68_idf (A68_EXT, "setpwd", m, genie_cd);
2178   m = a68_proc (MODE (BOOL), MODE (STRING), NO_MOID);
2179   a68_idf (A68_EXT, "fileisdirectory", m, genie_file_is_directory);
2180   a68_idf (A68_EXT, "fileisblockdevice", m, genie_file_is_block_device);
2181   a68_idf (A68_EXT, "fileischardevice", m, genie_file_is_char_device);
2182   a68_idf (A68_EXT, "fileisregular", m, genie_file_is_regular);
2183 #if defined __S_IFIFO
2184   a68_idf (A68_EXT, "fileisfifo", m, genie_file_is_fifo);
2185 #endif
2186 #if defined __S_IFLNK
2187   a68_idf (A68_EXT, "fileislink", m, genie_file_is_link);
2188 #endif
2189   m = a68_proc (MODE (BITS), MODE (STRING), NO_MOID);
2190   a68_idf (A68_EXT, "filemode", m, genie_file_mode);
2191   m = a68_proc (MODE (STRING), MODE (INT), NO_MOID);
2192   a68_idf (A68_EXT, "argv", m, genie_argv);
2193   a68_idf (A68_EXT, "a68gargv", m, genie_a68g_argv);
2194   m = proc_void;
2195   a68_idf (A68_EXT, "reseterrno", m, genie_reset_errno);
2196   m = a68_proc (MODE (STRING), MODE (INT), NO_MOID);
2197   a68_idf (A68_EXT, "strerror", m, genie_strerror);
2198   m = a68_proc (MODE (INT), MODE (STRING), MODE (ROW_STRING), MODE (ROW_STRING), NO_MOID);
2199   a68_idf (A68_EXT, "execve", m, genie_execve);
2200   m = a68_proc (MODE (PIPE), NO_MOID);
2201   a68_idf (A68_EXT, "createpipe", m, genie_create_pipe);
2202   m = a68_proc (MODE (INT), MODE (STRING), MODE (ROW_STRING), MODE (ROW_STRING), NO_MOID);
2203   a68_idf (A68_EXT, "execvechild", m, genie_execve_child);
2204   m = a68_proc (MODE (PIPE), MODE (STRING), MODE (ROW_STRING), MODE (ROW_STRING), NO_MOID);
2205   a68_idf (A68_EXT, "execvechildpipe", m, genie_execve_child_pipe);
2206   m = a68_proc (MODE (INT), MODE (STRING), MODE (ROW_STRING), MODE (ROW_STRING), MODE (REF_STRING), NO_MOID);
2207   a68_idf (A68_EXT, "execveoutput", m, genie_execve_output);
2208   m = a68_proc (MODE (STRING), MODE (STRING), NO_MOID);
2209   a68_idf (A68_EXT, "getenv", m, genie_getenv);
2210   m = a68_proc (MODE (VOID), MODE (INT), NO_MOID);
2211   a68_idf (A68_EXT, "waitpid", m, genie_waitpid);
2212   m = a68_proc (MODE (ROW_INT), NO_MOID);
2213   a68_idf (A68_EXT, "utctime", m, genie_utctime);
2214   a68_idf (A68_EXT, "localtime", m, genie_localtime);
2215 #if defined HAVE_DIRENT_H
2216   m = a68_proc (MODE (ROW_STRING), MODE (STRING), NO_MOID);
2217   a68_idf (A68_EXT, "getdirectory", m, genie_directory);
2218 #endif
2219 #if defined HAVE_HTTP
2220   m = a68_proc (MODE (INT), MODE (REF_STRING), MODE (STRING), MODE (STRING), MODE (INT), NO_MOID);
2221   a68_idf (A68_EXT, "httpcontent", m, genie_http_content);
2222   a68_idf (A68_EXT, "tcprequest", m, genie_tcp_request);
2223 #endif
2224 #if defined HAVE_REGEX_H
2225   m = a68_proc (MODE (INT), MODE (STRING), MODE (STRING), MODE (REF_INT), MODE (REF_INT), NO_MOID);
2226   a68_idf (A68_EXT, "grepinstring", m, genie_grep_in_string);
2227   a68_idf (A68_EXT, "grepinsubstring", m, genie_grep_in_substring);
2228   m = a68_proc (MODE (INT), MODE (STRING), MODE (STRING), MODE (REF_STRING), NO_MOID);
2229   a68_idf (A68_EXT, "subinstring", m, genie_sub_in_string);
2230 #endif
2231 #if defined HAVE_CURSES
2232   m = proc_void;
2233   a68_idf (A68_EXT, "cursesstart", m, genie_curses_start);
2234   a68_idf (A68_EXT, "cursesend", m, genie_curses_end);
2235   a68_idf (A68_EXT, "cursesclear", m, genie_curses_clear);
2236   a68_idf (A68_EXT, "cursesrefresh", m, genie_curses_refresh);
2237   a68_idf (A68_EXT, "cursesgreen", m, genie_curses_green);
2238   a68_idf (A68_EXT, "cursescyan", m, genie_curses_cyan);
2239   a68_idf (A68_EXT, "cursesred", m, genie_curses_red);
2240   a68_idf (A68_EXT, "cursesyellow", m, genie_curses_yellow);
2241   a68_idf (A68_EXT, "cursesmagenta", m, genie_curses_magenta);
2242   a68_idf (A68_EXT, "cursesblue", m, genie_curses_blue);
2243   a68_idf (A68_EXT, "curseswhite", m, genie_curses_white);
2244   a68_idf (A68_EXT, "cursesgreeninverse", m, genie_curses_green_inverse);
2245   a68_idf (A68_EXT, "cursescyaninverse", m, genie_curses_cyan_inverse);
2246   a68_idf (A68_EXT, "cursesredinverse", m, genie_curses_red_inverse);
2247   a68_idf (A68_EXT, "cursesyellowinverse", m, genie_curses_yellow_inverse);
2248   a68_idf (A68_EXT, "cursesmagentainverse", m, genie_curses_magenta_inverse);
2249   a68_idf (A68_EXT, "cursesblueinverse", m, genie_curses_blue_inverse);
2250   a68_idf (A68_EXT, "curseswhiteinverse", m, genie_curses_white_inverse);
2251   m = proc_char;
2252   a68_idf (A68_EXT, "cursesgetchar", m, genie_curses_getchar);
2253   m = a68_proc (MODE (VOID), MODE (CHAR), NO_MOID);
2254   a68_idf (A68_EXT, "cursesputchar", m, genie_curses_putchar);
2255   m = a68_proc (MODE (VOID), MODE (INT), MODE (INT), NO_MOID);
2256   a68_idf (A68_EXT, "cursesmove", m, genie_curses_move);
2257   m = proc_int;
2258   a68_idf (A68_EXT, "curseslines", m, genie_curses_lines);
2259   a68_idf (A68_EXT, "cursescolumns", m, genie_curses_columns);
2260   m = a68_proc (MODE (BOOL), MODE (CHAR), NO_MOID);
2261   a68_idf (A68_EXT, "cursesdelchar", m, genie_curses_del_char);
2262 #endif
2263 #if HAVE_POSTGRESQL
2264   m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (STRING), MODE (REF_STRING), NO_MOID);
2265   a68_idf (A68_EXT, "pqconnectdb", m, genie_pq_connectdb);
2266   m = a68_proc (MODE (INT), MODE (REF_FILE), NO_MOID);
2267   a68_idf (A68_EXT, "pqfinish", m, genie_pq_finish);
2268   a68_idf (A68_EXT, "pqreset", m, genie_pq_reset);
2269   m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (STRING), NO_MOID);
2270   a68_idf (A68_EXT, "pqparameterstatus", m, genie_pq_parameterstatus);
2271   a68_idf (A68_EXT, "pqexec", m, genie_pq_exec);
2272   a68_idf (A68_EXT, "pqfnumber", m, genie_pq_fnumber);
2273   m = a68_proc (MODE (INT), MODE (REF_FILE), NO_MOID);
2274   a68_idf (A68_EXT, "pqntuples", m, genie_pq_ntuples);
2275   a68_idf (A68_EXT, "pqnfields", m, genie_pq_nfields);
2276   a68_idf (A68_EXT, "pqcmdstatus", m, genie_pq_cmdstatus);
2277   a68_idf (A68_EXT, "pqcmdtuples", m, genie_pq_cmdtuples);
2278   a68_idf (A68_EXT, "pqerrormessage", m, genie_pq_errormessage);
2279   a68_idf (A68_EXT, "pqresulterrormessage", m, genie_pq_resulterrormessage);
2280   a68_idf (A68_EXT, "pqdb", m, genie_pq_db);
2281   a68_idf (A68_EXT, "pquser", m, genie_pq_user);
2282   a68_idf (A68_EXT, "pqpass", m, genie_pq_pass);
2283   a68_idf (A68_EXT, "pqhost", m, genie_pq_host);
2284   a68_idf (A68_EXT, "pqport", m, genie_pq_port);
2285   a68_idf (A68_EXT, "pqtty", m, genie_pq_tty);
2286   a68_idf (A68_EXT, "pqoptions", m, genie_pq_options);
2287   a68_idf (A68_EXT, "pqprotocolversion", m, genie_pq_protocolversion);
2288   a68_idf (A68_EXT, "pqserverversion", m, genie_pq_serverversion);
2289   a68_idf (A68_EXT, "pqsocket", m, genie_pq_socket);
2290   a68_idf (A68_EXT, "pqbackendpid", m, genie_pq_backendpid);
2291   m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (INT), NO_MOID);
2292   a68_idf (A68_EXT, "pqfname", m, genie_pq_fname);
2293   a68_idf (A68_EXT, "pqfformat", m, genie_pq_fformat);
2294   m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (INT), MODE (INT), NO_MOID);
2295   a68_idf (A68_EXT, "pqgetvalue", m, genie_pq_getvalue);
2296   a68_idf (A68_EXT, "pqgetisnull", m, genie_pq_getisnull);
2297 #endif
2298 }
2299 
2300 /**
2301 @brief Build the standard environ symbol table.
2302 **/
2303 
2304 void
make_standard_environ(void)2305 make_standard_environ (void)
2306 {
2307   stand_moids ();
2308   proc_int = a68_proc (MODE (INT), NO_MOID);
2309   proc_real = a68_proc (MODE (REAL), NO_MOID);
2310   proc_real_real = MODE (PROC_REAL_REAL);
2311   proc_real_real_real = a68_proc (MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID);
2312   proc_real_real_real_real = a68_proc (MODE (REAL), MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID);
2313   proc_complex_complex = a68_proc (MODE (COMPLEX), MODE (COMPLEX), NO_MOID);
2314   proc_bool = a68_proc (MODE (BOOL), NO_MOID);
2315   proc_char = a68_proc (MODE (CHAR), NO_MOID);
2316   proc_void = a68_proc (MODE (VOID), NO_MOID);
2317   stand_prelude ();
2318   stand_transput ();
2319   stand_extensions ();
2320 }
2321 
2322 /**
2323 Standard prelude implementation, except transput.
2324 */
2325 
2326 /*
2327 This file contains Algol68G's standard environ. Transput routines are not here.
2328 Some of the LONG operations are generic for LONG and LONG LONG.
2329 This file contains calculus related routines from the C library and GNU
2330 scientific library. When GNU scientific library is not installed then the
2331 routines in this file will give a runtime error when called. You can also choose
2332 to not have them defined in "prelude.c".
2333 */
2334 
2335 double inverf (double);
2336 double inverfc (double);
2337 
2338 double cputime_0;
2339 
2340 #define A68_MONAD(n, MODE, OP)\
2341 void n (NODE_T * p) {\
2342   MODE *i;\
2343   POP_OPERAND_ADDRESS (p, i, MODE);\
2344   VALUE (i) = OP (VALUE (i));\
2345 }
2346 
2347 /**
2348 @brief PROC (PROC VOID) VOID on gc event
2349 @param p Node in syntax tree.
2350 **/
2351 
2352 void
genie_on_gc_event(NODE_T * p)2353 genie_on_gc_event (NODE_T * p)
2354 {
2355   POP_PROCEDURE (p, &on_gc_event);
2356 }
2357 
2358 /**
2359 @brief Generic procedure for OP AND BECOMES (+:=, -:=, ...).
2360 @param p Node in syntax tree.
2361 @param ref Mode of destination.
2362 @param f Pointer to function that performs operation.
2363 **/
2364 
2365 void
genie_f_and_becomes(NODE_T * p,MOID_T * ref,GPROC * f)2366 genie_f_and_becomes (NODE_T * p, MOID_T * ref, GPROC * f)
2367 {
2368   MOID_T *mode = SUB (ref);
2369   int size = SIZE (mode);
2370   BYTE_T *src = STACK_OFFSET (-size), *addr;
2371   A68_REF *dst = (A68_REF *) STACK_OFFSET (-size - A68_REF_SIZE);
2372   CHECK_REF (p, *dst, ref);
2373   addr = ADDRESS (dst);
2374   PUSH (p, addr, size);
2375   genie_check_initialisation (p, STACK_OFFSET (-size), mode);
2376   PUSH (p, src, size);
2377   (*f) (p);
2378   POP (p, addr, size);
2379   DECREMENT_STACK_POINTER (p, size);
2380 }
2381 
2382 /* Environment enquiries */
2383 
2384 A68_ENV_INT (genie_int_lengths, 3)
2385   A68_ENV_INT (genie_int_shorths, 1)
2386   A68_ENV_INT (genie_real_lengths, 3)
2387   A68_ENV_INT (genie_real_shorths, 1)
2388   A68_ENV_INT (genie_complex_lengths, 3)
2389   A68_ENV_INT (genie_complex_shorths, 1)
2390   A68_ENV_INT (genie_bits_lengths, 3)
2391   A68_ENV_INT (genie_bits_shorths, 1)
2392   A68_ENV_INT (genie_bytes_lengths, 2)
2393   A68_ENV_INT (genie_bytes_shorths, 1)
A68_ENV_INT(genie_int_width,INT_WIDTH)2394   A68_ENV_INT (genie_int_width, INT_WIDTH)
2395   A68_ENV_INT (genie_long_int_width, LONG_INT_WIDTH)
2396   A68_ENV_INT (genie_longlong_int_width, LONGLONG_INT_WIDTH)
2397   A68_ENV_INT (genie_real_width, REAL_WIDTH)
2398   A68_ENV_INT (genie_long_real_width, LONG_REAL_WIDTH)
2399   A68_ENV_INT (genie_longlong_real_width, LONGLONG_REAL_WIDTH)
2400   A68_ENV_INT (genie_exp_width, EXP_WIDTH)
2401   A68_ENV_INT (genie_long_exp_width, LONG_EXP_WIDTH)
2402   A68_ENV_INT (genie_longlong_exp_width, LONGLONG_EXP_WIDTH)
2403   A68_ENV_INT (genie_bits_width, BITS_WIDTH)
2404   A68_ENV_INT (genie_long_bits_width, get_mp_bits_width (MODE (LONG_BITS)))
2405   A68_ENV_INT (genie_longlong_bits_width, get_mp_bits_width (MODE (LONGLONG_BITS)))
2406   A68_ENV_INT (genie_bytes_width, BYTES_WIDTH)
2407   A68_ENV_INT (genie_long_bytes_width, LONG_BYTES_WIDTH)
2408   A68_ENV_INT (genie_max_abs_char, UCHAR_MAX)
2409   A68_ENV_INT (genie_max_int, A68_MAX_INT)
2410   A68_ENV_REAL (genie_max_real, DBL_MAX)
2411   A68_ENV_REAL (genie_min_real, DBL_MIN)
2412   A68_ENV_REAL (genie_small_real, DBL_EPSILON)
2413   A68_ENV_REAL (genie_pi, A68_PI)
2414   A68_ENV_REAL (genie_cputime, seconds () - cputime_0)
2415   A68_ENV_INT (genie_stack_pointer, stack_pointer)
2416   A68_ENV_INT (genie_system_stack_size, stack_size)
2417 
2418 /**
2419 @brief INT system heap pointer
2420 @param p Node in syntax tree.
2421 **/
2422      void genie_system_heap_pointer (NODE_T * p)
2423 {
2424   PUSH_PRIMITIVE (p, (int) (heap_pointer), A68_INT);
2425 }
2426 
2427 /**
2428 @brief INT system stack pointer
2429 @param p Node in syntax tree.
2430 **/
2431 
2432 void
genie_system_stack_pointer(NODE_T * p)2433 genie_system_stack_pointer (NODE_T * p)
2434 {
2435   BYTE_T stack_offset;
2436   PUSH_PRIMITIVE (p, (int) (system_stack_offset - &stack_offset), A68_INT);
2437 }
2438 
2439 /**
2440 @brief LONG INT max long int
2441 @param p Node in syntax tree.
2442 **/
2443 
2444 void
genie_long_max_int(NODE_T * p)2445 genie_long_max_int (NODE_T * p)
2446 {
2447   int digits = DIGITS (MODE (LONG_INT));
2448   MP_T *z;
2449   int k, j = 1 + digits;
2450   STACK_MP (z, p, digits);
2451   MP_STATUS (z) = (MP_T) INIT_MASK;
2452   MP_EXPONENT (z) = (MP_T) (digits - 1);
2453   for (k = 2; k <= j; k++) {
2454     z[k] = (MP_T) (MP_RADIX - 1);
2455   }
2456 }
2457 
2458 /**
2459 @brief LONG LONG INT max long long int
2460 @param p Node in syntax tree.
2461 **/
2462 
2463 void
genie_longlong_max_int(NODE_T * p)2464 genie_longlong_max_int (NODE_T * p)
2465 {
2466   int digits = DIGITS (MODE (LONGLONG_INT));
2467   MP_T *z;
2468   int k, j = 1 + digits;
2469   STACK_MP (z, p, digits);
2470   MP_STATUS (z) = (MP_T) INIT_MASK;
2471   MP_EXPONENT (z) = (MP_T) (digits - 1);
2472   for (k = 2; k <= j; k++) {
2473     z[k] = (MP_T) (MP_RADIX - 1);
2474   }
2475 }
2476 
2477 /**
2478 @brief LONG REAL max long real
2479 @param p Node in syntax tree.
2480 **/
2481 
2482 void
genie_long_max_real(NODE_T * p)2483 genie_long_max_real (NODE_T * p)
2484 {
2485   int j, digits = DIGITS (MODE (LONG_REAL));
2486   MP_T *z;
2487   STACK_MP (z, p, digits);
2488   MP_STATUS (z) = (MP_T) INIT_MASK;
2489   MP_EXPONENT (z) = (MP_T) (MAX_MP_EXPONENT - 1);
2490   for (j = 2; j <= 1 + digits; j++) {
2491     z[j] = (MP_T) (MP_RADIX - 1);
2492   }
2493 }
2494 
2495 /**
2496 @brief LONG LONG REAL max long long real
2497 @param p Node in syntax tree.
2498 **/
2499 
2500 void
genie_longlong_max_real(NODE_T * p)2501 genie_longlong_max_real (NODE_T * p)
2502 {
2503   int j, digits = DIGITS (MODE (LONGLONG_REAL));
2504   MP_T *z;
2505   STACK_MP (z, p, digits);
2506   MP_STATUS (z) = (MP_T) INIT_MASK;
2507   MP_EXPONENT (z) = (MP_T) (MAX_MP_EXPONENT - 1);
2508   for (j = 2; j <= 1 + digits; j++) {
2509     z[j] = (MP_T) (MP_RADIX - 1);
2510   }
2511 }
2512 
2513 /**
2514 @brief LONG REAL min long real
2515 @param p Node in syntax tree.
2516 **/
2517 
2518 void
genie_long_min_real(NODE_T * p)2519 genie_long_min_real (NODE_T * p)
2520 {
2521   int digits = DIGITS (MODE (LONG_REAL));
2522   MP_T *z;
2523   STACK_MP (z, p, digits);
2524   SET_MP_ZERO (z, digits);
2525   MP_STATUS (z) = (MP_T) INIT_MASK;
2526   MP_EXPONENT (z) = (MP_T) - (MAX_MP_EXPONENT);
2527   MP_DIGIT (z, 1) = (MP_T) 1;
2528 }
2529 
2530 /**
2531 @brief LONG LONG REAL min long long real
2532 @param p Node in syntax tree.
2533 **/
2534 
2535 void
genie_longlong_min_real(NODE_T * p)2536 genie_longlong_min_real (NODE_T * p)
2537 {
2538   int digits = DIGITS (MODE (LONGLONG_REAL));
2539   MP_T *z;
2540   STACK_MP (z, p, digits);
2541   SET_MP_ZERO (z, digits);
2542   MP_STATUS (z) = (MP_T) INIT_MASK;
2543   MP_EXPONENT (z) = (MP_T) - (MAX_MP_EXPONENT);
2544   MP_DIGIT (z, 1) = (MP_T) 1;
2545 }
2546 
2547 /**
2548 @brief LONG REAL small long real
2549 @param p Node in syntax tree.
2550 **/
2551 
2552 void
genie_long_small_real(NODE_T * p)2553 genie_long_small_real (NODE_T * p)
2554 {
2555   int j, digits = DIGITS (MODE (LONG_REAL));
2556   MP_T *z;
2557   STACK_MP (z, p, digits);
2558   MP_STATUS (z) = (MP_T) INIT_MASK;
2559   MP_EXPONENT (z) = (MP_T) - (digits - 1);
2560   MP_DIGIT (z, 1) = (MP_T) 1;
2561   for (j = 3; j <= 1 + digits; j++) {
2562     z[j] = (MP_T) 0;
2563   }
2564 }
2565 
2566 /**
2567 @brief LONG LONG REAL small long long real
2568 @param p Node in syntax tree.
2569 **/
2570 
2571 void
genie_longlong_small_real(NODE_T * p)2572 genie_longlong_small_real (NODE_T * p)
2573 {
2574   int j, digits = DIGITS (MODE (LONGLONG_REAL));
2575   MP_T *z;
2576   STACK_MP (z, p, digits);
2577   MP_STATUS (z) = (MP_T) INIT_MASK;
2578   MP_EXPONENT (z) = (MP_T) - (digits - 1);
2579   MP_DIGIT (z, 1) = (MP_T) 1;
2580   for (j = 3; j <= 1 + digits; j++) {
2581     z[j] = (MP_T) 0;
2582   }
2583 }
2584 
2585 /**
2586 @brief BITS max bits
2587 @param p Node in syntax tree.
2588 **/
2589 
2590 void
genie_max_bits(NODE_T * p)2591 genie_max_bits (NODE_T * p)
2592 {
2593   PUSH_PRIMITIVE (p, A68_MAX_BITS, A68_BITS);
2594 }
2595 
2596 /**
2597 @brief LONG BITS long max bits
2598 @param p Node in syntax tree.
2599 **/
2600 
2601 void
genie_long_max_bits(NODE_T * p)2602 genie_long_max_bits (NODE_T * p)
2603 {
2604   int digits = DIGITS (MODE (LONG_BITS));
2605   int width = get_mp_bits_width (MODE (LONG_BITS));
2606   ADDR_T pop_sp;
2607   MP_T *z, *one;
2608   STACK_MP (z, p, digits);
2609   pop_sp = stack_pointer;
2610   STACK_MP (one, p, digits);
2611   (void) set_mp_short (z, (MP_T) 2, 0, digits);
2612   (void) set_mp_short (one, (MP_T) 1, 0, digits);
2613   (void) pow_mp_int (p, z, z, width, digits);
2614   (void) sub_mp (p, z, z, one, digits);
2615   stack_pointer = pop_sp;
2616 }
2617 
2618 /**
2619 @brief LONG LONG BITS long long max bits
2620 @param p Node in syntax tree.
2621 **/
2622 
2623 void
genie_longlong_max_bits(NODE_T * p)2624 genie_longlong_max_bits (NODE_T * p)
2625 {
2626   int digits = DIGITS (MODE (LONGLONG_BITS));
2627   int width = get_mp_bits_width (MODE (LONGLONG_BITS));
2628   ADDR_T pop_sp;
2629   MP_T *z, *one;
2630   STACK_MP (z, p, digits);
2631   pop_sp = stack_pointer;
2632   STACK_MP (one, p, digits);
2633   (void) set_mp_short (z, (MP_T) 2, 0, digits);
2634   (void) set_mp_short (one, (MP_T) 1, 0, digits);
2635   (void) pow_mp_int (p, z, z, width, digits);
2636   (void) sub_mp (p, z, z, one, digits);
2637   stack_pointer = pop_sp;
2638 }
2639 
2640 /**
2641 @brief LONG REAL long pi
2642 @param p Node in syntax tree.
2643 **/
2644 
2645 void
genie_pi_long_mp(NODE_T * p)2646 genie_pi_long_mp (NODE_T * p)
2647 {
2648   int digits = DIGITS (MOID (p));
2649   MP_T *z;
2650   STACK_MP (z, p, digits);
2651   (void) mp_pi (p, z, MP_PI, digits);
2652   MP_STATUS (z) = (MP_T) INIT_MASK;
2653 }
2654 
2655 /* BOOL operations */
2656 
2657 /* OP NOT = (BOOL) BOOL */
2658 
2659 A68_MONAD (genie_not_bool, A68_BOOL, (BOOL_T) !)
2660 
2661 /**
2662 @brief OP ABS = (BOOL) INT
2663 @param p Node in syntax tree.
2664 **/
genie_abs_bool(NODE_T * p)2665      void genie_abs_bool (NODE_T * p)
2666 {
2667   A68_BOOL j;
2668   POP_OBJECT (p, &j, A68_BOOL);
2669   PUSH_PRIMITIVE (p, (VALUE (&j) ? 1 : 0), A68_INT);
2670 }
2671 
2672 #define A68_BOOL_DYAD(n, OP)\
2673 void n (NODE_T * p) {\
2674   A68_BOOL *i, *j;\
2675   POP_OPERAND_ADDRESSES (p, i, j, A68_BOOL);\
2676   VALUE (i) = (BOOL_T) (VALUE (i) OP VALUE (j));\
2677 }
2678 
2679 A68_BOOL_DYAD (genie_and_bool, &)
2680   A68_BOOL_DYAD (genie_or_bool, |)
2681   A68_BOOL_DYAD (genie_xor_bool, ^)
2682   A68_BOOL_DYAD (genie_eq_bool, ==)
2683   A68_BOOL_DYAD (genie_ne_bool, !=)
2684 
2685 /* INT operations */
2686 /* OP - = (INT) INT */
2687   A68_MONAD (genie_minus_int, A68_INT, -)
2688 
2689 /**
2690 @brief OP ABS = (INT) INT
2691 @param p Node in syntax tree.
2692 **/
genie_abs_int(NODE_T * p)2693      void genie_abs_int (NODE_T * p)
2694 {
2695   A68_INT *j;
2696   POP_OPERAND_ADDRESS (p, j, A68_INT);
2697   VALUE (j) = ABS (VALUE (j));
2698 }
2699 
2700 /**
2701 @brief OP SIGN = (INT) INT
2702 @param p Node in syntax tree.
2703 **/
2704 
2705 void
genie_sign_int(NODE_T * p)2706 genie_sign_int (NODE_T * p)
2707 {
2708   A68_INT *j;
2709   POP_OPERAND_ADDRESS (p, j, A68_INT);
2710   VALUE (j) = SIGN (VALUE (j));
2711 }
2712 
2713 /**
2714 @brief OP ODD = (INT) INT
2715 @param p Node in syntax tree.
2716 **/
2717 
2718 void
genie_odd_int(NODE_T * p)2719 genie_odd_int (NODE_T * p)
2720 {
2721   A68_INT j;
2722   POP_OBJECT (p, &j, A68_INT);
2723   PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&j) >= 0 ? VALUE (&j) : -VALUE (&j)) % 2 == 1), A68_BOOL);
2724 }
2725 
2726 /**
2727 @brief OP + = (INT, INT) INT
2728 @param p Node in syntax tree.
2729 **/
2730 
2731 void
genie_add_int(NODE_T * p)2732 genie_add_int (NODE_T * p)
2733 {
2734   A68_INT *i, *j;
2735   POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
2736   CHECK_INT_ADDITION (p, VALUE (i), VALUE (j));
2737   VALUE (i) += VALUE (j);
2738 }
2739 
2740 /**
2741 @brief OP - = (INT, INT) INT
2742 @param p Node in syntax tree.
2743 **/
2744 
2745 void
genie_sub_int(NODE_T * p)2746 genie_sub_int (NODE_T * p)
2747 {
2748   A68_INT *i, *j;
2749   POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
2750   CHECK_INT_SUBTRACTION (p, VALUE (i), VALUE (j));
2751   VALUE (i) -= VALUE (j);
2752 }
2753 
2754 /**
2755 @brief OP * = (INT, INT) INT
2756 @param p Node in syntax tree.
2757 **/
2758 
2759 void
genie_mul_int(NODE_T * p)2760 genie_mul_int (NODE_T * p)
2761 {
2762   A68_INT *i, *j;
2763   POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
2764   CHECK_INT_MULTIPLICATION (p, VALUE (i), VALUE (j));
2765   VALUE (i) *= VALUE (j);
2766 }
2767 
2768 /**
2769 @brief OP OVER = (INT, INT) INT
2770 @param p Node in syntax tree.
2771 **/
2772 
2773 void
genie_over_int(NODE_T * p)2774 genie_over_int (NODE_T * p)
2775 {
2776   A68_INT *i, *j;
2777   POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
2778   PRELUDE_ERROR (VALUE (j) == 0, p, ERROR_DIVISION_BY_ZERO, MODE (INT));
2779   VALUE (i) /= VALUE (j);
2780 }
2781 
2782 /**
2783 @brief OP MOD = (INT, INT) INT
2784 @param p Node in syntax tree.
2785 **/
2786 
2787 void
genie_mod_int(NODE_T * p)2788 genie_mod_int (NODE_T * p)
2789 {
2790   A68_INT *i, *j;
2791   int k;
2792   POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
2793   PRELUDE_ERROR (VALUE (j) == 0, p, ERROR_DIVISION_BY_ZERO, MODE (INT));
2794   k = VALUE (i) % VALUE (j);
2795   if (k < 0) {
2796     k += (VALUE (j) >= 0 ? VALUE (j) : -VALUE (j));
2797   }
2798   VALUE (i) = k;
2799 }
2800 
2801 /**
2802 @brief OP / = (INT, INT) REAL
2803 @param p Node in syntax tree.
2804 **/
2805 
2806 void
genie_div_int(NODE_T * p)2807 genie_div_int (NODE_T * p)
2808 {
2809   A68_INT i, j;
2810   POP_OBJECT (p, &j, A68_INT);
2811   POP_OBJECT (p, &i, A68_INT);
2812   PRELUDE_ERROR (VALUE (&j) == 0, p, ERROR_DIVISION_BY_ZERO, MODE (INT));
2813   PUSH_PRIMITIVE (p, (double) (VALUE (&i)) / (double) (VALUE (&j)), A68_REAL);
2814 }
2815 
2816 /**
2817 @brief OP ** = (INT, INT) INT
2818 @param p Node in syntax tree.
2819 **/
2820 
2821 void
genie_pow_int(NODE_T * p)2822 genie_pow_int (NODE_T * p)
2823 {
2824   A68_INT i, j;
2825   int expo, mult, prod;
2826   POP_OBJECT (p, &j, A68_INT);
2827   PRELUDE_ERROR (VALUE (&j) < 0, p, ERROR_EXPONENT_INVALID, MODE (INT));
2828   POP_OBJECT (p, &i, A68_INT);
2829   prod = 1;
2830   mult = VALUE (&i);
2831   expo = 1;
2832   while ((unsigned) expo <= (unsigned) (VALUE (&j))) {
2833     if (VALUE (&j) & expo) {
2834       CHECK_INT_MULTIPLICATION (p, prod, mult);
2835       prod *= mult;
2836     }
2837     expo <<= 1;
2838     if (expo <= VALUE (&j)) {
2839       CHECK_INT_MULTIPLICATION (p, mult, mult);
2840       mult *= mult;
2841     }
2842   }
2843   PUSH_PRIMITIVE (p, prod, A68_INT);
2844 }
2845 
2846 /* OP (INT, INT) BOOL */
2847 
2848 #define A68_CMP_INT(n, OP)\
2849 void n (NODE_T * p) {\
2850   A68_INT i, j;\
2851   POP_OBJECT (p, &j, A68_INT);\
2852   POP_OBJECT (p, &i, A68_INT);\
2853   PUSH_PRIMITIVE (p, (BOOL_T) (VALUE (&i) OP VALUE (&j)), A68_BOOL);\
2854   }
2855 
2856 A68_CMP_INT (genie_eq_int, ==)
2857   A68_CMP_INT (genie_ne_int, !=)
2858   A68_CMP_INT (genie_lt_int, <)
2859   A68_CMP_INT (genie_gt_int, >)
2860   A68_CMP_INT (genie_le_int, <=)
2861   A68_CMP_INT (genie_ge_int, >=)
2862 
2863 /**
2864 @brief OP +:= = (REF INT, INT) REF INT
2865 @param p Node in syntax tree.
2866 **/
genie_plusab_int(NODE_T * p)2867      void genie_plusab_int (NODE_T * p)
2868 {
2869   genie_f_and_becomes (p, MODE (REF_INT), genie_add_int);
2870 }
2871 
2872 /**
2873 @brief OP -:= = (REF INT, INT) REF INT
2874 @param p Node in syntax tree.
2875 **/
2876 
2877 void
genie_minusab_int(NODE_T * p)2878 genie_minusab_int (NODE_T * p)
2879 {
2880   genie_f_and_becomes (p, MODE (REF_INT), genie_sub_int);
2881 }
2882 
2883 /**
2884 @brief OP *:= = (REF INT, INT) REF INT
2885 @param p Node in syntax tree.
2886 **/
2887 
2888 void
genie_timesab_int(NODE_T * p)2889 genie_timesab_int (NODE_T * p)
2890 {
2891   genie_f_and_becomes (p, MODE (REF_INT), genie_mul_int);
2892 }
2893 
2894 /**
2895 @brief OP %:= = (REF INT, INT) REF INT
2896 @param p Node in syntax tree.
2897 **/
2898 
2899 void
genie_overab_int(NODE_T * p)2900 genie_overab_int (NODE_T * p)
2901 {
2902   genie_f_and_becomes (p, MODE (REF_INT), genie_over_int);
2903 }
2904 
2905 /**
2906 @brief OP %*:= = (REF INT, INT) REF INT
2907 @param p Node in syntax tree.
2908 **/
2909 
2910 void
genie_modab_int(NODE_T * p)2911 genie_modab_int (NODE_T * p)
2912 {
2913   genie_f_and_becomes (p, MODE (REF_INT), genie_mod_int);
2914 }
2915 
2916 /**
2917 @brief OP LENG = (INT) LONG INT
2918 @param p Node in syntax tree.
2919 **/
2920 
2921 void
genie_lengthen_int_to_long_mp(NODE_T * p)2922 genie_lengthen_int_to_long_mp (NODE_T * p)
2923 {
2924   int digits = DIGITS (MODE (LONG_INT));
2925   MP_T *z;
2926   A68_INT k;
2927   POP_OBJECT (p, &k, A68_INT);
2928   STACK_MP (z, p, digits);
2929   (void) int_to_mp (p, z, VALUE (&k), digits);
2930   MP_STATUS (z) = (MP_T) INIT_MASK;
2931 }
2932 
2933 /**
2934 @brief OP LENG = (BITS) LONG BITS
2935 @param p Node in syntax tree.
2936 **/
2937 
2938 void
genie_lengthen_unsigned_to_long_mp(NODE_T * p)2939 genie_lengthen_unsigned_to_long_mp (NODE_T * p)
2940 {
2941   int digits = DIGITS (MODE (LONG_INT));
2942   MP_T *z;
2943   A68_BITS k;
2944   POP_OBJECT (p, &k, A68_BITS);
2945   STACK_MP (z, p, digits);
2946   (void) unsigned_to_mp (p, z, (unsigned) VALUE (&k), digits);
2947   MP_STATUS (z) = (MP_T) INIT_MASK;
2948 }
2949 
2950 /**
2951 @brief OP SHORTEN = (LONG INT) INT
2952 @param p Node in syntax tree.
2953 **/
2954 
2955 void
genie_shorten_long_mp_to_int(NODE_T * p)2956 genie_shorten_long_mp_to_int (NODE_T * p)
2957 {
2958   MOID_T *mode = LHS_MODE (p);
2959   int digits = DIGITS (mode), size = SIZE (mode);
2960   MP_T *z;
2961   DECREMENT_STACK_POINTER (p, size);
2962   z = (MP_T *) STACK_TOP;
2963   MP_STATUS (z) = (MP_T) INIT_MASK;
2964   PUSH_PRIMITIVE (p, mp_to_int (p, z, digits), A68_INT);
2965 }
2966 
2967 /**
2968 @brief OP ODD = (LONG INT) BOOL
2969 @param p Node in syntax tree.
2970 **/
2971 
2972 void
genie_odd_long_mp(NODE_T * p)2973 genie_odd_long_mp (NODE_T * p)
2974 {
2975   MOID_T *mode = LHS_MODE (p);
2976   int digits = DIGITS (mode), size = SIZE (mode);
2977   MP_T *z = (MP_T *) STACK_OFFSET (-size);
2978   DECREMENT_STACK_POINTER (p, size);
2979   if (MP_EXPONENT (z) <= (MP_T) (digits - 1)) {
2980     PUSH_PRIMITIVE (p, (BOOL_T) ((int) (z[(int) (2 + MP_EXPONENT (z))]) % 2 != 0), A68_BOOL);
2981   } else {
2982     PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL);
2983   }
2984 }
2985 
2986 /**
2987 @brief Test whether z is a valid LONG INT.
2988 @param p Node in syntax tree.
2989 @param z Mp number.
2990 @param m Mode associated with z.
2991 **/
2992 
2993 void
test_long_int_range(NODE_T * p,MP_T * z,MOID_T * m)2994 test_long_int_range (NODE_T * p, MP_T * z, MOID_T * m)
2995 {
2996   PRELUDE_ERROR (!check_mp_int (z, m), p, ERROR_OUT_OF_BOUNDS, m);
2997 }
2998 
2999 /**
3000 @brief OP + = (LONG INT, LONG INT) LONG INT
3001 @param p Node in syntax tree.
3002 **/
3003 
3004 void
genie_add_long_int(NODE_T * p)3005 genie_add_long_int (NODE_T * p)
3006 {
3007   MOID_T *m = RHS_MODE (p);
3008   int digits = DIGITS (m), size = SIZE (m);
3009   MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
3010   MP_T *y = (MP_T *) STACK_OFFSET (-size);
3011   (void) add_mp (p, x, x, y, digits);
3012   test_long_int_range (p, x, m);
3013   MP_STATUS (x) = (MP_T) INIT_MASK;
3014   DECREMENT_STACK_POINTER (p, size);
3015 }
3016 
3017 /**
3018 @brief OP - = (LONG INT, LONG INT) LONG INT
3019 @param p Node in syntax tree.
3020 **/
3021 
3022 void
genie_sub_long_int(NODE_T * p)3023 genie_sub_long_int (NODE_T * p)
3024 {
3025   MOID_T *m = RHS_MODE (p);
3026   int digits = DIGITS (m), size = SIZE (m);
3027   MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
3028   MP_T *y = (MP_T *) STACK_OFFSET (-size);
3029   (void) sub_mp (p, x, x, y, digits);
3030   test_long_int_range (p, x, m);
3031   MP_STATUS (x) = (MP_T) INIT_MASK;
3032   DECREMENT_STACK_POINTER (p, size);
3033 }
3034 
3035 /**
3036 @brief OP * = (LONG INT, LONG INT) LONG INT
3037 @param p Node in syntax tree.
3038 **/
3039 
3040 void
genie_mul_long_int(NODE_T * p)3041 genie_mul_long_int (NODE_T * p)
3042 {
3043   MOID_T *m = RHS_MODE (p);
3044   int digits = DIGITS (m), size = SIZE (m);
3045   MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
3046   MP_T *y = (MP_T *) STACK_OFFSET (-size);
3047   (void) mul_mp (p, x, x, y, digits);
3048   test_long_int_range (p, x, m);
3049   MP_STATUS (x) = (MP_T) INIT_MASK;
3050   DECREMENT_STACK_POINTER (p, size);
3051 }
3052 
3053 /**
3054 @brief OP ** = (LONG MODE, INT) LONG INT
3055 @param p Node in syntax tree.
3056 **/
3057 
3058 void
genie_pow_long_mp_int_int(NODE_T * p)3059 genie_pow_long_mp_int_int (NODE_T * p)
3060 {
3061   MOID_T *m = LHS_MODE (p);
3062   int digits = DIGITS (m), size = SIZE (m);
3063   A68_INT k;
3064   MP_T *x;
3065   POP_OBJECT (p, &k, A68_INT);
3066   x = (MP_T *) STACK_OFFSET (-size);
3067   (void) pow_mp_int (p, x, x, VALUE (&k), digits);
3068   test_long_int_range (p, x, m);
3069   MP_STATUS (x) = (MP_T) INIT_MASK;
3070 }
3071 
3072 /**
3073 @brief OP +:= = (REF LONG INT, LONG INT) REF LONG INT
3074 @param p Node in syntax tree.
3075 **/
3076 
3077 void
genie_plusab_long_int(NODE_T * p)3078 genie_plusab_long_int (NODE_T * p)
3079 {
3080   MOID_T *mode = LHS_MODE (p);
3081   genie_f_and_becomes (p, mode, genie_add_long_int);
3082 }
3083 
3084 /**
3085 @brief OP -:= = (REF LONG INT, LONG INT) REF LONG INT
3086 @param p Node in syntax tree.
3087 **/
3088 
3089 void
genie_minusab_long_int(NODE_T * p)3090 genie_minusab_long_int (NODE_T * p)
3091 {
3092   MOID_T *mode = LHS_MODE (p);
3093   genie_f_and_becomes (p, mode, genie_sub_long_int);
3094 }
3095 
3096 /**
3097 @brief OP *:= = (REF LONG INT, LONG INT) REF LONG INT
3098 @param p Node in syntax tree.
3099 **/
3100 
3101 void
genie_timesab_long_int(NODE_T * p)3102 genie_timesab_long_int (NODE_T * p)
3103 {
3104   MOID_T *mode = LHS_MODE (p);
3105   genie_f_and_becomes (p, mode, genie_mul_long_int);
3106 }
3107 
3108 /* REAL operations. REAL math is in gsl.c */
3109 
3110 /* OP - = (REAL) REAL */
3111 
3112 A68_MONAD (genie_minus_real, A68_REAL, -)
3113 
3114 /**
3115 @brief OP ABS = (REAL) REAL
3116 @param p Node in syntax tree.
3117 **/
genie_abs_real(NODE_T * p)3118      void genie_abs_real (NODE_T * p)
3119 {
3120   A68_REAL *x;
3121   POP_OPERAND_ADDRESS (p, x, A68_REAL);
3122   VALUE (x) = ABS (VALUE (x));
3123 }
3124 
3125 /**
3126 @brief OP ROUND = (REAL) INT
3127 @param p Node in syntax tree.
3128 **/
3129 
3130 void
genie_round_real(NODE_T * p)3131 genie_round_real (NODE_T * p)
3132 {
3133   A68_REAL x;
3134   POP_OBJECT (p, &x, A68_REAL);
3135   PRELUDE_ERROR (VALUE (&x) < -(double) A68_MAX_INT || VALUE (&x) > (double) A68_MAX_INT, p, ERROR_OUT_OF_BOUNDS, MODE (INT));
3136   PUSH_PRIMITIVE (p, a68g_round (VALUE (&x)), A68_INT);
3137 }
3138 
3139 /**
3140 @brief OP ENTIER = (REAL) INT
3141 @param p Node in syntax tree.
3142 **/
3143 
3144 void
genie_entier_real(NODE_T * p)3145 genie_entier_real (NODE_T * p)
3146 {
3147   A68_REAL x;
3148   POP_OBJECT (p, &x, A68_REAL);
3149   PRELUDE_ERROR (VALUE (&x) < -(double) A68_MAX_INT || VALUE (&x) > (double) A68_MAX_INT, p, ERROR_OUT_OF_BOUNDS, MODE (INT));
3150   PUSH_PRIMITIVE (p, (int) floor (VALUE (&x)), A68_INT);
3151 }
3152 
3153 /**
3154 @brief OP SIGN = (REAL) INT
3155 @param p Node in syntax tree.
3156 **/
3157 
3158 void
genie_sign_real(NODE_T * p)3159 genie_sign_real (NODE_T * p)
3160 {
3161   A68_REAL x;
3162   POP_OBJECT (p, &x, A68_REAL);
3163   PUSH_PRIMITIVE (p, SIGN (VALUE (&x)), A68_INT);
3164 }
3165 
3166 /**
3167 @brief OP + = (REAL, REAL) REAL
3168 @param p Node in syntax tree.
3169 **/
3170 
3171 void
genie_add_real(NODE_T * p)3172 genie_add_real (NODE_T * p)
3173 {
3174   A68_REAL *x, *y;
3175   POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
3176   VALUE (x) += VALUE (y);
3177   CHECK_REAL_REPRESENTATION (p, VALUE (x));
3178 }
3179 
3180 /**
3181 @brief OP - = (REAL, REAL) REAL
3182 @param p Node in syntax tree.
3183 **/
3184 
3185 void
genie_sub_real(NODE_T * p)3186 genie_sub_real (NODE_T * p)
3187 {
3188   A68_REAL *x, *y;
3189   POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
3190   VALUE (x) -= VALUE (y);
3191   CHECK_REAL_REPRESENTATION (p, VALUE (x));
3192 }
3193 
3194 /**
3195 @brief OP * = (REAL, REAL) REAL
3196 @param p Node in syntax tree.
3197 **/
3198 
3199 void
genie_mul_real(NODE_T * p)3200 genie_mul_real (NODE_T * p)
3201 {
3202   A68_REAL *x, *y;
3203   POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
3204   VALUE (x) *= VALUE (y);
3205   CHECK_REAL_REPRESENTATION (p, VALUE (x));
3206 }
3207 
3208 /**
3209 @brief OP / = (REAL, REAL) REAL
3210 @param p Node in syntax tree.
3211 **/
3212 
3213 void
genie_div_real(NODE_T * p)3214 genie_div_real (NODE_T * p)
3215 {
3216   A68_REAL *x, *y;
3217   POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
3218   PRELUDE_ERROR (VALUE (y) == 0.0, p, ERROR_DIVISION_BY_ZERO, MODE (REAL));
3219   VALUE (x) /= VALUE (y);
3220 }
3221 
3222 /**
3223 @brief OP ** = (REAL, INT) REAL
3224 @param p Node in syntax tree.
3225 **/
3226 
3227 void
genie_pow_real_int(NODE_T * p)3228 genie_pow_real_int (NODE_T * p)
3229 {
3230   A68_INT j;
3231   A68_REAL x;
3232   int expo;
3233   double mult, prod;
3234   BOOL_T negative;
3235   POP_OBJECT (p, &j, A68_INT);
3236   negative = (BOOL_T) (VALUE (&j) < 0);
3237   VALUE (&j) = (VALUE (&j) >= 0 ? VALUE (&j) : -VALUE (&j));
3238   POP_OBJECT (p, &x, A68_REAL);
3239   prod = 1;
3240   mult = VALUE (&x);
3241   expo = 1;
3242   while ((unsigned) expo <= (unsigned) (VALUE (&j))) {
3243     if (VALUE (&j) & expo) {
3244       CHECK_REAL_MULTIPLICATION (p, prod, mult);
3245       prod *= mult;
3246     }
3247     expo <<= 1;
3248     if (expo <= VALUE (&j)) {
3249       CHECK_REAL_MULTIPLICATION (p, mult, mult);
3250       mult *= mult;
3251     }
3252   }
3253   CHECK_REAL_REPRESENTATION (p, prod);
3254   if (negative) {
3255     prod = 1.0 / prod;
3256   }
3257   PUSH_PRIMITIVE (p, prod, A68_REAL);
3258 }
3259 
3260 /**
3261 @brief OP ** = (REAL, REAL) REAL
3262 @param p Node in syntax tree.
3263 **/
3264 
3265 void
genie_pow_real(NODE_T * p)3266 genie_pow_real (NODE_T * p)
3267 {
3268   A68_REAL x, y;
3269   double z = 0;
3270   POP_OBJECT (p, &y, A68_REAL);
3271   POP_OBJECT (p, &x, A68_REAL);
3272   RESET_ERRNO;
3273   PRELUDE_ERROR (VALUE (&x) < 0.0, p, ERROR_INVALID_ARGUMENT, MODE (REAL));
3274   if (VALUE (&x) == 0.0) {
3275     if (VALUE (&y) < 0) {
3276       errno = ERANGE;
3277       MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT);
3278     } else {
3279       z = (VALUE (&y) == 0.0 ? 1.0 : 0.0);
3280     }
3281   } else {
3282     z = exp (VALUE (&y) * log (VALUE (&x)));
3283     MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT);
3284   }
3285   PUSH_PRIMITIVE (p, z, A68_REAL);
3286 }
3287 
3288 /* OP (REAL, REAL) BOOL */
3289 
3290 #define A68_CMP_REAL(n, OP)\
3291 void n (NODE_T * p) {\
3292   A68_REAL i, j;\
3293   POP_OBJECT (p, &j, A68_REAL);\
3294   POP_OBJECT (p, &i, A68_REAL);\
3295   PUSH_PRIMITIVE (p, (BOOL_T) (VALUE (&i) OP VALUE (&j)), A68_BOOL);\
3296   }
3297 
3298 A68_CMP_REAL (genie_eq_real, ==)
3299   A68_CMP_REAL (genie_ne_real, !=)
3300   A68_CMP_REAL (genie_lt_real, <)
3301   A68_CMP_REAL (genie_gt_real, >)
3302   A68_CMP_REAL (genie_le_real, <=)
3303   A68_CMP_REAL (genie_ge_real, >=)
3304 
3305 /**
3306 @brief OP +:= = (REF REAL, REAL) REF REAL
3307 @param p Node in syntax tree.
3308 **/
genie_plusab_real(NODE_T * p)3309      void genie_plusab_real (NODE_T * p)
3310 {
3311   genie_f_and_becomes (p, MODE (REF_REAL), genie_add_real);
3312 }
3313 
3314 /**
3315 @brief OP -:= = (REF REAL, REAL) REF REAL
3316 @param p Node in syntax tree.
3317 **/
3318 
3319 void
genie_minusab_real(NODE_T * p)3320 genie_minusab_real (NODE_T * p)
3321 {
3322   genie_f_and_becomes (p, MODE (REF_REAL), genie_sub_real);
3323 }
3324 
3325 /**
3326 @brief OP *:= = (REF REAL, REAL) REF REAL
3327 @param p Node in syntax tree.
3328 **/
3329 
3330 void
genie_timesab_real(NODE_T * p)3331 genie_timesab_real (NODE_T * p)
3332 {
3333   genie_f_and_becomes (p, MODE (REF_REAL), genie_mul_real);
3334 }
3335 
3336 /**
3337 @brief OP /:= = (REF REAL, REAL) REF REAL
3338 @param p Node in syntax tree.
3339 **/
3340 
3341 void
genie_divab_real(NODE_T * p)3342 genie_divab_real (NODE_T * p)
3343 {
3344   genie_f_and_becomes (p, MODE (REF_REAL), genie_div_real);
3345 }
3346 
3347 /**
3348 @brief OP LENG = (REAL) LONG REAL
3349 @param p Node in syntax tree.
3350 **/
3351 
3352 void
genie_lengthen_real_to_long_mp(NODE_T * p)3353 genie_lengthen_real_to_long_mp (NODE_T * p)
3354 {
3355   int digits = DIGITS (MODE (LONG_REAL));
3356   MP_T *z;
3357   A68_REAL x;
3358   POP_OBJECT (p, &x, A68_REAL);
3359   STACK_MP (z, p, digits);
3360   (void) real_to_mp (p, z, VALUE (&x), digits);
3361   MP_STATUS (z) = (MP_T) INIT_MASK;
3362 }
3363 
3364 /**
3365 @brief OP SHORTEN = (LONG REAL) REAL
3366 @param p Node in syntax tree.
3367 **/
3368 
3369 void
genie_shorten_long_mp_to_real(NODE_T * p)3370 genie_shorten_long_mp_to_real (NODE_T * p)
3371 {
3372   MOID_T *mode = LHS_MODE (p);
3373   int digits = DIGITS (mode), size = SIZE (mode);
3374   MP_T *z;
3375   DECREMENT_STACK_POINTER (p, size);
3376   z = (MP_T *) STACK_TOP;
3377   MP_STATUS (z) = (MP_T) INIT_MASK;
3378   PUSH_PRIMITIVE (p, mp_to_real (p, z, digits), A68_REAL);
3379 }
3380 
3381 /**
3382 @brief OP ROUND = (LONG REAL) LONG INT
3383 @param p Node in syntax tree.
3384 **/
3385 
3386 void
genie_round_long_mp(NODE_T * p)3387 genie_round_long_mp (NODE_T * p)
3388 {
3389   MOID_T *mode = LHS_MODE (p);
3390   int digits = DIGITS (mode), size = SIZE (mode);
3391   ADDR_T pop_sp = stack_pointer;
3392   MP_T *z = (MP_T *) STACK_OFFSET (-size);
3393   (void) round_mp (p, z, z, digits);
3394   stack_pointer = pop_sp;
3395 }
3396 
3397 /**
3398 @brief OP ENTIER = (LONG REAL) LONG INT
3399 @param p Node in syntax tree.
3400 **/
3401 
3402 void
genie_entier_long_mp(NODE_T * p)3403 genie_entier_long_mp (NODE_T * p)
3404 {
3405   int digits = DIGITS (LHS_MODE (p)), size = SIZE (LHS_MODE (p));
3406   ADDR_T pop_sp = stack_pointer;
3407   MP_T *z = (MP_T *) STACK_OFFSET (-size);
3408   (void) entier_mp (p, z, z, digits);
3409   stack_pointer = pop_sp;
3410 }
3411 
3412 /**
3413 @brief PROC long sqrt = (LONG REAL) LONG REAL
3414 @param p Node in syntax tree.
3415 **/
3416 
3417 void
genie_sqrt_long_mp(NODE_T * p)3418 genie_sqrt_long_mp (NODE_T * p)
3419 {
3420   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3421   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3422   PRELUDE_ERROR (sqrt_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
3423   MP_STATUS (x) = (MP_T) INIT_MASK;
3424 }
3425 
3426 /**
3427 @brief PROC long curt = (LONG REAL) LONG REAL
3428 @param p Node in syntax tree.
3429 **/
3430 
3431 void
genie_curt_long_mp(NODE_T * p)3432 genie_curt_long_mp (NODE_T * p)
3433 {
3434   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3435   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3436   PRELUDE_ERROR (curt_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
3437   MP_STATUS (x) = (MP_T) INIT_MASK;
3438 }
3439 
3440 /**
3441 @brief PROC long exp = (LONG REAL) LONG REAL
3442 @param p Node in syntax tree.
3443 **/
3444 
3445 void
genie_exp_long_mp(NODE_T * p)3446 genie_exp_long_mp (NODE_T * p)
3447 {
3448   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3449   ADDR_T pop_sp = stack_pointer;
3450   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3451   (void) exp_mp (p, x, x, digits);
3452   MP_STATUS (x) = (MP_T) INIT_MASK;
3453   stack_pointer = pop_sp;
3454 }
3455 
3456 /**
3457 @brief PROC long ln = (LONG REAL) LONG REAL
3458 @param p Node in syntax tree.
3459 **/
3460 
3461 void
genie_ln_long_mp(NODE_T * p)3462 genie_ln_long_mp (NODE_T * p)
3463 {
3464   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3465   ADDR_T pop_sp = stack_pointer;
3466   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3467   PRELUDE_ERROR (ln_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
3468   MP_STATUS (x) = (MP_T) INIT_MASK;
3469   stack_pointer = pop_sp;
3470 }
3471 
3472 /**
3473 @brief PROC long log = (LONG REAL) LONG REAL
3474 @param p Node in syntax tree.
3475 **/
3476 
3477 void
genie_log_long_mp(NODE_T * p)3478 genie_log_long_mp (NODE_T * p)
3479 {
3480   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3481   ADDR_T pop_sp = stack_pointer;
3482   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3483   PRELUDE_ERROR (log_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
3484   MP_STATUS (x) = (MP_T) INIT_MASK;
3485   stack_pointer = pop_sp;
3486 }
3487 
3488 /**
3489 @brief PROC long sinh = (LONG REAL) LONG REAL
3490 @param p Node in syntax tree.
3491 **/
3492 
3493 void
genie_sinh_long_mp(NODE_T * p)3494 genie_sinh_long_mp (NODE_T * p)
3495 {
3496   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3497   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3498   (void) sinh_mp (p, x, x, digits);
3499   MP_STATUS (x) = (MP_T) INIT_MASK;
3500 }
3501 
3502 /**
3503 @brief PROC long cosh = (LONG REAL) LONG REAL
3504 @param p Node in syntax tree.
3505 **/
3506 
3507 void
genie_cosh_long_mp(NODE_T * p)3508 genie_cosh_long_mp (NODE_T * p)
3509 {
3510   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3511   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3512   (void) cosh_mp (p, x, x, digits);
3513   MP_STATUS (x) = (MP_T) INIT_MASK;
3514 }
3515 
3516 /**
3517 @brief PROC long tanh = (LONG REAL) LONG REAL
3518 @param p Node in syntax tree.
3519 **/
3520 
3521 void
genie_tanh_long_mp(NODE_T * p)3522 genie_tanh_long_mp (NODE_T * p)
3523 {
3524   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3525   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3526   (void) tanh_mp (p, x, x, digits);
3527   MP_STATUS (x) = (MP_T) INIT_MASK;
3528 }
3529 
3530 /**
3531 @brief PROC long arcsinh = (LONG REAL) LONG REAL
3532 @param p Node in syntax tree.
3533 **/
3534 
3535 void
genie_arcsinh_long_mp(NODE_T * p)3536 genie_arcsinh_long_mp (NODE_T * p)
3537 {
3538   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3539   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3540   (void) asinh_mp (p, x, x, digits);
3541   MP_STATUS (x) = (MP_T) INIT_MASK;
3542 }
3543 
3544 /**
3545 @brief PROC long arccosh = (LONG REAL) LONG REAL
3546 @param p Node in syntax tree.
3547 **/
3548 
3549 void
genie_arccosh_long_mp(NODE_T * p)3550 genie_arccosh_long_mp (NODE_T * p)
3551 {
3552   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3553   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3554   (void) acosh_mp (p, x, x, digits);
3555   MP_STATUS (x) = (MP_T) INIT_MASK;
3556 }
3557 
3558 /**
3559 @brief PROC long arctanh = (LONG REAL) LONG REAL
3560 @param p Node in syntax tree.
3561 **/
3562 
3563 void
genie_arctanh_long_mp(NODE_T * p)3564 genie_arctanh_long_mp (NODE_T * p)
3565 {
3566   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3567   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3568   (void) atanh_mp (p, x, x, digits);
3569   MP_STATUS (x) = (MP_T) INIT_MASK;
3570 }
3571 
3572 /**
3573 @brief PROC long sin = (LONG REAL) LONG REAL
3574 @param p Node in syntax tree.
3575 **/
3576 
3577 void
genie_sin_long_mp(NODE_T * p)3578 genie_sin_long_mp (NODE_T * p)
3579 {
3580   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3581   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3582   (void) sin_mp (p, x, x, digits);
3583   MP_STATUS (x) = (MP_T) INIT_MASK;
3584 }
3585 
3586 /**
3587 @brief PROC long cos = (LONG REAL) LONG REAL
3588 @param p Node in syntax tree.
3589 **/
3590 
3591 void
genie_cos_long_mp(NODE_T * p)3592 genie_cos_long_mp (NODE_T * p)
3593 {
3594   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3595   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3596   (void) cos_mp (p, x, x, digits);
3597   MP_STATUS (x) = (MP_T) INIT_MASK;
3598 }
3599 
3600 /**
3601 @brief PROC long tan = (LONG REAL) LONG REAL
3602 @param p Node in syntax tree.
3603 **/
3604 
3605 void
genie_tan_long_mp(NODE_T * p)3606 genie_tan_long_mp (NODE_T * p)
3607 {
3608   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3609   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3610   PRELUDE_ERROR (tan_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
3611   MP_STATUS (x) = (MP_T) INIT_MASK;
3612 }
3613 
3614 /**
3615 @brief PROC long arcsin = (LONG REAL) LONG REAL
3616 @param p Node in syntax tree.
3617 **/
3618 
3619 void
genie_asin_long_mp(NODE_T * p)3620 genie_asin_long_mp (NODE_T * p)
3621 {
3622   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3623   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3624   PRELUDE_ERROR (asin_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
3625   MP_STATUS (x) = (MP_T) INIT_MASK;
3626 }
3627 
3628 /**
3629 @brief PROC long arccos = (LONG REAL) LONG REAL
3630 @param p Node in syntax tree.
3631 **/
3632 
3633 void
genie_acos_long_mp(NODE_T * p)3634 genie_acos_long_mp (NODE_T * p)
3635 {
3636   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3637   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3638   PRELUDE_ERROR (acos_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
3639   MP_STATUS (x) = (MP_T) INIT_MASK;
3640 }
3641 
3642 /**
3643 @brief PROC long arctan = (LONG REAL) LONG REAL
3644 @param p Node in syntax tree.
3645 **/
3646 
3647 void
genie_atan_long_mp(NODE_T * p)3648 genie_atan_long_mp (NODE_T * p)
3649 {
3650   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3651   MP_T *x = (MP_T *) STACK_OFFSET (-size);
3652   (void) atan_mp (p, x, x, digits);
3653   MP_STATUS (x) = (MP_T) INIT_MASK;
3654 }
3655 
3656 /**
3657 @brief PROC long arctan2 = (LONG REAL, LONG REAL) LONG REAL
3658 @param p Node in syntax tree.
3659 **/
3660 
3661 void
genie_atan2_long_mp(NODE_T * p)3662 genie_atan2_long_mp (NODE_T * p)
3663 {
3664   int digits = DIGITS (MOID (p)), size = SIZE (MOID (p));
3665   MP_T *y = (MP_T *) STACK_OFFSET (-size);
3666   MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
3667   stack_pointer -= size;
3668   PRELUDE_ERROR (atan2_mp (p, x, y, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
3669   MP_STATUS (x) = (MP_T) INIT_MASK;
3670 }
3671 
3672 /* Arithmetic operations */
3673 
3674 /**
3675 @brief OP LENG = (LONG MODE) LONG LONG MODE
3676 @param p Node in syntax tree.
3677 **/
3678 
3679 void
genie_lengthen_long_mp_to_longlong_mp(NODE_T * p)3680 genie_lengthen_long_mp_to_longlong_mp (NODE_T * p)
3681 {
3682   MP_T *z;
3683   DECREMENT_STACK_POINTER (p, (int) size_long_mp ());
3684   STACK_MP (z, p, longlong_mp_digits ());
3685   (void) lengthen_mp (p, z, longlong_mp_digits (), z, long_mp_digits ());
3686   MP_STATUS (z) = (MP_T) INIT_MASK;
3687 }
3688 
3689 /**
3690 @brief OP SHORTEN = (LONG LONG MODE) LONG MODE
3691 @param p Node in syntax tree.
3692 **/
3693 
3694 void
genie_shorten_longlong_mp_to_long_mp(NODE_T * p)3695 genie_shorten_longlong_mp_to_long_mp (NODE_T * p)
3696 {
3697   MP_T *z;
3698   MOID_T *m = SUB_MOID (p);
3699   DECREMENT_STACK_POINTER (p, (int) size_longlong_mp ());
3700   STACK_MP (z, p, long_mp_digits ());
3701   if (m == MODE (LONG_INT)) {
3702     PRELUDE_ERROR (MP_EXPONENT (z) > LONG_MP_DIGITS - 1, p, ERROR_OUT_OF_BOUNDS, m);
3703   }
3704   (void) shorten_mp (p, z, long_mp_digits (), z, longlong_mp_digits ());
3705   MP_STATUS (z) = (MP_T) INIT_MASK;
3706 }
3707 
3708 /**
3709 @brief OP - = (LONG MODE) LONG MODE
3710 @param p Node in syntax tree.
3711 **/
3712 
3713 void
genie_minus_long_mp(NODE_T * p)3714 genie_minus_long_mp (NODE_T * p)
3715 {
3716   int size = SIZE (LHS_MODE (p));
3717   MP_T *z = (MP_T *) STACK_OFFSET (-size);
3718   MP_STATUS (z) = (MP_T) INIT_MASK;
3719   MP_DIGIT (z, 1) = -MP_DIGIT (z, 1);
3720 }
3721 
3722 /**
3723 @brief OP ABS = (LONG MODE) LONG MODE
3724 @param p Node in syntax tree.
3725 **/
3726 
3727 void
genie_abs_long_mp(NODE_T * p)3728 genie_abs_long_mp (NODE_T * p)
3729 {
3730   int size = SIZE (LHS_MODE (p));
3731   MP_T *z = (MP_T *) STACK_OFFSET (-size);
3732   MP_STATUS (z) = (MP_T) INIT_MASK;
3733   MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1));
3734 }
3735 
3736 /**
3737 @brief OP SIGN = (LONG MODE) INT
3738 @param p Node in syntax tree.
3739 **/
3740 
3741 void
genie_sign_long_mp(NODE_T * p)3742 genie_sign_long_mp (NODE_T * p)
3743 {
3744   int size = SIZE (LHS_MODE (p));
3745   MP_T *z = (MP_T *) STACK_OFFSET (-size);
3746   DECREMENT_STACK_POINTER (p, size);
3747   PUSH_PRIMITIVE (p, SIGN (MP_DIGIT (z, 1)), A68_INT);
3748 }
3749 
3750 /**
3751 @brief OP + = (LONG MODE, LONG MODE) LONG MODE
3752 @param p Node in syntax tree.
3753 **/
3754 
3755 void
genie_add_long_mp(NODE_T * p)3756 genie_add_long_mp (NODE_T * p)
3757 {
3758   MOID_T *mode = RHS_MODE (p);
3759   int digits = DIGITS (mode), size = SIZE (mode);
3760   MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
3761   MP_T *y = (MP_T *) STACK_OFFSET (-size);
3762   (void) add_mp (p, x, x, y, digits);
3763   MP_STATUS (x) = (MP_T) INIT_MASK;
3764   DECREMENT_STACK_POINTER (p, size);
3765 }
3766 
3767 /**
3768 @brief OP - = (LONG MODE, LONG MODE) LONG MODE
3769 @param p Node in syntax tree.
3770 **/
3771 
3772 void
genie_sub_long_mp(NODE_T * p)3773 genie_sub_long_mp (NODE_T * p)
3774 {
3775   MOID_T *mode = RHS_MODE (p);
3776   int digits = DIGITS (mode), size = SIZE (mode);
3777   MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
3778   MP_T *y = (MP_T *) STACK_OFFSET (-size);
3779   (void) sub_mp (p, x, x, y, digits);
3780   MP_STATUS (x) = (MP_T) INIT_MASK;
3781   DECREMENT_STACK_POINTER (p, size);
3782 }
3783 
3784 /**
3785 @brief OP * = (LONG MODE, LONG MODE) LONG MODE
3786 @param p Node in syntax tree.
3787 **/
3788 
3789 void
genie_mul_long_mp(NODE_T * p)3790 genie_mul_long_mp (NODE_T * p)
3791 {
3792   MOID_T *mode = RHS_MODE (p);
3793   int digits = DIGITS (mode), size = SIZE (mode);
3794   MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
3795   MP_T *y = (MP_T *) STACK_OFFSET (-size);
3796   (void) mul_mp (p, x, x, y, digits);
3797   MP_STATUS (x) = (MP_T) INIT_MASK;
3798   DECREMENT_STACK_POINTER (p, size);
3799 }
3800 
3801 /**
3802 @brief OP / = (LONG MODE, LONG MODE) LONG MODE
3803 @param p Node in syntax tree.
3804 **/
3805 
3806 void
genie_div_long_mp(NODE_T * p)3807 genie_div_long_mp (NODE_T * p)
3808 {
3809   MOID_T *mode = RHS_MODE (p);
3810   int digits = DIGITS (mode), size = SIZE (mode);
3811   MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
3812   MP_T *y = (MP_T *) STACK_OFFSET (-size);
3813   PRELUDE_ERROR (div_mp (p, x, x, y, digits) == NO_MP, p, ERROR_DIVISION_BY_ZERO, MODE (LONG_REAL));
3814   MP_STATUS (x) = (MP_T) INIT_MASK;
3815   DECREMENT_STACK_POINTER (p, size);
3816 }
3817 
3818 /**
3819 @brief OP % = (LONG MODE, LONG MODE) LONG MODE
3820 @param p Node in syntax tree.
3821 **/
3822 
3823 void
genie_over_long_mp(NODE_T * p)3824 genie_over_long_mp (NODE_T * p)
3825 {
3826   MOID_T *mode = RHS_MODE (p);
3827   int digits = DIGITS (mode), size = SIZE (mode);
3828   MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
3829   MP_T *y = (MP_T *) STACK_OFFSET (-size);
3830   PRELUDE_ERROR (over_mp (p, x, x, y, digits) == NO_MP, p, ERROR_DIVISION_BY_ZERO, MODE (LONG_INT));
3831   MP_STATUS (x) = (MP_T) INIT_MASK;
3832   DECREMENT_STACK_POINTER (p, size);
3833 }
3834 
3835 /**
3836 @brief OP %* = (LONG MODE, LONG MODE) LONG MODE
3837 @param p Node in syntax tree.
3838 **/
3839 
3840 void
genie_mod_long_mp(NODE_T * p)3841 genie_mod_long_mp (NODE_T * p)
3842 {
3843   MOID_T *mode = RHS_MODE (p);
3844   int digits = DIGITS (mode), size = SIZE (mode);
3845   MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
3846   MP_T *y = (MP_T *) STACK_OFFSET (-size);
3847   PRELUDE_ERROR (mod_mp (p, x, x, y, digits) == NO_MP, p, ERROR_DIVISION_BY_ZERO, MODE (LONG_INT));
3848   if (MP_DIGIT (x, 1) < 0) {
3849     MP_DIGIT (y, 1) = ABS (MP_DIGIT (y, 1));
3850     (void) add_mp (p, x, x, y, digits);
3851   }
3852   MP_STATUS (x) = (MP_T) INIT_MASK;
3853   DECREMENT_STACK_POINTER (p, size);
3854 }
3855 
3856 /**
3857 @brief OP +:= = (REF LONG MODE, LONG MODE) REF LONG MODE
3858 @param p Node in syntax tree.
3859 **/
3860 
3861 void
genie_plusab_long_mp(NODE_T * p)3862 genie_plusab_long_mp (NODE_T * p)
3863 {
3864   MOID_T *mode = LHS_MODE (p);
3865   genie_f_and_becomes (p, mode, genie_add_long_mp);
3866 }
3867 
3868 /**
3869 @brief OP -:= = (REF LONG MODE, LONG MODE) REF LONG MODE
3870 @param p Node in syntax tree.
3871 **/
3872 
3873 void
genie_minusab_long_mp(NODE_T * p)3874 genie_minusab_long_mp (NODE_T * p)
3875 {
3876   MOID_T *mode = LHS_MODE (p);
3877   genie_f_and_becomes (p, mode, genie_sub_long_mp);
3878 }
3879 
3880 /**
3881 @brief OP *:= = (REF LONG MODE, LONG MODE) REF LONG MODE
3882 @param p Node in syntax tree.
3883 **/
3884 
3885 void
genie_timesab_long_mp(NODE_T * p)3886 genie_timesab_long_mp (NODE_T * p)
3887 {
3888   MOID_T *mode = LHS_MODE (p);
3889   genie_f_and_becomes (p, mode, genie_mul_long_mp);
3890 }
3891 
3892 /**
3893 @brief OP /:= = (REF LONG MODE, LONG MODE) REF LONG MODE
3894 @param p Node in syntax tree.
3895 **/
3896 
3897 void
genie_divab_long_mp(NODE_T * p)3898 genie_divab_long_mp (NODE_T * p)
3899 {
3900   MOID_T *mode = LHS_MODE (p);
3901   genie_f_and_becomes (p, mode, genie_div_long_mp);
3902 }
3903 
3904 /**
3905 @brief OP %:= = (REF LONG MODE, LONG MODE) REF LONG MODE
3906 @param p Node in syntax tree.
3907 **/
3908 
3909 void
genie_overab_long_mp(NODE_T * p)3910 genie_overab_long_mp (NODE_T * p)
3911 {
3912   MOID_T *mode = LHS_MODE (p);
3913   genie_f_and_becomes (p, mode, genie_over_long_mp);
3914 }
3915 
3916 /**
3917 @brief OP %*:= = (REF LONG MODE, LONG MODE) REF LONG MODE
3918 @param p Node in syntax tree.
3919 **/
3920 
3921 void
genie_modab_long_mp(NODE_T * p)3922 genie_modab_long_mp (NODE_T * p)
3923 {
3924   MOID_T *mode = LHS_MODE (p);
3925   genie_f_and_becomes (p, mode, genie_mod_long_mp);
3926 }
3927 
3928 /* OP (LONG MODE, LONG MODE) BOOL */
3929 
3930 #define A68_CMP_LONG(n, OP)\
3931 void n (NODE_T * p) {\
3932   MOID_T *mode = LHS_MODE (p);\
3933   A68_BOOL z;\
3934   int digits = DIGITS (mode), size = SIZE (mode);\
3935   MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);\
3936   MP_T *y = (MP_T *) STACK_OFFSET (-size);\
3937   OP (p, &z, x, y, digits);\
3938   DECREMENT_STACK_POINTER (p, 2 * size);\
3939   PUSH_PRIMITIVE (p, VALUE (&z), A68_BOOL);\
3940 }
3941 
A68_CMP_LONG(genie_eq_long_mp,eq_mp)3942 A68_CMP_LONG (genie_eq_long_mp, eq_mp)
3943   A68_CMP_LONG (genie_ne_long_mp, ne_mp)
3944   A68_CMP_LONG (genie_lt_long_mp, lt_mp)
3945   A68_CMP_LONG (genie_gt_long_mp, gt_mp)
3946   A68_CMP_LONG (genie_le_long_mp, le_mp)
3947   A68_CMP_LONG (genie_ge_long_mp, ge_mp)
3948 
3949 /**
3950 @brief OP ** = (LONG MODE, INT) LONG MODE
3951 @param p Node in syntax tree.
3952 **/
3953      void genie_pow_long_mp_int (NODE_T * p)
3954 {
3955   MOID_T *mode = LHS_MODE (p);
3956   int digits = DIGITS (mode), size = SIZE (mode);
3957   A68_INT k;
3958   MP_T *x;
3959   POP_OBJECT (p, &k, A68_INT);
3960   x = (MP_T *) STACK_OFFSET (-size);
3961   (void) pow_mp_int (p, x, x, VALUE (&k), digits);
3962   MP_STATUS (x) = (MP_T) INIT_MASK;
3963 }
3964 
3965 /**
3966 @brief OP ** = (LONG MODE, LONG MODE) LONG MODE
3967 @param p Node in syntax tree.
3968 **/
3969 
3970 void
genie_pow_long_mp(NODE_T * p)3971 genie_pow_long_mp (NODE_T * p)
3972 {
3973   MOID_T *mode = LHS_MODE (p);
3974   int digits = DIGITS (mode), size = SIZE (mode);
3975   ADDR_T pop_sp = stack_pointer;
3976   MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
3977   MP_T *y = (MP_T *) STACK_OFFSET (-size);
3978   MP_T *z;
3979   STACK_MP (z, p, digits);
3980   if (IS_ZERO_MP (x)) {
3981     if (MP_DIGIT (y, 1) < (MP_T) 0) {
3982       PRELUDE_ERROR (A68_TRUE, p, ERROR_INVALID_ARGUMENT, MOID (p));
3983     } else if (IS_ZERO_MP (y)) {
3984       (void) set_mp_short (x, (MP_T) 1, 0, digits);
3985     }
3986   } else {
3987     PRELUDE_ERROR (ln_mp (p, z, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
3988     (void) mul_mp (p, z, y, z, digits);
3989     (void) exp_mp (p, x, z, digits);
3990   }
3991   stack_pointer = pop_sp - size;
3992   MP_STATUS (x) = (MP_T) INIT_MASK;
3993 }
3994 
3995 /* Character operations */
3996 
3997 /* OP (CHAR, CHAR) BOOL */
3998 
3999 #define A68_CMP_CHAR(n, OP)\
4000 void n (NODE_T * p) {\
4001   A68_CHAR i, j;\
4002   POP_OBJECT (p, &j, A68_CHAR);\
4003   POP_OBJECT (p, &i, A68_CHAR);\
4004   PUSH_PRIMITIVE (p, (BOOL_T) (TO_UCHAR (VALUE (&i)) OP TO_UCHAR (VALUE (&j))), A68_BOOL);\
4005   }
4006 
4007 A68_CMP_CHAR (genie_eq_char, ==)
4008   A68_CMP_CHAR (genie_ne_char, !=)
4009   A68_CMP_CHAR (genie_lt_char, <)
4010   A68_CMP_CHAR (genie_gt_char, >)
4011   A68_CMP_CHAR (genie_le_char, <=)
4012   A68_CMP_CHAR (genie_ge_char, >=)
4013 
4014 /**
4015 @brief OP ABS = (CHAR) INT
4016 @param p Node in syntax tree.
4017 **/
genie_abs_char(NODE_T * p)4018      void genie_abs_char (NODE_T * p)
4019 {
4020   A68_CHAR i;
4021   POP_OBJECT (p, &i, A68_CHAR);
4022   PUSH_PRIMITIVE (p, TO_UCHAR (VALUE (&i)), A68_INT);
4023 }
4024 
4025 /**
4026 @brief OP REPR = (INT) CHAR
4027 @param p Node in syntax tree.
4028 **/
4029 
4030 void
genie_repr_char(NODE_T * p)4031 genie_repr_char (NODE_T * p)
4032 {
4033   A68_INT k;
4034   POP_OBJECT (p, &k, A68_INT);
4035   PRELUDE_ERROR (VALUE (&k) < 0 || VALUE (&k) > (int) UCHAR_MAX, p, ERROR_OUT_OF_BOUNDS, MODE (CHAR));
4036   PUSH_PRIMITIVE (p, (char) (VALUE (&k)), A68_CHAR);
4037 }
4038 
4039 /* OP (CHAR) BOOL */
4040 
4041 #define A68_CHAR_BOOL(n, OP)\
4042 void n (NODE_T * p) {\
4043   A68_CHAR ch;\
4044   POP_OBJECT (p, &ch, A68_CHAR);\
4045   PUSH_PRIMITIVE (p, (BOOL_T) (OP (VALUE (&ch)) == 0 ? A68_FALSE : A68_TRUE), A68_BOOL);\
4046   }
4047 
A68_CHAR_BOOL(genie_is_alnum,IS_ALNUM)4048 A68_CHAR_BOOL (genie_is_alnum, IS_ALNUM)
4049   A68_CHAR_BOOL (genie_is_alpha, IS_ALPHA)
4050   A68_CHAR_BOOL (genie_is_cntrl, IS_CNTRL)
4051   A68_CHAR_BOOL (genie_is_digit, IS_DIGIT)
4052   A68_CHAR_BOOL (genie_is_graph, IS_GRAPH)
4053   A68_CHAR_BOOL (genie_is_lower, IS_LOWER)
4054   A68_CHAR_BOOL (genie_is_print, IS_PRINT)
4055   A68_CHAR_BOOL (genie_is_punct, IS_PUNCT)
4056   A68_CHAR_BOOL (genie_is_space, IS_SPACE)
4057   A68_CHAR_BOOL (genie_is_upper, IS_UPPER)
4058   A68_CHAR_BOOL (genie_is_xdigit, IS_XDIGIT)
4059 #define A68_CHAR_CHAR(n, OP)\
4060 void n (NODE_T * p) {\
4061   A68_CHAR *ch;\
4062   POP_OPERAND_ADDRESS (p, ch, A68_CHAR);\
4063   VALUE (ch) = (char) (OP (TO_UCHAR (VALUE (ch))));\
4064 }
4065   A68_CHAR_CHAR (genie_to_lower, TO_LOWER)
4066   A68_CHAR_CHAR (genie_to_upper, TO_UPPER)
4067 
4068 /**
4069 @brief OP + = (CHAR, CHAR) STRING
4070 @param p Node in syntax tree.
4071 **/
4072      void genie_add_char (NODE_T * p)
4073 {
4074   A68_CHAR a, b;
4075   A68_REF c, d;
4076   A68_ARRAY *a_3;
4077   A68_TUPLE *t_3;
4078   BYTE_T *b_3;
4079 /* right part */
4080   POP_OBJECT (p, &b, A68_CHAR);
4081   CHECK_INIT (p, INITIALISED (&b), MODE (CHAR));
4082 /* left part */
4083   POP_OBJECT (p, &a, A68_CHAR);
4084   CHECK_INIT (p, INITIALISED (&a), MODE (CHAR));
4085 /* sum */
4086   c = heap_generator (p, MODE (STRING), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE));
4087   d = heap_generator (p, MODE (STRING), 2 * SIZE (MODE (CHAR)));
4088   GET_DESCRIPTOR (a_3, t_3, &c);
4089   DIM (a_3) = 1;
4090   MOID (a_3) = MODE (CHAR);
4091   ELEM_SIZE (a_3) = SIZE (MODE (CHAR));
4092   SLICE_OFFSET (a_3) = 0;
4093   FIELD_OFFSET (a_3) = 0;
4094   ARRAY (a_3) = d;
4095   LWB (t_3) = 1;
4096   UPB (t_3) = 2;
4097   SHIFT (t_3) = LWB (t_3);
4098   SPAN (t_3) = 1;
4099 /* add chars */
4100   b_3 = DEREF (BYTE_T, &ARRAY (a_3));
4101   MOVE ((BYTE_T *) & b_3[0], (BYTE_T *) & a, SIZE (MODE (CHAR)));
4102   MOVE ((BYTE_T *) & b_3[SIZE (MODE (CHAR))], (BYTE_T *) & b, SIZE (MODE (CHAR)));
4103   PUSH_REF (p, c);
4104 }
4105 
4106 /**
4107 @brief OP ELEM = (INT, STRING) CHAR # ALGOL68C #
4108 @param p Node in syntax tree.
4109 **/
4110 
4111 void
genie_elem_string(NODE_T * p)4112 genie_elem_string (NODE_T * p)
4113 {
4114   A68_REF z;
4115   A68_ARRAY *a;
4116   A68_TUPLE *t;
4117   A68_INT k;
4118   BYTE_T *base;
4119   A68_CHAR *ch;
4120   POP_REF (p, &z);
4121   CHECK_REF (p, z, MODE (STRING));
4122   POP_OBJECT (p, &k, A68_INT);
4123   GET_DESCRIPTOR (a, t, &z);
4124   PRELUDE_ERROR (VALUE (&k) < LWB (t), p, ERROR_INDEX_OUT_OF_BOUNDS, NO_TEXT);
4125   PRELUDE_ERROR (VALUE (&k) > UPB (t), p, ERROR_INDEX_OUT_OF_BOUNDS, NO_TEXT);
4126   base = DEREF (BYTE_T, &(ARRAY (a)));
4127   ch = (A68_CHAR *) & (base[INDEX_1_DIM (a, t, VALUE (&k))]);
4128   PUSH_PRIMITIVE (p, VALUE (ch), A68_CHAR);
4129 }
4130 
4131 /**
4132 @brief OP + = (STRING, STRING) STRING
4133 @param p Node in syntax tree.
4134 **/
4135 
4136 void
genie_add_string(NODE_T * p)4137 genie_add_string (NODE_T * p)
4138 {
4139   A68_REF a, b, c, d;
4140   A68_ARRAY *a_1, *a_2, *a_3;
4141   A68_TUPLE *t_1, *t_2, *t_3;
4142   int l_1, l_2, k, m;
4143   BYTE_T *b_1, *b_2, *b_3;
4144 /* right part */
4145   POP_REF (p, &b);
4146   CHECK_INIT (p, INITIALISED (&b), MODE (STRING));
4147   GET_DESCRIPTOR (a_2, t_2, &b);
4148   l_2 = ROW_SIZE (t_2);
4149 /* left part */
4150   POP_REF (p, &a);
4151   CHECK_REF (p, a, MODE (STRING));
4152   GET_DESCRIPTOR (a_1, t_1, &a);
4153   l_1 = ROW_SIZE (t_1);
4154 /* sum */
4155   c = heap_generator (p, MODE (STRING), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE));
4156   d = heap_generator (p, MODE (STRING), (l_1 + l_2) * SIZE (MODE (CHAR)));
4157 /* Calculate again since garbage collector might have moved data */
4158   GET_DESCRIPTOR (a_1, t_1, &a);
4159   GET_DESCRIPTOR (a_2, t_2, &b);
4160   GET_DESCRIPTOR (a_3, t_3, &c);
4161   DIM (a_3) = 1;
4162   MOID (a_3) = MODE (CHAR);
4163   ELEM_SIZE (a_3) = SIZE (MODE (CHAR));
4164   SLICE_OFFSET (a_3) = 0;
4165   FIELD_OFFSET (a_3) = 0;
4166   ARRAY (a_3) = d;
4167   LWB (t_3) = 1;
4168   UPB (t_3) = l_1 + l_2;
4169   SHIFT (t_3) = LWB (t_3);
4170   SPAN (t_3) = 1;
4171 /* add strings */
4172   b_3 = DEREF (BYTE_T, &ARRAY (a_3));
4173   m = 0;
4174   if (ROW_SIZE (t_1) > 0) {
4175     b_1 = DEREF (BYTE_T, &ARRAY (a_1));
4176     for (k = LWB (t_1); k <= UPB (t_1); k++) {
4177       MOVE ((BYTE_T *) & b_3[m], (BYTE_T *) & b_1[INDEX_1_DIM (a_1, t_1, k)], SIZE (MODE (CHAR)));
4178       m += SIZE (MODE (CHAR));
4179     }
4180   }
4181   if (ROW_SIZE (t_2) > 0) {
4182     b_2 = DEREF (BYTE_T, &ARRAY (a_2));
4183     for (k = LWB (t_2); k <= UPB (t_2); k++) {
4184       MOVE ((BYTE_T *) & b_3[m], (BYTE_T *) & b_2[INDEX_1_DIM (a_2, t_2, k)], SIZE (MODE (CHAR)));
4185       m += SIZE (MODE (CHAR));
4186     }
4187   }
4188   PUSH_REF (p, c);
4189 }
4190 
4191 /**
4192 @brief OP * = (INT, STRING) STRING
4193 @param p Node in syntax tree.
4194 **/
4195 
4196 void
genie_times_int_string(NODE_T * p)4197 genie_times_int_string (NODE_T * p)
4198 {
4199   A68_INT k;
4200   A68_REF a;
4201   POP_REF (p, &a);
4202   POP_OBJECT (p, &k, A68_INT);
4203   PRELUDE_ERROR (VALUE (&k) < 0, p, ERROR_INVALID_ARGUMENT, MODE (INT));
4204   PUSH_REF (p, empty_string (p));
4205   while (VALUE (&k)--) {
4206     PUSH_REF (p, a);
4207     genie_add_string (p);
4208   }
4209 }
4210 
4211 /**
4212 @brief OP * = (STRING, INT) STRING
4213 @param p Node in syntax tree.
4214 **/
4215 
4216 void
genie_times_string_int(NODE_T * p)4217 genie_times_string_int (NODE_T * p)
4218 {
4219   A68_INT k;
4220   A68_REF a;
4221   POP_OBJECT (p, &k, A68_INT);
4222   POP_REF (p, &a);
4223   PUSH_PRIMITIVE (p, VALUE (&k), A68_INT);
4224   PUSH_REF (p, a);
4225   genie_times_int_string (p);
4226 }
4227 
4228 /**
4229 @brief OP * = (INT, CHAR) STRING
4230 @param p Node in syntax tree.
4231 **/
4232 
4233 void
genie_times_int_char(NODE_T * p)4234 genie_times_int_char (NODE_T * p)
4235 {
4236   A68_INT str_size;
4237   A68_CHAR a;
4238   A68_REF z, row;
4239   A68_ARRAY arr;
4240   A68_TUPLE tup;
4241   BYTE_T *base;
4242   int k;
4243 /* Pop operands */
4244   POP_OBJECT (p, &a, A68_CHAR);
4245   POP_OBJECT (p, &str_size, A68_INT);
4246   PRELUDE_ERROR (VALUE (&str_size) < 0, p, ERROR_INVALID_ARGUMENT, MODE (INT));
4247 /* Make new_one string */
4248   z = heap_generator (p, MODE (ROW_CHAR), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE));
4249   row = heap_generator (p, MODE (ROW_CHAR), (int) (VALUE (&str_size)) * SIZE (MODE (CHAR)));
4250   DIM (&arr) = 1;
4251   MOID (&arr) = MODE (CHAR);
4252   ELEM_SIZE (&arr) = SIZE (MODE (CHAR));
4253   SLICE_OFFSET (&arr) = 0;
4254   FIELD_OFFSET (&arr) = 0;
4255   ARRAY (&arr) = row;
4256   LWB (&tup) = 1;
4257   UPB (&tup) = VALUE (&str_size);
4258   SHIFT (&tup) = LWB (&tup);
4259   SPAN (&tup) = 1;
4260   K (&tup) = 0;
4261   PUT_DESCRIPTOR (arr, tup, &z);
4262 /* Copy */
4263   base = ADDRESS (&row);
4264   for (k = 0; k < VALUE (&str_size); k++) {
4265     A68_CHAR ch;
4266     STATUS (&ch) = INIT_MASK;
4267     VALUE (&ch) = VALUE (&a);
4268     *(A68_CHAR *) & base[k * SIZE (MODE (CHAR))] = ch;
4269   }
4270   PUSH_REF (p, z);
4271 }
4272 
4273 /**
4274 @brief OP * = (CHAR, INT) STRING
4275 @param p Node in syntax tree.
4276 **/
4277 
4278 void
genie_times_char_int(NODE_T * p)4279 genie_times_char_int (NODE_T * p)
4280 {
4281   A68_INT k;
4282   A68_CHAR a;
4283   POP_OBJECT (p, &k, A68_INT);
4284   POP_OBJECT (p, &a, A68_CHAR);
4285   PUSH_PRIMITIVE (p, VALUE (&k), A68_INT);
4286   PUSH_PRIMITIVE (p, VALUE (&a), A68_CHAR);
4287   genie_times_int_char (p);
4288 }
4289 
4290 /**
4291 @brief OP +:= = (REF STRING, STRING) REF STRING
4292 @param p Node in syntax tree.
4293 **/
4294 
4295 void
genie_plusab_string(NODE_T * p)4296 genie_plusab_string (NODE_T * p)
4297 {
4298   genie_f_and_becomes (p, MODE (REF_STRING), genie_add_string);
4299 }
4300 
4301 /**
4302 @brief OP +=: = (STRING, REF STRING) REF STRING
4303 @param p Node in syntax tree.
4304 **/
4305 
4306 void
genie_plusto_string(NODE_T * p)4307 genie_plusto_string (NODE_T * p)
4308 {
4309   A68_REF refa, a, b;
4310   POP_REF (p, &refa);
4311   CHECK_REF (p, refa, MODE (REF_STRING));
4312   a = *DEREF (A68_REF, &refa);
4313   CHECK_INIT (p, INITIALISED (&a), MODE (STRING));
4314   POP_REF (p, &b);
4315   PUSH_REF (p, b);
4316   PUSH_REF (p, a);
4317   genie_add_string (p);
4318   POP_REF (p, DEREF (A68_REF, &refa));
4319   PUSH_REF (p, refa);
4320 }
4321 
4322 /**
4323 @brief OP *:= = (REF STRING, INT) REF STRING
4324 @param p Node in syntax tree.
4325 **/
4326 
4327 void
genie_timesab_string(NODE_T * p)4328 genie_timesab_string (NODE_T * p)
4329 {
4330   A68_INT k;
4331   A68_REF refa, a;
4332   int i;
4333 /* INT */
4334   POP_OBJECT (p, &k, A68_INT);
4335   PRELUDE_ERROR (VALUE (&k) < 0, p, ERROR_INVALID_ARGUMENT, MODE (INT));
4336 /* REF STRING */
4337   POP_REF (p, &refa);
4338   CHECK_REF (p, refa, MODE (REF_STRING));
4339   a = *DEREF (A68_REF, &refa);
4340   CHECK_INIT (p, INITIALISED (&a), MODE (STRING));
4341 /* Multiplication as repeated addition */
4342   PUSH_REF (p, empty_string (p));
4343   for (i = 1; i <= VALUE (&k); i++) {
4344     PUSH_REF (p, a);
4345     genie_add_string (p);
4346   }
4347 /* The stack contains a STRING, promote to REF STRING */
4348   POP_REF (p, DEREF (A68_REF, &refa));
4349   PUSH_REF (p, refa);
4350 }
4351 
4352 /**
4353 @brief Difference between two STRINGs in the stack.
4354 @param p Node in syntax tree.
4355 @return -1 if a < b, 0 if a = b or -1 if a > b
4356 **/
4357 
4358 static int
string_difference(NODE_T * p)4359 string_difference (NODE_T * p)
4360 {
4361   A68_REF row1, row2;
4362   A68_ARRAY *a_1, *a_2;
4363   A68_TUPLE *t_1, *t_2;
4364   BYTE_T *b_1, *b_2;
4365   int size, s_1, s_2, k, diff;
4366 /* Pop operands */
4367   POP_REF (p, &row2);
4368   CHECK_INIT (p, INITIALISED (&row2), MODE (STRING));
4369   GET_DESCRIPTOR (a_2, t_2, &row2);
4370   s_2 = ROW_SIZE (t_2);
4371   POP_REF (p, &row1);
4372   CHECK_INIT (p, INITIALISED (&row1), MODE (STRING));
4373   GET_DESCRIPTOR (a_1, t_1, &row1);
4374   s_1 = ROW_SIZE (t_1);
4375 /* Get difference */
4376   size = (s_1 > s_2 ? s_1 : s_2);
4377   diff = 0;
4378   b_1 = (s_1 > 0 ? DEREF (BYTE_T, &ARRAY (a_1)) : NO_BYTE);
4379   b_2 = (s_2 > 0 ? DEREF (BYTE_T, &ARRAY (a_2)) : NO_BYTE);
4380   for (k = 0; k < size && diff == 0; k++) {
4381     int a, b;
4382     if (s_1 > 0 && k < s_1) {
4383       A68_CHAR *ch = (A68_CHAR *) & b_1[INDEX_1_DIM (a_1, t_1, LWB (t_1) + k)];
4384       a = (int) VALUE (ch);
4385     } else {
4386       a = 0;
4387     }
4388     if (s_2 > 0 && k < s_2) {
4389       A68_CHAR *ch = (A68_CHAR *) & b_2[INDEX_1_DIM (a_2, t_2, LWB (t_2) + k)];
4390       b = (int) VALUE (ch);
4391     } else {
4392       b = 0;
4393     }
4394     diff += (TO_UCHAR (a) - TO_UCHAR (b));
4395   }
4396   return (diff);
4397 }
4398 
4399 /* OP (STRING, STRING) BOOL */
4400 
4401 #define A68_CMP_STRING(n, OP)\
4402 void n (NODE_T * p) {\
4403   int k = string_difference (p);\
4404   PUSH_PRIMITIVE (p, (BOOL_T) (k OP 0), A68_BOOL);\
4405 }
4406 
4407 A68_CMP_STRING (genie_eq_string, ==)
4408   A68_CMP_STRING (genie_ne_string, !=)
4409   A68_CMP_STRING (genie_lt_string, <)
4410   A68_CMP_STRING (genie_gt_string, >)
4411   A68_CMP_STRING (genie_le_string, <=)
4412   A68_CMP_STRING (genie_ge_string, >=)
4413 
4414 /* RNG functions are in gsl.c.*/
4415 /**
4416 @brief PROC first random = (INT) VOID
4417 @param p Node in syntax tree.
4418 **/
genie_first_random(NODE_T * p)4419      void genie_first_random (NODE_T * p)
4420 {
4421   A68_INT i;
4422   POP_OBJECT (p, &i, A68_INT);
4423   init_rng ((unsigned long) VALUE (&i));
4424 }
4425 
4426 /**
4427 @brief PROC next random = REAL
4428 @param p Node in syntax tree.
4429 **/
4430 
4431 void
genie_next_random(NODE_T * p)4432 genie_next_random (NODE_T * p)
4433 {
4434   PUSH_PRIMITIVE (p, rng_53_bit (), A68_REAL);
4435 }
4436 
4437 /**
4438 @brief PROC rnd = REAL
4439 @param p Node in syntax tree.
4440 **/
4441 
4442 void
genie_next_rnd(NODE_T * p)4443 genie_next_rnd (NODE_T * p)
4444 {
4445   PUSH_PRIMITIVE (p, 2 * rng_53_bit () - 1, A68_REAL);
4446 }
4447 
4448 /**
4449 @brief PROC next long random = LONG REAL
4450 @param p Node in syntax tree.
4451 **/
4452 
4453 void
genie_long_next_random(NODE_T * p)4454 genie_long_next_random (NODE_T * p)
4455 {
4456   int digits = DIGITS (MOID (p));
4457   MP_T *z;
4458   int k = 2 + digits;
4459   STACK_MP (z, p, digits);
4460   while (--k > 1) {
4461     z[k] = (MP_T) (int) (rng_53_bit () * MP_RADIX);
4462   }
4463   MP_EXPONENT (z) = (MP_T) (-1);
4464   MP_STATUS (z) = (MP_T) INIT_MASK;
4465 }
4466 
4467 /* BYTES operations */
4468 
4469 /**
4470 @brief OP ELEM = (INT, BYTES) CHAR
4471 @param p Node in syntax tree.
4472 **/
4473 
4474 void
genie_elem_bytes(NODE_T * p)4475 genie_elem_bytes (NODE_T * p)
4476 {
4477   A68_BYTES j;
4478   A68_INT i;
4479   POP_OBJECT (p, &j, A68_BYTES);
4480   POP_OBJECT (p, &i, A68_INT);
4481   PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT));
4482   if (VALUE (&i) > (int) strlen (VALUE (&j))) {
4483     genie_null_char (p);
4484   } else {
4485     PUSH_PRIMITIVE (p, VALUE (&j)[VALUE (&i) - 1], A68_CHAR);
4486   }
4487 }
4488 
4489 /**
4490 @brief PROC bytes pack = (STRING) BYTES
4491 @param p Node in syntax tree.
4492 **/
4493 
4494 void
genie_bytespack(NODE_T * p)4495 genie_bytespack (NODE_T * p)
4496 {
4497   A68_REF z;
4498   A68_BYTES b;
4499   POP_REF (p, &z);
4500   CHECK_REF (p, z, MODE (STRING));
4501   PRELUDE_ERROR (a68_string_size (p, z) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (STRING));
4502   STATUS (&b) = INIT_MASK;
4503   ASSERT (a_to_c_string (p, VALUE (&b), z) != NO_TEXT);
4504   PUSH_BYTES (p, VALUE (&b));
4505 }
4506 
4507 /**
4508 @brief PROC bytes pack = (STRING) BYTES
4509 @param p Node in syntax tree.
4510 **/
4511 
4512 void
genie_add_bytes(NODE_T * p)4513 genie_add_bytes (NODE_T * p)
4514 {
4515   A68_BYTES *i, *j;
4516   POP_OPERAND_ADDRESSES (p, i, j, A68_BYTES);
4517   PRELUDE_ERROR (((int) strlen (VALUE (i)) + (int) strlen (VALUE (j))) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (BYTES));
4518   bufcat (VALUE (i), VALUE (j), BYTES_WIDTH);
4519 }
4520 
4521 /**
4522 @brief OP +:= = (REF BYTES, BYTES) REF BYTES
4523 @param p Node in syntax tree.
4524 **/
4525 
4526 void
genie_plusab_bytes(NODE_T * p)4527 genie_plusab_bytes (NODE_T * p)
4528 {
4529   genie_f_and_becomes (p, MODE (REF_BYTES), genie_add_bytes);
4530 }
4531 
4532 /**
4533 @brief OP +=: = (BYTES, REF BYTES) REF BYTES
4534 @param p Node in syntax tree.
4535 **/
4536 
4537 void
genie_plusto_bytes(NODE_T * p)4538 genie_plusto_bytes (NODE_T * p)
4539 {
4540   A68_BYTES i, *address, j;
4541   A68_REF z;
4542   POP_REF (p, &z);
4543   CHECK_REF (p, z, MODE (REF_BYTES));
4544   address = DEREF (A68_BYTES, &z);
4545   CHECK_INIT (p, INITIALISED (address), MODE (BYTES));
4546   POP_OBJECT (p, &i, A68_BYTES);
4547   PRELUDE_ERROR (((int) strlen (VALUE (address)) + (int) strlen (VALUE (&i))) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (BYTES));
4548   bufcpy (VALUE (&j), VALUE (&i), BYTES_WIDTH);
4549   bufcat (VALUE (&j), VALUE (address), BYTES_WIDTH);
4550   bufcpy (VALUE (address), VALUE (&j), BYTES_WIDTH);
4551   PUSH_REF (p, z);
4552 }
4553 
4554 /**
4555 @brief Difference between BYTE strings.
4556 @param p Node in syntax tree.
4557 @return Difference between objects.
4558 **/
4559 
4560 static int
compare_bytes(NODE_T * p)4561 compare_bytes (NODE_T * p)
4562 {
4563   A68_BYTES x, y;
4564   POP_OBJECT (p, &y, A68_BYTES);
4565   POP_OBJECT (p, &x, A68_BYTES);
4566   return (strcmp (VALUE (&x), VALUE (&y)));
4567 }
4568 
4569 /* OP (BYTES, BYTES) BOOL */
4570 
4571 #define A68_CMP_BYTES(n, OP)\
4572 void n (NODE_T * p) {\
4573   int k = compare_bytes (p);\
4574   PUSH_PRIMITIVE (p, (BOOL_T) (k OP 0), A68_BOOL);\
4575 }
4576 
4577 A68_CMP_BYTES (genie_eq_bytes, ==)
4578   A68_CMP_BYTES (genie_ne_bytes, !=)
4579   A68_CMP_BYTES (genie_lt_bytes, <)
4580   A68_CMP_BYTES (genie_gt_bytes, >)
4581   A68_CMP_BYTES (genie_le_bytes, <=)
4582   A68_CMP_BYTES (genie_ge_bytes, >=)
4583 
4584 /**
4585 @brief OP LENG = (BYTES) LONG BYTES
4586 @param p Node in syntax tree.
4587 **/
genie_leng_bytes(NODE_T * p)4588      void genie_leng_bytes (NODE_T * p)
4589 {
4590   A68_BYTES a;
4591   POP_OBJECT (p, &a, A68_BYTES);
4592   PUSH_LONG_BYTES (p, VALUE (&a));
4593 }
4594 
4595 /**
4596 @brief OP SHORTEN = (LONG BYTES) BYTES
4597 @param p Node in syntax tree.
4598 **/
4599 
4600 void
genie_shorten_bytes(NODE_T * p)4601 genie_shorten_bytes (NODE_T * p)
4602 {
4603   A68_LONG_BYTES a;
4604   POP_OBJECT (p, &a, A68_LONG_BYTES);
4605   PRELUDE_ERROR (strlen (VALUE (&a)) >= BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (BYTES));
4606   PUSH_BYTES (p, VALUE (&a));
4607 }
4608 
4609 /**
4610 @brief OP ELEM = (INT, LONG BYTES) CHAR
4611 @param p Node in syntax tree.
4612 **/
4613 
4614 void
genie_elem_long_bytes(NODE_T * p)4615 genie_elem_long_bytes (NODE_T * p)
4616 {
4617   A68_LONG_BYTES j;
4618   A68_INT i;
4619   POP_OBJECT (p, &j, A68_LONG_BYTES);
4620   POP_OBJECT (p, &i, A68_INT);
4621   PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT));
4622   if (VALUE (&i) > (int) strlen (VALUE (&j))) {
4623     genie_null_char (p);
4624   } else {
4625     PUSH_PRIMITIVE (p, VALUE (&j)[VALUE (&i) - 1], A68_CHAR);
4626   }
4627 }
4628 
4629 /**
4630 @brief PROC long bytes pack = (STRING) LONG BYTES
4631 @param p Node in syntax tree.
4632 **/
4633 
4634 void
genie_long_bytespack(NODE_T * p)4635 genie_long_bytespack (NODE_T * p)
4636 {
4637   A68_REF z;
4638   A68_LONG_BYTES b;
4639   POP_REF (p, &z);
4640   CHECK_REF (p, z, MODE (STRING));
4641   PRELUDE_ERROR (a68_string_size (p, z) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (STRING));
4642   STATUS (&b) = INIT_MASK;
4643   ASSERT (a_to_c_string (p, VALUE (&b), z) != NO_TEXT);
4644   PUSH_LONG_BYTES (p, VALUE (&b));
4645 }
4646 
4647 /**
4648 @brief OP + = (LONG BYTES, LONG BYTES) LONG BYTES
4649 @param p Node in syntax tree.
4650 **/
4651 
4652 void
genie_add_long_bytes(NODE_T * p)4653 genie_add_long_bytes (NODE_T * p)
4654 {
4655   A68_LONG_BYTES *i, *j;
4656   POP_OPERAND_ADDRESSES (p, i, j, A68_LONG_BYTES);
4657   PRELUDE_ERROR (((int) strlen (VALUE (i)) + (int) strlen (VALUE (j))) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (LONG_BYTES));
4658   bufcat (VALUE (i), VALUE (j), LONG_BYTES_WIDTH);
4659 }
4660 
4661 /**
4662 @brief OP +:= = (REF LONG BYTES, LONG BYTES) REF LONG BYTES
4663 @param p Node in syntax tree.
4664 **/
4665 
4666 void
genie_plusab_long_bytes(NODE_T * p)4667 genie_plusab_long_bytes (NODE_T * p)
4668 {
4669   genie_f_and_becomes (p, MODE (REF_LONG_BYTES), genie_add_long_bytes);
4670 }
4671 
4672 /**
4673 @brief OP +=: = (LONG BYTES, REF LONG BYTES) REF LONG BYTES
4674 @param p Node in syntax tree.
4675 **/
4676 
4677 void
genie_plusto_long_bytes(NODE_T * p)4678 genie_plusto_long_bytes (NODE_T * p)
4679 {
4680   A68_LONG_BYTES i, *address, j;
4681   A68_REF z;
4682   POP_REF (p, &z);
4683   CHECK_REF (p, z, MODE (REF_LONG_BYTES));
4684   address = DEREF (A68_LONG_BYTES, &z);
4685   CHECK_INIT (p, INITIALISED (address), MODE (LONG_BYTES));
4686   POP_OBJECT (p, &i, A68_LONG_BYTES);
4687   PRELUDE_ERROR (((int) strlen (VALUE (address)) + (int) strlen (VALUE (&i))) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (LONG_BYTES));
4688   bufcpy (VALUE (&j), VALUE (&i), LONG_BYTES_WIDTH);
4689   bufcat (VALUE (&j), VALUE (address), LONG_BYTES_WIDTH);
4690   bufcpy (VALUE (address), VALUE (&j), LONG_BYTES_WIDTH);
4691   PUSH_REF (p, z);
4692 }
4693 
4694 /**
4695 @brief Difference between LONG BYTE strings.
4696 @param p Node in syntax tree.
4697 @return Difference between objects.
4698 **/
4699 
4700 static int
compare_long_bytes(NODE_T * p)4701 compare_long_bytes (NODE_T * p)
4702 {
4703   A68_LONG_BYTES x, y;
4704   POP_OBJECT (p, &y, A68_LONG_BYTES);
4705   POP_OBJECT (p, &x, A68_LONG_BYTES);
4706   return (strcmp (VALUE (&x), VALUE (&y)));
4707 }
4708 
4709 /* OP (LONG BYTES, LONG BYTES) BOOL */
4710 
4711 #define A68_CMP_LONG_BYTES(n, OP)\
4712 void n (NODE_T * p) {\
4713   int k = compare_long_bytes (p);\
4714   PUSH_PRIMITIVE (p, (BOOL_T) (k OP 0), A68_BOOL);\
4715 }
4716 
4717 A68_CMP_LONG_BYTES (genie_eq_long_bytes, ==)
4718   A68_CMP_LONG_BYTES (genie_ne_long_bytes, !=)
4719   A68_CMP_LONG_BYTES (genie_lt_long_bytes, <)
4720   A68_CMP_LONG_BYTES (genie_gt_long_bytes, >)
4721   A68_CMP_LONG_BYTES (genie_le_long_bytes, <=)
4722   A68_CMP_LONG_BYTES (genie_ge_long_bytes, >=)
4723 
4724 /* BITS operations */
4725 /* OP NOT = (BITS) BITS */
4726   A68_MONAD (genie_not_bits, A68_BITS, ~)
4727 
4728 /**
4729 @brief OP AND = (BITS, BITS) BITS
4730 @param p Node in syntax tree.
4731 **/
genie_and_bits(NODE_T * p)4732      void genie_and_bits (NODE_T * p)
4733 {
4734   A68_BITS *i, *j;
4735   POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
4736   VALUE (i) = VALUE (i) & VALUE (j);
4737 }
4738 
4739 /**
4740 @brief OP OR = (BITS, BITS) BITS
4741 @param p Node in syntax tree.
4742 **/
4743 
4744 void
genie_or_bits(NODE_T * p)4745 genie_or_bits (NODE_T * p)
4746 {
4747   A68_BITS *i, *j;
4748   POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
4749   VALUE (i) = VALUE (i) | VALUE (j);
4750 }
4751 
4752 /**
4753 @brief OP XOR = (BITS, BITS) BITS
4754 @param p Node in syntax tree.
4755 **/
4756 
4757 void
genie_xor_bits(NODE_T * p)4758 genie_xor_bits (NODE_T * p)
4759 {
4760   A68_BITS *i, *j;
4761   POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
4762   VALUE (i) = VALUE (i) ^ VALUE (j);
4763 }
4764 
4765 /* OP = = (BITS, BITS) BOOL */
4766 
4767 #define A68_CMP_BITS(n, OP)\
4768 void n (NODE_T * p) {\
4769   A68_BITS i, j;\
4770   POP_OBJECT (p, &j, A68_BITS);\
4771   POP_OBJECT (p, &i, A68_BITS);\
4772   PUSH_PRIMITIVE (p, (BOOL_T) (VALUE (&i) OP VALUE (&j)), A68_BOOL);\
4773   }
4774 
4775 A68_CMP_BITS (genie_eq_bits, ==)
4776   A68_CMP_BITS (genie_ne_bits, !=)
4777 
4778 /**
4779 @brief OP <= = (BITS, BITS) BOOL
4780 @param p Node in syntax tree.
4781 **/
genie_le_bits(NODE_T * p)4782      void genie_le_bits (NODE_T * p)
4783 {
4784   A68_BITS i, j;
4785   POP_OBJECT (p, &j, A68_BITS);
4786   POP_OBJECT (p, &i, A68_BITS);
4787   PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&j)), A68_BOOL);
4788 }
4789 
4790 /**
4791 @brief OP >= = (BITS, BITS) BOOL
4792 @param p Node in syntax tree.
4793 **/
4794 
4795 void
genie_ge_bits(NODE_T * p)4796 genie_ge_bits (NODE_T * p)
4797 {
4798   A68_BITS i, j;
4799   POP_OBJECT (p, &j, A68_BITS);
4800   POP_OBJECT (p, &i, A68_BITS);
4801   PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&i)), A68_BOOL);
4802 }
4803 
4804 /**
4805 @brief OP SHL = (BITS, INT) BITS
4806 @param p Node in syntax tree.
4807 **/
4808 
4809 void
genie_shl_bits(NODE_T * p)4810 genie_shl_bits (NODE_T * p)
4811 {
4812   A68_BITS i;
4813   A68_INT j;
4814   POP_OBJECT (p, &j, A68_INT);
4815   POP_OBJECT (p, &i, A68_BITS);
4816   if (VALUE (&j) >= 0) {
4817     PUSH_PRIMITIVE (p, VALUE (&i) << VALUE (&j), A68_BITS);
4818   } else {
4819     PUSH_PRIMITIVE (p, VALUE (&i) >> -VALUE (&j), A68_BITS);
4820   }
4821 }
4822 
4823 /**
4824 @brief OP SHR = (BITS, INT) BITS
4825 @param p Node in syntax tree.
4826 **/
4827 
4828 void
genie_shr_bits(NODE_T * p)4829 genie_shr_bits (NODE_T * p)
4830 {
4831   A68_INT *j;
4832   POP_OPERAND_ADDRESS (p, j, A68_INT);
4833   VALUE (j) = -VALUE (j);
4834   genie_shl_bits (p);           /* Conform RR */
4835 }
4836 
4837 /**
4838 @brief OP ELEM = (INT, BITS) BOOL
4839 @param p Node in syntax tree.
4840 **/
4841 
4842 void
genie_elem_bits(NODE_T * p)4843 genie_elem_bits (NODE_T * p)
4844 {
4845   A68_BITS j;
4846   A68_INT i;
4847   int n;
4848   unsigned mask = 0x1;
4849   POP_OBJECT (p, &j, A68_BITS);
4850   POP_OBJECT (p, &i, A68_INT);
4851   PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT));
4852   for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) {
4853     mask = mask << 1;
4854   }
4855   PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&j) & mask) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
4856 }
4857 
4858 /**
4859 @brief OP SET = (INT, BITS) BITS
4860 @param p Node in syntax tree.
4861 **/
4862 
4863 void
genie_set_bits(NODE_T * p)4864 genie_set_bits (NODE_T * p)
4865 {
4866   A68_BITS j;
4867   A68_INT i;
4868   int n;
4869   unsigned mask = 0x1;
4870   POP_OBJECT (p, &j, A68_BITS);
4871   POP_OBJECT (p, &i, A68_INT);
4872   PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT));
4873   for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) {
4874     mask = mask << 1;
4875   }
4876   PUSH_PRIMITIVE (p, VALUE (&j) | mask, A68_BITS);
4877 }
4878 
4879 /**
4880 @brief OP CLEAR = (INT, BITS) BITS
4881 @param p Node in syntax tree.
4882 **/
4883 
4884 void
genie_clear_bits(NODE_T * p)4885 genie_clear_bits (NODE_T * p)
4886 {
4887   A68_BITS j;
4888   A68_INT i;
4889   int n;
4890   unsigned mask = 0x1;
4891   POP_OBJECT (p, &j, A68_BITS);
4892   POP_OBJECT (p, &i, A68_INT);
4893   PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT));
4894   for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) {
4895     mask = mask << 1;
4896   }
4897   PUSH_PRIMITIVE (p, VALUE (&j) & ~mask, A68_BITS);
4898 }
4899 
4900 /**
4901 @brief OP ABS = (BITS) INT
4902 @param p Node in syntax tree.
4903 **/
4904 
4905 void
genie_abs_bits(NODE_T * p)4906 genie_abs_bits (NODE_T * p)
4907 {
4908   A68_BITS i;
4909   POP_OBJECT (p, &i, A68_BITS);
4910   PUSH_PRIMITIVE (p, (int) (VALUE (&i)), A68_INT);
4911 }
4912 
4913 /**
4914 @brief OP BIN = (INT) BITS
4915 @param p Node in syntax tree.
4916 **/
4917 
4918 void
genie_bin_int(NODE_T * p)4919 genie_bin_int (NODE_T * p)
4920 {
4921   A68_INT i;
4922   POP_OBJECT (p, &i, A68_INT);
4923 /* RR does not convert negative numbers. */
4924   if (VALUE (&i) < 0) {
4925     errno = EDOM;
4926     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MODE (BITS));
4927     exit_genie (p, A68_RUNTIME_ERROR);
4928   }
4929   PUSH_PRIMITIVE (p, (unsigned) (VALUE (&i)), A68_BITS);
4930 }
4931 
4932 /**
4933 @brief OP BIN = (LONG INT) LONG BITS
4934 @param p Node in syntax tree.
4935 **/
4936 
4937 void
genie_bin_long_mp(NODE_T * p)4938 genie_bin_long_mp (NODE_T * p)
4939 {
4940   MOID_T *mode = SUB_MOID (p);
4941   int size = SIZE (mode);
4942   ADDR_T pop_sp = stack_pointer;
4943   MP_T *u = (MP_T *) STACK_OFFSET (-size);
4944 /* We convert just for the operand check */
4945   (void) stack_mp_bits (p, u, mode);
4946   MP_STATUS (u) = (MP_T) INIT_MASK;
4947   stack_pointer = pop_sp;
4948 }
4949 
4950 /**
4951 @brief OP NOT = (LONG BITS) LONG BITS
4952 @param p Node in syntax tree.
4953 **/
4954 
4955 void
genie_not_long_mp(NODE_T * p)4956 genie_not_long_mp (NODE_T * p)
4957 {
4958   MOID_T *mode = LHS_MODE (p);
4959   int size = SIZE (mode);
4960   ADDR_T pop_sp = stack_pointer;
4961   int k, words = get_mp_bits_words (mode);
4962   MP_T *u = (MP_T *) STACK_OFFSET (-size);
4963   unsigned *row = stack_mp_bits (p, u, mode);
4964   for (k = 0; k < words; k++) {
4965     row[k] = ~row[k];
4966   }
4967   (void) pack_mp_bits (p, u, row, mode);
4968   stack_pointer = pop_sp;
4969 }
4970 
4971 /**
4972 @brief OP SHORTEN = (LONG BITS) BITS
4973 @param p Node in syntax tree.
4974 **/
4975 
4976 void
genie_shorten_long_mp_to_bits(NODE_T * p)4977 genie_shorten_long_mp_to_bits (NODE_T * p)
4978 {
4979   MOID_T *mode = LHS_MODE (p);
4980   int digits = DIGITS (mode), size = SIZE (mode);
4981   MP_T *z = (MP_T *) STACK_OFFSET (-size);
4982   DECREMENT_STACK_POINTER (p, size);
4983   PUSH_PRIMITIVE (p, mp_to_unsigned (p, z, digits), A68_BITS);
4984 }
4985 
4986 /**
4987 @brief Get bit from LONG BITS.
4988 @param p Node in syntax tree.
4989 @param k Element number.
4990 @param z Mp number.
4991 @param m Mode associated with z.
4992 @return See brief description.
4993 **/
4994 
4995 unsigned
elem_long_bits(NODE_T * p,ADDR_T k,MP_T * z,MOID_T * m)4996 elem_long_bits (NODE_T * p, ADDR_T k, MP_T * z, MOID_T * m)
4997 {
4998   int n;
4999   ADDR_T pop_sp = stack_pointer;
5000   unsigned *words = stack_mp_bits (p, z, m), mask = 0x1;
5001   k += (MP_BITS_BITS - get_mp_bits_width (m) % MP_BITS_BITS - 1);
5002   for (n = 0; n < MP_BITS_BITS - k % MP_BITS_BITS - 1; n++) {
5003     mask = mask << 1;
5004   }
5005   stack_pointer = pop_sp;
5006   return ((words[k / MP_BITS_BITS]) & mask);
5007 }
5008 
5009 /**
5010 @brief OP ELEM = (INT, LONG BITS) BOOL
5011 @param p Node in syntax tree.
5012 **/
5013 
5014 void
genie_elem_long_bits(NODE_T * p)5015 genie_elem_long_bits (NODE_T * p)
5016 {
5017   A68_INT *i;
5018   MP_T *z;
5019   unsigned w;
5020   int bits = get_mp_bits_width (MODE (LONG_BITS)), size = SIZE (MODE (LONG_BITS));
5021   z = (MP_T *) STACK_OFFSET (-size);
5022   i = (A68_INT *) STACK_OFFSET (-(size + SIZE (MODE (INT))));
5023   PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT));
5024   w = elem_long_bits (p, VALUE (i), z, MODE (LONG_BITS));
5025   DECREMENT_STACK_POINTER (p, size + SIZE (MODE (INT)));
5026   PUSH_PRIMITIVE (p, (BOOL_T) (w != 0), A68_BOOL);
5027 }
5028 
5029 /**
5030 @brief OP ELEM = (INT, LONG LONG BITS) BOOL
5031 @param p Node in syntax tree.
5032 **/
5033 
5034 void
genie_elem_longlong_bits(NODE_T * p)5035 genie_elem_longlong_bits (NODE_T * p)
5036 {
5037   A68_INT *i;
5038   MP_T *z;
5039   unsigned w;
5040   int bits = get_mp_bits_width (MODE (LONGLONG_BITS)), size = SIZE (MODE (LONGLONG_BITS));
5041   z = (MP_T *) STACK_OFFSET (-size);
5042   i = (A68_INT *) STACK_OFFSET (-(size + SIZE (MODE (INT))));
5043   PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT));
5044   w = elem_long_bits (p, VALUE (i), z, MODE (LONGLONG_BITS));
5045   DECREMENT_STACK_POINTER (p, size + SIZE (MODE (INT)));
5046   PUSH_PRIMITIVE (p, (BOOL_T) (w != 0), A68_BOOL);
5047 }
5048 
5049 /**
5050 @brief Set bit in LONG BITS.
5051 @param p Node in syntax tree.
5052 @param k Bit index.
5053 @param z Mp number.
5054 @param m Mode associated with z.
5055 @param bit Bit to set.
5056 **/
5057 
5058 static unsigned *
set_long_bits(NODE_T * p,int k,MP_T * z,MOID_T * m,unsigned bit)5059 set_long_bits (NODE_T * p, int k, MP_T * z, MOID_T * m, unsigned bit)
5060 {
5061   int n;
5062   unsigned *words = stack_mp_bits (p, z, m), mask = 0x1;
5063   k += (MP_BITS_BITS - get_mp_bits_width (m) % MP_BITS_BITS - 1);
5064   for (n = 0; n < MP_BITS_BITS - k % MP_BITS_BITS - 1; n++) {
5065     mask = mask << 1;
5066   }
5067   if (bit == 0x1) {
5068     words[k / MP_BITS_BITS] = (words[k / MP_BITS_BITS]) | mask;
5069   } else {
5070     words[k / MP_BITS_BITS] = (words[k / MP_BITS_BITS]) & (~mask);
5071   }
5072   return (words);
5073 }
5074 
5075 /**
5076 @brief OP SET = (INT, LONG BITS) VOID
5077 @param p Node in syntax tree.
5078 **/
5079 
5080 void
genie_set_long_bits(NODE_T * p)5081 genie_set_long_bits (NODE_T * p)
5082 {
5083   A68_INT *i;
5084   MP_T *z;
5085   unsigned *w;
5086   ADDR_T pop_sp = stack_pointer;
5087   int bits = get_mp_bits_width (MODE (LONG_BITS)), size = SIZE (MODE (LONG_BITS));
5088   z = (MP_T *) STACK_OFFSET (-size);
5089   i = (A68_INT *) STACK_OFFSET (-(size + SIZE (MODE (INT))));
5090   PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT));
5091   w = set_long_bits (p, VALUE (i), z, MODE (LONG_BITS), 0x1);
5092   (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (MODE (INT))), w, MODE (LONG_BITS));
5093   stack_pointer = pop_sp;
5094   DECREMENT_STACK_POINTER (p, SIZE (MODE (INT)));
5095 }
5096 
5097 /**
5098 @brief OP SET = (INT, LONG LONG BITS) BOOL
5099 @param p Node in syntax tree.
5100 **/
5101 
5102 void
genie_set_longlong_bits(NODE_T * p)5103 genie_set_longlong_bits (NODE_T * p)
5104 {
5105   A68_INT *i;
5106   MP_T *z;
5107   unsigned *w;
5108   ADDR_T pop_sp = stack_pointer;
5109   int bits = get_mp_bits_width (MODE (LONGLONG_BITS)), size = SIZE (MODE (LONGLONG_BITS));
5110   z = (MP_T *) STACK_OFFSET (-size);
5111   i = (A68_INT *) STACK_OFFSET (-(size + SIZE (MODE (INT))));
5112   PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT));
5113   w = set_long_bits (p, VALUE (i), z, MODE (LONGLONG_BITS), 0x1);
5114   (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (MODE (INT))), w, MODE (LONGLONG_BITS));
5115   stack_pointer = pop_sp;
5116   DECREMENT_STACK_POINTER (p, SIZE (MODE (INT)));
5117 }
5118 
5119 /**
5120 @brief OP CLEAR = (INT, LONG BITS) BOOL
5121 @param p Node in syntax tree.
5122 **/
5123 
5124 void
genie_clear_long_bits(NODE_T * p)5125 genie_clear_long_bits (NODE_T * p)
5126 {
5127   A68_INT *i;
5128   MP_T *z;
5129   unsigned *w;
5130   ADDR_T pop_sp = stack_pointer;
5131   int bits = get_mp_bits_width (MODE (LONG_BITS)), size = SIZE (MODE (LONG_BITS));
5132   z = (MP_T *) STACK_OFFSET (-size);
5133   i = (A68_INT *) STACK_OFFSET (-(size + SIZE (MODE (INT))));
5134   PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT));
5135   w = set_long_bits (p, VALUE (i), z, MODE (LONG_BITS), 0x0);
5136   (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (MODE (INT))), w, MODE (LONG_BITS));
5137   stack_pointer = pop_sp;
5138   DECREMENT_STACK_POINTER (p, SIZE (MODE (INT)));
5139 }
5140 
5141 /**
5142 @brief OP CLEAR = (INT, LONG LONG BITS) BOOL
5143 @param p Node in syntax tree.
5144 **/
5145 
5146 void
genie_clear_longlong_bits(NODE_T * p)5147 genie_clear_longlong_bits (NODE_T * p)
5148 {
5149   A68_INT *i;
5150   MP_T *z;
5151   unsigned *w;
5152   ADDR_T pop_sp = stack_pointer;
5153   int bits = get_mp_bits_width (MODE (LONGLONG_BITS)), size = SIZE (MODE (LONGLONG_BITS));
5154   z = (MP_T *) STACK_OFFSET (-size);
5155   i = (A68_INT *) STACK_OFFSET (-(size + SIZE (MODE (INT))));
5156   PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT));
5157   w = set_long_bits (p, VALUE (i), z, MODE (LONGLONG_BITS), 0x0);
5158   (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (MODE (INT))), w, MODE (LONGLONG_BITS));
5159   stack_pointer = pop_sp;
5160   DECREMENT_STACK_POINTER (p, SIZE (MODE (INT)));
5161 }
5162 
5163 /**
5164 @brief PROC bits pack = ([] BOOL) BITS
5165 @param p Node in syntax tree.
5166 **/
5167 
5168 void
genie_bits_pack(NODE_T * p)5169 genie_bits_pack (NODE_T * p)
5170 {
5171   A68_REF z;
5172   A68_BITS b;
5173   A68_ARRAY *arr;
5174   A68_TUPLE *tup;
5175   BYTE_T *base;
5176   int size, k;
5177   unsigned bit;
5178   POP_REF (p, &z);
5179   CHECK_REF (p, z, MODE (ROW_BOOL));
5180   GET_DESCRIPTOR (arr, tup, &z);
5181   size = ROW_SIZE (tup);
5182   PRELUDE_ERROR (size < 0 || size > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (ROW_BOOL));
5183   VALUE (&b) = 0x0;
5184   if (ROW_SIZE (tup) > 0) {
5185     base = DEREF (BYTE_T, &ARRAY (arr));
5186     bit = 0x1;
5187     for (k = UPB (tup); k >= LWB (tup); k--) {
5188       int addr = INDEX_1_DIM (arr, tup, k);
5189       A68_BOOL *boo = (A68_BOOL *) & (base[addr]);
5190       CHECK_INIT (p, INITIALISED (boo), MODE (BOOL));
5191       if (VALUE (boo)) {
5192         VALUE (&b) |= bit;
5193       }
5194       bit <<= 1;
5195     }
5196   }
5197   STATUS (&b) = INIT_MASK;
5198   PUSH_OBJECT (p, b, A68_BITS);
5199 }
5200 
5201 /**
5202 @brief PROC long bits pack = ([] BOOL) LONG BITS
5203 @param p Node in syntax tree.
5204 **/
5205 
5206 void
genie_long_bits_pack(NODE_T * p)5207 genie_long_bits_pack (NODE_T * p)
5208 {
5209   MOID_T *mode = MOID (p);
5210   A68_REF z;
5211   A68_ARRAY *arr;
5212   A68_TUPLE *tup;
5213   BYTE_T *base;
5214   int size, k, bits, digits;
5215   ADDR_T pop_sp;
5216   MP_T *sum, *fact;
5217   POP_REF (p, &z);
5218   CHECK_REF (p, z, MODE (ROW_BOOL));
5219   GET_DESCRIPTOR (arr, tup, &z);
5220   size = ROW_SIZE (tup);
5221   bits = get_mp_bits_width (mode);
5222   digits = DIGITS (mode);
5223   PRELUDE_ERROR (size < 0 || size > bits, p, ERROR_OUT_OF_BOUNDS, MODE (ROW_BOOL));
5224 /* Convert so that LWB goes to MSB, so ELEM gives same order as [] BOOL */
5225   STACK_MP (sum, p, digits);
5226   SET_MP_ZERO (sum, digits);
5227   pop_sp = stack_pointer;
5228   STACK_MP (fact, p, digits);
5229   (void) set_mp_short (fact, (MP_T) 1, 0, digits);
5230   if (ROW_SIZE (tup) > 0) {
5231     base = DEREF (BYTE_T, &ARRAY (arr));
5232     for (k = UPB (tup); k >= LWB (tup); k--) {
5233       int addr = INDEX_1_DIM (arr, tup, k);
5234       A68_BOOL *boo = (A68_BOOL *) & (base[addr]);
5235       CHECK_INIT (p, INITIALISED (boo), MODE (BOOL));
5236       if (VALUE (boo)) {
5237         (void) add_mp (p, sum, sum, fact, digits);
5238       }
5239       (void) mul_mp_digit (p, fact, fact, (MP_T) 2, digits);
5240     }
5241   }
5242   stack_pointer = pop_sp;
5243   MP_STATUS (sum) = (MP_T) INIT_MASK;
5244 }
5245 
5246 /**
5247 @brief OP SHL = (LONG BITS, INT) LONG BITS
5248 @param p Node in syntax tree.
5249 **/
5250 
5251 void
genie_shl_long_mp(NODE_T * p)5252 genie_shl_long_mp (NODE_T * p)
5253 {
5254   MOID_T *mode = LHS_MODE (p);
5255   int i, k, size = SIZE (mode), words = get_mp_bits_words (mode);
5256   MP_T *u;
5257   unsigned *row_u;
5258   ADDR_T pop_sp;
5259   A68_INT j;
5260 /* Pop number of bits */
5261   POP_OBJECT (p, &j, A68_INT);
5262   u = (MP_T *) STACK_OFFSET (-size);
5263   pop_sp = stack_pointer;
5264   row_u = stack_mp_bits (p, u, mode);
5265   if (VALUE (&j) >= 0) {
5266     for (i = 0; i < VALUE (&j); i++) {
5267       BOOL_T carry = A68_FALSE;
5268       for (k = words - 1; k >= 0; k--) {
5269         row_u[k] <<= 1;
5270         if (carry) {
5271           row_u[k] |= 0x1;
5272         }
5273         carry = (BOOL_T) ((row_u[k] & MP_BITS_RADIX) != 0);
5274         row_u[k] &= ~((unsigned) MP_BITS_RADIX);
5275       }
5276     }
5277   } else {
5278     for (i = 0; i < -VALUE (&j); i++) {
5279       BOOL_T carry = A68_FALSE;
5280       for (k = 0; k < words; k++) {
5281         if (carry) {
5282           row_u[k] |= MP_BITS_RADIX;
5283         }
5284         carry = (BOOL_T) ((row_u[k] & 0x1) != 0);
5285         row_u[k] >>= 1;
5286       }
5287     }
5288   }
5289   (void) pack_mp_bits (p, u, row_u, mode);
5290   stack_pointer = pop_sp;
5291 }
5292 
5293 /**
5294 @brief OP SHR = (LONG BITS, INT) LONG BITS
5295 @param p Node in syntax tree.
5296 **/
5297 
5298 void
genie_shr_long_mp(NODE_T * p)5299 genie_shr_long_mp (NODE_T * p)
5300 {
5301   A68_INT *j;
5302   POP_OPERAND_ADDRESS (p, j, A68_INT);
5303   VALUE (j) = -VALUE (j);
5304   (void) genie_shl_long_mp (p); /* Conform RR */
5305 }
5306 
5307 /**
5308 @brief OP <= = (LONG BITS, LONG BITS) BOOL
5309 @param p Node in syntax tree.
5310 **/
5311 
5312 void
genie_le_long_bits(NODE_T * p)5313 genie_le_long_bits (NODE_T * p)
5314 {
5315   MOID_T *mode = LHS_MODE (p);
5316   int k, size = SIZE (mode), words = get_mp_bits_words (mode);
5317   ADDR_T pop_sp = stack_pointer;
5318   BOOL_T result = A68_TRUE;
5319   MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size);
5320   unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode);
5321   for (k = 0; (k < words) && result; k++) {
5322     result = (BOOL_T) (result & ((row_u[k] | row_v[k]) == row_v[k]));
5323   }
5324   stack_pointer = pop_sp;
5325   DECREMENT_STACK_POINTER (p, 2 * size);
5326   PUSH_PRIMITIVE (p, (BOOL_T) (result ? A68_TRUE : A68_FALSE), A68_BOOL);
5327 }
5328 
5329 /**
5330 @brief OP >= = (LONG BITS, LONG BITS) BOOL
5331 @param p Node in syntax tree.
5332 **/
5333 
5334 void
genie_ge_long_bits(NODE_T * p)5335 genie_ge_long_bits (NODE_T * p)
5336 {
5337   MOID_T *mode = LHS_MODE (p);
5338   int k, size = SIZE (mode), words = get_mp_bits_words (mode);
5339   ADDR_T pop_sp = stack_pointer;
5340   BOOL_T result = A68_TRUE;
5341   MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size);
5342   unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode);
5343   for (k = 0; (k < words) && result; k++) {
5344     result = (BOOL_T) (result & ((row_u[k] | row_v[k]) == row_u[k]));
5345   }
5346   stack_pointer = pop_sp;
5347   DECREMENT_STACK_POINTER (p, 2 * size);
5348   PUSH_PRIMITIVE (p, (BOOL_T) (result ? A68_TRUE : A68_FALSE), A68_BOOL);
5349 }
5350 
5351 /**
5352 @brief OP AND = (LONG BITS, LONG BITS) LONG BITS
5353 @param p Node in syntax tree.
5354 **/
5355 
5356 void
genie_and_long_mp(NODE_T * p)5357 genie_and_long_mp (NODE_T * p)
5358 {
5359   MOID_T *mode = LHS_MODE (p);
5360   int k, size = SIZE (mode), words = get_mp_bits_words (mode);
5361   ADDR_T pop_sp = stack_pointer;
5362   MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size);
5363   unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode);
5364   for (k = 0; k < words; k++) {
5365     row_u[k] &= row_v[k];
5366   }
5367   (void) pack_mp_bits (p, u, row_u, mode);
5368   stack_pointer = pop_sp;
5369   DECREMENT_STACK_POINTER (p, size);
5370 }
5371 
5372 /**
5373 @brief OP OR = (LONG BITS, LONG BITS) LONG BITS
5374 @param p Node in syntax tree.
5375 **/
5376 
5377 void
genie_or_long_mp(NODE_T * p)5378 genie_or_long_mp (NODE_T * p)
5379 {
5380   MOID_T *mode = LHS_MODE (p);
5381   int k, size = SIZE (mode), words = get_mp_bits_words (mode);
5382   ADDR_T pop_sp = stack_pointer;
5383   MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size);
5384   unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode);
5385   for (k = 0; k < words; k++) {
5386     row_u[k] |= row_v[k];
5387   }
5388   (void) pack_mp_bits (p, u, row_u, mode);
5389   stack_pointer = pop_sp;
5390   DECREMENT_STACK_POINTER (p, size);
5391 }
5392 
5393 /**
5394 @brief OP XOR = (LONG BITS, LONG BITS) LONG BITS
5395 @param p Node in syntax tree.
5396 **/
5397 
5398 void
genie_xor_long_mp(NODE_T * p)5399 genie_xor_long_mp (NODE_T * p)
5400 {
5401   MOID_T *mode = LHS_MODE (p);
5402   int k, size = SIZE (mode), words = get_mp_bits_words (mode);
5403   ADDR_T pop_sp = stack_pointer;
5404   MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size);
5405   unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode);
5406   for (k = 0; k < words; k++) {
5407     row_u[k] ^= row_v[k];
5408   }
5409   (void) pack_mp_bits (p, u, row_u, mode);
5410   stack_pointer = pop_sp;
5411   DECREMENT_STACK_POINTER (p, size);
5412 }
5413 
A68_ENV_REAL(genie_cgs_acre,GSL_CONST_CGSM_ACRE)5414 A68_ENV_REAL (genie_cgs_acre, GSL_CONST_CGSM_ACRE)
5415   A68_ENV_REAL (genie_cgs_angstrom, GSL_CONST_CGSM_ANGSTROM)
5416   A68_ENV_REAL (genie_cgs_astronomical_unit, GSL_CONST_CGSM_ASTRONOMICAL_UNIT)
5417   A68_ENV_REAL (genie_cgs_bar, GSL_CONST_CGSM_BAR)
5418   A68_ENV_REAL (genie_cgs_barn, GSL_CONST_CGSM_BARN)
5419   A68_ENV_REAL (genie_cgs_bohr_magneton, GSL_CONST_CGSM_BOHR_MAGNETON)
5420   A68_ENV_REAL (genie_cgs_bohr_radius, GSL_CONST_CGSM_BOHR_RADIUS)
5421   A68_ENV_REAL (genie_cgs_boltzmann, GSL_CONST_CGSM_BOLTZMANN)
5422   A68_ENV_REAL (genie_cgs_btu, GSL_CONST_CGSM_BTU)
5423   A68_ENV_REAL (genie_cgs_calorie, GSL_CONST_CGSM_CALORIE)
5424   A68_ENV_REAL (genie_cgs_canadian_gallon, GSL_CONST_CGSM_CANADIAN_GALLON)
5425   A68_ENV_REAL (genie_cgs_carat, GSL_CONST_CGSM_CARAT)
5426   A68_ENV_REAL (genie_cgs_cup, GSL_CONST_CGSM_CUP)
5427   A68_ENV_REAL (genie_cgs_curie, GSL_CONST_CGSM_CURIE)
5428   A68_ENV_REAL (genie_cgs_day, GSL_CONST_CGSM_DAY)
5429   A68_ENV_REAL (genie_cgs_dyne, GSL_CONST_CGSM_DYNE)
5430   A68_ENV_REAL (genie_cgs_electron_charge, GSL_CONST_CGSM_ELECTRON_CHARGE)
5431   A68_ENV_REAL (genie_cgs_electron_magnetic_moment, GSL_CONST_CGSM_ELECTRON_MAGNETIC_MOMENT)
5432   A68_ENV_REAL (genie_cgs_electron_volt, GSL_CONST_CGSM_ELECTRON_VOLT)
5433   A68_ENV_REAL (genie_cgs_erg, GSL_CONST_CGSM_ERG)
5434   A68_ENV_REAL (genie_cgs_faraday, GSL_CONST_CGSM_FARADAY)
5435   A68_ENV_REAL (genie_cgs_fathom, GSL_CONST_CGSM_FATHOM)
5436   A68_ENV_REAL (genie_cgs_fluid_ounce, GSL_CONST_CGSM_FLUID_OUNCE)
5437   A68_ENV_REAL (genie_cgs_foot, GSL_CONST_CGSM_FOOT)
5438   A68_ENV_REAL (genie_cgs_footcandle, GSL_CONST_CGSM_FOOTCANDLE)
5439   A68_ENV_REAL (genie_cgs_footlambert, GSL_CONST_CGSM_FOOTLAMBERT)
5440   A68_ENV_REAL (genie_cgs_gauss, GSL_CONST_CGSM_GAUSS)
5441   A68_ENV_REAL (genie_cgs_gram_force, GSL_CONST_CGSM_GRAM_FORCE)
5442   A68_ENV_REAL (genie_cgs_grav_accel, GSL_CONST_CGSM_GRAV_ACCEL)
5443   A68_ENV_REAL (genie_cgs_gravitational_constant, GSL_CONST_CGSM_GRAVITATIONAL_CONSTANT)
5444   A68_ENV_REAL (genie_cgs_hectare, GSL_CONST_CGSM_HECTARE)
5445   A68_ENV_REAL (genie_cgs_horsepower, GSL_CONST_CGSM_HORSEPOWER)
5446   A68_ENV_REAL (genie_cgs_hour, GSL_CONST_CGSM_HOUR)
5447   A68_ENV_REAL (genie_cgs_inch, GSL_CONST_CGSM_INCH)
5448   A68_ENV_REAL (genie_cgs_inch_of_mercury, GSL_CONST_CGSM_INCH_OF_MERCURY)
5449   A68_ENV_REAL (genie_cgs_inch_of_water, GSL_CONST_CGSM_INCH_OF_WATER)
5450   A68_ENV_REAL (genie_cgs_joule, GSL_CONST_CGSM_JOULE)
5451   A68_ENV_REAL (genie_cgs_kilometers_per_hour, GSL_CONST_CGSM_KILOMETERS_PER_HOUR)
5452   A68_ENV_REAL (genie_cgs_kilopound_force, GSL_CONST_CGSM_KILOPOUND_FORCE)
5453   A68_ENV_REAL (genie_cgs_knot, GSL_CONST_CGSM_KNOT)
5454   A68_ENV_REAL (genie_cgs_lambert, GSL_CONST_CGSM_LAMBERT)
5455   A68_ENV_REAL (genie_cgs_light_year, GSL_CONST_CGSM_LIGHT_YEAR)
5456   A68_ENV_REAL (genie_cgs_liter, GSL_CONST_CGSM_LITER)
5457   A68_ENV_REAL (genie_cgs_lumen, GSL_CONST_CGSM_LUMEN)
5458   A68_ENV_REAL (genie_cgs_lux, GSL_CONST_CGSM_LUX)
5459   A68_ENV_REAL (genie_cgs_mass_electron, GSL_CONST_CGSM_MASS_ELECTRON)
5460   A68_ENV_REAL (genie_cgs_mass_muon, GSL_CONST_CGSM_MASS_MUON)
5461   A68_ENV_REAL (genie_cgs_mass_neutron, GSL_CONST_CGSM_MASS_NEUTRON)
5462   A68_ENV_REAL (genie_cgs_mass_proton, GSL_CONST_CGSM_MASS_PROTON)
5463   A68_ENV_REAL (genie_cgs_meter_of_mercury, GSL_CONST_CGSM_METER_OF_MERCURY)
5464   A68_ENV_REAL (genie_cgs_metric_ton, GSL_CONST_CGSM_METRIC_TON)
5465   A68_ENV_REAL (genie_cgs_micron, GSL_CONST_CGSM_MICRON)
5466   A68_ENV_REAL (genie_cgs_mil, GSL_CONST_CGSM_MIL)
5467   A68_ENV_REAL (genie_cgs_mile, GSL_CONST_CGSM_MILE)
5468   A68_ENV_REAL (genie_cgs_miles_per_hour, GSL_CONST_CGSM_MILES_PER_HOUR)
5469   A68_ENV_REAL (genie_cgs_minute, GSL_CONST_CGSM_MINUTE)
5470   A68_ENV_REAL (genie_cgs_molar_gas, GSL_CONST_CGSM_MOLAR_GAS)
5471   A68_ENV_REAL (genie_cgs_nautical_mile, GSL_CONST_CGSM_NAUTICAL_MILE)
5472   A68_ENV_REAL (genie_cgs_newton, GSL_CONST_CGSM_NEWTON)
5473   A68_ENV_REAL (genie_cgs_nuclear_magneton, GSL_CONST_CGSM_NUCLEAR_MAGNETON)
5474   A68_ENV_REAL (genie_cgs_ounce_mass, GSL_CONST_CGSM_OUNCE_MASS)
5475   A68_ENV_REAL (genie_cgs_parsec, GSL_CONST_CGSM_PARSEC)
5476   A68_ENV_REAL (genie_cgs_phot, GSL_CONST_CGSM_PHOT)
5477   A68_ENV_REAL (genie_cgs_pint, GSL_CONST_CGSM_PINT)
5478   A68_ENV_REAL (genie_cgs_planck_constant_h, 6.6260693e-27)
5479   A68_ENV_REAL (genie_cgs_planck_constant_hbar, 6.6260693e-27 / (2 * A68_PI))
5480   A68_ENV_REAL (genie_cgs_point, GSL_CONST_CGSM_POINT)
5481   A68_ENV_REAL (genie_cgs_poise, GSL_CONST_CGSM_POISE)
5482   A68_ENV_REAL (genie_cgs_pound_force, GSL_CONST_CGSM_POUND_FORCE)
5483   A68_ENV_REAL (genie_cgs_pound_mass, GSL_CONST_CGSM_POUND_MASS)
5484   A68_ENV_REAL (genie_cgs_poundal, GSL_CONST_CGSM_POUNDAL)
5485   A68_ENV_REAL (genie_cgs_proton_magnetic_moment, GSL_CONST_CGSM_PROTON_MAGNETIC_MOMENT)
5486   A68_ENV_REAL (genie_cgs_psi, GSL_CONST_CGSM_PSI)
5487   A68_ENV_REAL (genie_cgs_quart, GSL_CONST_CGSM_QUART)
5488   A68_ENV_REAL (genie_cgs_rad, GSL_CONST_CGSM_RAD)
5489   A68_ENV_REAL (genie_cgs_roentgen, GSL_CONST_CGSM_ROENTGEN)
5490   A68_ENV_REAL (genie_cgs_rydberg, GSL_CONST_CGSM_RYDBERG)
5491   A68_ENV_REAL (genie_cgs_solar_mass, GSL_CONST_CGSM_SOLAR_MASS)
5492   A68_ENV_REAL (genie_cgs_speed_of_light, GSL_CONST_CGSM_SPEED_OF_LIGHT)
5493   A68_ENV_REAL (genie_cgs_standard_gas_volume, GSL_CONST_CGSM_STANDARD_GAS_VOLUME)
5494   A68_ENV_REAL (genie_cgs_std_atmosphere, GSL_CONST_CGSM_STD_ATMOSPHERE)
5495   A68_ENV_REAL (genie_cgs_stilb, GSL_CONST_CGSM_STILB)
5496   A68_ENV_REAL (genie_cgs_stokes, GSL_CONST_CGSM_STOKES)
5497   A68_ENV_REAL (genie_cgs_tablespoon, GSL_CONST_CGSM_TABLESPOON)
5498   A68_ENV_REAL (genie_cgs_teaspoon, GSL_CONST_CGSM_TEASPOON)
5499   A68_ENV_REAL (genie_cgs_texpoint, GSL_CONST_CGSM_TEXPOINT)
5500   A68_ENV_REAL (genie_cgs_therm, GSL_CONST_CGSM_THERM)
5501   A68_ENV_REAL (genie_cgs_ton, GSL_CONST_CGSM_TON)
5502   A68_ENV_REAL (genie_cgs_torr, GSL_CONST_CGSM_TORR)
5503   A68_ENV_REAL (genie_cgs_troy_ounce, GSL_CONST_CGSM_TROY_OUNCE)
5504   A68_ENV_REAL (genie_cgs_uk_gallon, GSL_CONST_CGSM_UK_GALLON)
5505   A68_ENV_REAL (genie_cgs_uk_ton, GSL_CONST_CGSM_UK_TON)
5506   A68_ENV_REAL (genie_cgs_unified_atomic_mass, GSL_CONST_CGSM_UNIFIED_ATOMIC_MASS)
5507   A68_ENV_REAL (genie_cgs_us_gallon, GSL_CONST_CGSM_US_GALLON)
5508   A68_ENV_REAL (genie_cgs_week, GSL_CONST_CGSM_WEEK)
5509   A68_ENV_REAL (genie_cgs_yard, GSL_CONST_CGSM_YARD)
5510   A68_ENV_REAL (genie_mks_acre, GSL_CONST_MKS_ACRE)
5511   A68_ENV_REAL (genie_mks_angstrom, GSL_CONST_MKS_ANGSTROM)
5512   A68_ENV_REAL (genie_mks_astronomical_unit, GSL_CONST_MKS_ASTRONOMICAL_UNIT)
5513   A68_ENV_REAL (genie_mks_bar, GSL_CONST_MKS_BAR)
5514   A68_ENV_REAL (genie_mks_barn, GSL_CONST_MKS_BARN)
5515   A68_ENV_REAL (genie_mks_bohr_magneton, GSL_CONST_MKS_BOHR_MAGNETON)
5516   A68_ENV_REAL (genie_mks_bohr_radius, GSL_CONST_MKS_BOHR_RADIUS)
5517   A68_ENV_REAL (genie_mks_boltzmann, GSL_CONST_MKS_BOLTZMANN)
5518   A68_ENV_REAL (genie_mks_btu, GSL_CONST_MKS_BTU)
5519   A68_ENV_REAL (genie_mks_calorie, GSL_CONST_MKS_CALORIE)
5520   A68_ENV_REAL (genie_mks_canadian_gallon, GSL_CONST_MKS_CANADIAN_GALLON)
5521   A68_ENV_REAL (genie_mks_carat, GSL_CONST_MKS_CARAT)
5522   A68_ENV_REAL (genie_mks_cup, GSL_CONST_MKS_CUP)
5523   A68_ENV_REAL (genie_mks_curie, GSL_CONST_MKS_CURIE)
5524   A68_ENV_REAL (genie_mks_day, GSL_CONST_MKS_DAY)
5525   A68_ENV_REAL (genie_mks_dyne, GSL_CONST_MKS_DYNE)
5526   A68_ENV_REAL (genie_mks_electron_charge, GSL_CONST_MKS_ELECTRON_CHARGE)
5527   A68_ENV_REAL (genie_mks_electron_magnetic_moment, GSL_CONST_MKS_ELECTRON_MAGNETIC_MOMENT)
5528   A68_ENV_REAL (genie_mks_electron_volt, GSL_CONST_MKS_ELECTRON_VOLT)
5529   A68_ENV_REAL (genie_mks_erg, GSL_CONST_MKS_ERG)
5530   A68_ENV_REAL (genie_mks_faraday, GSL_CONST_MKS_FARADAY)
5531   A68_ENV_REAL (genie_mks_fathom, GSL_CONST_MKS_FATHOM)
5532   A68_ENV_REAL (genie_mks_fluid_ounce, GSL_CONST_MKS_FLUID_OUNCE)
5533   A68_ENV_REAL (genie_mks_foot, GSL_CONST_MKS_FOOT)
5534   A68_ENV_REAL (genie_mks_footcandle, GSL_CONST_MKS_FOOTCANDLE)
5535   A68_ENV_REAL (genie_mks_footlambert, GSL_CONST_MKS_FOOTLAMBERT)
5536   A68_ENV_REAL (genie_mks_gauss, GSL_CONST_MKS_GAUSS)
5537   A68_ENV_REAL (genie_mks_gram_force, GSL_CONST_MKS_GRAM_FORCE)
5538   A68_ENV_REAL (genie_mks_grav_accel, GSL_CONST_MKS_GRAV_ACCEL)
5539   A68_ENV_REAL (genie_mks_gravitational_constant, GSL_CONST_MKS_GRAVITATIONAL_CONSTANT)
5540   A68_ENV_REAL (genie_mks_hectare, GSL_CONST_MKS_HECTARE)
5541   A68_ENV_REAL (genie_mks_horsepower, GSL_CONST_MKS_HORSEPOWER)
5542   A68_ENV_REAL (genie_mks_hour, GSL_CONST_MKS_HOUR)
5543   A68_ENV_REAL (genie_mks_inch, GSL_CONST_MKS_INCH)
5544   A68_ENV_REAL (genie_mks_inch_of_mercury, GSL_CONST_MKS_INCH_OF_MERCURY)
5545   A68_ENV_REAL (genie_mks_inch_of_water, GSL_CONST_MKS_INCH_OF_WATER)
5546   A68_ENV_REAL (genie_mks_joule, GSL_CONST_MKS_JOULE)
5547   A68_ENV_REAL (genie_mks_kilometers_per_hour, GSL_CONST_MKS_KILOMETERS_PER_HOUR)
5548   A68_ENV_REAL (genie_mks_kilopound_force, GSL_CONST_MKS_KILOPOUND_FORCE)
5549   A68_ENV_REAL (genie_mks_knot, GSL_CONST_MKS_KNOT)
5550   A68_ENV_REAL (genie_mks_lambert, GSL_CONST_MKS_LAMBERT)
5551   A68_ENV_REAL (genie_mks_light_year, GSL_CONST_MKS_LIGHT_YEAR)
5552   A68_ENV_REAL (genie_mks_liter, GSL_CONST_MKS_LITER)
5553   A68_ENV_REAL (genie_mks_lumen, GSL_CONST_MKS_LUMEN)
5554   A68_ENV_REAL (genie_mks_lux, GSL_CONST_MKS_LUX)
5555   A68_ENV_REAL (genie_mks_mass_electron, GSL_CONST_MKS_MASS_ELECTRON)
5556   A68_ENV_REAL (genie_mks_mass_muon, GSL_CONST_MKS_MASS_MUON)
5557   A68_ENV_REAL (genie_mks_mass_neutron, GSL_CONST_MKS_MASS_NEUTRON)
5558   A68_ENV_REAL (genie_mks_mass_proton, GSL_CONST_MKS_MASS_PROTON)
5559   A68_ENV_REAL (genie_mks_meter_of_mercury, GSL_CONST_MKS_METER_OF_MERCURY)
5560   A68_ENV_REAL (genie_mks_metric_ton, GSL_CONST_MKS_METRIC_TON)
5561   A68_ENV_REAL (genie_mks_micron, GSL_CONST_MKS_MICRON)
5562   A68_ENV_REAL (genie_mks_mil, GSL_CONST_MKS_MIL)
5563   A68_ENV_REAL (genie_mks_mile, GSL_CONST_MKS_MILE)
5564   A68_ENV_REAL (genie_mks_miles_per_hour, GSL_CONST_MKS_MILES_PER_HOUR)
5565   A68_ENV_REAL (genie_mks_minute, GSL_CONST_MKS_MINUTE)
5566   A68_ENV_REAL (genie_mks_molar_gas, GSL_CONST_MKS_MOLAR_GAS)
5567   A68_ENV_REAL (genie_mks_nautical_mile, GSL_CONST_MKS_NAUTICAL_MILE)
5568   A68_ENV_REAL (genie_mks_newton, GSL_CONST_MKS_NEWTON)
5569   A68_ENV_REAL (genie_mks_nuclear_magneton, GSL_CONST_MKS_NUCLEAR_MAGNETON)
5570   A68_ENV_REAL (genie_mks_ounce_mass, GSL_CONST_MKS_OUNCE_MASS)
5571   A68_ENV_REAL (genie_mks_parsec, GSL_CONST_MKS_PARSEC)
5572   A68_ENV_REAL (genie_mks_phot, GSL_CONST_MKS_PHOT)
5573   A68_ENV_REAL (genie_mks_pint, GSL_CONST_MKS_PINT)
5574   A68_ENV_REAL (genie_mks_planck_constant_h, 6.6260693e-34)
5575   A68_ENV_REAL (genie_mks_planck_constant_hbar, 6.6260693e-34 / (2 * A68_PI))
5576   A68_ENV_REAL (genie_mks_point, GSL_CONST_MKS_POINT)
5577   A68_ENV_REAL (genie_mks_poise, GSL_CONST_MKS_POISE)
5578   A68_ENV_REAL (genie_mks_pound_force, GSL_CONST_MKS_POUND_FORCE)
5579   A68_ENV_REAL (genie_mks_pound_mass, GSL_CONST_MKS_POUND_MASS)
5580   A68_ENV_REAL (genie_mks_poundal, GSL_CONST_MKS_POUNDAL)
5581   A68_ENV_REAL (genie_mks_proton_magnetic_moment, GSL_CONST_MKS_PROTON_MAGNETIC_MOMENT)
5582   A68_ENV_REAL (genie_mks_psi, GSL_CONST_MKS_PSI)
5583   A68_ENV_REAL (genie_mks_quart, GSL_CONST_MKS_QUART)
5584   A68_ENV_REAL (genie_mks_rad, GSL_CONST_MKS_RAD)
5585   A68_ENV_REAL (genie_mks_roentgen, GSL_CONST_MKS_ROENTGEN)
5586   A68_ENV_REAL (genie_mks_rydberg, GSL_CONST_MKS_RYDBERG)
5587   A68_ENV_REAL (genie_mks_solar_mass, GSL_CONST_MKS_SOLAR_MASS)
5588   A68_ENV_REAL (genie_mks_speed_of_light, GSL_CONST_MKS_SPEED_OF_LIGHT)
5589   A68_ENV_REAL (genie_mks_standard_gas_volume, GSL_CONST_MKS_STANDARD_GAS_VOLUME)
5590   A68_ENV_REAL (genie_mks_std_atmosphere, GSL_CONST_MKS_STD_ATMOSPHERE)
5591   A68_ENV_REAL (genie_mks_stilb, GSL_CONST_MKS_STILB)
5592   A68_ENV_REAL (genie_mks_stokes, GSL_CONST_MKS_STOKES)
5593   A68_ENV_REAL (genie_mks_tablespoon, GSL_CONST_MKS_TABLESPOON)
5594   A68_ENV_REAL (genie_mks_teaspoon, GSL_CONST_MKS_TEASPOON)
5595   A68_ENV_REAL (genie_mks_texpoint, GSL_CONST_MKS_TEXPOINT)
5596   A68_ENV_REAL (genie_mks_therm, GSL_CONST_MKS_THERM)
5597   A68_ENV_REAL (genie_mks_ton, GSL_CONST_MKS_TON)
5598   A68_ENV_REAL (genie_mks_torr, GSL_CONST_MKS_TORR)
5599   A68_ENV_REAL (genie_mks_troy_ounce, GSL_CONST_MKS_TROY_OUNCE)
5600   A68_ENV_REAL (genie_mks_uk_gallon, GSL_CONST_MKS_UK_GALLON)
5601   A68_ENV_REAL (genie_mks_uk_ton, GSL_CONST_MKS_UK_TON)
5602   A68_ENV_REAL (genie_mks_unified_atomic_mass, GSL_CONST_MKS_UNIFIED_ATOMIC_MASS)
5603   A68_ENV_REAL (genie_mks_us_gallon, GSL_CONST_MKS_US_GALLON)
5604   A68_ENV_REAL (genie_mks_vacuum_permeability, GSL_CONST_MKS_VACUUM_PERMEABILITY)
5605   A68_ENV_REAL (genie_mks_vacuum_permittivity, GSL_CONST_MKS_VACUUM_PERMITTIVITY)
5606   A68_ENV_REAL (genie_mks_week, GSL_CONST_MKS_WEEK)
5607   A68_ENV_REAL (genie_mks_yard, GSL_CONST_MKS_YARD)
5608   A68_ENV_REAL (genie_num_atto, GSL_CONST_NUM_ATTO)
5609   A68_ENV_REAL (genie_num_avogadro, GSL_CONST_NUM_AVOGADRO)
5610   A68_ENV_REAL (genie_num_exa, GSL_CONST_NUM_EXA)
5611   A68_ENV_REAL (genie_num_femto, GSL_CONST_NUM_FEMTO)
5612   A68_ENV_REAL (genie_num_fine_structure, GSL_CONST_NUM_FINE_STRUCTURE)
5613   A68_ENV_REAL (genie_num_giga, GSL_CONST_NUM_GIGA)
5614   A68_ENV_REAL (genie_num_kilo, GSL_CONST_NUM_KILO)
5615   A68_ENV_REAL (genie_num_mega, GSL_CONST_NUM_MEGA)
5616   A68_ENV_REAL (genie_num_micro, GSL_CONST_NUM_MICRO)
5617   A68_ENV_REAL (genie_num_milli, GSL_CONST_NUM_MILLI)
5618   A68_ENV_REAL (genie_num_nano, GSL_CONST_NUM_NANO)
5619   A68_ENV_REAL (genie_num_peta, GSL_CONST_NUM_PETA)
5620   A68_ENV_REAL (genie_num_pico, GSL_CONST_NUM_PICO)
5621   A68_ENV_REAL (genie_num_tera, GSL_CONST_NUM_TERA)
5622   A68_ENV_REAL (genie_num_yocto, GSL_CONST_NUM_YOCTO)
5623   A68_ENV_REAL (genie_num_yotta, GSL_CONST_NUM_YOTTA)
5624   A68_ENV_REAL (genie_num_zepto, GSL_CONST_NUM_ZEPTO)
5625   A68_ENV_REAL (genie_num_zetta, GSL_CONST_NUM_ZETTA)
5626 
5627 /* Macros */
5628 #define C_FUNCTION(p, f)\
5629   A68_REAL *x;\
5630   POP_OPERAND_ADDRESS (p, x, A68_REAL);\
5631   RESET_ERRNO;\
5632   VALUE (x) = f (VALUE (x));\
5633   MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT);
5634 #define OWN_FUNCTION(p, f)\
5635   A68_REAL *x;\
5636   POP_OPERAND_ADDRESS (p, x, A68_REAL);\
5637   RESET_ERRNO;\
5638   VALUE (x) = f (p, VALUE (x));\
5639   MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT);
5640 #define GSL_FUNCTION(p, f)\
5641   A68_REAL *x;\
5642   POP_OPERAND_ADDRESS (p, x, A68_REAL);\
5643   RESET_ERRNO;\
5644   VALUE (x) = f (VALUE (x));\
5645   MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT);
5646 #define GSL_COMPLEX_FUNCTION(f)\
5647   gsl_complex x, z;\
5648   A68_REAL *rex, *imx;\
5649   imx = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));\
5650   rex = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));\
5651   GSL_SET_COMPLEX (&x, VALUE (rex), VALUE (imx));\
5652   (void) gsl_set_error_handler_off ();\
5653   RESET_ERRNO;\
5654   z = f (x);\
5655   MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT);\
5656   VALUE (imx) = GSL_IMAG(z);\
5657   VALUE (rex) = GSL_REAL(z)
5658 #define GSL_1_FUNCTION(p, f)\
5659   A68_REAL *x;\
5660   gsl_sf_result y;\
5661   int status;\
5662   POP_OPERAND_ADDRESS (p, x, A68_REAL);\
5663   (void) gsl_set_error_handler_off ();\
5664   status = f (VALUE (x), &y);\
5665   MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\
5666   VALUE (x) = VAL (&y)
5667 #define GSL_2_FUNCTION(p, f)\
5668   A68_REAL *x, *y;\
5669   gsl_sf_result r;\
5670   int status;\
5671   POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\
5672   (void) gsl_set_error_handler_off ();\
5673   status = f (VALUE (x), VALUE (y), &r);\
5674   MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\
5675   VALUE (x) = VAL (&r)
5676 #define GSL_2_INT_FUNCTION(p, f)\
5677   A68_REAL *x, *y;\
5678   gsl_sf_result r;\
5679   int status;\
5680   POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\
5681   (void) gsl_set_error_handler_off ();\
5682   status = f ((int) VALUE (x), VALUE (y), &r);\
5683   MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\
5684   VALUE (x) = VAL (&r)
5685 #define GSL_3_FUNCTION(p, f)\
5686   A68_REAL *x, *y, *z;\
5687   gsl_sf_result r;\
5688   int status;\
5689   POP_ADDRESS (p, z, A68_REAL);\
5690   POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\
5691   (void) gsl_set_error_handler_off ();\
5692   status = f (VALUE (x), VALUE (y), VALUE (z),  &r);\
5693   MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\
5694   VALUE (x) = VAL (&r)
5695 #define GSL_1D_FUNCTION(p, f)\
5696   A68_REAL *x;\
5697   gsl_sf_result y;\
5698   int status;\
5699   POP_OPERAND_ADDRESS (p, x, A68_REAL);\
5700   (void) gsl_set_error_handler_off ();\
5701   status = f (VALUE (x), GSL_PREC_DOUBLE, &y);\
5702   MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\
5703   VALUE (x) = VAL (&y)
5704 #define GSL_2D_FUNCTION(p, f)\
5705   A68_REAL *x, *y;\
5706   gsl_sf_result r;\
5707   int status;\
5708   POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\
5709   (void) gsl_set_error_handler_off ();\
5710   status = f (VALUE (x), VALUE (y), GSL_PREC_DOUBLE, &r);\
5711   MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\
5712   VALUE (x) = VAL (&r)
5713 #define GSL_3D_FUNCTION(p, f)\
5714   A68_REAL *x, *y, *z;\
5715   gsl_sf_result r;\
5716   int status;\
5717   POP_ADDRESS (p, z, A68_REAL);\
5718   POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\
5719   (void) gsl_set_error_handler_off ();\
5720   status = f (VALUE (x), VALUE (y), VALUE (z), GSL_PREC_DOUBLE, &r);\
5721   MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\
5722   VALUE (x) = VAL (&r)
5723 #define GSL_4D_FUNCTION(p, f)\
5724   A68_REAL *x, *y, *z, *rho;\
5725   gsl_sf_result r;\
5726   int status;\
5727   POP_ADDRESS (p, rho, A68_REAL);\
5728   POP_ADDRESS (p, z, A68_REAL);\
5729   POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\
5730   (void) gsl_set_error_handler_off ();\
5731   status = f (VALUE (x), VALUE (y), VALUE (z), VALUE (rho), GSL_PREC_DOUBLE, &r);\
5732   MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\
5733   VALUE (x) = VAL (&r)
5734 /**
5735 @brief The cube root of x.
5736 @param x X.
5737 @return See brief description.
5738 **/
5739      double curt (double x)
5740 {
5741 #define CBRT2 1.2599210498948731647672;
5742 #define CBRT4 1.5874010519681994747517;
5743   int expo, sign;
5744   double z, x0;
5745   static double y[11] = {
5746     7.937005259840997e-01,
5747     8.193212706006459e-01,
5748     8.434326653017493e-01,
5749     8.662391053409029e-01,
5750     8.879040017426008e-01,
5751     9.085602964160699e-01,
5752     9.283177667225558e-01,
5753     9.472682371859097e-01,
5754     9.654893846056298e-01,
5755     9.830475724915586e-01,
5756     1.0
5757   };
5758   if (x == 0.0 || x == 1.0) {
5759     return (x);
5760   }
5761   if (x > 0.0) {
5762     sign = 1;
5763   } else {
5764     sign = -1;
5765     x = -x;
5766   }
5767   x = frexp (x, &expo);
5768 /* Cube root in [0.5, 1] by Newton's method */
5769   z = x;
5770   x = y[(int) (20 * x - 10)];
5771   x0 = 0;
5772   while (ABS (x - x0) > DBL_EPSILON) {
5773     x0 = x;
5774     x = (z / (x * x) + x + x) / 3;
5775   }
5776 /* Get exponent */
5777   if (expo >= 0) {
5778     int j = expo % 3;
5779     if (j == 1) {
5780       x *= CBRT2;
5781     } else if (j == 2) {
5782       x *= CBRT4;
5783     }
5784     expo /= 3;
5785   } else {
5786     int j = (-expo) % 3;
5787     if (j == 1) {
5788       x /= CBRT2;
5789     } else if (j == 2) {
5790       x /= CBRT4;
5791     }
5792     expo = -(-expo) / 3;
5793   }
5794   x = ldexp (x, expo);
5795   return (sign >= 0 ? x : -x);
5796 }
5797 
5798 /**
5799 @brief Inverse complementary error function.
5800 @param y Y.
5801 @return See brief description.
5802 **/
5803 
5804 double
inverfc(double y)5805 inverfc (double y)
5806 {
5807   if (y < 0.0 || y > 2.0) {
5808     errno = EDOM;
5809     return (0.0);
5810   } else if (y == 0.0) {
5811     return (DBL_MAX);
5812   } else if (y == 1.0) {
5813     return (0.0);
5814   } else if (y == 2.0) {
5815     return (-DBL_MAX);
5816   } else {
5817 /* Next is adapted code from a package that contains following statement:
5818    Copyright (c) 1996 Takuya Ooura.
5819    You may use, copy, modify this code for any purpose and without fee */
5820     double s, t, u, v, x, z;
5821     if (y <= 1.0) {
5822       z = y;
5823     } else {
5824       z = 2.0 - y;
5825     }
5826     v = 0.916461398268964 - log (z);
5827     u = sqrt (v);
5828     s = (log (u) + 0.488826640273108) / v;
5829     t = 1.0 / (u + 0.231729200323405);
5830     x = u * (1.0 - s * (s * 0.124610454613712 + 0.5)) - ((((-0.0728846765585675 * t + 0.269999308670029) * t + 0.150689047360223) * t + 0.116065025341614) * t + 0.499999303439796) * t;
5831     t = 3.97886080735226 / (x + 3.97886080735226);
5832     u = t - 0.5;
5833     s = (((((((((0.00112648096188977922 * u + 1.05739299623423047e-4) * u - 0.00351287146129100025) * u - 7.71708358954120939e-4) * u + 0.00685649426074558612) * u + 0.00339721910367775861) * u - 0.011274916933250487) * u - 0.0118598117047771104) * u + 0.0142961988697898018) * u + 0.0346494207789099922) * u + 0.00220995927012179067;
5834     s = ((((((((((((s * u - 0.0743424357241784861) * u - 0.105872177941595488) * u + 0.0147297938331485121) * u + 0.316847638520135944) * u + 0.713657635868730364) * u + 1.05375024970847138) * u + 1.21448730779995237) * u + 1.16374581931560831) * u + 0.956464974744799006) * u + 0.686265948274097816) * u + 0.434397492331430115) * u + 0.244044510593190935) * t - z * exp (x * x - 0.120782237635245222);
5835     x += s * (x * s + 1.0);
5836     return (y <= 1.0 ? x : -x);
5837   }
5838 }
5839 
5840 /**
5841 @brief Inverse error function.
5842 @param y Y.
5843 @return See brief description.
5844 **/
5845 
5846 double
inverf(double y)5847 inverf (double y)
5848 {
5849   return (inverfc (1 - y));
5850 }
5851 
5852 /**
5853 @brief PROC sqrt = (REAL) REAL
5854 @param p Node in syntax tree.
5855 **/
5856 
5857 void
genie_sqrt_real(NODE_T * p)5858 genie_sqrt_real (NODE_T * p)
5859 {
5860   C_FUNCTION (p, sqrt);
5861 }
5862 
5863 /**
5864 @brief PROC curt = (REAL) REAL
5865 @param p Node in syntax tree.
5866 **/
5867 
5868 void
genie_curt_real(NODE_T * p)5869 genie_curt_real (NODE_T * p)
5870 {
5871   C_FUNCTION (p, curt);
5872 }
5873 
5874 /**
5875 @brief PROC exp = (REAL) REAL
5876 @param p Node in syntax tree.
5877 **/
5878 
5879 void
genie_exp_real(NODE_T * p)5880 genie_exp_real (NODE_T * p)
5881 {
5882   C_FUNCTION (p, a68g_exp);
5883 }
5884 
5885 /**
5886 @brief PROC ln = (REAL) REAL
5887 @param p Node in syntax tree.
5888 **/
5889 
5890 void
genie_ln_real(NODE_T * p)5891 genie_ln_real (NODE_T * p)
5892 {
5893   C_FUNCTION (p, log);
5894 }
5895 
5896 /**
5897 @brief PROC log = (REAL) REAL
5898 @param p Node in syntax tree.
5899 **/
5900 
5901 void
genie_log_real(NODE_T * p)5902 genie_log_real (NODE_T * p)
5903 {
5904   C_FUNCTION (p, log10);
5905 }
5906 
5907 /**
5908 @brief PROC sin = (REAL) REAL
5909 @param p Node in syntax tree.
5910 **/
5911 
5912 void
genie_sin_real(NODE_T * p)5913 genie_sin_real (NODE_T * p)
5914 {
5915   C_FUNCTION (p, sin);
5916 }
5917 
5918 /**
5919 @brief PROC arcsin = (REAL) REAL
5920 @param p Node in syntax tree.
5921 **/
5922 
5923 void
genie_arcsin_real(NODE_T * p)5924 genie_arcsin_real (NODE_T * p)
5925 {
5926   C_FUNCTION (p, asin);
5927 }
5928 
5929 /**
5930 @brief PROC cos = (REAL) REAL
5931 @param p Node in syntax tree.
5932 **/
5933 
5934 void
genie_cos_real(NODE_T * p)5935 genie_cos_real (NODE_T * p)
5936 {
5937   C_FUNCTION (p, cos);
5938 }
5939 
5940 /**
5941 @brief PROC arccos = (REAL) REAL
5942 @param p Node in syntax tree.
5943 **/
5944 
5945 void
genie_arccos_real(NODE_T * p)5946 genie_arccos_real (NODE_T * p)
5947 {
5948   C_FUNCTION (p, acos);
5949 }
5950 
5951 /**
5952 @brief PROC tan = (REAL) REAL
5953 @param p Node in syntax tree.
5954 **/
5955 
5956 void
genie_tan_real(NODE_T * p)5957 genie_tan_real (NODE_T * p)
5958 {
5959   C_FUNCTION (p, tan);
5960 }
5961 
5962 /**
5963 @brief PROC arctan = (REAL) REAL
5964 @param p Node in syntax tree.
5965 **/
5966 
5967 void
genie_arctan_real(NODE_T * p)5968 genie_arctan_real (NODE_T * p)
5969 {
5970   C_FUNCTION (p, atan);
5971 }
5972 
5973 /**
5974 @brief PROC arctan2 = (REAL) REAL
5975 @param p Node in syntax tree.
5976 **/
5977 
5978 void
genie_atan2_real(NODE_T * p)5979 genie_atan2_real (NODE_T * p)
5980 {
5981   A68_REAL *x, *y;
5982   POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
5983   RESET_ERRNO;
5984   PRELUDE_ERROR (VALUE (x) == 0.0 && VALUE (y) == 0.0, p, ERROR_INVALID_ARGUMENT, MODE (LONG_REAL));
5985   VALUE (x) = a68g_atan2 (VALUE (y), VALUE (x));
5986   PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
5987 }
5988 
5989 /**
5990 @brief PROC sinh = (REAL) REAL
5991 @param p Node in syntax tree.
5992 **/
5993 
5994 void
genie_sinh_real(NODE_T * p)5995 genie_sinh_real (NODE_T * p)
5996 {
5997   C_FUNCTION (p, sinh);
5998 }
5999 
6000 /**
6001 @brief PROC cosh = (REAL) REAL
6002 @param p Node in syntax tree.
6003 **/
6004 
6005 void
genie_cosh_real(NODE_T * p)6006 genie_cosh_real (NODE_T * p)
6007 {
6008   C_FUNCTION (p, cosh);
6009 }
6010 
6011 /**
6012 @brief PROC tanh = (REAL) REAL
6013 @param p Node in syntax tree.
6014 **/
6015 
6016 void
genie_tanh_real(NODE_T * p)6017 genie_tanh_real (NODE_T * p)
6018 {
6019   C_FUNCTION (p, tanh);
6020 }
6021 
6022 /**
6023 @brief PROC arcsinh = (REAL) REAL
6024 @param p Node in syntax tree.
6025 **/
6026 
6027 void
genie_arcsinh_real(NODE_T * p)6028 genie_arcsinh_real (NODE_T * p)
6029 {
6030   C_FUNCTION (p, a68g_asinh);
6031 }
6032 
6033 /**
6034 @brief PROC arccosh = (REAL) REAL
6035 @param p Node in syntax tree.
6036 **/
6037 
6038 void
genie_arccosh_real(NODE_T * p)6039 genie_arccosh_real (NODE_T * p)
6040 {
6041   C_FUNCTION (p, a68g_acosh);
6042 }
6043 
6044 /**
6045 @brief PROC arctanh = (REAL) REAL
6046 @param p Node in syntax tree.
6047 **/
6048 
6049 void
genie_arctanh_real(NODE_T * p)6050 genie_arctanh_real (NODE_T * p)
6051 {
6052   C_FUNCTION (p, a68g_atanh);
6053 }
6054 
6055 /**
6056 @brief PROC inverse erf = (REAL) REAL
6057 @param p Node in syntax tree.
6058 **/
6059 
6060 void
genie_inverf_real(NODE_T * p)6061 genie_inverf_real (NODE_T * p)
6062 {
6063   C_FUNCTION (p, inverf);
6064 }
6065 
6066 /**
6067 @brief PROC inverse erfc = (REAL) REAL
6068 @param p Node in syntax tree.
6069 **/
6070 
6071 void
genie_inverfc_real(NODE_T * p)6072 genie_inverfc_real (NODE_T * p)
6073 {
6074   C_FUNCTION (p, inverfc);
6075 }
6076 
6077 /**
6078 @brief PROC lj e 12 6 = (REAL, REAL, REAL) REAL
6079 @param p Node in syntax tree.
6080 **/
6081 
6082 void
genie_lj_e_12_6(NODE_T * p)6083 genie_lj_e_12_6 (NODE_T * p)
6084 {
6085   A68_REAL *e, *s, *r;
6086   double u, u2, u6;
6087   POP_3_OPERAND_ADDRESSES (p, e, s, r, A68_REAL);
6088   u = (VALUE (s) / VALUE (r));
6089   u2 = u * u;
6090   u6 = u2 * u2 * u2;
6091   VALUE (e) = 4.0 * VALUE (e) * u6 * (u6 - 1.0);
6092 }
6093 
6094 /**
6095 @brief PROC lj f 12 6 = (REAL, REAL, REAL) REAL
6096 @param p Node in syntax tree.
6097 **/
6098 
6099 void
genie_lj_f_12_6(NODE_T * p)6100 genie_lj_f_12_6 (NODE_T * p)
6101 {
6102   A68_REAL *e, *s, *r;
6103   double u, u2, u6;
6104   POP_3_OPERAND_ADDRESSES (p, e, s, r, A68_REAL);
6105   u = (VALUE (s) / VALUE (r));
6106   u2 = u * u;
6107   u6 = u2 * u2 * u2;
6108   VALUE (e) = 24.0 * VALUE (e) * u * u6 * (1.0 - 2.0 * u6);
6109 }
6110 
6111 #if defined HAVE_GNU_GSL
6112 
6113 /* "Special" functions - but what is so "special" about them? */
6114 
6115 /**
6116 @brief PROC erf = (REAL) REAL
6117 @param p Node in syntax tree.
6118 **/
6119 
6120 void
genie_erf_real(NODE_T * p)6121 genie_erf_real (NODE_T * p)
6122 {
6123   GSL_1_FUNCTION (p, gsl_sf_erf_e);
6124 }
6125 
6126 /**
6127 @brief PROC erfc = (REAL) REAL
6128 @param p Node in syntax tree.
6129 **/
6130 
6131 void
genie_erfc_real(NODE_T * p)6132 genie_erfc_real (NODE_T * p)
6133 {
6134   GSL_1_FUNCTION (p, gsl_sf_erfc_e);
6135 }
6136 
6137 /**
6138 @brief PROC gamma = (REAL) REAL
6139 @param p Node in syntax tree.
6140 **/
6141 
6142 void
genie_gamma_real(NODE_T * p)6143 genie_gamma_real (NODE_T * p)
6144 {
6145   GSL_1_FUNCTION (p, gsl_sf_gamma_e);
6146 }
6147 
6148 /**
6149 @brief PROC gamma incomplete = (REAL, REAL) REAL
6150 @param p Node in syntax tree.
6151 **/
6152 
6153 void
genie_gamma_inc_real(NODE_T * p)6154 genie_gamma_inc_real (NODE_T * p)
6155 {
6156   GSL_2_FUNCTION (p, gsl_sf_gamma_inc_P_e);
6157 }
6158 
6159 /**
6160 @brief PROC lngamma = (REAL) REAL
6161 @param p Node in syntax tree.
6162 **/
6163 
6164 void
genie_lngamma_real(NODE_T * p)6165 genie_lngamma_real (NODE_T * p)
6166 {
6167   GSL_1_FUNCTION (p, gsl_sf_lngamma_e);
6168 }
6169 
6170 /**
6171 @brief PROC factorial = (REAL) REAL
6172 @param p Node in syntax tree.
6173 **/
6174 
6175 void
genie_factorial_real(NODE_T * p)6176 genie_factorial_real (NODE_T * p)
6177 {
6178 /* gsl_sf_fact reduces argument to int, hence we do gamma (x + 1) */
6179   A68_REAL *z = (A68_REAL *) STACK_OFFSET (-SIZE (MODE (REAL)));
6180   VALUE (z) += 1.0;
6181   {
6182     GSL_1_FUNCTION (p, gsl_sf_gamma_e);
6183   }
6184 }
6185 
6186 /**
6187 @brief PROC beta = (REAL, REAL) REAL
6188 @param p Node in syntax tree.
6189 **/
6190 
6191 void
genie_beta_real(NODE_T * p)6192 genie_beta_real (NODE_T * p)
6193 {
6194   GSL_2_FUNCTION (p, gsl_sf_beta_e);
6195 }
6196 
6197 /**
6198 @brief PROC beta incomplete = (REAL, REAL, REAL) REAL
6199 @param p Node in syntax tree.
6200 **/
6201 
6202 void
genie_beta_inc_real(NODE_T * p)6203 genie_beta_inc_real (NODE_T * p)
6204 {
6205   GSL_3_FUNCTION (p, gsl_sf_beta_inc_e);
6206 }
6207 
6208 /**
6209 @brief PROC airy ai = (REAL) REAL
6210 @param p Node in syntax tree.
6211 **/
6212 
6213 void
genie_airy_ai_real(NODE_T * p)6214 genie_airy_ai_real (NODE_T * p)
6215 {
6216   GSL_1D_FUNCTION (p, gsl_sf_airy_Ai_e);
6217 }
6218 
6219 /**
6220 @brief PROC airy bi = (REAL) REAL
6221 @param p Node in syntax tree.
6222 **/
6223 
6224 void
genie_airy_bi_real(NODE_T * p)6225 genie_airy_bi_real (NODE_T * p)
6226 {
6227   GSL_1D_FUNCTION (p, gsl_sf_airy_Bi_e);
6228 }
6229 
6230 /**
6231 @brief PROC airy ai derivative = (REAL) REAL
6232 @param p Node in syntax tree.
6233 **/
6234 
6235 void
genie_airy_ai_deriv_real(NODE_T * p)6236 genie_airy_ai_deriv_real (NODE_T * p)
6237 {
6238   GSL_1D_FUNCTION (p, gsl_sf_airy_Ai_deriv_e);
6239 }
6240 
6241 /**
6242 @brief PROC airy bi derivative = (REAL) REAL
6243 @param p Node in syntax tree.
6244 **/
6245 
6246 void
genie_airy_bi_deriv_real(NODE_T * p)6247 genie_airy_bi_deriv_real (NODE_T * p)
6248 {
6249   GSL_1D_FUNCTION (p, gsl_sf_airy_Bi_deriv_e);
6250 }
6251 
6252 /**
6253 @brief PROC bessel jn = (REAL, REAL) REAL
6254 @param p Node in syntax tree.
6255 **/
6256 
6257 void
genie_bessel_jn_real(NODE_T * p)6258 genie_bessel_jn_real (NODE_T * p)
6259 {
6260   GSL_2_INT_FUNCTION (p, gsl_sf_bessel_Jn_e);
6261 }
6262 
6263 /**
6264 @brief PROC bessel yn = (REAL, REAL) REAL
6265 @param p Node in syntax tree.
6266 **/
6267 
6268 void
genie_bessel_yn_real(NODE_T * p)6269 genie_bessel_yn_real (NODE_T * p)
6270 {
6271   GSL_2_INT_FUNCTION (p, gsl_sf_bessel_Yn_e);
6272 }
6273 
6274 /**
6275 @brief PROC bessel in = (REAL, REAL) REAL
6276 @param p Node in syntax tree.
6277 **/
6278 
6279 void
genie_bessel_in_real(NODE_T * p)6280 genie_bessel_in_real (NODE_T * p)
6281 {
6282   GSL_2_INT_FUNCTION (p, gsl_sf_bessel_In_e);
6283 }
6284 
6285 /**
6286 @brief PROC bessel exp in = (REAL, REAL) REAL
6287 @param p Node in syntax tree.
6288 **/
6289 
6290 void
genie_bessel_exp_in_real(NODE_T * p)6291 genie_bessel_exp_in_real (NODE_T * p)
6292 {
6293   GSL_2_INT_FUNCTION (p, gsl_sf_bessel_In_scaled_e);
6294 }
6295 
6296 /**
6297 @brief PROC bessel kn = (REAL, REAL) REAL
6298 @param p Node in syntax tree.
6299 **/
6300 
6301 void
genie_bessel_kn_real(NODE_T * p)6302 genie_bessel_kn_real (NODE_T * p)
6303 {
6304   GSL_2_INT_FUNCTION (p, gsl_sf_bessel_Kn_e);
6305 }
6306 
6307 /**
6308 @brief PROC bessel exp kn = (REAL, REAL) REAL
6309 @param p Node in syntax tree.
6310 **/
6311 
6312 void
genie_bessel_exp_kn_real(NODE_T * p)6313 genie_bessel_exp_kn_real (NODE_T * p)
6314 {
6315   GSL_2_INT_FUNCTION (p, gsl_sf_bessel_Kn_scaled_e);
6316 }
6317 
6318 /**
6319 @brief PROC bessel jl = (REAL, REAL) REAL
6320 @param p Node in syntax tree.
6321 **/
6322 
6323 void
genie_bessel_jl_real(NODE_T * p)6324 genie_bessel_jl_real (NODE_T * p)
6325 {
6326   GSL_2_INT_FUNCTION (p, gsl_sf_bessel_jl_e);
6327 }
6328 
6329 /**
6330 @brief PROC bessel yl = (REAL, REAL) REAL
6331 @param p Node in syntax tree.
6332 **/
6333 
6334 void
genie_bessel_yl_real(NODE_T * p)6335 genie_bessel_yl_real (NODE_T * p)
6336 {
6337   GSL_2_INT_FUNCTION (p, gsl_sf_bessel_yl_e);
6338 }
6339 
6340 /**
6341 @brief PROC bessel exp il = (REAL, REAL) REAL
6342 @param p Node in syntax tree.
6343 **/
6344 
6345 void
genie_bessel_exp_il_real(NODE_T * p)6346 genie_bessel_exp_il_real (NODE_T * p)
6347 {
6348   GSL_2_INT_FUNCTION (p, gsl_sf_bessel_il_scaled_e);
6349 }
6350 
6351 /**
6352 @brief PROC bessel exp kl = (REAL, REAL) REAL
6353 @param p Node in syntax tree.
6354 **/
6355 
6356 void
genie_bessel_exp_kl_real(NODE_T * p)6357 genie_bessel_exp_kl_real (NODE_T * p)
6358 {
6359   GSL_2_INT_FUNCTION (p, gsl_sf_bessel_kl_scaled_e);
6360 }
6361 
6362 /**
6363 @brief PROC bessel jnu = (REAL, REAL) REAL
6364 @param p Node in syntax tree.
6365 **/
6366 
6367 void
genie_bessel_jnu_real(NODE_T * p)6368 genie_bessel_jnu_real (NODE_T * p)
6369 {
6370   GSL_2_FUNCTION (p, gsl_sf_bessel_Jnu_e);
6371 }
6372 
6373 /**
6374 @brief PROC bessel ynu = (REAL, REAL) REAL
6375 @param p Node in syntax tree.
6376 **/
6377 
6378 void
genie_bessel_ynu_real(NODE_T * p)6379 genie_bessel_ynu_real (NODE_T * p)
6380 {
6381   GSL_2_FUNCTION (p, gsl_sf_bessel_Ynu_e);
6382 }
6383 
6384 /**
6385 @brief PROC bessel inu = (REAL, REAL) REAL
6386 @param p Node in syntax tree.
6387 **/
6388 
6389 void
genie_bessel_inu_real(NODE_T * p)6390 genie_bessel_inu_real (NODE_T * p)
6391 {
6392   GSL_2_FUNCTION (p, gsl_sf_bessel_Inu_e);
6393 }
6394 
6395 /**
6396 @brief PROC bessel exp inu = (REAL, REAL) REAL
6397 @param p Node in syntax tree.
6398 **/
6399 
6400 void
genie_bessel_exp_inu_real(NODE_T * p)6401 genie_bessel_exp_inu_real (NODE_T * p)
6402 {
6403   GSL_2_FUNCTION (p, gsl_sf_bessel_Inu_scaled_e);
6404 }
6405 
6406 /**
6407 @brief PROC bessel knu = (REAL, REAL) REAL
6408 @param p Node in syntax tree.
6409 **/
6410 
6411 void
genie_bessel_knu_real(NODE_T * p)6412 genie_bessel_knu_real (NODE_T * p)
6413 {
6414   GSL_2_FUNCTION (p, gsl_sf_bessel_Knu_e);
6415 }
6416 
6417 /**
6418 @brief PROC bessel exp knu = (REAL, REAL) REAL
6419 @param p Node in syntax tree.
6420 **/
6421 
6422 void
genie_bessel_exp_knu_real(NODE_T * p)6423 genie_bessel_exp_knu_real (NODE_T * p)
6424 {
6425   GSL_2_FUNCTION (p, gsl_sf_bessel_Knu_scaled_e);
6426 }
6427 
6428 /**
6429 @brief PROC elliptic integral k = (REAL) REAL
6430 @param p Node in syntax tree.
6431 **/
6432 
6433 void
genie_elliptic_integral_k_real(NODE_T * p)6434 genie_elliptic_integral_k_real (NODE_T * p)
6435 {
6436   GSL_1D_FUNCTION (p, gsl_sf_ellint_Kcomp_e);
6437 }
6438 
6439 /**
6440 @brief PROC elliptic integral e = (REAL) REAL
6441 @param p Node in syntax tree.
6442 **/
6443 
6444 void
genie_elliptic_integral_e_real(NODE_T * p)6445 genie_elliptic_integral_e_real (NODE_T * p)
6446 {
6447   GSL_1D_FUNCTION (p, gsl_sf_ellint_Ecomp_e);
6448 }
6449 
6450 /**
6451 @brief PROC elliptic integral rf = (REAL, REAL, REAL) REAL
6452 @param p Node in syntax tree.
6453 **/
6454 
6455 void
genie_elliptic_integral_rf_real(NODE_T * p)6456 genie_elliptic_integral_rf_real (NODE_T * p)
6457 {
6458   GSL_3D_FUNCTION (p, gsl_sf_ellint_RF_e);
6459 }
6460 
6461 /**
6462 @brief PROC elliptic integral rd = (REAL, REAL, REAL) REAL
6463 @param p Node in syntax tree.
6464 **/
6465 
6466 void
genie_elliptic_integral_rd_real(NODE_T * p)6467 genie_elliptic_integral_rd_real (NODE_T * p)
6468 {
6469   GSL_3D_FUNCTION (p, gsl_sf_ellint_RD_e);
6470 }
6471 
6472 /**
6473 @brief PROC elliptic integral rj = (REAL, REAL, REAL, REAL) REAL
6474 @param p Node in syntax tree.
6475 **/
6476 
6477 void
genie_elliptic_integral_rj_real(NODE_T * p)6478 genie_elliptic_integral_rj_real (NODE_T * p)
6479 {
6480   GSL_4D_FUNCTION (p, gsl_sf_ellint_RJ_e);
6481 }
6482 
6483 /**
6484 @brief PROC elliptic integral rc = (REAL, REAL) REAL
6485 @param p Node in syntax tree.
6486 **/
6487 
6488 void
genie_elliptic_integral_rc_real(NODE_T * p)6489 genie_elliptic_integral_rc_real (NODE_T * p)
6490 {
6491   GSL_2D_FUNCTION (p, gsl_sf_ellint_RC_e);
6492 }
6493 
6494 #endif
6495 
6496 /*
6497 Next part is a "stand-alone" version of GNU Scientific Library (GSL)
6498 random number generator "taus113", based on GSL file "rng/taus113.c" that
6499 has the notice:
6500 
6501 Copyright (C) 2002 Atakan Gurkan
6502 Based on the file taus.c which has the notice
6503 Copyright (C) 1996, 1997, 1998, 1999, 2000 James Theiler, Brian Gough.
6504 
6505 This is a maximally equidistributed combined, collision free
6506 Tausworthe generator, with a period ~2^113 (~10^34).
6507 The sequence is
6508 
6509 x_n = (z1_n ^ z2_n ^ z3_n ^ z4_n)
6510 
6511 b = (((z1_n <<  6) ^ z1_n) >> 13)
6512 z1_{n+1} = (((z1_n & 4294967294) << 18) ^ b)
6513 b = (((z2_n <<  2) ^ z2_n) >> 27)
6514 z2_{n+1} = (((z2_n & 4294967288) <<  2) ^ b)
6515 b = (((z3_n << 13) ^ z3_n) >> 21)
6516 z3_{n+1} = (((z3_n & 4294967280) <<  7) ^ b)
6517 b = (((z4_n <<  3)  ^ z4_n) >> 12)
6518 z4_{n+1} = (((z4_n & 4294967168) << 13) ^ b)
6519 
6520 computed modulo 2^32. In the formulas above '^' means exclusive-or
6521 (C-notation), not exponentiation.
6522 The algorithm is for 32-bit integers, hence a bitmask is used to clear
6523 all but least significant 32 bits, after left shifts, to make the code
6524 work on architectures where integers are 64-bit.
6525 
6526 The generator is initialized with
6527 zi = (69069 * z{i+1}) MOD 2^32 where z0 is the seed provided
6528 During initialization a check is done to make sure that the initial seeds
6529 have a required number of their most significant bits set.
6530 After this, the state is passed through the RNG 10 times to ensure the
6531 state satisfies a recurrence relation.
6532 
6533 References:
6534 P. L'Ecuyer, "Tables of Maximally-Equidistributed Combined LFSR Generators",
6535 Mathematics of Computation, 68, 225 (1999), 261--269.
6536   http://www.iro.umontreal.ca/~lecuyer/myftp/papers/tausme2.ps
6537 P. L'Ecuyer, "Maximally Equidistributed Combined Tausworthe Generators",
6538 Mathematics of Computation, 65, 213 (1996), 203--213.
6539   http://www.iro.umontreal.ca/~lecuyer/myftp/papers/tausme.ps
6540 the online version of the latter contains corrections to the print version.
6541 */
6542 
6543 #define LCG(n) ((69069UL * n) & 0xffffffffUL)
6544 #define TAUSWORTHE_MASK 0xffffffffUL
6545 #define Z1(p) ((p)->z1)
6546 #define Z2(p) ((p)->z2)
6547 #define Z3(p) ((p)->z3)
6548 #define Z4(p) ((p)->z4)
6549 
6550 typedef struct
6551 {
6552   unsigned long int z1, z2, z3, z4;
6553 } taus113_state_t;
6554 
6555 static taus113_state_t rng_state;
6556 
6557 static unsigned long int taus113_get (taus113_state_t * state);
6558 static void taus113_set (taus113_state_t * state, unsigned long int s);
6559 
6560 /**
6561 @brief Taus113_get.
6562 @param state State.
6563 @return See brief description.
6564 **/
6565 
6566 static unsigned long
taus113_get(taus113_state_t * state)6567 taus113_get (taus113_state_t * state)
6568 {
6569   unsigned long b1, b2, b3, b4;
6570   b1 = ((((Z1 (state) << 6UL) & TAUSWORTHE_MASK) ^ Z1 (state)) >> 13UL);
6571   Z1 (state) = ((((Z1 (state) & 4294967294UL) << 18UL) & TAUSWORTHE_MASK) ^ b1);
6572   b2 = ((((Z2 (state) << 2UL) & TAUSWORTHE_MASK) ^ Z2 (state)) >> 27UL);
6573   Z2 (state) = ((((Z2 (state) & 4294967288UL) << 2UL) & TAUSWORTHE_MASK) ^ b2);
6574   b3 = ((((Z3 (state) << 13UL) & TAUSWORTHE_MASK) ^ Z3 (state)) >> 21UL);
6575   Z3 (state) = ((((Z3 (state) & 4294967280UL) << 7UL) & TAUSWORTHE_MASK) ^ b3);
6576   b4 = ((((Z4 (state) << 3UL) & TAUSWORTHE_MASK) ^ Z4 (state)) >> 12UL);
6577   Z4 (state) = ((((Z4 (state) & 4294967168UL) << 13UL) & TAUSWORTHE_MASK) ^ b4);
6578   return (Z1 (state) ^ Z2 (state) ^ Z3 (state) ^ Z4 (state));
6579 }
6580 
6581 /**
6582 @brief Taus113_set.
6583 @param state State.
6584 @param s S.
6585 **/
6586 
6587 static void
taus113_set(taus113_state_t * state,unsigned long int s)6588 taus113_set (taus113_state_t * state, unsigned long int s)
6589 {
6590   if (!s) {
6591 /* default seed is 1 */
6592     s = 1UL;
6593   }
6594   Z1 (state) = LCG (s);
6595   if (Z1 (state) < 2UL) {
6596     Z1 (state) += 2UL;
6597   }
6598   Z2 (state) = LCG (Z1 (state));
6599   if (Z2 (state) < 8UL) {
6600     Z2 (state) += 8UL;
6601   }
6602   Z3 (state) = LCG (Z2 (state));
6603   if (Z3 (state) < 16UL) {
6604     Z3 (state) += 16UL;
6605   }
6606   Z4 (state) = LCG (Z3 (state));
6607   if (Z4 (state) < 128UL) {
6608     Z4 (state) += 128UL;
6609   }
6610 /* Calling RNG ten times to satify recurrence condition */
6611   (void) taus113_get (state);
6612   (void) taus113_get (state);
6613   (void) taus113_get (state);
6614   (void) taus113_get (state);
6615   (void) taus113_get (state);
6616   (void) taus113_get (state);
6617   (void) taus113_get (state);
6618   (void) taus113_get (state);
6619   (void) taus113_get (state);
6620   (void) taus113_get (state);
6621 }
6622 
6623 /**
6624 @brief Initialise rng.
6625 @param u Initialiser.
6626 **/
6627 
6628 void
init_rng(unsigned long u)6629 init_rng (unsigned long u)
6630 {
6631   taus113_set (&rng_state, u);
6632 }
6633 
6634 /**
6635 @brief Rng 53 bit.
6636 @return See brief description.
6637 **/
6638 
6639 double
rng_53_bit(void)6640 rng_53_bit (void)
6641 {
6642   double a = (double) (taus113_get (&rng_state) >> 5);
6643   double b = (double) (taus113_get (&rng_state) >> 6);
6644   return (a * /* 2^26 */ 67108864.0 + b) / /* 2^53 */ 9007199254740992.0;
6645 }
6646 
6647 /*
6648 Rules for analytic calculations using GNU Emacs Calc:
6649 (used to find the values for the test program)
6650 
6651 [ LCG(n) := n * 69069 mod (2^32) ]
6652 
6653 [ b1(x) := rsh(xor(lsh(x, 6), x), 13),
6654 q1(x) := xor(lsh(and(x, 4294967294), 18), b1(x)),
6655 b2(x) := rsh(xor(lsh(x, 2), x), 27),
6656 q2(x) := xor(lsh(and(x, 4294967288), 2), b2(x)),
6657 b3(x) := rsh(xor(lsh(x, 13), x), 21),
6658 q3(x) := xor(lsh(and(x, 4294967280), 7), b3(x)),
6659 b4(x) := rsh(xor(lsh(x, 3), x), 12),
6660 q4(x) := xor(lsh(and(x, 4294967168), 13), b4(x))
6661 ]
6662 
6663 [ S([z1,z2,z3,z4]) := [q1(z1), q2(z2), q3(z3), q4(z4)] ]
6664 */
6665 
6666 /*
6667 This file also contains Algol68G's standard environ for complex numbers.
6668 Some of the LONG operations are generic for LONG and LONG LONG.
6669 
6670 Some routines are based on
6671 * GNU Scientific Library
6672 * Abramowitz and Stegun.
6673 */
6674 
6675 #if defined HAVE_GNU_GSL
6676 
6677 #define GSL_COMPLEX_FUNCTION(f)\
6678   gsl_complex x, z;\
6679   A68_REAL *rex, *imx;\
6680   imx = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));\
6681   rex = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));\
6682   GSL_SET_COMPLEX (&x, VALUE (rex), VALUE (imx));\
6683   (void) gsl_set_error_handler_off ();\
6684   RESET_ERRNO;\
6685   z = f (x);\
6686   MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT);\
6687   VALUE (imx) = GSL_IMAG(z);\
6688   VALUE (rex) = GSL_REAL(z)
6689 
6690 #endif
6691 
6692 /**
6693 @brief OP +* = (REAL, REAL) COMPLEX
6694 @param p Node in syntax tree.
6695 **/
6696 
6697 void
genie_icomplex(NODE_T * p)6698 genie_icomplex (NODE_T * p)
6699 {
6700   (void) p;
6701 }
6702 
6703 /**
6704 @brief OP +* = (INT, INT) COMPLEX
6705 @param p Node in syntax tree.
6706 **/
6707 
6708 void
genie_iint_complex(NODE_T * p)6709 genie_iint_complex (NODE_T * p)
6710 {
6711   A68_INT re, im;
6712   POP_OBJECT (p, &im, A68_INT);
6713   POP_OBJECT (p, &re, A68_INT);
6714   PUSH_PRIMITIVE (p, (double) VALUE (&re), A68_REAL);
6715   PUSH_PRIMITIVE (p, (double) VALUE (&im), A68_REAL);
6716 }
6717 
6718 /**
6719 @brief OP RE = (COMPLEX) REAL
6720 @param p Node in syntax tree.
6721 **/
6722 
6723 void
genie_re_complex(NODE_T * p)6724 genie_re_complex (NODE_T * p)
6725 {
6726   DECREMENT_STACK_POINTER (p, SIZE (MODE (REAL)));
6727 }
6728 
6729 /**
6730 @brief OP IM = (COMPLEX) REAL
6731 @param p Node in syntax tree.
6732 **/
6733 
6734 void
genie_im_complex(NODE_T * p)6735 genie_im_complex (NODE_T * p)
6736 {
6737   A68_REAL im;
6738   POP_OBJECT (p, &im, A68_REAL);
6739   *(A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL)))) = im;
6740 }
6741 
6742 /**
6743 @brief OP - = (COMPLEX) COMPLEX
6744 @param p Node in syntax tree.
6745 **/
6746 
6747 void
genie_minus_complex(NODE_T * p)6748 genie_minus_complex (NODE_T * p)
6749 {
6750   A68_REAL *re_x, *im_x;
6751   im_x = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));
6752   re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));
6753   VALUE (im_x) = -VALUE (im_x);
6754   VALUE (re_x) = -VALUE (re_x);
6755   (void) p;
6756 }
6757 
6758 /**
6759 @brief ABS = (COMPLEX) REAL
6760 @param p Node in syntax tree.
6761 **/
6762 
6763 void
genie_abs_complex(NODE_T * p)6764 genie_abs_complex (NODE_T * p)
6765 {
6766   A68_REAL re_x, im_x;
6767   POP_COMPLEX (p, &re_x, &im_x);
6768   PUSH_PRIMITIVE (p, a68g_hypot (VALUE (&re_x), VALUE (&im_x)), A68_REAL);
6769 }
6770 
6771 /**
6772 @brief OP ARG = (COMPLEX) REAL
6773 @param p Node in syntax tree.
6774 **/
6775 
6776 void
genie_arg_complex(NODE_T * p)6777 genie_arg_complex (NODE_T * p)
6778 {
6779   A68_REAL re_x, im_x;
6780   POP_COMPLEX (p, &re_x, &im_x);
6781   PRELUDE_ERROR (VALUE (&re_x) == 0.0 && VALUE (&im_x) == 0.0, p, ERROR_INVALID_ARGUMENT, MODE (COMPLEX));
6782   PUSH_PRIMITIVE (p, atan2 (VALUE (&im_x), VALUE (&re_x)), A68_REAL);
6783 }
6784 
6785 /**
6786 @brief OP CONJ = (COMPLEX) COMPLEX
6787 @param p Node in syntax tree.
6788 **/
6789 
6790 void
genie_conj_complex(NODE_T * p)6791 genie_conj_complex (NODE_T * p)
6792 {
6793   A68_REAL *im;
6794   POP_OPERAND_ADDRESS (p, im, A68_REAL);
6795   VALUE (im) = -VALUE (im);
6796 }
6797 
6798 /**
6799 @brief OP + = (COMPLEX, COMPLEX) COMPLEX
6800 @param p Node in syntax tree.
6801 **/
6802 
6803 void
genie_add_complex(NODE_T * p)6804 genie_add_complex (NODE_T * p)
6805 {
6806   A68_REAL *re_x, *im_x, re_y, im_y;
6807   POP_COMPLEX (p, &re_y, &im_y);
6808   im_x = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));
6809   re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));
6810   VALUE (im_x) += VALUE (&im_y);
6811   VALUE (re_x) += VALUE (&re_y);
6812   CHECK_COMPLEX_REPRESENTATION (p, VALUE (re_x), VALUE (im_x));
6813 }
6814 
6815 /**
6816 @brief OP - = (COMPLEX, COMPLEX) COMPLEX
6817 @param p Node in syntax tree.
6818 **/
6819 
6820 void
genie_sub_complex(NODE_T * p)6821 genie_sub_complex (NODE_T * p)
6822 {
6823   A68_REAL *re_x, *im_x, re_y, im_y;
6824   POP_COMPLEX (p, &re_y, &im_y);
6825   im_x = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));
6826   re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));
6827   VALUE (im_x) -= VALUE (&im_y);
6828   VALUE (re_x) -= VALUE (&re_y);
6829   CHECK_COMPLEX_REPRESENTATION (p, VALUE (re_x), VALUE (im_x));
6830 }
6831 
6832 /**
6833 @brief OP * = (COMPLEX, COMPLEX) COMPLEX
6834 @param p Node in syntax tree.
6835 **/
6836 
6837 void
genie_mul_complex(NODE_T * p)6838 genie_mul_complex (NODE_T * p)
6839 {
6840   A68_REAL re_x, im_x, re_y, im_y;
6841   double re, im;
6842   POP_COMPLEX (p, &re_y, &im_y);
6843   POP_COMPLEX (p, &re_x, &im_x);
6844   re = VALUE (&re_x) * VALUE (&re_y) - VALUE (&im_x) * VALUE (&im_y);
6845   im = VALUE (&im_x) * VALUE (&re_y) + VALUE (&re_x) * VALUE (&im_y);
6846   CHECK_COMPLEX_REPRESENTATION (p, re, im);
6847   PUSH_COMPLEX (p, re, im);
6848 }
6849 
6850 /**
6851 @brief OP / = (COMPLEX, COMPLEX) COMPLEX
6852 @param p Node in syntax tree.
6853 **/
6854 
6855 void
genie_div_complex(NODE_T * p)6856 genie_div_complex (NODE_T * p)
6857 {
6858   A68_REAL re_x, im_x, re_y, im_y;
6859   double re = 0.0, im = 0.0;
6860   POP_COMPLEX (p, &re_y, &im_y);
6861   POP_COMPLEX (p, &re_x, &im_x);
6862 #if ! defined HAVE_IEEE_754
6863   PRELUDE_ERROR (VALUE (&re_y) == 0.0 && VALUE (&im_y) == 0.0, p, ERROR_DIVISION_BY_ZERO, MODE (COMPLEX));
6864 #endif
6865   if (ABS (VALUE (&re_y)) >= ABS (VALUE (&im_y))) {
6866     double r = VALUE (&im_y) / VALUE (&re_y), den = VALUE (&re_y) + r * VALUE (&im_y);
6867     re = (VALUE (&re_x) + r * VALUE (&im_x)) / den;
6868     im = (VALUE (&im_x) - r * VALUE (&re_x)) / den;
6869   } else {
6870     double r = VALUE (&re_y) / VALUE (&im_y), den = VALUE (&im_y) + r * VALUE (&re_y);
6871     re = (VALUE (&re_x) * r + VALUE (&im_x)) / den;
6872     im = (VALUE (&im_x) * r - VALUE (&re_x)) / den;
6873   }
6874   CHECK_COMPLEX_REPRESENTATION (p, re, im);
6875   PUSH_COMPLEX (p, re, im);
6876 }
6877 
6878 /**
6879 @brief OP ** = (COMPLEX, INT) COMPLEX
6880 @param p Node in syntax tree.
6881 **/
6882 
6883 void
genie_pow_complex_int(NODE_T * p)6884 genie_pow_complex_int (NODE_T * p)
6885 {
6886   A68_REAL re_x, im_x;
6887   double re_y, im_y, re_z, im_z, rea;
6888   A68_INT j;
6889   int expo;
6890   BOOL_T negative;
6891   POP_OBJECT (p, &j, A68_INT);
6892   POP_COMPLEX (p, &re_x, &im_x);
6893   re_z = 1.0;
6894   im_z = 0.0;
6895   re_y = VALUE (&re_x);
6896   im_y = VALUE (&im_x);
6897   expo = 1;
6898   negative = (BOOL_T) (VALUE (&j) < 0);
6899   if (negative) {
6900     VALUE (&j) = -VALUE (&j);
6901   }
6902   while ((unsigned) expo <= (unsigned) (VALUE (&j))) {
6903     if (expo & VALUE (&j)) {
6904       rea = re_z * re_y - im_z * im_y;
6905       im_z = re_z * im_y + im_z * re_y;
6906       re_z = rea;
6907     }
6908     rea = re_y * re_y - im_y * im_y;
6909     im_y = im_y * re_y + re_y * im_y;
6910     re_y = rea;
6911     expo <<= 1;
6912   }
6913   CHECK_COMPLEX_REPRESENTATION (p, re_z, im_z);
6914   if (negative) {
6915     PUSH_PRIMITIVE (p, 1.0, A68_REAL);
6916     PUSH_PRIMITIVE (p, 0.0, A68_REAL);
6917     PUSH_PRIMITIVE (p, re_z, A68_REAL);
6918     PUSH_PRIMITIVE (p, im_z, A68_REAL);
6919     genie_div_complex (p);
6920   } else {
6921     PUSH_PRIMITIVE (p, re_z, A68_REAL);
6922     PUSH_PRIMITIVE (p, im_z, A68_REAL);
6923   }
6924 }
6925 
6926 /**
6927 @brief OP = = (COMPLEX, COMPLEX) BOOL
6928 @param p Node in syntax tree.
6929 **/
6930 
6931 void
genie_eq_complex(NODE_T * p)6932 genie_eq_complex (NODE_T * p)
6933 {
6934   A68_REAL re_x, im_x, re_y, im_y;
6935   POP_COMPLEX (p, &re_y, &im_y);
6936   POP_COMPLEX (p, &re_x, &im_x);
6937   PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&re_x) == VALUE (&re_y)) && (VALUE (&im_x) == VALUE (&im_y))), A68_BOOL);
6938 }
6939 
6940 /**
6941 @brief OP /= = (COMPLEX, COMPLEX) BOOL
6942 @param p Node in syntax tree.
6943 **/
6944 
6945 void
genie_ne_complex(NODE_T * p)6946 genie_ne_complex (NODE_T * p)
6947 {
6948   A68_REAL re_x, im_x, re_y, im_y;
6949   POP_COMPLEX (p, &re_y, &im_y);
6950   POP_COMPLEX (p, &re_x, &im_x);
6951   PUSH_PRIMITIVE (p, (BOOL_T) ! ((VALUE (&re_x) == VALUE (&re_y)) && (VALUE (&im_x) == VALUE (&im_y))), A68_BOOL);
6952 }
6953 
6954 /**
6955 @brief OP +:= = (REF COMPLEX, COMPLEX) REF COMPLEX
6956 @param p Node in syntax tree.
6957 **/
6958 
6959 void
genie_plusab_complex(NODE_T * p)6960 genie_plusab_complex (NODE_T * p)
6961 {
6962   genie_f_and_becomes (p, MODE (REF_COMPLEX), genie_add_complex);
6963 }
6964 
6965 /**
6966 @brief OP -:= = (REF COMPLEX, COMPLEX) REF COMPLEX
6967 @param p Node in syntax tree.
6968 **/
6969 
6970 void
genie_minusab_complex(NODE_T * p)6971 genie_minusab_complex (NODE_T * p)
6972 {
6973   genie_f_and_becomes (p, MODE (REF_COMPLEX), genie_sub_complex);
6974 }
6975 
6976 /**
6977 @brief OP *:= = (REF COMPLEX, COMPLEX) REF COMPLEX
6978 @param p Node in syntax tree.
6979 **/
6980 
6981 void
genie_timesab_complex(NODE_T * p)6982 genie_timesab_complex (NODE_T * p)
6983 {
6984   genie_f_and_becomes (p, MODE (REF_COMPLEX), genie_mul_complex);
6985 }
6986 
6987 /**
6988 @brief OP /:= = (REF COMPLEX, COMPLEX) REF COMPLEX
6989 @param p Node in syntax tree.
6990 **/
6991 
6992 void
genie_divab_complex(NODE_T * p)6993 genie_divab_complex (NODE_T * p)
6994 {
6995   genie_f_and_becomes (p, MODE (REF_COMPLEX), genie_div_complex);
6996 }
6997 
6998 /**
6999 @brief OP LENG = (COMPLEX) LONG COMPLEX
7000 @param p Node in syntax tree.
7001 **/
7002 
7003 void
genie_lengthen_complex_to_long_complex(NODE_T * p)7004 genie_lengthen_complex_to_long_complex (NODE_T * p)
7005 {
7006   int digits = DIGITS (MODE (LONG_REAL));
7007   MP_T *z;
7008   A68_REAL a, b;
7009   POP_OBJECT (p, &b, A68_REAL);
7010   POP_OBJECT (p, &a, A68_REAL);
7011   STACK_MP (z, p, digits);
7012   (void) real_to_mp (p, z, VALUE (&a), digits);
7013   MP_STATUS (z) = (MP_T) INIT_MASK;
7014   STACK_MP (z, p, digits);
7015   (void) real_to_mp (p, z, VALUE (&b), digits);
7016   MP_STATUS (z) = (MP_T) INIT_MASK;
7017 }
7018 
7019 /**
7020 @brief OP SHORTEN = (LONG COMPLEX) COMPLEX
7021 @param p Node in syntax tree.
7022 **/
7023 
7024 void
genie_shorten_long_complex_to_complex(NODE_T * p)7025 genie_shorten_long_complex_to_complex (NODE_T * p)
7026 {
7027   int digits = DIGITS (MODE (LONG_REAL)), size = SIZE (MODE (LONG_REAL));
7028   MP_T *b = (MP_T *) STACK_OFFSET (-size);
7029   MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
7030   DECREMENT_STACK_POINTER (p, 2 * size);
7031   PUSH_PRIMITIVE (p, mp_to_real (p, a, digits), A68_REAL);
7032   PUSH_PRIMITIVE (p, mp_to_real (p, b, digits), A68_REAL);
7033 }
7034 
7035 /**
7036 @brief OP LENG = (LONG COMPLEX) LONG LONG COMPLEX
7037 @param p Node in syntax tree.
7038 **/
7039 
7040 void
genie_lengthen_long_complex_to_longlong_complex(NODE_T * p)7041 genie_lengthen_long_complex_to_longlong_complex (NODE_T * p)
7042 {
7043   int digits = DIGITS (MODE (LONG_REAL)), size = SIZE (MODE (LONG_REAL));
7044   int digs_long = DIGITS (MODE (LONGLONG_REAL)), size_long = SIZE (MODE (LONGLONG_REAL));
7045   ADDR_T pop_sp = stack_pointer;
7046   MP_T *a, *b, *c, *d;
7047   b = (MP_T *) STACK_OFFSET (-size);
7048   a = (MP_T *) STACK_OFFSET (-2 * size);
7049   STACK_MP (c, p, digs_long);
7050   STACK_MP (d, p, digs_long);
7051   (void) lengthen_mp (p, c, digs_long, a, digits);
7052   (void) lengthen_mp (p, d, digs_long, b, digits);
7053   MOVE_MP (a, c, digs_long);
7054   MOVE_MP (&a[2 + digs_long], d, digs_long);
7055   stack_pointer = pop_sp;
7056   MP_STATUS (a) = (MP_T) INIT_MASK;
7057   (&a[2 + digs_long])[0] = (MP_T) INIT_MASK;
7058   INCREMENT_STACK_POINTER (p, 2 * (size_long - size));
7059 }
7060 
7061 /**
7062 @brief OP SHORTEN = (LONG LONG COMPLEX) LONG COMPLEX
7063 @param p Node in syntax tree.
7064 **/
7065 
7066 void
genie_shorten_longlong_complex_to_long_complex(NODE_T * p)7067 genie_shorten_longlong_complex_to_long_complex (NODE_T * p)
7068 {
7069   int digits = DIGITS (MODE (LONG_REAL)), size = SIZE (MODE (LONG_REAL));
7070   int digs_long = DIGITS (MODE (LONGLONG_REAL)), size_long = SIZE (MODE (LONGLONG_REAL));
7071   ADDR_T pop_sp = stack_pointer;
7072   MP_T *a, *b;
7073   b = (MP_T *) STACK_OFFSET (-size_long);
7074   a = (MP_T *) STACK_OFFSET (-2 * size_long);
7075   (void) shorten_mp (p, a, digits, a, digs_long);
7076   (void) shorten_mp (p, &a[2 + digits], digits, b, digs_long);
7077   stack_pointer = pop_sp;
7078   MP_STATUS (a) = (MP_T) INIT_MASK;
7079   (&a[2 + digits])[0] = (MP_T) INIT_MASK;
7080   DECREMENT_STACK_POINTER (p, 2 * (size_long - size));
7081 }
7082 
7083 /**
7084 @brief OP RE = (LONG COMPLEX) LONG REAL
7085 @param p Node in syntax tree.
7086 **/
7087 
7088 void
genie_re_long_complex(NODE_T * p)7089 genie_re_long_complex (NODE_T * p)
7090 {
7091   int size = SIZE (SUB_MOID (p));
7092   MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
7093   MP_STATUS (a) = (MP_T) INIT_MASK;
7094   DECREMENT_STACK_POINTER (p, (int) size_long_mp ());
7095 }
7096 
7097 /**
7098 @brief OP IM = (LONG COMPLEX) LONG REAL
7099 @param p Node in syntax tree.
7100 **/
7101 
7102 void
genie_im_long_complex(NODE_T * p)7103 genie_im_long_complex (NODE_T * p)
7104 {
7105   MOID_T *mode = SUB_MOID (p);
7106   int digits = DIGITS (mode), size = SIZE (mode);
7107   MP_T *b = (MP_T *) STACK_OFFSET (-size);
7108   MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
7109   MOVE_MP (a, b, digits);
7110   MP_STATUS (a) = (MP_T) INIT_MASK;
7111   DECREMENT_STACK_POINTER (p, size);
7112 }
7113 
7114 /**
7115 @brief OP - = (LONG COMPLEX) LONG COMPLEX
7116 @param p Node in syntax tree.
7117 **/
7118 
7119 void
genie_minus_long_complex(NODE_T * p)7120 genie_minus_long_complex (NODE_T * p)
7121 {
7122   int size = SIZEC (SUB_MOID (p));
7123   MP_T *b = (MP_T *) STACK_OFFSET (-size);
7124   MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
7125   MP_DIGIT (a, 1) = -MP_DIGIT (a, 1);
7126   MP_DIGIT (b, 1) = -MP_DIGIT (b, 1);
7127   MP_STATUS (a) = (MP_T) INIT_MASK;
7128   MP_STATUS (b) = (MP_T) INIT_MASK;
7129 }
7130 
7131 /**
7132 @brief OP CONJ = (LONG COMPLEX) LONG COMPLEX
7133 @param p Node in syntax tree.
7134 **/
7135 
7136 void
genie_conj_long_complex(NODE_T * p)7137 genie_conj_long_complex (NODE_T * p)
7138 {
7139   int size = SIZEC (SUB_MOID (p));
7140   MP_T *b = (MP_T *) STACK_OFFSET (-size);
7141   MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
7142   MP_DIGIT (b, 1) = -MP_DIGIT (b, 1);
7143   MP_STATUS (a) = (MP_T) INIT_MASK;
7144   MP_STATUS (b) = (MP_T) INIT_MASK;
7145 }
7146 
7147 /**
7148 @brief OP ABS = (LONG COMPLEX) LONG REAL
7149 @param p Node in syntax tree.
7150 **/
7151 
7152 void
genie_abs_long_complex(NODE_T * p)7153 genie_abs_long_complex (NODE_T * p)
7154 {
7155   MOID_T *mode = SUB_MOID (p);
7156   int digits = DIGITS (mode), size = SIZE (mode);
7157   ADDR_T pop_sp = stack_pointer;
7158   MP_T *b = (MP_T *) STACK_OFFSET (-size);
7159   MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
7160   MP_T *z;
7161   STACK_MP (z, p, digits);
7162   (void) hypot_mp (p, z, a, b, digits);
7163   stack_pointer = pop_sp;
7164   DECREMENT_STACK_POINTER (p, size);
7165   MOVE_MP (a, z, digits);
7166   MP_STATUS (a) = (MP_T) INIT_MASK;
7167   MATH_RTE (p, errno != 0, mode, NO_TEXT);
7168 }
7169 
7170 /**
7171 @brief OP ARG = (LONG COMPLEX) LONG REAL
7172 @param p Node in syntax tree.
7173 **/
7174 
7175 void
genie_arg_long_complex(NODE_T * p)7176 genie_arg_long_complex (NODE_T * p)
7177 {
7178   MOID_T *mode = SUB_MOID (p);
7179   int digits = DIGITS (mode), size = SIZE (mode);
7180   ADDR_T pop_sp = stack_pointer;
7181   MP_T *b = (MP_T *) STACK_OFFSET (-size);
7182   MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
7183   MP_T *z;
7184   STACK_MP (z, p, digits);
7185   (void) atan2_mp (p, z, a, b, digits);
7186   stack_pointer = pop_sp;
7187   DECREMENT_STACK_POINTER (p, size);
7188   MOVE_MP (a, z, digits);
7189   MP_STATUS (a) = (MP_T) INIT_MASK;
7190   MATH_RTE (p, errno != 0, mode, NO_TEXT);
7191 }
7192 
7193 /**
7194 @brief OP + = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
7195 @param p Node in syntax tree.
7196 **/
7197 
7198 void
genie_add_long_complex(NODE_T * p)7199 genie_add_long_complex (NODE_T * p)
7200 {
7201   MOID_T *mode = SUB_MOID (p);
7202   int digits = DIGITSC (mode), size = SIZEC (mode);
7203   ADDR_T pop_sp = stack_pointer;
7204   MP_T *d = (MP_T *) STACK_OFFSET (-size);
7205   MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
7206   MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
7207   MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
7208   (void) add_mp (p, b, b, d, digits);
7209   (void) add_mp (p, a, a, c, digits);
7210   MP_STATUS (a) = (MP_T) INIT_MASK;
7211   MP_STATUS (b) = (MP_T) INIT_MASK;
7212   stack_pointer = pop_sp;
7213   DECREMENT_STACK_POINTER (p, 2 * size);
7214 }
7215 
7216 /**
7217 @brief OP - = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
7218 @param p Node in syntax tree.
7219 **/
7220 
7221 void
genie_sub_long_complex(NODE_T * p)7222 genie_sub_long_complex (NODE_T * p)
7223 {
7224   MOID_T *mode = SUB_MOID (p);
7225   int digits = DIGITSC (mode), size = SIZEC (mode);
7226   ADDR_T pop_sp = stack_pointer;
7227   MP_T *d = (MP_T *) STACK_OFFSET (-size);
7228   MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
7229   MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
7230   MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
7231   (void) sub_mp (p, b, b, d, digits);
7232   (void) sub_mp (p, a, a, c, digits);
7233   MP_STATUS (a) = (MP_T) INIT_MASK;
7234   MP_STATUS (b) = (MP_T) INIT_MASK;
7235   stack_pointer = pop_sp;
7236   DECREMENT_STACK_POINTER (p, 2 * size);
7237 }
7238 
7239 /**
7240 @brief OP * = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
7241 @param p Node in syntax tree.
7242 **/
7243 
7244 void
genie_mul_long_complex(NODE_T * p)7245 genie_mul_long_complex (NODE_T * p)
7246 {
7247   MOID_T *mode = SUB_MOID (p);
7248   int digits = DIGITSC (mode), size = SIZEC (mode);
7249   ADDR_T pop_sp = stack_pointer;
7250   MP_T *d = (MP_T *) STACK_OFFSET (-size);
7251   MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
7252   MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
7253   MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
7254   (void) cmul_mp (p, a, b, c, d, digits);
7255   MP_STATUS (a) = (MP_T) INIT_MASK;
7256   MP_STATUS (b) = (MP_T) INIT_MASK;
7257   stack_pointer = pop_sp;
7258   DECREMENT_STACK_POINTER (p, 2 * size);
7259 }
7260 
7261 /**
7262 @brief OP / = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
7263 @param p Node in syntax tree.
7264 **/
7265 
7266 void
genie_div_long_complex(NODE_T * p)7267 genie_div_long_complex (NODE_T * p)
7268 {
7269   MOID_T *mode = SUB_MOID (p);
7270   int digits = DIGITSC (mode), size = SIZEC (mode);
7271   ADDR_T pop_sp = stack_pointer;
7272   MP_T *d = (MP_T *) STACK_OFFSET (-size);
7273   MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
7274   MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
7275   MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
7276   PRELUDE_ERROR (cdiv_mp (p, a, b, c, d, digits) == NO_MP, p, ERROR_DIVISION_BY_ZERO, mode);
7277   MP_STATUS (a) = (MP_T) INIT_MASK;
7278   MP_STATUS (b) = (MP_T) INIT_MASK;
7279   stack_pointer = pop_sp;
7280   DECREMENT_STACK_POINTER (p, 2 * size);
7281 }
7282 
7283 /**
7284 @brief OP ** = (LONG COMPLEX, INT) LONG COMPLEX
7285 @param p Node in syntax tree.
7286 **/
7287 
7288 void
genie_pow_long_complex_int(NODE_T * p)7289 genie_pow_long_complex_int (NODE_T * p)
7290 {
7291   MOID_T *mode = SUB_MOID (p);
7292   int digits = DIGITSC (mode), size = SIZEC (mode);
7293   ADDR_T pop_sp;
7294   MP_T *re_x, *im_x, *re_y, *im_y, *re_z, *im_z, *rea, *acc;
7295   A68_INT j;
7296   int expo;
7297   BOOL_T negative;
7298   POP_OBJECT (p, &j, A68_INT);
7299   pop_sp = stack_pointer;
7300   im_x = (MP_T *) STACK_OFFSET (-size);
7301   re_x = (MP_T *) STACK_OFFSET (-2 * size);
7302   STACK_MP (re_z, p, digits);
7303   (void) set_mp_short (re_z, (MP_T) 1, 0, digits);
7304   STACK_MP (im_z, p, digits);
7305   SET_MP_ZERO (im_z, digits);
7306   STACK_MP (re_y, p, digits);
7307   STACK_MP (im_y, p, digits);
7308   MOVE_MP (re_y, re_x, digits);
7309   MOVE_MP (im_y, im_x, digits);
7310   STACK_MP (rea, p, digits);
7311   STACK_MP (acc, p, digits);
7312   expo = 1;
7313   negative = (BOOL_T) (VALUE (&j) < 0);
7314   if (negative) {
7315     VALUE (&j) = -VALUE (&j);
7316   }
7317   while ((unsigned) expo <= (unsigned) (VALUE (&j))) {
7318     if (expo & VALUE (&j)) {
7319       (void) mul_mp (p, acc, im_z, im_y, digits);
7320       (void) mul_mp (p, rea, re_z, re_y, digits);
7321       (void) sub_mp (p, rea, rea, acc, digits);
7322       (void) mul_mp (p, acc, im_z, re_y, digits);
7323       (void) mul_mp (p, im_z, re_z, im_y, digits);
7324       (void) add_mp (p, im_z, im_z, acc, digits);
7325       MOVE_MP (re_z, rea, digits);
7326     }
7327     (void) mul_mp (p, acc, im_y, im_y, digits);
7328     (void) mul_mp (p, rea, re_y, re_y, digits);
7329     (void) sub_mp (p, rea, rea, acc, digits);
7330     (void) mul_mp (p, acc, im_y, re_y, digits);
7331     (void) mul_mp (p, im_y, re_y, im_y, digits);
7332     (void) add_mp (p, im_y, im_y, acc, digits);
7333     MOVE_MP (re_y, rea, digits);
7334     expo <<= 1;
7335   }
7336   stack_pointer = pop_sp;
7337   if (negative) {
7338     (void) set_mp_short (re_x, (MP_T) 1, 0, digits);
7339     SET_MP_ZERO (im_x, digits);
7340     INCREMENT_STACK_POINTER (p, 2 * size);
7341     genie_div_long_complex (p);
7342   } else {
7343     MOVE_MP (re_x, re_z, digits);
7344     MOVE_MP (im_x, im_z, digits);
7345   }
7346   MP_STATUS (re_x) = (MP_T) INIT_MASK;
7347   MP_STATUS (im_x) = (MP_T) INIT_MASK;
7348 }
7349 
7350 /**
7351 @brief OP = = (LONG COMPLEX, LONG COMPLEX) BOOL
7352 @param p Node in syntax tree.
7353 **/
7354 
7355 void
genie_eq_long_complex(NODE_T * p)7356 genie_eq_long_complex (NODE_T * p)
7357 {
7358   int digits = DIGITSC (LHS_MODE (p)), size = SIZEC (LHS_MODE (p));
7359   ADDR_T pop_sp = stack_pointer;
7360   MP_T *d = (MP_T *) STACK_OFFSET (-size);
7361   MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
7362   MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
7363   MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
7364   (void) sub_mp (p, b, b, d, digits);
7365   (void) sub_mp (p, a, a, c, digits);
7366   stack_pointer = pop_sp;
7367   DECREMENT_STACK_POINTER (p, 4 * size);
7368   PUSH_PRIMITIVE (p, (BOOL_T) (MP_DIGIT (a, 1) == 0 && MP_DIGIT (b, 1) == 0), A68_BOOL);
7369 }
7370 
7371 /**
7372 @brief OP /= = (LONG COMPLEX, LONG COMPLEX) BOOL
7373 @param p Node in syntax tree.
7374 **/
7375 
7376 void
genie_ne_long_complex(NODE_T * p)7377 genie_ne_long_complex (NODE_T * p)
7378 {
7379   int digits = DIGITSC (LHS_MODE (p)), size = SIZEC (LHS_MODE (p));
7380   ADDR_T pop_sp = stack_pointer;
7381   MP_T *d = (MP_T *) STACK_OFFSET (-size);
7382   MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
7383   MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
7384   MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
7385   (void) sub_mp (p, b, b, d, digits);
7386   (void) sub_mp (p, a, a, c, digits);
7387   stack_pointer = pop_sp;
7388   DECREMENT_STACK_POINTER (p, 4 * size);
7389   PUSH_PRIMITIVE (p, (BOOL_T) (MP_DIGIT (a, 1) != 0 || MP_DIGIT (b, 1) != 0), A68_BOOL);
7390 }
7391 
7392 /**
7393 @brief OP +:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
7394 @param p Node in syntax tree.
7395 **/
7396 
7397 void
genie_plusab_long_complex(NODE_T * p)7398 genie_plusab_long_complex (NODE_T * p)
7399 {
7400   MOID_T *mode = LHS_MODE (p);
7401   genie_f_and_becomes (p, mode, genie_add_long_complex);
7402 }
7403 
7404 /**
7405 @brief OP -:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
7406 @param p Node in syntax tree.
7407 **/
7408 
7409 void
genie_minusab_long_complex(NODE_T * p)7410 genie_minusab_long_complex (NODE_T * p)
7411 {
7412   MOID_T *mode = LHS_MODE (p);
7413   genie_f_and_becomes (p, mode, genie_sub_long_complex);
7414 }
7415 
7416 /**
7417 @brief OP *:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
7418 @param p Node in syntax tree.
7419 **/
7420 
7421 void
genie_timesab_long_complex(NODE_T * p)7422 genie_timesab_long_complex (NODE_T * p)
7423 {
7424   MOID_T *mode = LHS_MODE (p);
7425   genie_f_and_becomes (p, mode, genie_mul_long_complex);
7426 }
7427 
7428 /**
7429 @brief OP /:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
7430 @param p Node in syntax tree.
7431 **/
7432 
7433 void
genie_divab_long_complex(NODE_T * p)7434 genie_divab_long_complex (NODE_T * p)
7435 {
7436   MOID_T *mode = LHS_MODE (p);
7437   genie_f_and_becomes (p, mode, genie_div_long_complex);
7438 }
7439 
7440 /**
7441 @brief PROC csqrt = (COMPLEX) COMPLEX
7442 @param p Node in syntax tree.
7443 **/
7444 
7445 void
genie_sqrt_complex(NODE_T * p)7446 genie_sqrt_complex (NODE_T * p)
7447 {
7448   A68_REAL *re, *im;
7449   im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));
7450   re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));
7451   RESET_ERRNO;
7452   if (VALUE (re) == 0.0 && VALUE (im) == 0.0) {
7453     VALUE (re) = 0.0;
7454     VALUE (im) = 0.0;
7455   } else {
7456     double x = ABS (VALUE (re)), y = ABS (VALUE (im)), w;
7457     if (x >= y) {
7458       double t = y / x;
7459       w = sqrt (x) * sqrt (0.5 * (1.0 + sqrt (1.0 + t * t)));
7460     } else {
7461       double t = x / y;
7462       w = sqrt (y) * sqrt (0.5 * (t + sqrt (1.0 + t * t)));
7463     }
7464     if (VALUE (re) >= 0.0) {
7465       VALUE (re) = w;
7466       VALUE (im) = VALUE (im) / (2.0 * w);
7467     } else {
7468       double ai = VALUE (im);
7469       double vi = (ai >= 0.0 ? w : -w);
7470       VALUE (re) = ai / (2.0 * vi);
7471       VALUE (im) = vi;
7472     }
7473   }
7474   MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT);
7475 }
7476 
7477 /**
7478 @brief PROC long csqrt = (LONG COMPLEX) LONG COMPLEX
7479 @param p Node in syntax tree.
7480 **/
7481 
7482 void
genie_sqrt_long_complex(NODE_T * p)7483 genie_sqrt_long_complex (NODE_T * p)
7484 {
7485   MOID_T *mode = MOID (p);
7486   int digits = DIGITSC (mode), size = SIZEC (mode);
7487   ADDR_T pop_sp = stack_pointer;
7488   MP_T *im = (MP_T *) STACK_OFFSET (-size);
7489   MP_T *re = (MP_T *) STACK_OFFSET (-2 * size);
7490   RESET_ERRNO;
7491   (void) csqrt_mp (p, re, im, digits);
7492   stack_pointer = pop_sp;
7493   MP_STATUS (re) = (MP_T) INIT_MASK;
7494   MP_STATUS (im) = (MP_T) INIT_MASK;
7495   MATH_RTE (p, errno != 0, mode, NO_TEXT);
7496 }
7497 
7498 /**
7499 @brief PROC cexp = (COMPLEX) COMPLEX
7500 @param p Node in syntax tree.
7501 **/
7502 
7503 void
genie_exp_complex(NODE_T * p)7504 genie_exp_complex (NODE_T * p)
7505 {
7506   A68_REAL *re, *im;
7507   double r;
7508   im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));
7509   re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));
7510   RESET_ERRNO;
7511   r = exp (VALUE (re));
7512   VALUE (re) = r * cos (VALUE (im));
7513   VALUE (im) = r * sin (VALUE (im));
7514   MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT);
7515 }
7516 
7517 /**
7518 @brief PROC long cexp = (LONG COMPLEX) LONG COMPLEX
7519 @param p Node in syntax tree.
7520 **/
7521 
7522 void
genie_exp_long_complex(NODE_T * p)7523 genie_exp_long_complex (NODE_T * p)
7524 {
7525   MOID_T *mode = MOID (p);
7526   int digits = DIGITSC (mode), size = SIZEC (mode);
7527   ADDR_T pop_sp = stack_pointer;
7528   MP_T *im = (MP_T *) STACK_OFFSET (-size);
7529   MP_T *re = (MP_T *) STACK_OFFSET (-2 * size);
7530   (void) cexp_mp (p, re, im, digits);
7531   stack_pointer = pop_sp;
7532   MP_STATUS (re) = (MP_T) INIT_MASK;
7533   MP_STATUS (im) = (MP_T) INIT_MASK;
7534   MATH_RTE (p, errno != 0, mode, NO_TEXT);
7535 }
7536 
7537 /**
7538 @brief PROC cln = (COMPLEX) COMPLEX
7539 @param p Node in syntax tree.
7540 **/
7541 
7542 void
genie_ln_complex(NODE_T * p)7543 genie_ln_complex (NODE_T * p)
7544 {
7545   A68_REAL *re, *im, r, th;
7546   im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));
7547   re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));
7548   RESET_ERRNO;
7549   PUSH_COMPLEX (p, VALUE (re), VALUE (im));
7550   genie_abs_complex (p);
7551   POP_OBJECT (p, &r, A68_REAL);
7552   PUSH_COMPLEX (p, VALUE (re), VALUE (im));
7553   genie_arg_complex (p);
7554   POP_OBJECT (p, &th, A68_REAL);
7555   VALUE (re) = log (VALUE (&r));
7556   VALUE (im) = VALUE (&th);
7557   MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT);
7558 }
7559 
7560 /**
7561 @brief PROC long cln = (LONG COMPLEX) LONG COMPLEX
7562 @param p Node in syntax tree.
7563 **/
7564 
7565 void
genie_ln_long_complex(NODE_T * p)7566 genie_ln_long_complex (NODE_T * p)
7567 {
7568   MOID_T *mode = MOID (p);
7569   int digits = DIGITSC (mode), size = SIZEC (mode);
7570   ADDR_T pop_sp = stack_pointer;
7571   MP_T *im = (MP_T *) STACK_OFFSET (-size);
7572   MP_T *re = (MP_T *) STACK_OFFSET (-2 * size);
7573   (void) cln_mp (p, re, im, digits);
7574   stack_pointer = pop_sp;
7575   MP_STATUS (re) = (MP_T) INIT_MASK;
7576   MP_STATUS (im) = (MP_T) INIT_MASK;
7577   MATH_RTE (p, errno != 0, mode, NO_TEXT);
7578 }
7579 
7580 /**
7581 @brief PROC csin = (COMPLEX) COMPLEX
7582 @param p Node in syntax tree.
7583 **/
7584 
7585 void
genie_sin_complex(NODE_T * p)7586 genie_sin_complex (NODE_T * p)
7587 {
7588   A68_REAL *re, *im;
7589   im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));
7590   re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));
7591   RESET_ERRNO;
7592   if (VALUE (im) == 0.0) {
7593     VALUE (re) = sin (VALUE (re));
7594     VALUE (im) = 0.0;
7595   } else {
7596     double r = VALUE (re), i = VALUE (im);
7597     VALUE (re) = sin (r) * cosh (i);
7598     VALUE (im) = cos (r) * sinh (i);
7599   }
7600   MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT);
7601 }
7602 
7603 /**
7604 @brief PROC long csin = (LONG COMPLEX) LONG COMPLEX
7605 @param p Node in syntax tree.
7606 **/
7607 
7608 void
genie_sin_long_complex(NODE_T * p)7609 genie_sin_long_complex (NODE_T * p)
7610 {
7611   MOID_T *mode = MOID (p);
7612   int digits = DIGITSC (mode), size = SIZEC (mode);
7613   ADDR_T pop_sp = stack_pointer;
7614   MP_T *im = (MP_T *) STACK_OFFSET (-size);
7615   MP_T *re = (MP_T *) STACK_OFFSET (-2 * size);
7616   (void) csin_mp (p, re, im, digits);
7617   stack_pointer = pop_sp;
7618   MP_STATUS (re) = (MP_T) INIT_MASK;
7619   MP_STATUS (im) = (MP_T) INIT_MASK;
7620   MATH_RTE (p, errno != 0, mode, NO_TEXT);
7621 }
7622 
7623 /**
7624 @brief PROC ccos = (COMPLEX) COMPLEX
7625 @param p Node in syntax tree.
7626 **/
7627 
7628 void
genie_cos_complex(NODE_T * p)7629 genie_cos_complex (NODE_T * p)
7630 {
7631   A68_REAL *re, *im;
7632   im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));
7633   re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));
7634   RESET_ERRNO;
7635   if (VALUE (im) == 0.0) {
7636     VALUE (re) = cos (VALUE (re));
7637     VALUE (im) = 0.0;
7638   } else {
7639     double r = VALUE (re), i = VALUE (im);
7640     VALUE (re) = cos (r) * cosh (i);
7641     VALUE (im) = sin (r) * sinh (-i);
7642   }
7643   MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT);
7644 }
7645 
7646 /**
7647 @brief PROC long ccos = (LONG COMPLEX) LONG COMPLEX
7648 @param p Node in syntax tree.
7649 **/
7650 
7651 void
genie_cos_long_complex(NODE_T * p)7652 genie_cos_long_complex (NODE_T * p)
7653 {
7654   MOID_T *mode = MOID (p);
7655   int digits = DIGITSC (mode), size = SIZEC (mode);
7656   ADDR_T pop_sp = stack_pointer;
7657   MP_T *im = (MP_T *) STACK_OFFSET (-size);
7658   MP_T *re = (MP_T *) STACK_OFFSET (-2 * size);
7659   (void) ccos_mp (p, re, im, digits);
7660   stack_pointer = pop_sp;
7661   MP_STATUS (re) = (MP_T) INIT_MASK;
7662   MP_STATUS (im) = (MP_T) INIT_MASK;
7663   MATH_RTE (p, errno != 0, mode, NO_TEXT);
7664 }
7665 
7666 /**
7667 @brief PROC ctan = (COMPLEX) COMPLEX
7668 @param p Node in syntax tree.
7669 **/
7670 
7671 void
genie_tan_complex(NODE_T * p)7672 genie_tan_complex (NODE_T * p)
7673 {
7674   A68_REAL *im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));
7675   A68_REAL *re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));
7676   double r, i;
7677   A68_REAL u, v;
7678   RESET_ERRNO;
7679   r = VALUE (re);
7680   i = VALUE (im);
7681   PUSH_PRIMITIVE (p, r, A68_REAL);
7682   PUSH_PRIMITIVE (p, i, A68_REAL);
7683   genie_sin_complex (p);
7684   POP_OBJECT (p, &v, A68_REAL);
7685   POP_OBJECT (p, &u, A68_REAL);
7686   PUSH_PRIMITIVE (p, r, A68_REAL);
7687   PUSH_PRIMITIVE (p, i, A68_REAL);
7688   genie_cos_complex (p);
7689   VALUE (re) = VALUE (&u);
7690   VALUE (im) = VALUE (&v);
7691   genie_div_complex (p);
7692   MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT);
7693 }
7694 
7695 /**
7696 @brief PROC long ctan = (LONG COMPLEX) LONG COMPLEX
7697 @param p Node in syntax tree.
7698 **/
7699 
7700 void
genie_tan_long_complex(NODE_T * p)7701 genie_tan_long_complex (NODE_T * p)
7702 {
7703   MOID_T *mode = MOID (p);
7704   int digits = DIGITSC (mode), size = SIZEC (mode);
7705   ADDR_T pop_sp = stack_pointer;
7706   MP_T *re = (MP_T *) STACK_OFFSET (-2 * size);
7707   MP_T *im = (MP_T *) STACK_OFFSET (-size);
7708   (void) ctan_mp (p, re, im, digits);
7709   stack_pointer = pop_sp;
7710   MP_STATUS (re) = (MP_T) INIT_MASK;
7711   MP_STATUS (im) = (MP_T) INIT_MASK;
7712   MATH_RTE (p, errno != 0, mode, NO_TEXT);
7713 }
7714 
7715 /**
7716 @brief PROC carcsin= (COMPLEX) COMPLEX
7717 @param p Node in syntax tree.
7718 **/
7719 
7720 void
genie_arcsin_complex(NODE_T * p)7721 genie_arcsin_complex (NODE_T * p)
7722 {
7723   A68_REAL *re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));
7724   A68_REAL *im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));
7725   RESET_ERRNO;
7726   if (im == 0) {
7727     VALUE (re) = asin (VALUE (re));
7728   } else {
7729     double r = VALUE (re), i = VALUE (im);
7730     double u = a68g_hypot (r + 1, i), v = a68g_hypot (r - 1, i);
7731     double a = 0.5 * (u + v), b = 0.5 * (u - v);
7732     VALUE (re) = asin (b);
7733     VALUE (im) = log (a + sqrt (a * a - 1));
7734   }
7735   MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT);
7736 }
7737 
7738 /**
7739 @brief PROC long arcsin = (LONG COMPLEX) LONG COMPLEX
7740 @param p Node in syntax tree.
7741 **/
7742 
7743 void
genie_asin_long_complex(NODE_T * p)7744 genie_asin_long_complex (NODE_T * p)
7745 {
7746   MOID_T *mode = MOID (p);
7747   int digits = DIGITSC (mode), size = SIZEC (mode);
7748   ADDR_T pop_sp = stack_pointer;
7749   MP_T *re = (MP_T *) STACK_OFFSET (-2 * size);
7750   MP_T *im = (MP_T *) STACK_OFFSET (-size);
7751   RESET_ERRNO;
7752   (void) casin_mp (p, re, im, digits);
7753   stack_pointer = pop_sp;
7754   MP_STATUS (re) = (MP_T) INIT_MASK;
7755   MP_STATUS (im) = (MP_T) INIT_MASK;
7756   MATH_RTE (p, errno != 0, mode, NO_TEXT);
7757 }
7758 
7759 /**
7760 @brief PROC carccos = (COMPLEX) COMPLEX
7761 @param p Node in syntax tree.
7762 **/
7763 
7764 void
genie_arccos_complex(NODE_T * p)7765 genie_arccos_complex (NODE_T * p)
7766 {
7767   A68_REAL *re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));
7768   A68_REAL *im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));
7769   RESET_ERRNO;
7770   if (im == 0) {
7771     VALUE (re) = acos (VALUE (re));
7772   } else {
7773     double r = VALUE (re), i = VALUE (im);
7774     double u = a68g_hypot (r + 1, i), v = a68g_hypot (r - 1, i);
7775     double a = 0.5 * (u + v), b = 0.5 * (u - v);
7776     VALUE (re) = acos (b);
7777     VALUE (im) = -log (a + sqrt (a * a - 1));
7778   }
7779   MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT);
7780 }
7781 
7782 /**
7783 @brief PROC long carccos = (LONG COMPLEX) LONG COMPLEX
7784 @param p Node in syntax tree.
7785 **/
7786 
7787 void
genie_acos_long_complex(NODE_T * p)7788 genie_acos_long_complex (NODE_T * p)
7789 {
7790   MOID_T *mode = MOID (p);
7791   int digits = DIGITSC (mode), size = SIZEC (mode);
7792   ADDR_T pop_sp = stack_pointer;
7793   MP_T *re = (MP_T *) STACK_OFFSET (-2 * size);
7794   MP_T *im = (MP_T *) STACK_OFFSET (-size);
7795   RESET_ERRNO;
7796   (void) cacos_mp (p, re, im, digits);
7797   stack_pointer = pop_sp;
7798   MP_STATUS (re) = (MP_T) INIT_MASK;
7799   MP_STATUS (im) = (MP_T) INIT_MASK;
7800   MATH_RTE (p, errno != 0, mode, NO_TEXT);
7801 }
7802 
7803 /**
7804 @brief PROC carctan = (COMPLEX) COMPLEX
7805 @param p Node in syntax tree.
7806 **/
7807 
7808 void
genie_arctan_complex(NODE_T * p)7809 genie_arctan_complex (NODE_T * p)
7810 {
7811   A68_REAL *re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));
7812   A68_REAL *im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));
7813   RESET_ERRNO;
7814   if (im == 0) {
7815     VALUE (re) = atan (VALUE (re));
7816   } else {
7817     double r = VALUE (re), i = VALUE (im);
7818     double a = a68g_hypot (r, i + 1), b = a68g_hypot (r, i - 1);
7819     VALUE (re) = 0.5 * atan (2 * r / (1 - r * r - i * i));
7820     VALUE (im) = 0.5 * log (a / b);
7821   }
7822   MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT);
7823 }
7824 
7825 /**
7826 @brief PROC long catan = (LONG COMPLEX) LONG COMPLEX
7827 @param p Node in syntax tree.
7828 **/
7829 
7830 void
genie_atan_long_complex(NODE_T * p)7831 genie_atan_long_complex (NODE_T * p)
7832 {
7833   MOID_T *mode = MOID (p);
7834   int digits = DIGITSC (mode), size = SIZEC (mode);
7835   ADDR_T pop_sp = stack_pointer;
7836   MP_T *re = (MP_T *) STACK_OFFSET (-2 * size);
7837   MP_T *im = (MP_T *) STACK_OFFSET (-size);
7838   RESET_ERRNO;
7839   (void) catan_mp (p, re, im, digits);
7840   stack_pointer = pop_sp;
7841   MP_STATUS (re) = (MP_T) INIT_MASK;
7842   MP_STATUS (im) = (MP_T) INIT_MASK;
7843   MATH_RTE (p, errno != 0, mode, NO_TEXT);
7844 }
7845 
7846 #if defined HAVE_GNU_GSL
7847 
7848 /**
7849 @brief PROC csinh = (COMPLEX) COMPLEX
7850 @param p Node in syntax tree.
7851 **/
7852 
7853 void
genie_sinh_complex(NODE_T * p)7854 genie_sinh_complex (NODE_T * p)
7855 {
7856   GSL_COMPLEX_FUNCTION (gsl_complex_sinh);
7857 }
7858 
7859 /**
7860 @brief PROC ccosh = (COMPLEX) COMPLEX
7861 @param p Node in syntax tree.
7862 **/
7863 
7864 void
genie_cosh_complex(NODE_T * p)7865 genie_cosh_complex (NODE_T * p)
7866 {
7867   GSL_COMPLEX_FUNCTION (gsl_complex_cosh);
7868 }
7869 
7870 /**
7871 @brief PROC ctanh = (COMPLEX) COMPLEX
7872 @param p Node in syntax tree.
7873 **/
7874 
7875 void
genie_tanh_complex(NODE_T * p)7876 genie_tanh_complex (NODE_T * p)
7877 {
7878   GSL_COMPLEX_FUNCTION (gsl_complex_tanh);
7879 }
7880 
7881 /**
7882 @brief PROC carcsinh = (COMPLEX) COMPLEX
7883 @param p Node in syntax tree.
7884 **/
7885 
7886 void
genie_arcsinh_complex(NODE_T * p)7887 genie_arcsinh_complex (NODE_T * p)
7888 {
7889   GSL_COMPLEX_FUNCTION (gsl_complex_arcsinh);
7890 }
7891 
7892 /**
7893 @brief PROC carccosh = (COMPLEX) COMPLEX
7894 @param p Node in syntax tree.
7895 **/
7896 
7897 void
genie_arccosh_complex(NODE_T * p)7898 genie_arccosh_complex (NODE_T * p)
7899 {
7900   GSL_COMPLEX_FUNCTION (gsl_complex_arccosh);
7901 }
7902 
7903 /**
7904 @brief PROC carctanh = (COMPLEX) COMPLEX
7905 @param p Node in syntax tree.
7906 **/
7907 
7908 void
genie_arctanh_complex(NODE_T * p)7909 genie_arctanh_complex (NODE_T * p)
7910 {
7911   GSL_COMPLEX_FUNCTION (gsl_complex_arctanh);
7912 }
7913 
7914 #endif /* defined HAVE_GNU_GSL */
7915 
7916 /* Standard prelude implementation, transput */
7917 
7918 /*
7919 Transput library - General routines and (formatted) transput.
7920 But Eeyore wasn't listening. He was taking the balloon out, and putting
7921 it back again, as happy as could be ... Winnie the Pooh, A.A. Milne.
7922 - Revised Report on the Algorithmic Language Algol 68.
7923 */
7924 
7925 A68_CHANNEL stand_in_channel, stand_out_channel, stand_draw_channel, stand_back_channel, stand_error_channel, associate_channel, skip_channel;
7926 A68_REF stand_in, stand_out, stand_back, stand_error, skip_file;
7927 A68_FORMAT nil_format = {
7928   INIT_MASK, NULL, 0
7929 };
7930 
7931 /* File table handling
7932 In a table we record opened files.
7933 When execution ends, unclosed files are closed, and temps are removed.
7934 This keeps /tmp free of spurious files :-)
7935 */
7936 
7937 typedef struct FILE_ENTRY FILE_ENTRY;
7938 
7939 struct FILE_ENTRY
7940 {
7941   NODE_T *pos;
7942   BOOL_T is_open, is_tmp;
7943   FILE_T fd;
7944   A68_REF idf;
7945 };
7946 
7947 FILE_ENTRY file_entries[MAX_OPEN_FILES];
7948 
7949 /**
7950 @brief Init a file entry.
7951 @param k  Entry to initialise.
7952 **/
7953 
7954 void
init_file_entry(int k)7955 init_file_entry (int k)
7956 {
7957   if (k >= 0 && k < MAX_OPEN_FILES) {
7958     FILE_ENTRY *fe = &(file_entries[k]);
7959     POS (fe) = NO_NODE;
7960     IS_OPEN (fe) = A68_FALSE;
7961     IS_TMP (fe) = A68_FALSE;
7962     FD (fe) = A68_NO_FILENO;
7963     IDF (fe) = nil_ref;
7964   }
7965 }
7966 
7967 /**
7968 @brief Initialise file entry table.
7969 **/
7970 
7971 void
init_file_entries(void)7972 init_file_entries (void)
7973 {
7974   int k;
7975   for (k = 0; k < MAX_OPEN_FILES; k++) {
7976     init_file_entry (k);
7977   }
7978 }
7979 
7980 /**
7981 @brief Store file for later closing when not explicitly closed.
7982 @param p Entry in syntax tree.
7983 @param fd File descriptor.
7984 @param idf File name.
7985 @param is_tmp Whether file is a temp file.
7986 @return Entry in table.
7987 **/
7988 
7989 int
store_file_entry(NODE_T * p,FILE_T fd,char * idf,BOOL_T is_tmp)7990 store_file_entry (NODE_T * p, FILE_T fd, char *idf, BOOL_T is_tmp)
7991 {
7992   int k;
7993   for (k = 0; k < MAX_OPEN_FILES; k++) {
7994     FILE_ENTRY *fe = &(file_entries[k]);
7995     if (!IS_OPEN (fe)) {
7996       int len = 1 + (int) strlen (idf);
7997       POS (fe) = p;
7998       IS_OPEN (fe) = A68_TRUE;
7999       IS_TMP (fe) = is_tmp;
8000       FD (fe) = fd;
8001       IDF (fe) = heap_generator (p, MODE (C_STRING), len);
8002       BLOCK_GC_HANDLE (&(IDF (fe)));
8003       bufcpy (DEREF (char, &IDF (fe)), idf, len);
8004       return (k);
8005     }
8006   }
8007   diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_TOO_MANY_OPEN_FILES);
8008   exit_genie (p, A68_RUNTIME_ERROR);
8009   return (-1);                  /* Fool them */
8010 }
8011 
8012 /**
8013 @brief Close file and delete temp file.
8014 @param p Entry in syntax tree.
8015 @param k Entry in table.
8016 **/
8017 
8018 static void
close_file_entry(NODE_T * p,int k)8019 close_file_entry (NODE_T * p, int k)
8020 {
8021   if (k >= 0 && k < MAX_OPEN_FILES) {
8022     FILE_ENTRY *fe = &(file_entries[k]);
8023     if (IS_OPEN (fe)) {
8024 /* Close the file */
8025       if (FD (fe) != A68_NO_FILENO && close (FD (fe)) == -1) {
8026         init_file_entry (k);
8027         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_CLOSE);
8028         exit_genie (p, A68_RUNTIME_ERROR);
8029       }
8030       IS_OPEN (fe) = A68_FALSE;
8031     }
8032   }
8033 }
8034 
8035 /**
8036 @brief Close file and delete temp file.
8037 @param p Entry in syntax tree.
8038 @param k Entry in table.
8039 **/
8040 
8041 static void
free_file_entry(NODE_T * p,int k)8042 free_file_entry (NODE_T * p, int k)
8043 {
8044   close_file_entry (p, k);
8045   if (k >= 0 && k < MAX_OPEN_FILES) {
8046     FILE_ENTRY *fe = &(file_entries[k]);
8047     if (IS_OPEN (fe)) {
8048 /* Attempt to remove a temp file, but ignore failure */
8049       if (FD (fe) != A68_NO_FILENO && IS_TMP (fe)) {
8050         if (!IS_NIL (IDF (fe))) {
8051           char *filename;
8052           CHECK_INIT (p, INITIALISED (&(IDF (fe))), MODE (ROWS));
8053           filename = DEREF (char, &IDF (fe));
8054           if (filename != NO_TEXT) {
8055             (void) remove (filename);
8056           }
8057         }
8058       }
8059 /* Restore the fields */
8060       if (!IS_NIL (IDF (fe))) {
8061         UNBLOCK_GC_HANDLE (&(IDF (fe)));
8062       }
8063       init_file_entry (k);
8064     }
8065   }
8066 }
8067 
8068 /**
8069 @brief Close all files and delete all temp files.
8070 **/
8071 
8072 void
free_file_entries(void)8073 free_file_entries (void)
8074 {
8075   int k;
8076   for (k = 0; k < MAX_OPEN_FILES; k++) {
8077     free_file_entry (NO_NODE, k);
8078   }
8079 }
8080 
8081 
8082 /**
8083 @brief PROC char in string = (CHAR, REF INT, STRING) BOOL
8084 @param p Node in syntax tree.
8085 **/
8086 
8087 void
genie_char_in_string(NODE_T * p)8088 genie_char_in_string (NODE_T * p)
8089 {
8090   A68_CHAR c;
8091   A68_INT pos;
8092   A68_REF ref_pos, ref_str, row;
8093   A68_ARRAY *arr;
8094   A68_TUPLE *tup;
8095   char *q, ch;
8096   int k, len;
8097   POP_REF (p, &ref_str);
8098   row = *(A68_REF *) & ref_str;
8099   CHECK_INIT (p, INITIALISED (&row), MODE (ROWS));
8100   GET_DESCRIPTOR (arr, tup, &row);
8101   POP_REF (p, &ref_pos);
8102   POP_OBJECT (p, &c, A68_CHAR);
8103   reset_transput_buffer (PATTERN_BUFFER);
8104   add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_str);
8105   len = get_transput_buffer_index (PATTERN_BUFFER);
8106   q = get_transput_buffer (PATTERN_BUFFER);
8107   ch = (char) VALUE (&c);
8108   for (k = 0; k < len; k++) {
8109     if (q[k] == ch) {
8110       STATUS (&pos) = INIT_MASK;
8111       VALUE (&pos) = k + LOWER_BOUND (tup);
8112       *DEREF (A68_INT, &ref_pos) = pos;
8113       PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL);
8114       return;
8115     }
8116   }
8117   PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL);
8118 }
8119 
8120 /**
8121 @brief PROC last char in string = (CHAR, REF INT, STRING) BOOL
8122 @param p Node in syntax tree.
8123 **/
8124 
8125 void
genie_last_char_in_string(NODE_T * p)8126 genie_last_char_in_string (NODE_T * p)
8127 {
8128   A68_CHAR c;
8129   A68_INT pos;
8130   A68_REF ref_pos, ref_str, row;
8131   A68_ARRAY *arr;
8132   A68_TUPLE *tup;
8133   char *q, ch;
8134   int k, len;
8135   POP_REF (p, &ref_str);
8136   row = *(A68_REF *) & ref_str;
8137   CHECK_INIT (p, INITIALISED (&row), MODE (ROWS));
8138   GET_DESCRIPTOR (arr, tup, &row);
8139   POP_REF (p, &ref_pos);
8140   POP_OBJECT (p, &c, A68_CHAR);
8141   reset_transput_buffer (PATTERN_BUFFER);
8142   add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_str);
8143   len = get_transput_buffer_index (PATTERN_BUFFER);
8144   q = get_transput_buffer (PATTERN_BUFFER);
8145   ch = (char) VALUE (&c);
8146   for (k = len - 1; k >= 0; k--) {
8147     if (q[k] == ch) {
8148       STATUS (&pos) = INIT_MASK;
8149       VALUE (&pos) = k + LOWER_BOUND (tup);
8150       *DEREF (A68_INT, &ref_pos) = pos;
8151       PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL);
8152       return;
8153     }
8154   }
8155   PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL);
8156 }
8157 
8158 /**
8159 @brief PROC string in string = (STRING, REF INT, STRING) BOOL
8160 @param p Node in syntax tree.
8161 **/
8162 
8163 void
genie_string_in_string(NODE_T * p)8164 genie_string_in_string (NODE_T * p)
8165 {
8166   A68_REF ref_pos, ref_str, ref_pat, row;
8167   A68_ARRAY *arr;
8168   A68_TUPLE *tup;
8169   char *q;
8170   POP_REF (p, &ref_str);
8171   row = *(A68_REF *) & ref_str;
8172   CHECK_INIT (p, INITIALISED (&row), MODE (ROWS));
8173   GET_DESCRIPTOR (arr, tup, &row);
8174   POP_REF (p, &ref_pos);
8175   POP_REF (p, &ref_pat);
8176   reset_transput_buffer (PATTERN_BUFFER);
8177   reset_transput_buffer (STRING_BUFFER);
8178   add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_pat);
8179   add_a_string_transput_buffer (p, STRING_BUFFER, (BYTE_T *) & ref_str);
8180   q = strstr (get_transput_buffer (STRING_BUFFER), get_transput_buffer (PATTERN_BUFFER));
8181   if (q != NO_TEXT) {
8182     if (!IS_NIL (ref_pos)) {
8183       A68_INT pos;
8184       STATUS (&pos) = INIT_MASK;
8185 /* ANSI standard leaves pointer difference undefined */
8186       VALUE (&pos) = LOWER_BOUND (tup) + (int) get_transput_buffer_index (STRING_BUFFER) - (int) strlen (q);
8187       *DEREF (A68_INT, &ref_pos) = pos;
8188     }
8189     PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL);
8190   } else {
8191     PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL);
8192   }
8193 }
8194 
8195 /*
8196 Strings in transput are of arbitrary size. For this, we have transput buffers.
8197 A transput buffer is a REF STRUCT (INT size, index, STRING buffer).
8198 It is in the heap, but cannot be gced. If it is too small, we give up on
8199 it and make a larger one.
8200 */
8201 
8202 static A68_REF ref_transput_buffer[MAX_TRANSPUT_BUFFER];
8203 
8204 /**
8205 @brief Set max number of chars in a transput buffer.
8206 @param n Transput buffer number.
8207 @param size Max number of chars.
8208 **/
8209 
8210 void
set_transput_buffer_size(int n,int size)8211 set_transput_buffer_size (int n, int size)
8212 {
8213   A68_INT *k = (A68_INT *) (ADDRESS (&ref_transput_buffer[n]));
8214   STATUS (k) = INIT_MASK;
8215   VALUE (k) = size;
8216 }
8217 
8218 /**
8219 @brief Set char index for transput buffer.
8220 @param n Transput buffer number.
8221 @param cindex Char index.
8222 **/
8223 
8224 void
set_transput_buffer_index(int n,int cindex)8225 set_transput_buffer_index (int n, int cindex)
8226 {
8227   A68_INT *k = (A68_INT *) (ADDRESS (&ref_transput_buffer[n]) + SIZE (MODE (INT)));
8228   STATUS (k) = INIT_MASK;
8229   VALUE (k) = cindex;
8230 }
8231 
8232 /**
8233 @brief Get max number of chars in a transput buffer.
8234 @param n Transput buffer number.
8235 @return See brief description.
8236 **/
8237 
8238 int
get_transput_buffer_size(int n)8239 get_transput_buffer_size (int n)
8240 {
8241   A68_INT *k = (A68_INT *) (ADDRESS (&ref_transput_buffer[n]));
8242   return (VALUE (k));
8243 }
8244 
8245 /**
8246 @brief Get char index for transput buffer.
8247 @param n Transput buffer number.
8248 @return See brief description.
8249 **/
8250 
8251 int
get_transput_buffer_index(int n)8252 get_transput_buffer_index (int n)
8253 {
8254   A68_INT *k = (A68_INT *) (ADDRESS (&ref_transput_buffer[n]) + SIZE (MODE (INT)));
8255   return (VALUE (k));
8256 }
8257 
8258 /**
8259 @brief Get char[] from transput buffer.
8260 @param n Transput buffer number.
8261 @return See brief description.
8262 **/
8263 
8264 char *
get_transput_buffer(int n)8265 get_transput_buffer (int n)
8266 {
8267   return ((char *) (ADDRESS (&ref_transput_buffer[n]) + 2 * SIZE (MODE (INT))));
8268 }
8269 
8270 /**
8271 @brief Mark transput buffer as no longer in use.
8272 @param n Transput buffer number.
8273 **/
8274 
8275 void
unblock_transput_buffer(int n)8276 unblock_transput_buffer (int n)
8277 {
8278   set_transput_buffer_index (n, -1);
8279 }
8280 
8281 /**
8282 @brief Find first unused transput buffer (for opening a file).
8283 @param p Node in syntax tree position in syntax tree.
8284 @return See brief description.
8285 **/
8286 
8287 int
get_unblocked_transput_buffer(NODE_T * p)8288 get_unblocked_transput_buffer (NODE_T * p)
8289 {
8290   int k;
8291   for (k = FIXED_TRANSPUT_BUFFERS; k < MAX_TRANSPUT_BUFFER; k++) {
8292     if (get_transput_buffer_index (k) == -1) {
8293       return (k);
8294     }
8295   }
8296 /* Oops! */
8297   diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_TOO_MANY_OPEN_FILES);
8298   exit_genie (p, A68_RUNTIME_ERROR);
8299   return (-1);
8300 }
8301 
8302 /**
8303 @brief Empty contents of transput buffer.
8304 @param n Transput buffer number.
8305 **/
8306 
8307 void
reset_transput_buffer(int n)8308 reset_transput_buffer (int n)
8309 {
8310   set_transput_buffer_index (n, 0);
8311   (get_transput_buffer (n))[0] = NULL_CHAR;
8312 }
8313 
8314 /**
8315 @brief Initialise transput buffers before use.
8316 @param p Node in syntax tree position in syntax tree.
8317 **/
8318 
8319 void
init_transput_buffers(NODE_T * p)8320 init_transput_buffers (NODE_T * p)
8321 {
8322   int k;
8323   for (k = 0; k < MAX_TRANSPUT_BUFFER; k++) {
8324     ref_transput_buffer[k] = heap_generator (p, MODE (ROWS), 2 * SIZE (MODE (INT)) + TRANSPUT_BUFFER_SIZE);
8325     BLOCK_GC_HANDLE (&ref_transput_buffer[k]);
8326     set_transput_buffer_size (k, TRANSPUT_BUFFER_SIZE);
8327     reset_transput_buffer (k);
8328   }
8329 /* Last buffers are available for FILE values */
8330   for (k = FIXED_TRANSPUT_BUFFERS; k < MAX_TRANSPUT_BUFFER; k++) {
8331     unblock_transput_buffer (k);
8332   }
8333 }
8334 
8335 /**
8336 @brief Make a transput buffer larger.
8337 @param p Node in syntax tree.
8338 @param k Transput buffer number.
8339 @param size New size in characters.
8340 **/
8341 
8342 void
enlarge_transput_buffer(NODE_T * p,int k,int size)8343 enlarge_transput_buffer (NODE_T * p, int k, int size)
8344 {
8345   int tbindex = get_transput_buffer_index (k);
8346   char *sb_1 = get_transput_buffer (k), *sb_2;
8347   UNBLOCK_GC_HANDLE (&ref_transput_buffer[k]);
8348   ref_transput_buffer[k] = heap_generator (p, MODE (ROWS), 2 * SIZE (MODE (INT)) + size);
8349   BLOCK_GC_HANDLE (&ref_transput_buffer[k]);
8350   set_transput_buffer_size (k, size);
8351   set_transput_buffer_index (k, tbindex);
8352   sb_2 = get_transput_buffer (k);
8353   bufcpy (sb_2, sb_1, size);
8354 }
8355 
8356 /**
8357 @brief Add char to transput buffer; if the buffer is full, make it larger.
8358 @param p Node in syntax tree.
8359 @param k Transput buffer number.
8360 @param ch Char to add.
8361 **/
8362 
8363 void
add_char_transput_buffer(NODE_T * p,int k,char ch)8364 add_char_transput_buffer (NODE_T * p, int k, char ch)
8365 {
8366   char *sb = get_transput_buffer (k);
8367   int size = get_transput_buffer_size (k);
8368   int tbindex = get_transput_buffer_index (k);
8369   if (tbindex == size - 2) {
8370     enlarge_transput_buffer (p, k, 10 * size /* size + TRANSPUT_BUFFER_SIZE */ );
8371     add_char_transput_buffer (p, k, ch);
8372   } else {
8373     sb[tbindex] = ch;
8374     sb[tbindex + 1] = NULL_CHAR;
8375     set_transput_buffer_index (k, tbindex + 1);
8376   }
8377 }
8378 
8379 /**
8380 @brief Add char[] to transput buffer.
8381 @param p Node in syntax tree.
8382 @param k Transput buffer number.
8383 @param ch String to add.
8384 **/
8385 
8386 void
add_string_transput_buffer(NODE_T * p,int k,char * ch)8387 add_string_transput_buffer (NODE_T * p, int k, char *ch)
8388 {
8389   for (; ch[0] != NULL_CHAR; ch++) {
8390     add_char_transput_buffer (p, k, ch[0]);
8391   }
8392 }
8393 
8394 /**
8395 @brief Add A68 string to transput buffer.
8396 @param p Node in syntax tree.
8397 @param k Transput buffer number.
8398 @param ref Fat pointer to A68 string.
8399 **/
8400 
8401 void
add_a_string_transput_buffer(NODE_T * p,int k,BYTE_T * ref)8402 add_a_string_transput_buffer (NODE_T * p, int k, BYTE_T * ref)
8403 {
8404   A68_REF row = *(A68_REF *) ref;
8405   A68_ARRAY *arr;
8406   A68_TUPLE *tup;
8407   CHECK_INIT (p, INITIALISED (&row), MODE (ROWS));
8408   GET_DESCRIPTOR (arr, tup, &row);
8409   if (ROW_SIZE (tup) > 0) {
8410     int i;
8411     BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
8412     for (i = LWB (tup); i <= UPB (tup); i++) {
8413       int addr = INDEX_1_DIM (arr, tup, i);
8414       A68_CHAR *ch = (A68_CHAR *) & (base_address[addr]);
8415       CHECK_INIT (p, INITIALISED (ch), MODE (CHAR));
8416       add_char_transput_buffer (p, k, (char) VALUE (ch));
8417     }
8418   }
8419 }
8420 
8421 /**
8422 @brief Pop A68 string and add to buffer.
8423 @param p Node in syntax tree.
8424 @param k Transput buffer number.
8425 **/
8426 
8427 void
add_string_from_stack_transput_buffer(NODE_T * p,int k)8428 add_string_from_stack_transput_buffer (NODE_T * p, int k)
8429 {
8430   DECREMENT_STACK_POINTER (p, A68_REF_SIZE);
8431   add_a_string_transput_buffer (p, k, STACK_TOP);
8432 }
8433 
8434 /**
8435 @brief Pop first character from transput buffer.
8436 @param k Transput buffer number.
8437 @return See brief description.
8438 **/
8439 
8440 char
pop_char_transput_buffer(int k)8441 pop_char_transput_buffer (int k)
8442 {
8443   char *sb = get_transput_buffer (k);
8444   int tbindex = get_transput_buffer_index (k);
8445   if (tbindex <= 0) {
8446     return (NULL_CHAR);
8447   } else {
8448     char ch = sb[0];
8449     MOVE (&sb[0], &sb[1], tbindex);
8450     set_transput_buffer_index (k, tbindex - 1);
8451     return (ch);
8452   }
8453 }
8454 
8455 /**
8456 @brief Add C string to A68 string.
8457 @param p Node in syntax tree.
8458 @param ref_str Fat pointer to A68 string.
8459 @param str Pointer to C string.
8460 **/
8461 
8462 static void
add_c_string_to_a_string(NODE_T * p,A68_REF ref_str,char * str)8463 add_c_string_to_a_string (NODE_T * p, A68_REF ref_str, char *str)
8464 {
8465   A68_REF a, c, d;
8466   A68_ARRAY *a_1, *a_3;
8467   A68_TUPLE *t_1, *t_3;
8468   int l_1, l_2, u, v;
8469   BYTE_T *b_1, *b_3;
8470   l_2 = (int) strlen (str);
8471 /* left part */
8472   CHECK_REF (p, ref_str, MODE (REF_STRING));
8473   a = *DEREF (A68_REF, &ref_str);
8474   CHECK_INIT (p, INITIALISED (&a), MODE (STRING));
8475   GET_DESCRIPTOR (a_1, t_1, &a);
8476   l_1 = ROW_SIZE (t_1);
8477 /* Sum string */
8478   c = heap_generator (p, MODE (STRING), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE));
8479   d = heap_generator (p, MODE (STRING), (l_1 + l_2) * SIZE (MODE (CHAR)));
8480 /* Calculate again since garbage collector might have moved data */
8481   GET_DESCRIPTOR (a_1, t_1, &a);
8482 /* Make descriptor of new string */
8483   GET_DESCRIPTOR (a_3, t_3, &c);
8484   DIM (a_3) = 1;
8485   MOID (a_3) = MODE (CHAR);
8486   ELEM_SIZE (a_3) = SIZE (MODE (CHAR));
8487   SLICE_OFFSET (a_3) = 0;
8488   FIELD_OFFSET (a_3) = 0;
8489   ARRAY (a_3) = d;
8490   LWB (t_3) = 1;
8491   UPB (t_3) = l_1 + l_2;
8492   SHIFT (t_3) = LWB (t_3);
8493   SPAN (t_3) = 1;
8494 /* add strings */
8495   b_1 = (ROW_SIZE (t_1) > 0 ? DEREF (BYTE_T, &ARRAY (a_1)) : NO_BYTE);
8496   b_3 = DEREF (BYTE_T, &ARRAY (a_3));
8497   u = 0;
8498   for (v = LWB (t_1); v <= UPB (t_1); v++) {
8499     MOVE ((BYTE_T *) & b_3[u], (BYTE_T *) & b_1[INDEX_1_DIM (a_1, t_1, v)], SIZE (MODE (CHAR)));
8500     u += SIZE (MODE (CHAR));
8501   }
8502   for (v = 0; v < l_2; v++) {
8503     A68_CHAR ch;
8504     STATUS (&ch) = INIT_MASK;
8505     VALUE (&ch) = str[v];
8506     MOVE ((BYTE_T *) & b_3[u], (BYTE_T *) & ch, SIZE (MODE (CHAR)));
8507     u += SIZE (MODE (CHAR));
8508   }
8509   *DEREF (A68_REF, &ref_str) = c;
8510 }
8511 
8512 /**
8513 @brief Purge buffer for file.
8514 @param p Node in syntax tree.
8515 @param ref_file
8516 @param k Transput buffer number for file.
8517 **/
8518 
8519 void
write_purge_buffer(NODE_T * p,A68_REF ref_file,int k)8520 write_purge_buffer (NODE_T * p, A68_REF ref_file, int k)
8521 {
8522   A68_FILE *file = FILE_DEREF (&ref_file);
8523   if (IS_NIL (STRING (file))) {
8524     if (!(FD (file) == STDOUT_FILENO && halt_typing)) {
8525       WRITE (FD (file), get_transput_buffer (k));
8526     }
8527   } else {
8528     add_c_string_to_a_string (p, STRING (file), get_transput_buffer (k));
8529   }
8530   reset_transput_buffer (k);
8531 }
8532 
8533 /* Routines that involve the A68 expression stack */
8534 
8535 /**
8536 @brief Allocate a temporary string on the stack.
8537 @param p Node in syntax tree.
8538 @param size Size in characters.
8539 @return See brief description.
8540 **/
8541 
8542 char *
stack_string(NODE_T * p,int size)8543 stack_string (NODE_T * p, int size)
8544 {
8545   char *new_str = (char *) STACK_TOP;
8546   INCREMENT_STACK_POINTER (p, size);
8547   if (stack_pointer > expr_stack_limit) {
8548     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW);
8549     exit_genie (p, A68_RUNTIME_ERROR);
8550   }
8551   FILL (new_str, NULL_CHAR, size);
8552   return (new_str);
8553 }
8554 
8555 /* Transput basic RTS routines */
8556 
8557 /**
8558 @brief REF FILE standin
8559 @param p Node in syntax tree.
8560 **/
8561 
8562 void
genie_stand_in(NODE_T * p)8563 genie_stand_in (NODE_T * p)
8564 {
8565   PUSH_REF (p, stand_in);
8566 }
8567 
8568 /**
8569 @brief REF FILE standout
8570 @param p Node in syntax tree.
8571 **/
8572 
8573 void
genie_stand_out(NODE_T * p)8574 genie_stand_out (NODE_T * p)
8575 {
8576   PUSH_REF (p, stand_out);
8577 }
8578 
8579 /**
8580 @brief REF FILE standback
8581 @param p Node in syntax tree.
8582 **/
8583 
8584 void
genie_stand_back(NODE_T * p)8585 genie_stand_back (NODE_T * p)
8586 {
8587   PUSH_REF (p, stand_back);
8588 }
8589 
8590 /**
8591 @brief REF FILE standerror
8592 @param p Node in syntax tree.
8593 **/
8594 
8595 void
genie_stand_error(NODE_T * p)8596 genie_stand_error (NODE_T * p)
8597 {
8598   PUSH_REF (p, stand_error);
8599 }
8600 
8601 /**
8602 @brief CHAR error char
8603 @param p Node in syntax tree.
8604 **/
8605 
8606 void
genie_error_char(NODE_T * p)8607 genie_error_char (NODE_T * p)
8608 {
8609   PUSH_PRIMITIVE (p, ERROR_CHAR, A68_CHAR);
8610 }
8611 
8612 /**
8613 @brief CHAR exp char
8614 @param p Node in syntax tree.
8615 **/
8616 
8617 void
genie_exp_char(NODE_T * p)8618 genie_exp_char (NODE_T * p)
8619 {
8620   PUSH_PRIMITIVE (p, EXPONENT_CHAR, A68_CHAR);
8621 }
8622 
8623 /**
8624 @brief CHAR flip char
8625 @param p Node in syntax tree.
8626 **/
8627 
8628 void
genie_flip_char(NODE_T * p)8629 genie_flip_char (NODE_T * p)
8630 {
8631   PUSH_PRIMITIVE (p, FLIP_CHAR, A68_CHAR);
8632 }
8633 
8634 /**
8635 @brief CHAR flop char
8636 @param p Node in syntax tree.
8637 **/
8638 
8639 void
genie_flop_char(NODE_T * p)8640 genie_flop_char (NODE_T * p)
8641 {
8642   PUSH_PRIMITIVE (p, FLOP_CHAR, A68_CHAR);
8643 }
8644 
8645 /**
8646 @brief CHAR null char
8647 @param p Node in syntax tree.
8648 **/
8649 
8650 void
genie_null_char(NODE_T * p)8651 genie_null_char (NODE_T * p)
8652 {
8653   PUSH_PRIMITIVE (p, NULL_CHAR, A68_CHAR);
8654 }
8655 
8656 /**
8657 @brief CHAR blank
8658 @param p Node in syntax tree.
8659 **/
8660 
8661 void
genie_blank_char(NODE_T * p)8662 genie_blank_char (NODE_T * p)
8663 {
8664   PUSH_PRIMITIVE (p, BLANK_CHAR, A68_CHAR);
8665 }
8666 
8667 /**
8668 @brief CHAR newline char
8669 @param p Node in syntax tree.
8670 **/
8671 
8672 void
genie_newline_char(NODE_T * p)8673 genie_newline_char (NODE_T * p)
8674 {
8675   PUSH_PRIMITIVE (p, NEWLINE_CHAR, A68_CHAR);
8676 }
8677 
8678 /**
8679 @brief CHAR formfeed char
8680 @param p Node in syntax tree.
8681 **/
8682 
8683 void
genie_formfeed_char(NODE_T * p)8684 genie_formfeed_char (NODE_T * p)
8685 {
8686   PUSH_PRIMITIVE (p, FORMFEED_CHAR, A68_CHAR);
8687 }
8688 
8689 /**
8690 @brief CHAR tab char
8691 @param p Node in syntax tree.
8692 **/
8693 
8694 void
genie_tab_char(NODE_T * p)8695 genie_tab_char (NODE_T * p)
8696 {
8697   PUSH_PRIMITIVE (p, TAB_CHAR, A68_CHAR);
8698 }
8699 
8700 /**
8701 @brief CHANNEL standin channel
8702 @param p Node in syntax tree.
8703 **/
8704 
8705 void
genie_stand_in_channel(NODE_T * p)8706 genie_stand_in_channel (NODE_T * p)
8707 {
8708   PUSH_OBJECT (p, stand_in_channel, A68_CHANNEL);
8709 }
8710 
8711 /**
8712 @brief CHANNEL standout channel
8713 @param p Node in syntax tree.
8714 **/
8715 
8716 void
genie_stand_out_channel(NODE_T * p)8717 genie_stand_out_channel (NODE_T * p)
8718 {
8719   PUSH_OBJECT (p, stand_out_channel, A68_CHANNEL);
8720 }
8721 
8722 /**
8723 @brief CHANNEL stand draw channel
8724 @param p Node in syntax tree.
8725 **/
8726 
8727 void
genie_stand_draw_channel(NODE_T * p)8728 genie_stand_draw_channel (NODE_T * p)
8729 {
8730   PUSH_OBJECT (p, stand_draw_channel, A68_CHANNEL);
8731 }
8732 
8733 /**
8734 @brief CHANNEL standback channel
8735 @param p Node in syntax tree.
8736 **/
8737 
8738 void
genie_stand_back_channel(NODE_T * p)8739 genie_stand_back_channel (NODE_T * p)
8740 {
8741   PUSH_OBJECT (p, stand_back_channel, A68_CHANNEL);
8742 }
8743 
8744 /**
8745 @brief CHANNEL standerror channel
8746 @param p Node in syntax tree.
8747 **/
8748 
8749 void
genie_stand_error_channel(NODE_T * p)8750 genie_stand_error_channel (NODE_T * p)
8751 {
8752   PUSH_OBJECT (p, stand_error_channel, A68_CHANNEL);
8753 }
8754 
8755 /**
8756 @brief PROC STRING program idf
8757 @param p Node in syntax tree.
8758 **/
8759 
8760 void
genie_program_idf(NODE_T * p)8761 genie_program_idf (NODE_T * p)
8762 {
8763   PUSH_REF (p, c_to_a_string (p, FILE_SOURCE_NAME (&program), DEFAULT_WIDTH));
8764 }
8765 
8766 /* FILE and CHANNEL initialisations */
8767 
8768 /**
8769 @brief Set_default_event_procedure.
8770 @param z
8771 **/
8772 
8773 void
set_default_event_procedure(A68_PROCEDURE * z)8774 set_default_event_procedure (A68_PROCEDURE * z)
8775 {
8776   STATUS (z) = INIT_MASK;
8777   NODE (&(BODY (z))) = NO_NODE;
8778   ENVIRON (z) = 0;
8779 }
8780 
8781 /**
8782 @brief Initialise channel.
8783 @param chan Channel.
8784 @param r Reset possible.
8785 @param s Set possible.
8786 @param g Get possible.
8787 @param p Put possible.
8788 @param b Bin possible.
8789 @param d Draw possible.
8790 **/
8791 
8792 static void
init_channel(A68_CHANNEL * chan,BOOL_T r,BOOL_T s,BOOL_T g,BOOL_T p,BOOL_T b,BOOL_T d)8793 init_channel (A68_CHANNEL * chan, BOOL_T r, BOOL_T s, BOOL_T g, BOOL_T p, BOOL_T b, BOOL_T d)
8794 {
8795   STATUS (chan) = INIT_MASK;
8796   RESET (chan) = r;
8797   SET (chan) = s;
8798   GET (chan) = g;
8799   PUT (chan) = p;
8800   BIN (chan) = b;
8801   DRAW (chan) = d;
8802   COMPRESS (chan) = A68_TRUE;
8803 }
8804 
8805 /**
8806 @brief Set default event handlers.
8807 @param f File.
8808 **/
8809 
8810 void
set_default_event_procedures(A68_FILE * f)8811 set_default_event_procedures (A68_FILE * f)
8812 {
8813   set_default_event_procedure (&(FILE_END_MENDED (f)));
8814   set_default_event_procedure (&(PAGE_END_MENDED (f)));
8815   set_default_event_procedure (&(LINE_END_MENDED (f)));
8816   set_default_event_procedure (&(VALUE_ERROR_MENDED (f)));
8817   set_default_event_procedure (&(OPEN_ERROR_MENDED (f)));
8818   set_default_event_procedure (&(TRANSPUT_ERROR_MENDED (f)));
8819   set_default_event_procedure (&(FORMAT_END_MENDED (f)));
8820   set_default_event_procedure (&(FORMAT_ERROR_MENDED (f)));
8821 }
8822 
8823 /**
8824 @brief Set up a REF FILE object.
8825 @param p Node in syntax tree.
8826 @param ref_file Fat pointer to A68 file.
8827 @param c Channel.
8828 @param s File number.
8829 @param rm Read mood.
8830 @param wm Write mood.
8831 @param cm Char mood.
8832 @param env Unix ENVIRONMENT variable.
8833 **/
8834 
8835 static void
init_file(NODE_T * p,A68_REF * ref_file,A68_CHANNEL c,FILE_T s,BOOL_T rm,BOOL_T wm,BOOL_T cm,char * env)8836 init_file (NODE_T * p, A68_REF * ref_file, A68_CHANNEL c, FILE_T s, BOOL_T rm, BOOL_T wm, BOOL_T cm, char *env)
8837 {
8838   A68_FILE *f;
8839   char *filename = (env == NO_TEXT ? NO_TEXT : getenv (env));
8840   *ref_file = heap_generator (p, MODE (REF_FILE), SIZE (MODE (FILE)));
8841   BLOCK_GC_HANDLE (ref_file);
8842   f = FILE_DEREF (ref_file);
8843   STATUS (f) = INIT_MASK;
8844   TERMINATOR (f) = nil_ref;
8845   CHANNEL (f) = c;
8846   if (filename != NO_TEXT && strlen (filename) > 0) {
8847     int len = 1 + (int) strlen (filename);
8848     IDENTIFICATION (f) = heap_generator (p, MODE (C_STRING), len);
8849     BLOCK_GC_HANDLE (&(IDENTIFICATION (f)));
8850     bufcpy (DEREF (char, &IDENTIFICATION (f)), filename, len);
8851     FD (f) = A68_NO_FILENO;
8852     READ_MOOD (f) = A68_FALSE;
8853     WRITE_MOOD (f) = A68_FALSE;
8854     CHAR_MOOD (f) = A68_FALSE;
8855     DRAW_MOOD (f) = A68_FALSE;
8856   } else {
8857     IDENTIFICATION (f) = nil_ref;
8858     FD (f) = s;
8859     READ_MOOD (f) = rm;
8860     WRITE_MOOD (f) = wm;
8861     CHAR_MOOD (f) = cm;
8862     DRAW_MOOD (f) = A68_FALSE;
8863   }
8864   TRANSPUT_BUFFER (f) = get_unblocked_transput_buffer (p);
8865   reset_transput_buffer (TRANSPUT_BUFFER (f));
8866   END_OF_FILE (f) = A68_FALSE;
8867   TMP_FILE (f) = A68_FALSE;
8868   OPENED (f) = A68_TRUE;
8869   OPEN_EXCLUSIVE (f) = A68_FALSE;
8870   FORMAT (f) = nil_format;
8871   STRING (f) = nil_ref;
8872   STRPOS (f) = 0;
8873   FILE_ENTRY (f) = -1;
8874   set_default_event_procedures (f);
8875 }
8876 
8877 /**
8878 @brief Initialise the transput RTL.
8879 @param p Node in syntax tree.
8880 **/
8881 
8882 void
genie_init_transput(NODE_T * p)8883 genie_init_transput (NODE_T * p)
8884 {
8885   init_transput_buffers (p);
8886 /* Channels */
8887   init_channel (&stand_in_channel, A68_FALSE, A68_FALSE, A68_TRUE, A68_FALSE, A68_FALSE, A68_FALSE);
8888   init_channel (&stand_out_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE, A68_FALSE, A68_FALSE);
8889   init_channel (&stand_back_channel, A68_TRUE, A68_TRUE, A68_TRUE, A68_TRUE, A68_TRUE, A68_FALSE);
8890   init_channel (&stand_error_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE, A68_FALSE, A68_FALSE);
8891   init_channel (&associate_channel, A68_TRUE, A68_TRUE, A68_TRUE, A68_TRUE, A68_FALSE, A68_FALSE);
8892   init_channel (&skip_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE);
8893 #if defined HAVE_GNU_PLOTUTILS
8894   init_channel (&stand_draw_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE);
8895 #else /*  */
8896   init_channel (&stand_draw_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE);
8897 #endif /*  */
8898 /* Files */
8899   init_file (p, &stand_in, stand_in_channel, STDIN_FILENO, A68_TRUE, A68_FALSE, A68_TRUE, "A68G_STANDIN");
8900   init_file (p, &stand_out, stand_out_channel, STDOUT_FILENO, A68_FALSE, A68_TRUE, A68_TRUE, "A68G_STANDOUT");
8901   init_file (p, &stand_back, stand_back_channel, A68_NO_FILENO, A68_FALSE, A68_FALSE, A68_FALSE, NO_TEXT);
8902   init_file (p, &stand_error, stand_error_channel, STDERR_FILENO, A68_FALSE, A68_TRUE, A68_TRUE, "A68G_STANDERROR");
8903   init_file (p, &skip_file, skip_channel, A68_NO_FILENO, A68_FALSE, A68_FALSE, A68_FALSE, NO_TEXT);
8904 }
8905 
8906 /**
8907 @brief PROC (REF FILE) STRING idf
8908 @param p Node in syntax tree.
8909 **/
8910 
8911 void
genie_idf(NODE_T * p)8912 genie_idf (NODE_T * p)
8913 {
8914   A68_REF ref_file, ref_filename;
8915   char *filename;
8916   POP_REF (p, &ref_file);
8917   CHECK_REF (p, ref_file, MODE (REF_FILE));
8918   ref_file = *(A68_REF *) STACK_TOP;
8919   ref_filename = IDENTIFICATION (FILE_DEREF (&ref_file));
8920   CHECK_REF (p, ref_filename, MODE (ROWS));
8921   filename = DEREF (char, &ref_filename);
8922   PUSH_REF (p, c_to_a_string (p, filename, DEFAULT_WIDTH));
8923 }
8924 
8925 /**
8926 @brief PROC (REF FILE) STRING term
8927 @param p Node in syntax tree.
8928 **/
8929 
8930 void
genie_term(NODE_T * p)8931 genie_term (NODE_T * p)
8932 {
8933   A68_REF ref_file, ref_term;
8934   char *term;
8935   POP_REF (p, &ref_file);
8936   CHECK_REF (p, ref_file, MODE (REF_FILE));
8937   ref_file = *(A68_REF *) STACK_TOP;
8938   ref_term = TERMINATOR (FILE_DEREF (&ref_file));
8939   CHECK_REF (p, ref_term, MODE (ROWS));
8940   term = DEREF (char, &ref_term);
8941   PUSH_REF (p, c_to_a_string (p, term, DEFAULT_WIDTH));
8942 }
8943 
8944 /**
8945 @brief PROC (REF FILE, STRING) VOID make term
8946 @param p Node in syntax tree.
8947 **/
8948 
8949 void
genie_make_term(NODE_T * p)8950 genie_make_term (NODE_T * p)
8951 {
8952   int size;
8953   A68_FILE *file;
8954   A68_REF ref_file, str;
8955   POP_REF (p, &str);
8956   POP_REF (p, &ref_file);
8957   CHECK_REF (p, ref_file, MODE (REF_FILE));
8958   ref_file = *(A68_REF *) STACK_TOP;
8959   file = FILE_DEREF (&ref_file);
8960 /* Don't check initialisation so we can "make term" before opening.
8961    That is ok */
8962   size = a68_string_size (p, str);
8963   if (INITIALISED (&(TERMINATOR (file))) && !IS_NIL (TERMINATOR (file))) {
8964     UNBLOCK_GC_HANDLE (&(TERMINATOR (file)));
8965   }
8966   TERMINATOR (file) = heap_generator (p, MODE (C_STRING), 1 + size);
8967   BLOCK_GC_HANDLE (&(TERMINATOR (file)));
8968   ASSERT (a_to_c_string (p, DEREF (char, &TERMINATOR (file)), str) != NO_TEXT);
8969 }
8970 
8971 /**
8972 @brief PROC (REF FILE) BOOL put possible
8973 @param p Node in syntax tree.
8974 **/
8975 
8976 void
genie_put_possible(NODE_T * p)8977 genie_put_possible (NODE_T * p)
8978 {
8979   A68_REF ref_file;
8980   A68_FILE *file;
8981   POP_REF (p, &ref_file);
8982   CHECK_REF (p, ref_file, MODE (REF_FILE));
8983   file = FILE_DEREF (&ref_file);
8984   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
8985   PUSH_PRIMITIVE (p, PUT (&CHANNEL (file)), A68_BOOL);
8986 }
8987 
8988 /**
8989 @brief PROC (REF FILE) BOOL get possible
8990 @param p Node in syntax tree.
8991 **/
8992 
8993 void
genie_get_possible(NODE_T * p)8994 genie_get_possible (NODE_T * p)
8995 {
8996   A68_REF ref_file;
8997   A68_FILE *file;
8998   POP_REF (p, &ref_file);
8999   CHECK_REF (p, ref_file, MODE (REF_FILE));
9000   file = FILE_DEREF (&ref_file);
9001   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9002   PUSH_PRIMITIVE (p, GET (&CHANNEL (file)), A68_BOOL);
9003 }
9004 
9005 /**
9006 @brief PROC (REF FILE) BOOL bin possible
9007 @param p Node in syntax tree.
9008 **/
9009 
9010 void
genie_bin_possible(NODE_T * p)9011 genie_bin_possible (NODE_T * p)
9012 {
9013   A68_REF ref_file;
9014   A68_FILE *file;
9015   POP_REF (p, &ref_file);
9016   CHECK_REF (p, ref_file, MODE (REF_FILE));
9017   file = FILE_DEREF (&ref_file);
9018   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9019   PUSH_PRIMITIVE (p, BIN (&CHANNEL (file)), A68_BOOL);
9020 }
9021 
9022 /**
9023 @brief PROC (REF FILE) BOOL set possible
9024 @param p Node in syntax tree.
9025 **/
9026 
9027 void
genie_set_possible(NODE_T * p)9028 genie_set_possible (NODE_T * p)
9029 {
9030   A68_REF ref_file;
9031   A68_FILE *file;
9032   POP_REF (p, &ref_file);
9033   CHECK_REF (p, ref_file, MODE (REF_FILE));
9034   file = FILE_DEREF (&ref_file);
9035   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9036   PUSH_PRIMITIVE (p, SET (&CHANNEL (file)), A68_BOOL);
9037 }
9038 
9039 /**
9040 @brief PROC (REF FILE) BOOL reidf possible
9041 @param p Node in syntax tree.
9042 **/
9043 
9044 void
genie_reidf_possible(NODE_T * p)9045 genie_reidf_possible (NODE_T * p)
9046 {
9047   A68_REF ref_file;
9048   A68_FILE *file;
9049   POP_REF (p, &ref_file);
9050   CHECK_REF (p, ref_file, MODE (REF_FILE));
9051   file = FILE_DEREF (&ref_file);
9052   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9053   PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL);
9054 }
9055 
9056 /**
9057 @brief PROC (REF FILE) BOOL reset possible
9058 @param p Node in syntax tree.
9059 **/
9060 
9061 void
genie_reset_possible(NODE_T * p)9062 genie_reset_possible (NODE_T * p)
9063 {
9064   A68_REF ref_file;
9065   A68_FILE *file;
9066   POP_REF (p, &ref_file);
9067   CHECK_REF (p, ref_file, MODE (REF_FILE));
9068   file = FILE_DEREF (&ref_file);
9069   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9070   PUSH_PRIMITIVE (p, RESET (&CHANNEL (file)), A68_BOOL);
9071 }
9072 
9073 /**
9074 @brief PROC (REF FILE) BOOL compressible
9075 @param p Node in syntax tree.
9076 **/
9077 
9078 void
genie_compressible(NODE_T * p)9079 genie_compressible (NODE_T * p)
9080 {
9081   A68_REF ref_file;
9082   A68_FILE *file;
9083   POP_REF (p, &ref_file);
9084   CHECK_REF (p, ref_file, MODE (REF_FILE));
9085   file = FILE_DEREF (&ref_file);
9086   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9087   PUSH_PRIMITIVE (p, COMPRESS (&CHANNEL (file)), A68_BOOL);
9088 }
9089 
9090 /**
9091 @brief PROC (REF FILE) BOOL draw possible
9092 @param p Node in syntax tree.
9093 **/
9094 
9095 void
genie_draw_possible(NODE_T * p)9096 genie_draw_possible (NODE_T * p)
9097 {
9098   A68_REF ref_file;
9099   A68_FILE *file;
9100   POP_REF (p, &ref_file);
9101   CHECK_REF (p, ref_file, MODE (REF_FILE));
9102   file = FILE_DEREF (&ref_file);
9103   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9104   PUSH_PRIMITIVE (p, DRAW (&CHANNEL (file)), A68_BOOL);
9105 }
9106 
9107 /**
9108 @brief PROC (REF FILE, STRING, CHANNEL) INT open
9109 @param p Node in syntax tree.
9110 **/
9111 
9112 void
genie_open(NODE_T * p)9113 genie_open (NODE_T * p)
9114 {
9115   A68_CHANNEL channel;
9116   A68_REF ref_iden, ref_file;
9117   A68_FILE *file;
9118   int size;
9119   POP_OBJECT (p, &channel, A68_CHANNEL);
9120   POP_REF (p, &ref_iden);
9121   CHECK_REF (p, ref_iden, MODE (REF_STRING));
9122   POP_REF (p, &ref_file);
9123   CHECK_REF (p, ref_file, MODE (REF_FILE));
9124   file = FILE_DEREF (&ref_file);
9125   STATUS (file) = INIT_MASK;
9126   FILE_ENTRY (file) = -1;
9127   CHANNEL (file) = channel;
9128   OPENED (file) = A68_TRUE;
9129   OPEN_EXCLUSIVE (file) = A68_FALSE;
9130   READ_MOOD (file) = A68_FALSE;
9131   WRITE_MOOD (file) = A68_FALSE;
9132   CHAR_MOOD (file) = A68_FALSE;
9133   DRAW_MOOD (file) = A68_FALSE;
9134   TMP_FILE (file) = A68_FALSE;
9135   size = a68_string_size (p, ref_iden);
9136   if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) {
9137     UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
9138   }
9139   IDENTIFICATION (file) = heap_generator (p, MODE (C_STRING), 1 + size);
9140   BLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
9141   ASSERT (a_to_c_string (p, DEREF (char, &IDENTIFICATION (file)), ref_iden) != NO_TEXT);
9142   TERMINATOR (file) = nil_ref;
9143   FORMAT (file) = nil_format;
9144   FD (file) = A68_NO_FILENO;
9145   if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) {
9146     UNBLOCK_GC_HANDLE (DEREF (A68_REF, &STRING (file)));
9147   }
9148   STRING (file) = nil_ref;
9149   STRPOS (file) = 0;
9150   DEVICE_MADE (&DEVICE (file)) = A68_FALSE;
9151   STREAM (&DEVICE (file)) = NO_STREAM;
9152   set_default_event_procedures (file);
9153   {
9154     struct stat status;
9155     if (stat (DEREF (char, &IDENTIFICATION (file)), &status) == 0) {
9156       PUSH_PRIMITIVE (p, (S_ISREG (ST_MODE (&status)) != 0 ? 0 : 1), A68_INT);
9157     } else {
9158       PUSH_PRIMITIVE (p, 1, A68_INT);
9159     }
9160     RESET_ERRNO;
9161   }
9162 }
9163 
9164 /**
9165 @brief PROC (REF FILE, STRING, CHANNEL) INT establish
9166 @param p Node in syntax tree.
9167 **/
9168 
9169 void
genie_establish(NODE_T * p)9170 genie_establish (NODE_T * p)
9171 {
9172   A68_CHANNEL channel;
9173   A68_REF ref_iden, ref_file;
9174   A68_FILE *file;
9175   int size;
9176   POP_OBJECT (p, &channel, A68_CHANNEL);
9177   POP_REF (p, &ref_iden);
9178   CHECK_REF (p, ref_iden, MODE (REF_STRING));
9179   POP_REF (p, &ref_file);
9180   CHECK_REF (p, ref_file, MODE (REF_FILE));
9181   file = FILE_DEREF (&ref_file);
9182   STATUS (file) = INIT_MASK;
9183   FILE_ENTRY (file) = -1;
9184   CHANNEL (file) = channel;
9185   OPENED (file) = A68_TRUE;
9186   OPEN_EXCLUSIVE (file) = A68_TRUE;
9187   READ_MOOD (file) = A68_FALSE;
9188   WRITE_MOOD (file) = A68_FALSE;
9189   CHAR_MOOD (file) = A68_FALSE;
9190   DRAW_MOOD (file) = A68_FALSE;
9191   TMP_FILE (file) = A68_FALSE;
9192   if (!PUT (&CHANNEL (file))) {
9193     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
9194     exit_genie (p, A68_RUNTIME_ERROR);
9195   }
9196   size = a68_string_size (p, ref_iden);
9197   if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) {
9198     UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
9199   }
9200   IDENTIFICATION (file) = heap_generator (p, MODE (C_STRING), 1 + size);
9201   BLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
9202   ASSERT (a_to_c_string (p, DEREF (char, &IDENTIFICATION (file)), ref_iden) != NO_TEXT);
9203   TERMINATOR (file) = nil_ref;
9204   FORMAT (file) = nil_format;
9205   FD (file) = A68_NO_FILENO;
9206   if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) {
9207     UNBLOCK_GC_HANDLE (DEREF (A68_REF, &STRING (file)));
9208   }
9209   STRING (file) = nil_ref;
9210   STRPOS (file) = 0;
9211   DEVICE_MADE (&DEVICE (file)) = A68_FALSE;
9212   STREAM (&DEVICE (file)) = NO_STREAM;
9213   set_default_event_procedures (file);
9214   PUSH_PRIMITIVE (p, 0, A68_INT);
9215 }
9216 
9217 /**
9218 @brief PROC (REF FILE, CHANNEL) INT create
9219 @param p Node in syntax tree.
9220 **/
9221 
9222 void
genie_create(NODE_T * p)9223 genie_create (NODE_T * p)
9224 {
9225   A68_CHANNEL channel;
9226   A68_REF ref_file;
9227   A68_FILE *file;
9228   POP_OBJECT (p, &channel, A68_CHANNEL);
9229   POP_REF (p, &ref_file);
9230   CHECK_REF (p, ref_file, MODE (REF_FILE));
9231   file = FILE_DEREF (&ref_file);
9232   STATUS (file) = INIT_MASK;
9233   FILE_ENTRY (file) = -1;
9234   CHANNEL (file) = channel;
9235   OPENED (file) = A68_TRUE;
9236   OPEN_EXCLUSIVE (file) = A68_FALSE;
9237   READ_MOOD (file) = A68_FALSE;
9238   WRITE_MOOD (file) = A68_FALSE;
9239   CHAR_MOOD (file) = A68_FALSE;
9240   DRAW_MOOD (file) = A68_FALSE;
9241   TMP_FILE (file) = A68_TRUE;
9242   if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) {
9243     UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
9244   }
9245   IDENTIFICATION (file) = nil_ref;
9246   TERMINATOR (file) = nil_ref;
9247   FORMAT (file) = nil_format;
9248   FD (file) = A68_NO_FILENO;
9249   if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) {
9250     UNBLOCK_GC_HANDLE (DEREF (A68_REF, &STRING (file)));
9251   }
9252   STRING (file) = nil_ref;
9253   STRPOS (file) = 0;
9254   DEVICE_MADE (&DEVICE (file)) = A68_FALSE;
9255   STREAM (&DEVICE (file)) = NO_STREAM;
9256   set_default_event_procedures (file);
9257   PUSH_PRIMITIVE (p, 0, A68_INT);
9258 }
9259 
9260 /**
9261 @brief PROC (REF FILE, REF STRING) VOID associate
9262 @param p Node in syntax tree.
9263 **/
9264 
9265 void
genie_associate(NODE_T * p)9266 genie_associate (NODE_T * p)
9267 {
9268   A68_REF ref_string, ref_file;
9269   A68_FILE *file;
9270   POP_REF (p, &ref_string);
9271   CHECK_REF (p, ref_string, MODE (REF_STRING));
9272   POP_REF (p, &ref_file);
9273   CHECK_REF (p, ref_file, MODE (REF_FILE));
9274   if (IS_IN_HEAP (&ref_file) && !IS_IN_HEAP (&ref_string)) {
9275     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, MODE (REF_STRING));
9276     exit_genie (p, A68_RUNTIME_ERROR);
9277   } else if (IS_IN_FRAME (&ref_file) && IS_IN_FRAME (&ref_string)) {
9278     if (REF_SCOPE (&ref_string) > REF_SCOPE (&ref_file)) {
9279       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, MODE (REF_STRING));
9280       exit_genie (p, A68_RUNTIME_ERROR);
9281     }
9282   }
9283   file = FILE_DEREF (&ref_file);
9284   STATUS (file) = INIT_MASK;
9285   FILE_ENTRY (file) = -1;
9286   CHANNEL (file) = associate_channel;
9287   OPENED (file) = A68_TRUE;
9288   OPEN_EXCLUSIVE (file) = A68_FALSE;
9289   READ_MOOD (file) = A68_FALSE;
9290   WRITE_MOOD (file) = A68_FALSE;
9291   CHAR_MOOD (file) = A68_FALSE;
9292   DRAW_MOOD (file) = A68_FALSE;
9293   TMP_FILE (file) = A68_FALSE;
9294   if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) {
9295     UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
9296   }
9297   IDENTIFICATION (file) = nil_ref;
9298   TERMINATOR (file) = nil_ref;
9299   FORMAT (file) = nil_format;
9300   FD (file) = A68_NO_FILENO;
9301   if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) {
9302     UNBLOCK_GC_HANDLE (DEREF (A68_REF, &STRING (file)));
9303   }
9304   STRING (file) = ref_string;
9305   BLOCK_GC_HANDLE ((A68_REF *) (&(STRING (file))));
9306   STRPOS (file) = 0;
9307   DEVICE_MADE (&DEVICE (file)) = A68_FALSE;
9308   STREAM (&DEVICE (file)) = NO_STREAM;
9309   set_default_event_procedures (file);
9310 }
9311 
9312 /**
9313 @brief PROC (REF FILE) VOID close
9314 @param p Node in syntax tree.
9315 **/
9316 
9317 void
genie_close(NODE_T * p)9318 genie_close (NODE_T * p)
9319 {
9320   A68_REF ref_file;
9321   A68_FILE *file;
9322   POP_REF (p, &ref_file);
9323   CHECK_REF (p, ref_file, MODE (REF_FILE));
9324   file = FILE_DEREF (&ref_file);
9325   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9326   if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) {
9327     return;
9328   }
9329   DEVICE_MADE (&DEVICE (file)) = A68_FALSE;
9330 #if defined HAVE_GNU_PLOTUTILS
9331   if (DEVICE_OPENED (&DEVICE (file))) {
9332     ASSERT (close_device (p, file) == A68_TRUE);
9333     STREAM (&DEVICE (file)) = NO_STREAM;
9334     return;
9335   }
9336 #endif /*  */
9337   FD (file) = A68_NO_FILENO;
9338   OPENED (file) = A68_FALSE;
9339   unblock_transput_buffer (TRANSPUT_BUFFER (file));
9340   set_default_event_procedures (file);
9341   free_file_entry (p, FILE_ENTRY (file));
9342 }
9343 
9344 /**
9345 @brief PROC (REF FILE) VOID lock
9346 @param p Node in syntax tree.
9347 **/
9348 
9349 void
genie_lock(NODE_T * p)9350 genie_lock (NODE_T * p)
9351 {
9352   A68_REF ref_file;
9353   A68_FILE *file;
9354   POP_REF (p, &ref_file);
9355   CHECK_REF (p, ref_file, MODE (REF_FILE));
9356   file = FILE_DEREF (&ref_file);
9357   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9358   if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) {
9359     return;
9360   }
9361   DEVICE_MADE (&DEVICE (file)) = A68_FALSE;
9362 #if defined HAVE_GNU_PLOTUTILS
9363   if (DEVICE_OPENED (&DEVICE (file))) {
9364     ASSERT (close_device (p, file) == A68_TRUE);
9365     STREAM (&DEVICE (file)) = NO_STREAM;
9366     return;
9367   }
9368 #endif /*  */
9369 #if ! defined HAVE_WIN32
9370   RESET_ERRNO;
9371   ASSERT (fchmod (FD (file), (mode_t) 0x0) != -1);
9372 #endif
9373   if (FD (file) != A68_NO_FILENO && close (FD (file)) == -1) {
9374     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_LOCK);
9375     exit_genie (p, A68_RUNTIME_ERROR);
9376   } else {
9377     FD (file) = A68_NO_FILENO;
9378     OPENED (file) = A68_FALSE;
9379     unblock_transput_buffer (TRANSPUT_BUFFER (file));
9380     set_default_event_procedures (file);
9381   }
9382   free_file_entry (p, FILE_ENTRY (file));
9383 }
9384 
9385 /**
9386 @brief PROC (REF FILE) VOID erase
9387 @param p Node in syntax tree.
9388 **/
9389 
9390 void
genie_erase(NODE_T * p)9391 genie_erase (NODE_T * p)
9392 {
9393   A68_REF ref_file;
9394   A68_FILE *file;
9395   POP_REF (p, &ref_file);
9396   CHECK_REF (p, ref_file, MODE (REF_FILE));
9397   file = FILE_DEREF (&ref_file);
9398   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9399   if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) {
9400     return;
9401   }
9402   DEVICE_MADE (&DEVICE (file)) = A68_FALSE;
9403 #if defined HAVE_GNU_PLOTUTILS
9404   if (DEVICE_OPENED (&DEVICE (file))) {
9405     ASSERT (close_device (p, file) == A68_TRUE);
9406     STREAM (&DEVICE (file)) = NO_STREAM;
9407     return;
9408   }
9409 #endif /*  */
9410   if (FD (file) != A68_NO_FILENO && close (FD (file)) == -1) {
9411     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_SCRATCH);
9412     exit_genie (p, A68_RUNTIME_ERROR);
9413   } else {
9414     unblock_transput_buffer (TRANSPUT_BUFFER (file));
9415     set_default_event_procedures (file);
9416   }
9417 /* Remove the file */
9418   if (!IS_NIL (IDENTIFICATION (file))) {
9419     char *filename;
9420     CHECK_INIT (p, INITIALISED (&(IDENTIFICATION (file))), MODE (ROWS));
9421     filename = DEREF (char, &IDENTIFICATION (file));
9422     if (remove (filename) != 0) {
9423       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_SCRATCH);
9424       exit_genie (p, A68_RUNTIME_ERROR);
9425     }
9426     UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
9427     IDENTIFICATION (file) = nil_ref;
9428   }
9429   init_file_entry (FILE_ENTRY (file));
9430 }
9431 
9432 /**
9433 @brief PROC (REF FILE) VOID backspace
9434 @param p Node in syntax tree.
9435 **/
9436 
9437 void
genie_backspace(NODE_T * p)9438 genie_backspace (NODE_T * p)
9439 {
9440   ADDR_T pop_sp = stack_pointer;
9441   PUSH_PRIMITIVE (p, -1, A68_INT);
9442   genie_set (p);
9443   stack_pointer = pop_sp;
9444 }
9445 
9446 /**
9447 @brief PROC (REF FILE, INT) INT set
9448 @param p Node in syntax tree.
9449 **/
9450 
9451 void
genie_set(NODE_T * p)9452 genie_set (NODE_T * p)
9453 {
9454   A68_REF ref_file;
9455   A68_FILE *file;
9456   A68_INT pos;
9457   POP_OBJECT (p, &pos, A68_INT);
9458   POP_REF (p, &ref_file);
9459   CHECK_REF (p, ref_file, MODE (REF_FILE));
9460   file = FILE_DEREF (&ref_file);
9461   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9462   if (!OPENED (file)) {
9463     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
9464     exit_genie (p, A68_RUNTIME_ERROR);
9465   }
9466   if (!SET (&CHANNEL (file))) {
9467     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_CANT_SET);
9468     exit_genie (p, A68_RUNTIME_ERROR);
9469   }
9470   if (!IS_NIL (STRING (file))) {
9471     A68_REF z = *DEREF (A68_REF, &STRING (file));
9472     A68_ARRAY *a;
9473     A68_TUPLE *t;
9474     int size;
9475 /* Circumvent buffering problems */
9476     STRPOS (file) -= get_transput_buffer_index (TRANSPUT_BUFFER (file));
9477     ASSERT (STRPOS (file) > 0);
9478     reset_transput_buffer (TRANSPUT_BUFFER (file));
9479 /* Now set */
9480     CHECK_INT_ADDITION (p, STRPOS (file), VALUE (&pos));
9481     STRPOS (file) += VALUE (&pos);
9482     GET_DESCRIPTOR (a, t, &z);
9483     size = ROW_SIZE (t);
9484     if (size <= 0 || STRPOS (file) < 0 || STRPOS (file) >= size) {
9485       A68_BOOL res;
9486       on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
9487       POP_OBJECT (p, &res, A68_BOOL);
9488       if (VALUE (&res) == A68_FALSE) {
9489         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ENDED);
9490         exit_genie (p, A68_RUNTIME_ERROR);
9491       }
9492     }
9493     PUSH_PRIMITIVE (p, STRPOS (file), A68_INT);
9494   } else if (FD (file) == A68_NO_FILENO) {
9495     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_RESET);
9496     exit_genie (p, A68_RUNTIME_ERROR);
9497   } else {
9498     __off_t curpos = lseek (FD (file), 0, SEEK_CUR);
9499     __off_t maxpos = lseek (FD (file), 0, SEEK_END);
9500     __off_t res = lseek (FD (file), curpos, SEEK_SET);
9501 /* Circumvent buffering problems */
9502     int reserve = get_transput_buffer_index (TRANSPUT_BUFFER (file));
9503     curpos -= (__off_t) reserve;
9504     res = lseek (FD (file), -reserve, SEEK_CUR);
9505     ASSERT (res != -1 && errno == 0);
9506     reset_transput_buffer (TRANSPUT_BUFFER (file));
9507 /* Now set */
9508     CHECK_INT_ADDITION (p, curpos, VALUE (&pos));
9509     curpos += VALUE (&pos);
9510     if (curpos < 0 || curpos >= maxpos) {
9511       A68_BOOL ret;
9512       on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
9513       POP_OBJECT (p, &ret, A68_BOOL);
9514       if (VALUE (&ret) == A68_FALSE) {
9515         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ENDED);
9516         exit_genie (p, A68_RUNTIME_ERROR);
9517       }
9518       PUSH_PRIMITIVE (p, (int) lseek (FD (file), 0, SEEK_CUR), A68_INT);
9519     } else {
9520       res = lseek (FD (file), curpos, SEEK_SET);
9521       if (res == -1 || errno != 0) {
9522         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_SET);
9523         exit_genie (p, A68_RUNTIME_ERROR);
9524       }
9525       PUSH_PRIMITIVE (p, (int) res, A68_INT);
9526     }
9527   }
9528 }
9529 
9530 /**
9531 @brief PROC (REF FILE) VOID reset
9532 @param p Node in syntax tree.
9533 **/
9534 
9535 void
genie_reset(NODE_T * p)9536 genie_reset (NODE_T * p)
9537 {
9538   A68_REF ref_file;
9539   A68_FILE *file;
9540   POP_REF (p, &ref_file);
9541   CHECK_REF (p, ref_file, MODE (REF_FILE));
9542   file = FILE_DEREF (&ref_file);
9543   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9544   if (!OPENED (file)) {
9545     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
9546     exit_genie (p, A68_RUNTIME_ERROR);
9547   }
9548   if (!RESET (&CHANNEL (file))) {
9549     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_CANT_RESET);
9550     exit_genie (p, A68_RUNTIME_ERROR);
9551   }
9552   if (IS_NIL (STRING (file))) {
9553     close_file_entry (p, FILE_ENTRY (file));
9554   } else {
9555     STRPOS (file) = 0;
9556   }
9557   READ_MOOD (file) = A68_FALSE;
9558   WRITE_MOOD (file) = A68_FALSE;
9559   CHAR_MOOD (file) = A68_FALSE;
9560   DRAW_MOOD (file) = A68_FALSE;
9561   FD (file) = A68_NO_FILENO;
9562 /*  set_default_event_procedures (file); */
9563 }
9564 
9565 /**
9566 @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on file end
9567 @param p Node in syntax tree.
9568 **/
9569 
9570 void
genie_on_file_end(NODE_T * p)9571 genie_on_file_end (NODE_T * p)
9572 {
9573   A68_PROCEDURE z;
9574   A68_REF ref_file;
9575   A68_FILE *file;
9576   POP_PROCEDURE (p, &z);
9577   POP_REF (p, &ref_file);
9578   CHECK_REF (p, ref_file, MODE (REF_FILE));
9579   file = FILE_DEREF (&ref_file);
9580   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9581   FILE_END_MENDED (file) = z;
9582 }
9583 
9584 /**
9585 @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on page end
9586 @param p Node in syntax tree.
9587 **/
9588 
9589 void
genie_on_page_end(NODE_T * p)9590 genie_on_page_end (NODE_T * p)
9591 {
9592   A68_PROCEDURE z;
9593   A68_REF ref_file;
9594   A68_FILE *file;
9595   POP_PROCEDURE (p, &z);
9596   POP_REF (p, &ref_file);
9597   CHECK_REF (p, ref_file, MODE (REF_FILE));
9598   file = FILE_DEREF (&ref_file);
9599   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9600   PAGE_END_MENDED (file) = z;
9601 }
9602 
9603 /**
9604 @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on line end
9605 @param p Node in syntax tree.
9606 **/
9607 
9608 void
genie_on_line_end(NODE_T * p)9609 genie_on_line_end (NODE_T * p)
9610 {
9611   A68_PROCEDURE z;
9612   A68_REF ref_file;
9613   A68_FILE *file;
9614   POP_PROCEDURE (p, &z);
9615   POP_REF (p, &ref_file);
9616   CHECK_REF (p, ref_file, MODE (REF_FILE));
9617   file = FILE_DEREF (&ref_file);
9618   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9619   LINE_END_MENDED (file) = z;
9620 }
9621 
9622 /**
9623 @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on format end
9624 @param p Node in syntax tree.
9625 **/
9626 
9627 void
genie_on_format_end(NODE_T * p)9628 genie_on_format_end (NODE_T * p)
9629 {
9630   A68_PROCEDURE z;
9631   A68_REF ref_file;
9632   A68_FILE *file;
9633   POP_PROCEDURE (p, &z);
9634   POP_REF (p, &ref_file);
9635   CHECK_REF (p, ref_file, MODE (REF_FILE));
9636   file = FILE_DEREF (&ref_file);
9637   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9638   FORMAT_END_MENDED (file) = z;
9639 }
9640 
9641 /**
9642 @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on format error
9643 @param p Node in syntax tree.
9644 **/
9645 
9646 void
genie_on_format_error(NODE_T * p)9647 genie_on_format_error (NODE_T * p)
9648 {
9649   A68_PROCEDURE z;
9650   A68_REF ref_file;
9651   A68_FILE *file;
9652   POP_PROCEDURE (p, &z);
9653   POP_REF (p, &ref_file);
9654   CHECK_REF (p, ref_file, MODE (REF_FILE));
9655   file = FILE_DEREF (&ref_file);
9656   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9657   FORMAT_ERROR_MENDED (file) = z;
9658 }
9659 
9660 /**
9661 @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on value error
9662 @param p Node in syntax tree.
9663 **/
9664 
9665 void
genie_on_value_error(NODE_T * p)9666 genie_on_value_error (NODE_T * p)
9667 {
9668   A68_PROCEDURE z;
9669   A68_REF ref_file;
9670   A68_FILE *file;
9671   POP_PROCEDURE (p, &z);
9672   POP_REF (p, &ref_file);
9673   CHECK_REF (p, ref_file, MODE (REF_FILE));
9674   file = FILE_DEREF (&ref_file);
9675   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9676   VALUE_ERROR_MENDED (file) = z;
9677 }
9678 
9679 /**
9680 @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on open error
9681 @param p Node in syntax tree.
9682 **/
9683 
9684 void
genie_on_open_error(NODE_T * p)9685 genie_on_open_error (NODE_T * p)
9686 {
9687   A68_PROCEDURE z;
9688   A68_REF ref_file;
9689   A68_FILE *file;
9690   POP_PROCEDURE (p, &z);
9691   POP_REF (p, &ref_file);
9692   CHECK_REF (p, ref_file, MODE (REF_FILE));
9693   file = FILE_DEREF (&ref_file);
9694   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9695   OPEN_ERROR_MENDED (file) = z;
9696 }
9697 
9698 /**
9699 @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on transput error
9700 @param p Node in syntax tree.
9701 **/
9702 
9703 void
genie_on_transput_error(NODE_T * p)9704 genie_on_transput_error (NODE_T * p)
9705 {
9706   A68_PROCEDURE z;
9707   A68_REF ref_file;
9708   A68_FILE *file;
9709   POP_PROCEDURE (p, &z);
9710   POP_REF (p, &ref_file);
9711   CHECK_REF (p, ref_file, MODE (REF_FILE));
9712   file = FILE_DEREF (&ref_file);
9713   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9714   TRANSPUT_ERROR_MENDED (file) = z;
9715 }
9716 
9717 /**
9718 @brief Invoke event routine.
9719 @param p Node in syntax tree.
9720 @param z Routine to invoke.
9721 @param ref_file Fat pointer to A68 file.
9722 **/
9723 
9724 void
on_event_handler(NODE_T * p,A68_PROCEDURE z,A68_REF ref_file)9725 on_event_handler (NODE_T * p, A68_PROCEDURE z, A68_REF ref_file)
9726 {
9727   if (NODE (&(BODY (&z))) == NO_NODE) {
9728 /* Default procedure */
9729     PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL);
9730   } else {
9731     ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer;
9732     PUSH_REF (p, ref_file);
9733     genie_call_event_routine (p, MODE (PROC_REF_FILE_BOOL), &z, pop_sp, pop_fp);
9734   }
9735 }
9736 
9737 /**
9738 @brief Handle end-of-file event.
9739 @param p Node in syntax tree.
9740 @param ref_file Fat pointer to A68 file.
9741 **/
9742 
9743 void
end_of_file_error(NODE_T * p,A68_REF ref_file)9744 end_of_file_error (NODE_T * p, A68_REF ref_file)
9745 {
9746   A68_BOOL z;
9747   on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
9748   POP_OBJECT (p, &z, A68_BOOL);
9749   if (VALUE (&z) == A68_FALSE) {
9750     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ENDED);
9751     exit_genie (p, A68_RUNTIME_ERROR);
9752   }
9753 }
9754 
9755 /**
9756 @brief Handle file-open-error event.
9757 @param p Node in syntax tree.
9758 @param ref_file Fat pointer to A68 file.
9759 @param mode Mode for opening.
9760 **/
9761 
9762 void
open_error(NODE_T * p,A68_REF ref_file,char * mode)9763 open_error (NODE_T * p, A68_REF ref_file, char *mode)
9764 {
9765   A68_BOOL z;
9766   on_event_handler (p, OPEN_ERROR_MENDED (FILE_DEREF (&ref_file)), ref_file);
9767   POP_OBJECT (p, &z, A68_BOOL);
9768   if (VALUE (&z) == A68_FALSE) {
9769     A68_FILE *file;
9770     char *filename;
9771     CHECK_REF (p, ref_file, MODE (REF_FILE));
9772     file = FILE_DEREF (&ref_file);
9773     CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9774     if (!IS_NIL (IDENTIFICATION (file))) {
9775       filename = DEREF (char, &IDENTIFICATION (FILE_DEREF (&ref_file)));
9776     } else {
9777       filename = "(missing filename)";
9778     }
9779     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_CANNOT_OPEN_FOR, filename, mode);
9780     exit_genie (p, A68_RUNTIME_ERROR);
9781   }
9782 }
9783 
9784 /**
9785 @brief Handle value error event.
9786 @param p Node in syntax tree.
9787 @param m Mode of object read or written.
9788 @param ref_file Fat pointer to A68 file.
9789 **/
9790 
9791 void
value_error(NODE_T * p,MOID_T * m,A68_REF ref_file)9792 value_error (NODE_T * p, MOID_T * m, A68_REF ref_file)
9793 {
9794   A68_FILE *f = FILE_DEREF (&ref_file);
9795   if (END_OF_FILE (f)) {
9796     end_of_file_error (p, ref_file);
9797   } else {
9798     A68_BOOL z;
9799     on_event_handler (p, VALUE_ERROR_MENDED (f), ref_file);
9800     POP_OBJECT (p, &z, A68_BOOL);
9801     if (VALUE (&z) == A68_FALSE) {
9802       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT, m);
9803       exit_genie (p, A68_RUNTIME_ERROR);
9804     }
9805   }
9806 }
9807 
9808 /**
9809 @brief Handle value_error event.
9810 @param p Node in syntax tree.
9811 @param m Mode of object read or written.
9812 @param ref_file Fat pointer to A68 file.
9813 **/
9814 
9815 void
value_sign_error(NODE_T * p,MOID_T * m,A68_REF ref_file)9816 value_sign_error (NODE_T * p, MOID_T * m, A68_REF ref_file)
9817 {
9818   A68_FILE *f = FILE_DEREF (&ref_file);
9819   if (END_OF_FILE (f)) {
9820     end_of_file_error (p, ref_file);
9821   } else {
9822     A68_BOOL z;
9823     on_event_handler (p, VALUE_ERROR_MENDED (f), ref_file);
9824     POP_OBJECT (p, &z, A68_BOOL);
9825     if (VALUE (&z) == A68_FALSE) {
9826       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT_SIGN, m);
9827       exit_genie (p, A68_RUNTIME_ERROR);
9828     }
9829   }
9830 }
9831 
9832 /**
9833 @brief Handle transput-error event.
9834 @param p Node in syntax tree.
9835 @param ref_file Fat pointer to A68 file.
9836 @param m Mode of object read or written.
9837 **/
9838 
9839 void
transput_error(NODE_T * p,A68_REF ref_file,MOID_T * m)9840 transput_error (NODE_T * p, A68_REF ref_file, MOID_T * m)
9841 {
9842   A68_BOOL z;
9843   on_event_handler (p, TRANSPUT_ERROR_MENDED (FILE_DEREF (&ref_file)), ref_file);
9844   POP_OBJECT (p, &z, A68_BOOL);
9845   if (VALUE (&z) == A68_FALSE) {
9846     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT, m);
9847     exit_genie (p, A68_RUNTIME_ERROR);
9848   }
9849 }
9850 
9851 /* Implementation of put and get */
9852 
9853 /**
9854 @brief Get next char from file.
9855 @param f File.
9856 @return See brief description.
9857 **/
9858 
9859 int
char_scanner(A68_FILE * f)9860 char_scanner (A68_FILE * f)
9861 {
9862   if (get_transput_buffer_index (TRANSPUT_BUFFER (f)) > 0) {
9863 /* There are buffered characters */
9864     END_OF_FILE (f) = A68_FALSE;
9865     return (pop_char_transput_buffer (TRANSPUT_BUFFER (f)));
9866   } else if (IS_NIL (STRING (f))) {
9867 /* Fetch next CHAR from the FILE */
9868     ssize_t chars_read;
9869     char ch;
9870     chars_read = io_read_conv (FD (f), &ch, 1);
9871     if (chars_read == 1) {
9872       END_OF_FILE (f) = A68_FALSE;
9873       return (ch);
9874     } else {
9875       END_OF_FILE (f) = A68_TRUE;
9876       return (EOF_CHAR);
9877     }
9878   } else {
9879 /*
9880 File is associated with a STRING. Give next CHAR.
9881 When we're outside the STRING give EOF_CHAR.
9882 */
9883     A68_REF z = *DEREF (A68_REF, &STRING (f));
9884     A68_ARRAY *a;
9885     A68_TUPLE *t;
9886     BYTE_T *base;
9887     A68_CHAR *ch;
9888     int k;
9889     GET_DESCRIPTOR (a, t, &z);
9890     k = STRPOS (f) + LWB (t);
9891     if (ROW_SIZE (t) <= 0 || k < LWB (t) || k > UPB (t)) {
9892       END_OF_FILE (f) = A68_TRUE;
9893       return (EOF_CHAR);
9894     } else {
9895       base = DEREF (BYTE_T, &ARRAY (a));
9896       ch = (A68_CHAR *) & (base[INDEX_1_DIM (a, t, k)]);
9897       STRPOS (f)++;
9898       return (VALUE (ch));
9899     }
9900   }
9901 }
9902 
9903 /**
9904 @brief Push back look-ahead character to file.
9905 @param p Node in syntax tree.
9906 @param f File.
9907 @param ch Character to push.
9908 **/
9909 
9910 void
unchar_scanner(NODE_T * p,A68_FILE * f,char ch)9911 unchar_scanner (NODE_T * p, A68_FILE * f, char ch)
9912 {
9913   END_OF_FILE (f) = A68_FALSE;
9914   add_char_transput_buffer (p, TRANSPUT_BUFFER (f), ch);
9915 }
9916 
9917 /**
9918 @brief PROC (REF FILE) BOOL eof
9919 @param p Node in syntax tree.
9920 **/
9921 
9922 void
genie_eof(NODE_T * p)9923 genie_eof (NODE_T * p)
9924 {
9925   A68_REF ref_file;
9926   A68_FILE *file;
9927   POP_REF (p, &ref_file);
9928   CHECK_REF (p, ref_file, MODE (REF_FILE));
9929   file = FILE_DEREF (&ref_file);
9930   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9931   if (!OPENED (file)) {
9932     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
9933     exit_genie (p, A68_RUNTIME_ERROR);
9934   }
9935   if (DRAW_MOOD (file)) {
9936     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
9937     exit_genie (p, A68_RUNTIME_ERROR);
9938   }
9939   if (WRITE_MOOD (file)) {
9940     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
9941     exit_genie (p, A68_RUNTIME_ERROR);
9942   } else if (READ_MOOD (file)) {
9943     int ch = char_scanner (file);
9944     PUSH_PRIMITIVE (p, (BOOL_T) ((ch == EOF_CHAR || END_OF_FILE (file)) ? A68_TRUE : A68_FALSE), A68_BOOL);
9945     unchar_scanner (p, file, (char) ch);
9946   } else {
9947     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
9948     exit_genie (p, A68_RUNTIME_ERROR);
9949   }
9950 }
9951 
9952 /**
9953 @brief PROC (REF FILE) BOOL eoln
9954 @param p Node in syntax tree.
9955 **/
9956 
9957 void
genie_eoln(NODE_T * p)9958 genie_eoln (NODE_T * p)
9959 {
9960   A68_REF ref_file;
9961   A68_FILE *file;
9962   POP_REF (p, &ref_file);
9963   CHECK_REF (p, ref_file, MODE (REF_FILE));
9964   file = FILE_DEREF (&ref_file);
9965   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
9966   if (!OPENED (file)) {
9967     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
9968     exit_genie (p, A68_RUNTIME_ERROR);
9969   }
9970   if (DRAW_MOOD (file)) {
9971     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
9972     exit_genie (p, A68_RUNTIME_ERROR);
9973   }
9974   if (WRITE_MOOD (file)) {
9975     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
9976     exit_genie (p, A68_RUNTIME_ERROR);
9977   } else if (READ_MOOD (file)) {
9978     int ch = char_scanner (file);
9979     if (END_OF_FILE (file)) {
9980       end_of_file_error (p, ref_file);
9981     }
9982     PUSH_PRIMITIVE (p, (BOOL_T) (ch == NEWLINE_CHAR ? A68_TRUE : A68_FALSE), A68_BOOL);
9983     unchar_scanner (p, file, (char) ch);
9984   } else {
9985     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
9986     exit_genie (p, A68_RUNTIME_ERROR);
9987   }
9988 }
9989 
9990 /**
9991 @brief PROC (REF FILE) VOID new line
9992 @param p Node in syntax tree.
9993 **/
9994 
9995 void
genie_new_line(NODE_T * p)9996 genie_new_line (NODE_T * p)
9997 {
9998   A68_REF ref_file;
9999   A68_FILE *file;
10000   POP_REF (p, &ref_file);
10001   CHECK_REF (p, ref_file, MODE (REF_FILE));
10002   file = FILE_DEREF (&ref_file);
10003   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
10004   if (!OPENED (file)) {
10005     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
10006     exit_genie (p, A68_RUNTIME_ERROR);
10007   }
10008   if (DRAW_MOOD (file)) {
10009     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
10010     exit_genie (p, A68_RUNTIME_ERROR);
10011   }
10012   if (WRITE_MOOD (file)) {
10013     on_event_handler (p, LINE_END_MENDED (file), ref_file);
10014     if (IS_NIL (STRING (file))) {
10015       WRITE (FD (file), NEWLINE_STRING);
10016     } else {
10017       add_c_string_to_a_string (p, STRING (file), NEWLINE_STRING);
10018     }
10019   } else if (READ_MOOD (file)) {
10020     BOOL_T go_on = A68_TRUE;
10021     while (go_on) {
10022       int ch;
10023       if (END_OF_FILE (file)) {
10024         end_of_file_error (p, ref_file);
10025       }
10026       ch = char_scanner (file);
10027       go_on = (BOOL_T) ((ch != NEWLINE_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
10028     }
10029   } else {
10030     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
10031     exit_genie (p, A68_RUNTIME_ERROR);
10032   }
10033 }
10034 
10035 /**
10036 @brief PROC (REF FILE) VOID new page
10037 @param p Node in syntax tree.
10038 **/
10039 
10040 void
genie_new_page(NODE_T * p)10041 genie_new_page (NODE_T * p)
10042 {
10043   A68_REF ref_file;
10044   A68_FILE *file;
10045   POP_REF (p, &ref_file);
10046   CHECK_REF (p, ref_file, MODE (REF_FILE));
10047   file = FILE_DEREF (&ref_file);
10048   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
10049   if (!OPENED (file)) {
10050     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
10051     exit_genie (p, A68_RUNTIME_ERROR);
10052   }
10053   if (DRAW_MOOD (file)) {
10054     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
10055     exit_genie (p, A68_RUNTIME_ERROR);
10056   }
10057   if (WRITE_MOOD (file)) {
10058     on_event_handler (p, PAGE_END_MENDED (file), ref_file);
10059     if (IS_NIL (STRING (file))) {
10060       WRITE (FD (file), "\f");
10061     } else {
10062       add_c_string_to_a_string (p, STRING (file), "\f");
10063     }
10064   } else if (READ_MOOD (file)) {
10065     BOOL_T go_on = A68_TRUE;
10066     while (go_on) {
10067       int ch;
10068       if (END_OF_FILE (file)) {
10069         end_of_file_error (p, ref_file);
10070       }
10071       ch = char_scanner (file);
10072       go_on = (BOOL_T) ((ch != FORMFEED_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
10073     }
10074   } else {
10075     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
10076     exit_genie (p, A68_RUNTIME_ERROR);
10077   }
10078 }
10079 
10080 /**
10081 @brief PROC (REF FILE) VOID space
10082 @param p Node in syntax tree.
10083 **/
10084 
10085 void
genie_space(NODE_T * p)10086 genie_space (NODE_T * p)
10087 {
10088   A68_REF ref_file;
10089   A68_FILE *file;
10090   POP_REF (p, &ref_file);
10091   CHECK_REF (p, ref_file, MODE (REF_FILE));
10092   file = FILE_DEREF (&ref_file);
10093   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
10094   if (!OPENED (file)) {
10095     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
10096     exit_genie (p, A68_RUNTIME_ERROR);
10097   }
10098   if (DRAW_MOOD (file)) {
10099     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
10100     exit_genie (p, A68_RUNTIME_ERROR);
10101   }
10102   if (WRITE_MOOD (file)) {
10103     WRITE (FD (file), " ");
10104   } else if (READ_MOOD (file)) {
10105     if (!END_OF_FILE (file)) {
10106       (void) char_scanner (file);
10107     }
10108   } else {
10109     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
10110     exit_genie (p, A68_RUNTIME_ERROR);
10111   }
10112 }
10113 
10114 #define IS_NL_FF(ch) ((ch) == NEWLINE_CHAR || (ch) == FORMFEED_CHAR)
10115 
10116 /**
10117 @brief Skip new-lines and form-feeds.
10118 @param p Node in syntax tree.
10119 @param ch Pointer to scanned character.
10120 @param ref_file Fat pointer to A68 file.
10121 **/
10122 
10123 void
skip_nl_ff(NODE_T * p,int * ch,A68_REF ref_file)10124 skip_nl_ff (NODE_T * p, int *ch, A68_REF ref_file)
10125 {
10126   A68_FILE *f = FILE_DEREF (&ref_file);
10127   while ((*ch) != EOF_CHAR && IS_NL_FF (*ch)) {
10128     A68_BOOL *z = (A68_BOOL *) STACK_TOP;
10129     ADDR_T pop_sp = stack_pointer;
10130     unchar_scanner (p, f, (char) (*ch));
10131     if (*ch == NEWLINE_CHAR) {
10132       on_event_handler (p, LINE_END_MENDED (f), ref_file);
10133       stack_pointer = pop_sp;
10134       if (VALUE (z) == A68_FALSE) {
10135         PUSH_REF (p, ref_file);
10136         genie_new_line (p);
10137       }
10138     } else if (*ch == FORMFEED_CHAR) {
10139       on_event_handler (p, PAGE_END_MENDED (f), ref_file);
10140       stack_pointer = pop_sp;
10141       if (VALUE (z) == A68_FALSE) {
10142         PUSH_REF (p, ref_file);
10143         genie_new_page (p);
10144       }
10145     }
10146     (*ch) = char_scanner (f);
10147   }
10148 }
10149 
10150 /**
10151 @brief Scan an int from file.
10152 @param p Node in syntax tree.
10153 @param ref_file Fat pointer to A68 file.
10154 **/
10155 
10156 void
scan_integer(NODE_T * p,A68_REF ref_file)10157 scan_integer (NODE_T * p, A68_REF ref_file)
10158 {
10159   A68_FILE *f = FILE_DEREF (&ref_file);
10160   int ch;
10161   reset_transput_buffer (INPUT_BUFFER);
10162   ch = char_scanner (f);
10163   while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
10164     if (IS_NL_FF (ch)) {
10165       skip_nl_ff (p, &ch, ref_file);
10166     } else {
10167       ch = char_scanner (f);
10168     }
10169   }
10170   if (ch != EOF_CHAR && (ch == '+' || ch == '-')) {
10171     add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
10172     ch = char_scanner (f);
10173   }
10174   while (ch != EOF_CHAR && IS_DIGIT (ch)) {
10175     add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
10176     ch = char_scanner (f);
10177   }
10178   if (ch != EOF_CHAR) {
10179     unchar_scanner (p, f, (char) ch);
10180   }
10181 }
10182 
10183 /**
10184 @brief Scan a real from file.
10185 @param p Node in syntax tree.
10186 @param ref_file Fat pointer to A68 file.
10187 **/
10188 
10189 void
scan_real(NODE_T * p,A68_REF ref_file)10190 scan_real (NODE_T * p, A68_REF ref_file)
10191 {
10192   A68_FILE *f = FILE_DEREF (&ref_file);
10193   char x_e = EXPONENT_CHAR;
10194   int ch;
10195   reset_transput_buffer (INPUT_BUFFER);
10196   ch = char_scanner (f);
10197   while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
10198     if (IS_NL_FF (ch)) {
10199       skip_nl_ff (p, &ch, ref_file);
10200     } else {
10201       ch = char_scanner (f);
10202     }
10203   }
10204   if (ch != EOF_CHAR && (ch == '+' || ch == '-')) {
10205     add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
10206     ch = char_scanner (f);
10207   }
10208   while (ch != EOF_CHAR && IS_DIGIT (ch)) {
10209     add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
10210     ch = char_scanner (f);
10211   }
10212   if (ch == EOF_CHAR || !(ch == POINT_CHAR || TO_UPPER (ch) == TO_UPPER (x_e))) {
10213     goto salida;
10214   }
10215   if (ch == POINT_CHAR) {
10216     add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
10217     ch = char_scanner (f);
10218     while (ch != EOF_CHAR && IS_DIGIT (ch)) {
10219       add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
10220       ch = char_scanner (f);
10221     }
10222   }
10223   if (ch == EOF_CHAR || TO_UPPER (ch) != TO_UPPER (x_e)) {
10224     goto salida;
10225   }
10226   if (TO_UPPER (ch) == TO_UPPER (x_e)) {
10227     add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
10228     ch = char_scanner (f);
10229     while (ch != EOF_CHAR && ch == BLANK_CHAR) {
10230       ch = char_scanner (f);
10231     }
10232     if (ch != EOF_CHAR && (ch == '+' || ch == '-')) {
10233       add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
10234       ch = char_scanner (f);
10235     }
10236     while (ch != EOF_CHAR && IS_DIGIT (ch)) {
10237       add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
10238       ch = char_scanner (f);
10239     }
10240   }
10241 salida:if (ch != EOF_CHAR) {
10242     unchar_scanner (p, f, (char) ch);
10243   }
10244 }
10245 
10246 /**
10247 @brief Scan a bits from file.
10248 @param p Node in syntax tree.
10249 @param ref_file Fat pointer to A68 file.
10250 **/
10251 
10252 void
scan_bits(NODE_T * p,A68_REF ref_file)10253 scan_bits (NODE_T * p, A68_REF ref_file)
10254 {
10255   A68_FILE *f = FILE_DEREF (&ref_file);
10256   int ch, flip = FLIP_CHAR, flop = FLOP_CHAR;
10257   reset_transput_buffer (INPUT_BUFFER);
10258   ch = char_scanner (f);
10259   while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
10260     if (IS_NL_FF (ch)) {
10261       skip_nl_ff (p, &ch, ref_file);
10262     } else {
10263       ch = char_scanner (f);
10264     }
10265   }
10266   while (ch != EOF_CHAR && (ch == flip || ch == flop)) {
10267     add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
10268     ch = char_scanner (f);
10269   }
10270   if (ch != EOF_CHAR) {
10271     unchar_scanner (p, f, (char) ch);
10272   }
10273 }
10274 
10275 /**
10276 @brief Scan a char from file.
10277 @param p Node in syntax tree.
10278 @param ref_file Fat pointer to A68 file.
10279 **/
10280 
10281 void
scan_char(NODE_T * p,A68_REF ref_file)10282 scan_char (NODE_T * p, A68_REF ref_file)
10283 {
10284   A68_FILE *f = FILE_DEREF (&ref_file);
10285   int ch;
10286   reset_transput_buffer (INPUT_BUFFER);
10287   ch = char_scanner (f);
10288   skip_nl_ff (p, &ch, ref_file);
10289   if (ch != EOF_CHAR) {
10290     add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
10291   }
10292 }
10293 
10294 /**
10295 @brief Scan a string from file.
10296 @param p Node in syntax tree.
10297 @param term String with terminators.
10298 @param ref_file Fat pointer to A68 file.
10299 **/
10300 
10301 void
scan_string(NODE_T * p,char * term,A68_REF ref_file)10302 scan_string (NODE_T * p, char *term, A68_REF ref_file)
10303 {
10304   A68_FILE *f = FILE_DEREF (&ref_file);
10305   if (END_OF_FILE (f)) {
10306     reset_transput_buffer (INPUT_BUFFER);
10307     end_of_file_error (p, ref_file);
10308   } else {
10309     BOOL_T go_on;
10310     int ch;
10311     reset_transput_buffer (INPUT_BUFFER);
10312     ch = char_scanner (f);
10313     go_on = A68_TRUE;
10314     while (go_on) {
10315       if (ch == EOF_CHAR || END_OF_FILE (f)) {
10316         if (get_transput_buffer_index (INPUT_BUFFER) == 0) {
10317           end_of_file_error (p, ref_file);
10318         }
10319         go_on = A68_FALSE;
10320       } else if (IS_NL_FF (ch)) {
10321         ADDR_T pop_sp = stack_pointer;
10322         unchar_scanner (p, f, (char) ch);
10323         if (ch == NEWLINE_CHAR) {
10324           on_event_handler (p, LINE_END_MENDED (f), ref_file);
10325         } else if (ch == FORMFEED_CHAR) {
10326           on_event_handler (p, PAGE_END_MENDED (f), ref_file);
10327         }
10328         stack_pointer = pop_sp;
10329         go_on = A68_FALSE;
10330       } else if (term != NO_TEXT && a68g_strchr (term, ch) != NO_TEXT) {
10331         go_on = A68_FALSE;
10332         unchar_scanner (p, f, (char) ch);
10333       } else {
10334         add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
10335         ch = char_scanner (f);
10336       }
10337     }
10338   }
10339 }
10340 
10341 /**
10342 @brief Make temp file name.
10343 @param fn Pointer to string to hold filename.
10344 @param flags Mode to open file with.
10345 @param permissions Permissions to open file with.
10346 @return Whether file is good for use.
10347 **/
10348 
10349 BOOL_T
a68g_mkstemp(char * fn,int flags,mode_t permissions)10350 a68g_mkstemp (char *fn, int flags, mode_t permissions)
10351 {
10352 /* "tmpnam" is not safe, "mkstemp" is Unix, so a68g brings its own tmpnam  */
10353 #define TMP_SIZE 32
10354 #define TRIALS 32
10355   char tfilename[BUFFER_SIZE];
10356   char *letters = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
10357   int i, k, len = (int) strlen (letters);
10358   BOOL_T good_file = A68_FALSE;
10359 /*
10360 Next are prefixes to try.
10361 First we try /tmp, and if that won't go, the current dir.
10362 */
10363   char *prefix[] = {
10364     "/tmp/a68g_",
10365     "./a68g_",
10366     NO_TEXT
10367   };
10368   for (i = 0; prefix[i] != NO_TEXT; i++) {
10369     for (k = 0; k < TRIALS && good_file == A68_FALSE; k++) {
10370       int j, cindex;
10371       FILE_T fd;
10372       bufcpy (tfilename, prefix[i], BUFFER_SIZE);
10373       for (j = 0; j < TMP_SIZE; j++) {
10374         char chars[2];
10375         do {
10376           cindex = (int) (rng_53_bit () * len);
10377         } while (cindex < 0 || cindex >= len);
10378         chars[0] = letters[cindex];
10379         chars[1] = NULL_CHAR;
10380         bufcat (tfilename, chars, BUFFER_SIZE);
10381       }
10382       bufcat (tfilename, ".tmp", BUFFER_SIZE);
10383       RESET_ERRNO;
10384       fd = open (tfilename, flags | O_EXCL, permissions);
10385       good_file = (BOOL_T) (fd != A68_NO_FILENO && errno == 0);
10386       if (good_file) {
10387         (void) close (fd);
10388       }
10389     }
10390   }
10391   if (good_file) {
10392     bufcpy (fn, tfilename, BUFFER_SIZE);
10393     return (A68_TRUE);
10394   } else {
10395     return (A68_FALSE);
10396   }
10397 #undef TMP_SIZE
10398 #undef TRIALS
10399 }
10400 
10401 /**
10402 @brief Open a file, or establish it.
10403 @param p Node in syntax tree.
10404 @param ref_file Fat pointer to A68 file.
10405 @param flags Required access mode.
10406 @param permissions Optional permissions.
10407 @return File number.
10408 **/
10409 
10410 FILE_T
open_physical_file(NODE_T * p,A68_REF ref_file,int flags,mode_t permissions)10411 open_physical_file (NODE_T * p, A68_REF ref_file, int flags, mode_t permissions)
10412 {
10413   A68_FILE *file;
10414   A68_REF ref_filename;
10415   char *filename;
10416   BOOL_T reading = (flags & ~O_BINARY) == A68_READ_ACCESS;
10417   BOOL_T writing = (flags & ~O_BINARY) == A68_WRITE_ACCESS;
10418   ABEND (reading == writing, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
10419   CHECK_REF (p, ref_file, MODE (REF_FILE));
10420   file = FILE_DEREF (&ref_file);
10421   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
10422   if (!IS_NIL (STRING (file))) {
10423     if (writing) {
10424       A68_REF z = *DEREF (A68_REF, &STRING (file));
10425       A68_ARRAY *a;
10426       A68_TUPLE *t;
10427       GET_DESCRIPTOR (a, t, &z);
10428       UPB (t) = LWB (t) - 1;
10429     }
10430 /* Associated file */
10431     TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p);
10432     reset_transput_buffer (TRANSPUT_BUFFER (file));
10433     END_OF_FILE (file) = A68_FALSE;
10434     FILE_ENTRY (file) = -1;
10435     return (FD (file));
10436   } else if (IS_NIL (IDENTIFICATION (file))) {
10437 /* No identification, so generate a unique identification. */
10438     if (reading) {
10439       return (A68_NO_FILENO);
10440     } else {
10441       char tfilename[BUFFER_SIZE];
10442       int len;
10443       if (!a68g_mkstemp (tfilename, flags, permissions)) {
10444         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NO_TEMP);
10445         exit_genie (p, A68_RUNTIME_ERROR);
10446       }
10447       FD (file) = open (tfilename, flags, permissions);
10448       len = 1 + (int) strlen (tfilename);
10449       IDENTIFICATION (file) = heap_generator (p, MODE (C_STRING), len);
10450       BLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
10451       bufcpy (DEREF (char, &IDENTIFICATION (file)), tfilename, len);
10452       TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p);
10453       reset_transput_buffer (TRANSPUT_BUFFER (file));
10454       END_OF_FILE (file) = A68_FALSE;
10455       TMP_FILE (file) = A68_TRUE;
10456       FILE_ENTRY (file) = store_file_entry (p, FD (file), tfilename, TMP_FILE (file));
10457       return (FD (file));
10458     }
10459   } else {
10460 /* Opening an identified file */
10461     ref_filename = IDENTIFICATION (file);
10462     CHECK_REF (p, ref_filename, MODE (ROWS));
10463     filename = DEREF (char, &ref_filename);
10464     if (OPEN_EXCLUSIVE (file)) {
10465 /* Establishing requires that the file does not exist */
10466       if (flags == (A68_WRITE_ACCESS)) {
10467         flags |= O_EXCL;
10468       }
10469       OPEN_EXCLUSIVE (file) = A68_FALSE;
10470     }
10471     FD (file) = open (filename, flags, permissions);
10472     TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p);
10473     reset_transput_buffer (TRANSPUT_BUFFER (file));
10474     END_OF_FILE (file) = A68_FALSE;
10475     FILE_ENTRY (file) = store_file_entry (p, FD (file), filename, TMP_FILE (file));
10476     return (FD (file));
10477   }
10478 }
10479 
10480 /**
10481 @brief Call PROC (REF FILE) VOID during transput.
10482 @param p Node in syntax tree.
10483 @param ref_file Fat pointer to A68 file.
10484 @param z A68 routine to call
10485 **/
10486 
10487 void
genie_call_proc_ref_file_void(NODE_T * p,A68_REF ref_file,A68_PROCEDURE z)10488 genie_call_proc_ref_file_void (NODE_T * p, A68_REF ref_file, A68_PROCEDURE z)
10489 {
10490   ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer;
10491   MOID_T *u = MODE (PROC_REF_FILE_VOID);
10492   PUSH_REF (p, ref_file);
10493   genie_call_procedure (p, MOID (&z), u, u, &z, pop_sp, pop_fp);
10494   stack_pointer = pop_sp;       /* VOIDING */
10495 }
10496 
10497 /* Unformatted transput */
10498 
10499 /**
10500 @brief Hexadecimal value of digit.
10501 @param ch Digit.
10502 @return See brief description.
10503 **/
10504 
10505 static int
char_value(int ch)10506 char_value (int ch)
10507 {
10508   switch (ch) {
10509   case '0':
10510     {
10511       return (0);
10512     }
10513   case '1':
10514     {
10515       return (1);
10516     }
10517   case '2':
10518     {
10519       return (2);
10520     }
10521   case '3':
10522     {
10523       return (3);
10524     }
10525   case '4':
10526     {
10527       return (4);
10528     }
10529   case '5':
10530     {
10531       return (5);
10532     }
10533   case '6':
10534     {
10535       return (6);
10536     }
10537   case '7':
10538     {
10539       return (7);
10540     }
10541   case '8':
10542     {
10543       return (8);
10544     }
10545   case '9':
10546     {
10547       return (9);
10548     }
10549   case 'A':
10550   case 'a':
10551     {
10552       return (10);
10553     }
10554   case 'B':
10555   case 'b':
10556     {
10557       return (11);
10558     }
10559   case 'C':
10560   case 'c':
10561     {
10562       return (12);
10563     }
10564   case 'D':
10565   case 'd':
10566     {
10567       return (13);
10568     }
10569   case 'E':
10570   case 'e':
10571     {
10572       return (14);
10573     }
10574   case 'F':
10575   case 'f':
10576     {
10577       return (15);
10578     }
10579   default:
10580     {
10581       return (-1);
10582     }
10583   }
10584 }
10585 
10586 /**
10587 @brief Own strtoul; some systems have no strtoul.
10588 @param str String representing an unsigned int denotation.
10589 @param end Points to first character after denotation.
10590 @param base Exponent base.
10591 @return Value of denotation in str.
10592 **/
10593 
10594 unsigned
a68g_strtoul(char * str,char ** end,int base)10595 a68g_strtoul (char *str, char **end, int base)
10596 {
10597   if (str == NO_TEXT || str[0] == NULL_CHAR) {
10598     (*end) = NO_TEXT;
10599     errno = EDOM;
10600     return (0);
10601   } else {
10602     int j, k = 0, start;
10603     char *q = str;
10604     unsigned mul = 1, sum = 0;
10605     while (IS_SPACE (q[k])) {
10606       k++;
10607     }
10608     if (q[k] == '+') {
10609       k++;
10610     }
10611     start = k;
10612     while (IS_XDIGIT (q[k])) {
10613       k++;
10614     }
10615     if (k == start) {
10616       if (end != NO_VAR) {
10617         *end = str;
10618       }
10619       errno = EDOM;
10620       return (0);
10621     }
10622     if (end != NO_VAR) {
10623       (*end) = &q[k];
10624     }
10625     for (j = k - 1; j >= start; j--) {
10626       if (char_value (q[j]) >= base) {
10627         errno = EDOM;
10628         return (0);
10629       } else {
10630         unsigned add = (unsigned) ((unsigned) (char_value (q[j])) * mul);
10631         if (A68_MAX_UNT - sum >= add) {
10632           sum += add;
10633           mul *= (unsigned) base;
10634         } else {
10635           errno = ERANGE;
10636           return (0);
10637         }
10638       }
10639     }
10640     return (sum);
10641   }
10642 }
10643 
10644 /**
10645 @brief INT value of BITS denotation
10646 @param p Node in syntax tree.
10647 @param str String with BITS denotation.
10648 @return See brief description.
10649 **/
10650 
10651 static unsigned
bits_to_int(NODE_T * p,char * str)10652 bits_to_int (NODE_T * p, char *str)
10653 {
10654   int base = 0;
10655   unsigned bits = 0;
10656   char *radix = NO_TEXT, *end = NO_TEXT;
10657   RESET_ERRNO;
10658   base = (int) a68g_strtoul (str, &radix, 10);
10659   if (radix != NO_TEXT && TO_UPPER (radix[0]) == TO_UPPER (RADIX_CHAR) && errno == 0) {
10660     if (base < 2 || base > 16) {
10661       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, base);
10662       exit_genie (p, A68_RUNTIME_ERROR);
10663     }
10664     bits = a68g_strtoul (&(radix[1]), &end, base);
10665     if (end != NO_TEXT && end[0] == NULL_CHAR && errno == 0) {
10666       return (bits);
10667     }
10668   }
10669   diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, MODE (BITS));
10670   exit_genie (p, A68_RUNTIME_ERROR);
10671   return (0);
10672 }
10673 
10674 /**
10675 @brief LONG BITS value of LONG BITS denotation
10676 @param p Node in syntax tree.
10677 @param z Multi-precision number.
10678 @param str String with LONG BITS denotation .
10679 @param m Mode of 'z'.
10680 **/
10681 
10682 static void
long_bits_to_long_int(NODE_T * p,MP_T * z,char * str,MOID_T * m)10683 long_bits_to_long_int (NODE_T * p, MP_T * z, char *str, MOID_T * m)
10684 {
10685   int base = 0;
10686   char *radix = NO_TEXT;
10687   RESET_ERRNO;
10688   base = (int) a68g_strtoul (str, &radix, 10);
10689   if (radix != NO_TEXT && TO_UPPER (radix[0]) == TO_UPPER (RADIX_CHAR) && errno == 0) {
10690     int digits = DIGITS (m);
10691     ADDR_T pop_sp = stack_pointer;
10692     MP_T *v;
10693     MP_T *w;
10694     char *q = radix;
10695     STACK_MP (v, p, digits);
10696     STACK_MP (w, p, digits);
10697     while (q[0] != NULL_CHAR) {
10698       q++;
10699     }
10700     SET_MP_ZERO (z, digits);
10701     (void) set_mp_short (w, (MP_T) 1, 0, digits);
10702     if (base < 2 || base > 16) {
10703       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, base);
10704       exit_genie (p, A68_RUNTIME_ERROR);
10705     }
10706     while ((--q) != radix) {
10707       int digit = char_value (q[0]);
10708       if (digit >= 0 && digit < base) {
10709         (void) mul_mp_digit (p, v, w, (MP_T) digit, digits);
10710         (void) add_mp (p, z, z, v, digits);
10711       } else {
10712         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m);
10713         exit_genie (p, A68_RUNTIME_ERROR);
10714       }
10715       (void) mul_mp_digit (p, w, w, (MP_T) base, digits);
10716     }
10717     check_long_bits_value (p, z, m);
10718     stack_pointer = pop_sp;
10719   } else {
10720     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m);
10721     exit_genie (p, A68_RUNTIME_ERROR);
10722   }
10723 }
10724 
10725 /**
10726 @brief Convert string to required mode and store.
10727 @param p Node in syntax tree.
10728 @param m Mode to convert to.
10729 @param a String to convert.
10730 @param item Where to store result.
10731 @return Whether conversion is successful.
10732 **/
10733 
10734 BOOL_T
genie_string_to_value_internal(NODE_T * p,MOID_T * m,char * a,BYTE_T * item)10735 genie_string_to_value_internal (NODE_T * p, MOID_T * m, char *a, BYTE_T * item)
10736 {
10737   RESET_ERRNO;
10738 /* strto.. does not mind empty strings */
10739   if (strlen (a) == 0) {
10740     return (A68_FALSE);
10741   }
10742   if (m == MODE (INT)) {
10743     A68_INT *z = (A68_INT *) item;
10744     char *end;
10745     VALUE (z) = (int) strtol (a, &end, 10);
10746     if (end[0] == NULL_CHAR && errno == 0) {
10747       STATUS (z) = INIT_MASK;
10748       return (A68_TRUE);
10749     } else {
10750       return (A68_FALSE);
10751     }
10752   } else if (m == MODE (REAL)) {
10753     A68_REAL *z = (A68_REAL *) item;
10754     char *end;
10755     VALUE (z) = strtod (a, &end);
10756     if (end[0] == NULL_CHAR && errno == 0) {
10757       STATUS (z) = INIT_MASK;
10758       return (A68_TRUE);
10759     } else {
10760       return (A68_FALSE);
10761     }
10762   } else if (m == MODE (LONG_INT) || m == MODE (LONGLONG_INT)) {
10763     int digits = DIGITS (m);
10764     MP_T *z = (MP_T *) item;
10765     if (string_to_mp (p, z, a, digits) == NO_MP) {
10766       return (A68_FALSE);
10767     }
10768     if (!check_mp_int (z, m)) {
10769       errno = ERANGE;
10770       return (A68_FALSE);
10771     }
10772     MP_STATUS (z) = (MP_T) INIT_MASK;
10773     return (A68_TRUE);
10774   } else if (m == MODE (LONG_REAL) || m == MODE (LONGLONG_REAL)) {
10775     int digits = DIGITS (m);
10776     MP_T *z = (MP_T *) item;
10777     if (string_to_mp (p, z, a, digits) == NO_MP) {
10778       return (A68_FALSE);
10779     }
10780     MP_STATUS (z) = (MP_T) INIT_MASK;
10781     return (A68_TRUE);
10782   } else if (m == MODE (BOOL)) {
10783     A68_BOOL *z = (A68_BOOL *) item;
10784     char q = a[0], flip = FLIP_CHAR, flop = FLOP_CHAR;
10785     if (q == flip || q == flop) {
10786       VALUE (z) = (BOOL_T) (q == flip);
10787       STATUS (z) = INIT_MASK;
10788       return (A68_TRUE);
10789     } else {
10790       return (A68_FALSE);
10791     }
10792   } else if (m == MODE (BITS)) {
10793     A68_BITS *z = (A68_BITS *) item;
10794     int status = A68_TRUE;
10795     if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) {
10796 /* [] BOOL denotation is "TTFFFFTFT ..." */
10797       if (strlen (a) > (size_t) BITS_WIDTH) {
10798         errno = ERANGE;
10799         status = A68_FALSE;
10800       } else {
10801         int j = (int) strlen (a) - 1;
10802         unsigned k = 0x1;
10803         VALUE (z) = 0;
10804         for (; j >= 0; j--) {
10805           if (a[j] == FLIP_CHAR) {
10806             VALUE (z) += k;
10807           } else if (a[j] != FLOP_CHAR) {
10808             status = A68_FALSE;
10809           }
10810           k <<= 1;
10811         }
10812       }
10813     } else {
10814 /* BITS denotation is also allowed */
10815       VALUE (z) = bits_to_int (p, a);
10816     }
10817     if (errno != 0 || status == A68_FALSE) {
10818       return (A68_FALSE);
10819     }
10820     STATUS (z) = INIT_MASK;
10821     return (A68_TRUE);
10822   } else if (m == MODE (LONG_BITS) || m == MODE (LONGLONG_BITS)) {
10823     int digits = DIGITS (m);
10824     int status = A68_TRUE;
10825     ADDR_T pop_sp = stack_pointer;
10826     MP_T *z = (MP_T *) item;
10827     if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) {
10828 /* [] BOOL denotation is "TTFFFFTFT ..." */
10829       if (strlen (a) > (size_t) BITS_WIDTH) {
10830         errno = ERANGE;
10831         status = A68_FALSE;
10832       } else {
10833         int j;
10834         MP_T *w;
10835         STACK_MP (w, p, digits);
10836         SET_MP_ZERO (z, digits);
10837         (void) set_mp_short (w, (MP_T) 1, 0, digits);
10838         for (j = (int) strlen (a) - 1; j >= 0; j--) {
10839           if (a[j] == FLIP_CHAR) {
10840             (void) add_mp (p, z, z, w, digits);
10841           } else if (a[j] != FLOP_CHAR) {
10842             status = A68_FALSE;
10843           }
10844           (void) mul_mp_digit (p, w, w, (MP_T) 2, digits);
10845         }
10846       }
10847     } else {
10848 /* BITS denotation is also allowed */
10849       long_bits_to_long_int (p, z, a, m);
10850     }
10851     stack_pointer = pop_sp;
10852     if (errno != 0 || status == A68_FALSE) {
10853       return (A68_FALSE);
10854     }
10855     MP_STATUS (z) = (MP_T) INIT_MASK;
10856     return (A68_TRUE);
10857   }
10858   return (A68_FALSE);
10859 }
10860 
10861 /**
10862 @brief Convert string in input buffer to value of required mode.
10863 @param p Node in syntax tree.
10864 @param mode Mode to convert to.
10865 @param item Where to store result.
10866 @param ref_file Fat pointer to A68 file.
10867 **/
10868 
10869 void
genie_string_to_value(NODE_T * p,MOID_T * mode,BYTE_T * item,A68_REF ref_file)10870 genie_string_to_value (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
10871 {
10872   char *str = get_transput_buffer (INPUT_BUFFER);
10873   RESET_ERRNO;
10874 /* end string, just in case */
10875   add_char_transput_buffer (p, INPUT_BUFFER, NULL_CHAR);
10876   if (mode == MODE (INT)) {
10877     if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
10878       value_error (p, mode, ref_file);
10879     }
10880   } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) {
10881     if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
10882       value_error (p, mode, ref_file);
10883     }
10884   } else if (mode == MODE (REAL)) {
10885     if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
10886       value_error (p, mode, ref_file);
10887     }
10888   } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) {
10889     if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
10890       value_error (p, mode, ref_file);
10891     }
10892   } else if (mode == MODE (BOOL)) {
10893     if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
10894       value_error (p, mode, ref_file);
10895     }
10896   } else if (mode == MODE (BITS)) {
10897     if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
10898       value_error (p, mode, ref_file);
10899     }
10900   } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) {
10901     if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
10902       value_error (p, mode, ref_file);
10903     }
10904   } else if (mode == MODE (CHAR)) {
10905     A68_CHAR *z = (A68_CHAR *) item;
10906     if (str[0] == NULL_CHAR) {
10907 /*      value_error (p, mode, ref_file); */
10908       VALUE (z) = NULL_CHAR;
10909       STATUS (z) = INIT_MASK;
10910     } else {
10911       int len = (int) strlen (str);
10912       if (len == 0 || len > 1) {
10913         value_error (p, mode, ref_file);
10914       }
10915       VALUE (z) = str[0];
10916       STATUS (z) = INIT_MASK;
10917     }
10918   } else if (mode == MODE (STRING)) {
10919     A68_REF z;
10920     z = c_to_a_string (p, str, get_transput_buffer_index (INPUT_BUFFER) - 1);
10921 /*
10922     z = c_to_a_string (p, str, DEFAULT_WIDTH);
10923 */
10924     *(A68_REF *) item = z;
10925   }
10926   if (errno != 0) {
10927     transput_error (p, ref_file, mode);
10928   }
10929 }
10930 
10931 /**
10932 @brief Read object from file.
10933 @param p Node in syntax tree.
10934 @param mode Mode to read.
10935 @param item Where to store result.
10936 @param ref_file Fat pointer to A68 file.
10937 **/
10938 
10939 void
genie_read_standard(NODE_T * p,MOID_T * mode,BYTE_T * item,A68_REF ref_file)10940 genie_read_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
10941 {
10942   A68_FILE *f = FILE_DEREF (&ref_file);
10943   RESET_ERRNO;
10944   if (END_OF_FILE (f)) {
10945     end_of_file_error (p, ref_file);
10946   }
10947   if (mode == MODE (PROC_REF_FILE_VOID)) {
10948     genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item);
10949   } else if (mode == MODE (FORMAT)) {
10950     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (FORMAT));
10951     exit_genie (p, A68_RUNTIME_ERROR);
10952   } else if (mode == MODE (REF_SOUND)) {
10953     read_sound (p, ref_file, DEREF (A68_SOUND, (A68_REF *) item));
10954   } else if (IS (mode, REF_SYMBOL)) {
10955     CHECK_REF (p, *(A68_REF *) item, mode);
10956     genie_read_standard (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file);
10957   } else if (mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) {
10958     scan_integer (p, ref_file);
10959     genie_string_to_value (p, mode, item, ref_file);
10960   } else if (mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) {
10961     scan_real (p, ref_file);
10962     genie_string_to_value (p, mode, item, ref_file);
10963   } else if (mode == MODE (BOOL)) {
10964     scan_char (p, ref_file);
10965     genie_string_to_value (p, mode, item, ref_file);
10966   } else if (mode == MODE (CHAR)) {
10967     scan_char (p, ref_file);
10968     genie_string_to_value (p, mode, item, ref_file);
10969   } else if (mode == MODE (BITS) || mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) {
10970     scan_bits (p, ref_file);
10971     genie_string_to_value (p, mode, item, ref_file);
10972   } else if (mode == MODE (STRING)) {
10973     char *term = DEREF (char, &TERMINATOR (f));
10974     scan_string (p, term, ref_file);
10975     genie_string_to_value (p, mode, item, ref_file);
10976   } else if (IS (mode, STRUCT_SYMBOL)) {
10977     PACK_T *q = PACK (mode);
10978     for (; q != NO_PACK; FORWARD (q)) {
10979       genie_read_standard (p, MOID (q), &item[OFFSET (q)], ref_file);
10980     }
10981   } else if (IS (mode, UNION_SYMBOL)) {
10982     A68_UNION *z = (A68_UNION *) item;
10983     if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) {
10984       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
10985       exit_genie (p, A68_RUNTIME_ERROR);
10986     }
10987     genie_read_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file);
10988   } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) {
10989     MOID_T *deflexed = DEFLEX (mode);
10990     A68_ARRAY *arr;
10991     A68_TUPLE *tup;
10992     CHECK_INIT (p, INITIALISED ((A68_REF *) item), mode);
10993     GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
10994     if (get_row_size (tup, DIM (arr)) > 0) {
10995       BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
10996       BOOL_T done = A68_FALSE;
10997       initialise_internal_index (tup, DIM (arr));
10998       while (!done) {
10999         ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
11000         ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
11001         genie_read_standard (p, SUB (deflexed), &base_addr[elem_addr], ref_file);
11002         done = increment_internal_index (tup, DIM (arr));
11003       }
11004     }
11005   }
11006   if (errno != 0) {
11007     transput_error (p, ref_file, mode);
11008   }
11009 }
11010 
11011 /**
11012 @brief PROC ([] SIMPLIN) VOID read
11013 @param p Node in syntax tree.
11014 **/
11015 
11016 void
genie_read(NODE_T * p)11017 genie_read (NODE_T * p)
11018 {
11019   A68_REF row;
11020   POP_REF (p, &row);
11021   genie_stand_in (p);
11022   PUSH_REF (p, row);
11023   genie_read_file (p);
11024 }
11025 
11026 /**
11027 @brief Open for reading.
11028 @param p Node in syntax tree.
11029 @param ref_file File to open.
11030 **/
11031 
11032 void
open_for_reading(NODE_T * p,A68_REF ref_file)11033 open_for_reading (NODE_T * p, A68_REF ref_file)
11034 {
11035   A68_FILE *file = FILE_DEREF (&ref_file);
11036   if (!OPENED (file)) {
11037     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
11038     exit_genie (p, A68_RUNTIME_ERROR);
11039   }
11040   if (DRAW_MOOD (file)) {
11041     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
11042     exit_genie (p, A68_RUNTIME_ERROR);
11043   }
11044   if (WRITE_MOOD (file)) {
11045     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
11046     exit_genie (p, A68_RUNTIME_ERROR);
11047   }
11048   if (!GET (&CHANNEL (file))) {
11049     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
11050     exit_genie (p, A68_RUNTIME_ERROR);
11051   }
11052   if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
11053     if (IS_NIL (STRING (file))) {
11054       if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0)) == A68_NO_FILENO) {
11055         open_error (p, ref_file, "getting");
11056       }
11057     } else {
11058       FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0);
11059     }
11060     DRAW_MOOD (file) = A68_FALSE;
11061     READ_MOOD (file) = A68_TRUE;
11062     WRITE_MOOD (file) = A68_FALSE;
11063     CHAR_MOOD (file) = A68_TRUE;
11064   }
11065   if (!CHAR_MOOD (file)) {
11066     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
11067     exit_genie (p, A68_RUNTIME_ERROR);
11068   }
11069 }
11070 
11071 /**
11072 @brief PROC (REF FILE, [] SIMPLIN) VOID get
11073 @param p Node in syntax tree.
11074 **/
11075 
11076 void
genie_read_file(NODE_T * p)11077 genie_read_file (NODE_T * p)
11078 {
11079   A68_REF ref_file;
11080   A68_FILE *file;
11081   A68_REF row;
11082   A68_ARRAY *arr;
11083   A68_TUPLE *tup;
11084   BYTE_T *base_address;
11085   int elems, k, elem_index;
11086   POP_REF (p, &row);
11087   CHECK_REF (p, row, MODE (ROW_SIMPLIN));
11088   GET_DESCRIPTOR (arr, tup, &row);
11089   elems = ROW_SIZE (tup);
11090   POP_REF (p, &ref_file);
11091   CHECK_REF (p, ref_file, MODE (REF_FILE));
11092   file = FILE_DEREF (&ref_file);
11093   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
11094   open_for_reading (p, ref_file);
11095 /* Read */
11096   if (elems <= 0) {
11097     return;
11098   }
11099   base_address = DEREF (BYTE_T, &ARRAY (arr));
11100   elem_index = 0;
11101   for (k = 0; k < elems; k++) {
11102     A68_UNION *z = (A68_UNION *) & base_address[elem_index];
11103     MOID_T *mode = (MOID_T *) (VALUE (z));
11104     BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
11105     genie_read_standard (p, mode, item, ref_file);
11106     elem_index += SIZE (MODE (SIMPLIN));
11107   }
11108 }
11109 
11110 /**
11111 @brief Convert value to string.
11112 @param p Node in syntax tree.
11113 @param moid Mode to convert to.
11114 @param item Pointer to value.
11115 @param mod Format modifier.
11116 **/
11117 
11118 void
genie_value_to_string(NODE_T * p,MOID_T * moid,BYTE_T * item,int mod)11119 genie_value_to_string (NODE_T * p, MOID_T * moid, BYTE_T * item, int mod)
11120 {
11121   if (moid == MODE (INT)) {
11122     A68_INT *z = (A68_INT *) item;
11123     PUSH_UNION (p, MODE (INT));
11124     PUSH_PRIMITIVE (p, VALUE (z), A68_INT);
11125     INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (INT))));
11126     if (mod == FORMAT_ITEM_G) {
11127       PUSH_PRIMITIVE (p, INT_WIDTH + 1, A68_INT);
11128       genie_whole (p);
11129     } else if (mod == FORMAT_ITEM_H) {
11130       PUSH_PRIMITIVE (p, REAL_WIDTH + EXP_WIDTH + 4, A68_INT);
11131       PUSH_PRIMITIVE (p, REAL_WIDTH - 1, A68_INT);
11132       PUSH_PRIMITIVE (p, EXP_WIDTH + 1, A68_INT);
11133       PUSH_PRIMITIVE (p, 3, A68_INT);
11134       genie_real (p);
11135     }
11136   } else if (moid == MODE (LONG_INT)) {
11137     MP_T *z = (MP_T *) item;
11138     PUSH_UNION (p, MODE (LONG_INT));
11139     PUSH (p, z, SIZE (MODE (LONG_INT)));
11140     INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (LONG_INT))));
11141     if (mod == FORMAT_ITEM_G) {
11142       PUSH_PRIMITIVE (p, LONG_WIDTH + 1, A68_INT);
11143       genie_whole (p);
11144     } else if (mod == FORMAT_ITEM_H) {
11145       PUSH_PRIMITIVE (p, LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4, A68_INT);
11146       PUSH_PRIMITIVE (p, LONG_REAL_WIDTH - 1, A68_INT);
11147       PUSH_PRIMITIVE (p, LONG_EXP_WIDTH + 1, A68_INT);
11148       PUSH_PRIMITIVE (p, 3, A68_INT);
11149       genie_real (p);
11150     }
11151   } else if (moid == MODE (LONGLONG_INT)) {
11152     MP_T *z = (MP_T *) item;
11153     PUSH_UNION (p, MODE (LONGLONG_INT));
11154     PUSH (p, z, SIZE (MODE (LONGLONG_INT)));
11155     INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (LONGLONG_INT))));
11156     if (mod == FORMAT_ITEM_G) {
11157       PUSH_PRIMITIVE (p, LONGLONG_WIDTH + 1, A68_INT);
11158       genie_whole (p);
11159     } else if (mod == FORMAT_ITEM_H) {
11160       PUSH_PRIMITIVE (p, LONGLONG_REAL_WIDTH + LONGLONG_EXP_WIDTH + 4, A68_INT);
11161       PUSH_PRIMITIVE (p, LONGLONG_REAL_WIDTH - 1, A68_INT);
11162       PUSH_PRIMITIVE (p, LONGLONG_EXP_WIDTH + 1, A68_INT);
11163       PUSH_PRIMITIVE (p, 3, A68_INT);
11164       genie_real (p);
11165     }
11166   } else if (moid == MODE (REAL)) {
11167     A68_REAL *z = (A68_REAL *) item;
11168     PUSH_UNION (p, MODE (REAL));
11169     PUSH_PRIMITIVE (p, VALUE (z), A68_REAL);
11170     INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (REAL))));
11171     PUSH_PRIMITIVE (p, REAL_WIDTH + EXP_WIDTH + 4, A68_INT);
11172     PUSH_PRIMITIVE (p, REAL_WIDTH - 1, A68_INT);
11173     PUSH_PRIMITIVE (p, EXP_WIDTH + 1, A68_INT);
11174     if (mod == FORMAT_ITEM_G) {
11175       genie_float (p);
11176     } else if (mod == FORMAT_ITEM_H) {
11177       PUSH_PRIMITIVE (p, 3, A68_INT);
11178       genie_real (p);
11179     }
11180   } else if (moid == MODE (LONG_REAL)) {
11181     MP_T *z = (MP_T *) item;
11182     PUSH_UNION (p, MODE (LONG_REAL));
11183     PUSH (p, z, (int) SIZE (MODE (LONG_REAL)));
11184     INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (LONG_REAL))));
11185     PUSH_PRIMITIVE (p, LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4, A68_INT);
11186     PUSH_PRIMITIVE (p, LONG_REAL_WIDTH - 1, A68_INT);
11187     PUSH_PRIMITIVE (p, LONG_EXP_WIDTH + 1, A68_INT);
11188     if (mod == FORMAT_ITEM_G) {
11189       genie_float (p);
11190     } else if (mod == FORMAT_ITEM_H) {
11191       PUSH_PRIMITIVE (p, 3, A68_INT);
11192       genie_real (p);
11193     }
11194   } else if (moid == MODE (LONGLONG_REAL)) {
11195     MP_T *z = (MP_T *) item;
11196     PUSH_UNION (p, MODE (LONGLONG_REAL));
11197     PUSH (p, z, (int) SIZE (MODE (LONGLONG_REAL)));
11198     INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (LONGLONG_REAL))));
11199     PUSH_PRIMITIVE (p, LONGLONG_REAL_WIDTH + LONGLONG_EXP_WIDTH + 4, A68_INT);
11200     PUSH_PRIMITIVE (p, LONGLONG_REAL_WIDTH - 1, A68_INT);
11201     PUSH_PRIMITIVE (p, LONGLONG_EXP_WIDTH + 1, A68_INT);
11202     if (mod == FORMAT_ITEM_G) {
11203       genie_float (p);
11204     } else if (mod == FORMAT_ITEM_H) {
11205       PUSH_PRIMITIVE (p, 3, A68_INT);
11206       genie_real (p);
11207     }
11208   } else if (moid == MODE (BITS)) {
11209     A68_BITS *z = (A68_BITS *) item;
11210     char *str = stack_string (p, 8 + BITS_WIDTH);
11211     unsigned bit = 0x1;
11212     int j;
11213     for (j = 1; j < BITS_WIDTH; j++) {
11214       bit <<= 1;
11215     }
11216     for (j = 0; j < BITS_WIDTH; j++) {
11217       str[j] = (char) ((VALUE (z) & bit) ? FLIP_CHAR : FLOP_CHAR);
11218       bit >>= 1;
11219     }
11220     str[j] = NULL_CHAR;
11221   } else if (moid == MODE (LONG_BITS) || moid == MODE (LONGLONG_BITS)) {
11222     int bits = get_mp_bits_width (moid), word = get_mp_bits_words (moid);
11223     int cher = bits;
11224     char *str = stack_string (p, 8 + bits);
11225     ADDR_T pop_sp = stack_pointer;
11226     unsigned *row = stack_mp_bits (p, (MP_T *) item, moid);
11227     str[cher--] = NULL_CHAR;
11228     while (cher >= 0) {
11229       unsigned bit = 0x1;
11230       int j;
11231       for (j = 0; j < MP_BITS_BITS && cher >= 0; j++) {
11232         str[cher--] = (char) ((row[word - 1] & bit) ? FLIP_CHAR : FLOP_CHAR);
11233         bit <<= 1;
11234       }
11235       word--;
11236     }
11237     stack_pointer = pop_sp;
11238   }
11239 }
11240 
11241 /**
11242 @brief Print object to file.
11243 @param p Node in syntax tree.
11244 @param mode Mode of object to print.
11245 @param item Pointer to value.
11246 @param ref_file Fat pointer to A68 file.
11247 **/
11248 
11249 void
genie_write_standard(NODE_T * p,MOID_T * mode,BYTE_T * item,A68_REF ref_file)11250 genie_write_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
11251 {
11252   RESET_ERRNO;
11253   if (mode == MODE (PROC_REF_FILE_VOID)) {
11254     genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item);
11255   } else if (mode == MODE (FORMAT)) {
11256     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (FORMAT));
11257     exit_genie (p, A68_RUNTIME_ERROR);
11258   } else if (mode == MODE (SOUND)) {
11259     write_sound (p, ref_file, (A68_SOUND *) item);
11260   } else if (mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) {
11261     genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
11262     add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER);
11263   } else if (mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) {
11264     genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
11265     add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER);
11266   } else if (mode == MODE (BOOL)) {
11267     A68_BOOL *z = (A68_BOOL *) item;
11268     char flipflop = (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR);
11269     add_char_transput_buffer (p, UNFORMATTED_BUFFER, flipflop);
11270   } else if (mode == MODE (CHAR)) {
11271     A68_CHAR *ch = (A68_CHAR *) item;
11272     add_char_transput_buffer (p, UNFORMATTED_BUFFER, (char) VALUE (ch));
11273   } else if (mode == MODE (BITS) || mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) {
11274     char *str = (char *) STACK_TOP;
11275     genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
11276     add_string_transput_buffer (p, UNFORMATTED_BUFFER, str);
11277   } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) {
11278 /* Handle these separately since this is faster than straightening */
11279     add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item);
11280   } else if (IS (mode, UNION_SYMBOL)) {
11281     A68_UNION *z = (A68_UNION *) item;
11282     genie_write_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file);
11283   } else if (IS (mode, STRUCT_SYMBOL)) {
11284     PACK_T *q = PACK (mode);
11285     for (; q != NO_PACK; FORWARD (q)) {
11286       BYTE_T *elem = &item[OFFSET (q)];
11287       genie_check_initialisation (p, elem, MOID (q));
11288       genie_write_standard (p, MOID (q), elem, ref_file);
11289     }
11290   } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) {
11291     MOID_T *deflexed = DEFLEX (mode);
11292     A68_ARRAY *arr;
11293     A68_TUPLE *tup;
11294     CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS));
11295     GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
11296     if (get_row_size (tup, DIM (arr)) > 0) {
11297       BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
11298       BOOL_T done = A68_FALSE;
11299       initialise_internal_index (tup, DIM (arr));
11300       while (!done) {
11301         ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
11302         ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
11303         BYTE_T *elem = &base_addr[elem_addr];
11304         genie_check_initialisation (p, elem, SUB (deflexed));
11305         genie_write_standard (p, SUB (deflexed), elem, ref_file);
11306         done = increment_internal_index (tup, DIM (arr));
11307       }
11308     }
11309   }
11310   if (errno != 0) {
11311     ABEND (IS_NIL (ref_file), "conversion error: ", error_specification ());
11312     transput_error (p, ref_file, mode);
11313   }
11314 }
11315 
11316 /**
11317 @brief PROC ([] SIMPLOUT) VOID print, write
11318 @param p Node in syntax tree.
11319 **/
11320 
11321 void
genie_write(NODE_T * p)11322 genie_write (NODE_T * p)
11323 {
11324   A68_REF row;
11325   POP_REF (p, &row);
11326   genie_stand_out (p);
11327   PUSH_REF (p, row);
11328   genie_write_file (p);
11329 }
11330 
11331 /**
11332 @brief Open for writing.
11333 @param p Node in syntax tree.
11334 @param ref_file File to open.
11335 **/
11336 
11337 void
open_for_writing(NODE_T * p,A68_REF ref_file)11338 open_for_writing (NODE_T * p, A68_REF ref_file)
11339 {
11340   A68_FILE *file = FILE_DEREF (&ref_file);
11341   if (!OPENED (file)) {
11342     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
11343     exit_genie (p, A68_RUNTIME_ERROR);
11344   }
11345   if (DRAW_MOOD (file)) {
11346     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
11347     exit_genie (p, A68_RUNTIME_ERROR);
11348   }
11349   if (READ_MOOD (file)) {
11350     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
11351     exit_genie (p, A68_RUNTIME_ERROR);
11352   }
11353   if (!PUT (&CHANNEL (file))) {
11354     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
11355     exit_genie (p, A68_RUNTIME_ERROR);
11356   }
11357   if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
11358     if (IS_NIL (STRING (file))) {
11359       if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, A68_PROTECTION)) == A68_NO_FILENO) {
11360         open_error (p, ref_file, "putting");
11361       }
11362     } else {
11363       FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, 0);
11364     }
11365     DRAW_MOOD (file) = A68_FALSE;
11366     READ_MOOD (file) = A68_FALSE;
11367     WRITE_MOOD (file) = A68_TRUE;
11368     CHAR_MOOD (file) = A68_TRUE;
11369   }
11370   if (!CHAR_MOOD (file)) {
11371     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
11372     exit_genie (p, A68_RUNTIME_ERROR);
11373   }
11374 }
11375 
11376 /**
11377 @brief PROC (REF FILE, [] SIMPLOUT) VOID put
11378 @param p Node in syntax tree.
11379 **/
11380 
11381 void
genie_write_file(NODE_T * p)11382 genie_write_file (NODE_T * p)
11383 {
11384   A68_REF ref_file;
11385   A68_FILE *file;
11386   A68_REF row;
11387   A68_ARRAY *arr;
11388   A68_TUPLE *tup;
11389   BYTE_T *base_address;
11390   int elems, k, elem_index;
11391   POP_REF (p, &row);
11392   CHECK_REF (p, row, MODE (ROW_SIMPLOUT));
11393   GET_DESCRIPTOR (arr, tup, &row);
11394   elems = ROW_SIZE (tup);
11395   POP_REF (p, &ref_file);
11396   CHECK_REF (p, ref_file, MODE (REF_FILE));
11397   file = FILE_DEREF (&ref_file);
11398   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
11399   open_for_writing (p, ref_file);
11400 /* Write. */
11401   if (elems <= 0) {
11402     return;
11403   }
11404   base_address = DEREF (BYTE_T, &ARRAY (arr));
11405   elem_index = 0;
11406   for (k = 0; k < elems; k++) {
11407     A68_UNION *z = (A68_UNION *) & (base_address[elem_index]);
11408     MOID_T *mode = (MOID_T *) (VALUE (z));
11409     BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
11410     reset_transput_buffer (UNFORMATTED_BUFFER);
11411     genie_write_standard (p, mode, item, ref_file);
11412     write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);
11413     elem_index += SIZE (MODE (SIMPLOUT));
11414   }
11415 }
11416 
11417 /**
11418 @brief Read object binary from file.
11419 @param p Node in syntax tree.
11420 @param mode Mode to read.
11421 @param item Pointer to value.
11422 @param ref_file Fat pointer to A68 file.
11423 **/
11424 
11425 static void
genie_read_bin_standard(NODE_T * p,MOID_T * mode,BYTE_T * item,A68_REF ref_file)11426 genie_read_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
11427 {
11428   A68_FILE *f;
11429   CHECK_REF (p, ref_file, MODE (REF_FILE));
11430   f = FILE_DEREF (&ref_file);
11431   RESET_ERRNO;
11432   if (END_OF_FILE (f)) {
11433     end_of_file_error (p, ref_file);
11434   }
11435   if (mode == MODE (PROC_REF_FILE_VOID)) {
11436     genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item);
11437   } else if (mode == MODE (FORMAT)) {
11438     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (FORMAT));
11439     exit_genie (p, A68_RUNTIME_ERROR);
11440   } else if (mode == MODE (REF_SOUND)) {
11441     read_sound (p, ref_file, (A68_SOUND *) ADDRESS ((A68_REF *) item));
11442   } else if (IS (mode, REF_SYMBOL)) {
11443     CHECK_REF (p, *(A68_REF *) item, mode);
11444     genie_read_bin_standard (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file);
11445   } else if (mode == MODE (INT)) {
11446     A68_INT *z = (A68_INT *) item;
11447     ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
11448     STATUS (z) = INIT_MASK;
11449   } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) {
11450     MP_T *z = (MP_T *) item;
11451     ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
11452     MP_STATUS (z) = (MP_T) INIT_MASK;
11453   } else if (mode == MODE (REAL)) {
11454     A68_REAL *z = (A68_REAL *) item;
11455     ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
11456     STATUS (z) = INIT_MASK;
11457   } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) {
11458     MP_T *z = (MP_T *) item;
11459     ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
11460     MP_STATUS (z) = (MP_T) INIT_MASK;
11461   } else if (mode == MODE (BOOL)) {
11462     A68_BOOL *z = (A68_BOOL *) item;
11463     ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
11464     STATUS (z) = INIT_MASK;
11465   } else if (mode == MODE (CHAR)) {
11466     A68_CHAR *z = (A68_CHAR *) item;
11467     ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
11468     STATUS (z) = INIT_MASK;
11469   } else if (mode == MODE (BITS)) {
11470     A68_BITS *z = (A68_BITS *) item;
11471     ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
11472     STATUS (z) = INIT_MASK;
11473   } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) {
11474     MP_T *z = (MP_T *) item;
11475     ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
11476     MP_STATUS (z) = (MP_T) INIT_MASK;
11477   } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) {
11478     int len, k;
11479     ASSERT (io_read (FD (f), &(len), sizeof (len)) != -1);
11480     reset_transput_buffer (UNFORMATTED_BUFFER);
11481     for (k = 0; k < len; k++) {
11482       A68_CHAR z;
11483       ASSERT (io_read (FD (f), &(VALUE (&z)), sizeof (VALUE (&z))) != -1);
11484       add_char_transput_buffer (p, UNFORMATTED_BUFFER, (char) VALUE (&z));
11485     }
11486     *(A68_REF *) item = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
11487   } else if (IS (mode, UNION_SYMBOL)) {
11488     A68_UNION *z = (A68_UNION *) item;
11489     if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) {
11490       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
11491       exit_genie (p, A68_RUNTIME_ERROR);
11492     }
11493     genie_read_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file);
11494   } else if (IS (mode, STRUCT_SYMBOL)) {
11495     PACK_T *q = PACK (mode);
11496     for (; q != NO_PACK; FORWARD (q)) {
11497       genie_read_bin_standard (p, MOID (q), &item[OFFSET (q)], ref_file);
11498     }
11499   } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) {
11500     MOID_T *deflexed = DEFLEX (mode);
11501     A68_ARRAY *arr;
11502     A68_TUPLE *tup;
11503     CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS));
11504     GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
11505     if (get_row_size (tup, DIM (arr)) > 0) {
11506       BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
11507       BOOL_T done = A68_FALSE;
11508       initialise_internal_index (tup, DIM (arr));
11509       while (!done) {
11510         ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
11511         ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
11512         genie_read_bin_standard (p, SUB (deflexed), &base_addr[elem_addr], ref_file);
11513         done = increment_internal_index (tup, DIM (arr));
11514       }
11515     }
11516   }
11517   if (errno != 0) {
11518     transput_error (p, ref_file, mode);
11519   }
11520 }
11521 
11522 /**
11523 @brief PROC ([] SIMPLIN) VOID read bin
11524 @param p Node in syntax tree.
11525 **/
11526 
11527 void
genie_read_bin(NODE_T * p)11528 genie_read_bin (NODE_T * p)
11529 {
11530   A68_REF row;
11531   POP_REF (p, &row);
11532   genie_stand_back (p);
11533   PUSH_REF (p, row);
11534   genie_read_bin_file (p);
11535 }
11536 
11537 /**
11538 @brief PROC (REF FILE, [] SIMPLIN) VOID get bin
11539 @param p Node in syntax tree.
11540 **/
11541 
11542 void
genie_read_bin_file(NODE_T * p)11543 genie_read_bin_file (NODE_T * p)
11544 {
11545   A68_REF ref_file;
11546   A68_FILE *file;
11547   A68_REF row;
11548   A68_ARRAY *arr;
11549   A68_TUPLE *tup;
11550   BYTE_T *base_address;
11551   int elems, k, elem_index;
11552   POP_REF (p, &row);
11553   CHECK_REF (p, row, MODE (ROW_SIMPLIN));
11554   GET_DESCRIPTOR (arr, tup, &row);
11555   elems = ROW_SIZE (tup);
11556   POP_REF (p, &ref_file);
11557   ref_file = *(A68_REF *) STACK_TOP;
11558   CHECK_REF (p, ref_file, MODE (REF_FILE));
11559   file = FILE_DEREF (&ref_file);
11560   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
11561   if (!OPENED (file)) {
11562     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
11563     exit_genie (p, A68_RUNTIME_ERROR);
11564   }
11565   if (DRAW_MOOD (file)) {
11566     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
11567     exit_genie (p, A68_RUNTIME_ERROR);
11568   }
11569   if (WRITE_MOOD (file)) {
11570     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
11571     exit_genie (p, A68_RUNTIME_ERROR);
11572   }
11573   if (!GET (&CHANNEL (file))) {
11574     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
11575     exit_genie (p, A68_RUNTIME_ERROR);
11576   }
11577   if (!BIN (&CHANNEL (file))) {
11578     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "binary getting");
11579     exit_genie (p, A68_RUNTIME_ERROR);
11580   }
11581   if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
11582     if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS | O_BINARY, 0)) == A68_NO_FILENO) {
11583       open_error (p, ref_file, "binary getting");
11584     }
11585     DRAW_MOOD (file) = A68_FALSE;
11586     READ_MOOD (file) = A68_TRUE;
11587     WRITE_MOOD (file) = A68_FALSE;
11588     CHAR_MOOD (file) = A68_FALSE;
11589   }
11590   if (CHAR_MOOD (file)) {
11591     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "text");
11592     exit_genie (p, A68_RUNTIME_ERROR);
11593   }
11594 /* Read */
11595   if (elems <= 0) {
11596     return;
11597   }
11598   elem_index = 0;
11599   base_address = DEREF (BYTE_T, &ARRAY (arr));
11600   for (k = 0; k < elems; k++) {
11601     A68_UNION *z = (A68_UNION *) & base_address[elem_index];
11602     MOID_T *mode = (MOID_T *) (VALUE (z));
11603     BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
11604     genie_read_bin_standard (p, mode, item, ref_file);
11605     elem_index += SIZE (MODE (SIMPLIN));
11606   }
11607 }
11608 
11609 /**
11610 @brief Write object binary to file.
11611 @param p Node in syntax tree.
11612 @param mode Mode to write.
11613 @param item Pointer to value.
11614 @param ref_file Fat pointer to A68 file.
11615 **/
11616 
11617 static void
genie_write_bin_standard(NODE_T * p,MOID_T * mode,BYTE_T * item,A68_REF ref_file)11618 genie_write_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
11619 {
11620   A68_FILE *f;
11621   CHECK_REF (p, ref_file, MODE (REF_FILE));
11622   f = FILE_DEREF (&ref_file);
11623   RESET_ERRNO;
11624   if (mode == MODE (PROC_REF_FILE_VOID)) {
11625     genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item);
11626   } else if (mode == MODE (FORMAT)) {
11627     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (FORMAT));
11628     exit_genie (p, A68_RUNTIME_ERROR);
11629   } else if (mode == MODE (SOUND)) {
11630     write_sound (p, ref_file, (A68_SOUND *) item);
11631   } else if (mode == MODE (INT)) {
11632     ASSERT (io_write (FD (f), &(VALUE ((A68_INT *) item)), sizeof (VALUE ((A68_INT *) item))) != -1);
11633   } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) {
11634     ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
11635   } else if (mode == MODE (REAL)) {
11636     ASSERT (io_write (FD (f), &(VALUE ((A68_REAL *) item)), sizeof (VALUE ((A68_REAL *) item))) != -1);
11637   } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) {
11638     ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
11639   } else if (mode == MODE (BOOL)) {
11640     ASSERT (io_write (FD (f), &(VALUE ((A68_BOOL *) item)), sizeof (VALUE ((A68_BOOL *) item))) != -1);
11641   } else if (mode == MODE (CHAR)) {
11642     ASSERT (io_write (FD (f), &(VALUE ((A68_CHAR *) item)), sizeof (VALUE ((A68_CHAR *) item))) != -1);
11643   } else if (mode == MODE (BITS)) {
11644     ASSERT (io_write (FD (f), &(VALUE ((A68_BITS *) item)), sizeof (VALUE ((A68_BITS *) item))) != -1);
11645   } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) {
11646     ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
11647   } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) {
11648     int len;
11649     reset_transput_buffer (UNFORMATTED_BUFFER);
11650     add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item);
11651     len = get_transput_buffer_index (UNFORMATTED_BUFFER);
11652     ASSERT (io_write (FD (f), &(len), sizeof (len)) != -1);
11653     WRITE (FD (f), get_transput_buffer (UNFORMATTED_BUFFER));
11654   } else if (IS (mode, UNION_SYMBOL)) {
11655     A68_UNION *z = (A68_UNION *) item;
11656     genie_write_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file);
11657   } else if (IS (mode, STRUCT_SYMBOL)) {
11658     PACK_T *q = PACK (mode);
11659     for (; q != NO_PACK; FORWARD (q)) {
11660       BYTE_T *elem = &item[OFFSET (q)];
11661       genie_check_initialisation (p, elem, MOID (q));
11662       genie_write_bin_standard (p, MOID (q), elem, ref_file);
11663     }
11664   } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) {
11665     MOID_T *deflexed = DEFLEX (mode);
11666     A68_ARRAY *arr;
11667     A68_TUPLE *tup;
11668     CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS));
11669     GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
11670     if (get_row_size (tup, DIM (arr)) > 0) {
11671       BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
11672       BOOL_T done = A68_FALSE;
11673       initialise_internal_index (tup, DIM (arr));
11674       while (!done) {
11675         ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
11676         ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
11677         BYTE_T *elem = &base_addr[elem_addr];
11678         genie_check_initialisation (p, elem, SUB (deflexed));
11679         genie_write_bin_standard (p, SUB (deflexed), elem, ref_file);
11680         done = increment_internal_index (tup, DIM (arr));
11681       }
11682     }
11683   }
11684   if (errno != 0) {
11685     transput_error (p, ref_file, mode);
11686   }
11687 }
11688 
11689 /**
11690 @brief PROC ([] SIMPLOUT) VOID write bin, print bin
11691 @param p Node in syntax tree.
11692 **/
11693 
11694 void
genie_write_bin(NODE_T * p)11695 genie_write_bin (NODE_T * p)
11696 {
11697   A68_REF row;
11698   POP_REF (p, &row);
11699   genie_stand_back (p);
11700   PUSH_REF (p, row);
11701   genie_write_bin_file (p);
11702 }
11703 
11704 /**
11705 @brief PROC (REF FILE, [] SIMPLOUT) VOID put bin
11706 @param p Node in syntax tree.
11707 **/
11708 
11709 void
genie_write_bin_file(NODE_T * p)11710 genie_write_bin_file (NODE_T * p)
11711 {
11712   A68_REF ref_file, row;
11713   A68_FILE *file;
11714   A68_ARRAY *arr;
11715   A68_TUPLE *tup;
11716   BYTE_T *base_address;
11717   int elems, k, elem_index;
11718   POP_REF (p, &row);
11719   CHECK_REF (p, row, MODE (ROW_SIMPLOUT));
11720   GET_DESCRIPTOR (arr, tup, &row);
11721   elems = ROW_SIZE (tup);
11722   POP_REF (p, &ref_file);
11723   ref_file = *(A68_REF *) STACK_TOP;
11724   CHECK_REF (p, ref_file, MODE (REF_FILE));
11725   file = FILE_DEREF (&ref_file);
11726   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
11727   if (!OPENED (file)) {
11728     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
11729     exit_genie (p, A68_RUNTIME_ERROR);
11730   }
11731   if (DRAW_MOOD (file)) {
11732     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
11733     exit_genie (p, A68_RUNTIME_ERROR);
11734   }
11735   if (READ_MOOD (file)) {
11736     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
11737     exit_genie (p, A68_RUNTIME_ERROR);
11738   }
11739   if (!PUT (&CHANNEL (file))) {
11740     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
11741     exit_genie (p, A68_RUNTIME_ERROR);
11742   }
11743   if (!BIN (&CHANNEL (file))) {
11744     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "binary putting");
11745     exit_genie (p, A68_RUNTIME_ERROR);
11746   }
11747   if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
11748     if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS | O_BINARY, A68_PROTECTION)) == A68_NO_FILENO) {
11749       open_error (p, ref_file, "binary putting");
11750     }
11751     DRAW_MOOD (file) = A68_FALSE;
11752     READ_MOOD (file) = A68_FALSE;
11753     WRITE_MOOD (file) = A68_TRUE;
11754     CHAR_MOOD (file) = A68_FALSE;
11755   }
11756   if (CHAR_MOOD (file)) {
11757     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "text");
11758     exit_genie (p, A68_RUNTIME_ERROR);
11759   }
11760   if (elems <= 0) {
11761     return;
11762   }
11763   base_address = DEREF (BYTE_T, &ARRAY (arr));
11764   elem_index = 0;
11765   for (k = 0; k < elems; k++) {
11766     A68_UNION *z = (A68_UNION *) & base_address[elem_index];
11767     MOID_T *mode = (MOID_T *) (VALUE (z));
11768     BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
11769     genie_write_bin_standard (p, mode, item, ref_file);
11770     elem_index += SIZE (MODE (SIMPLOUT));
11771   }
11772 }
11773 
11774 /*
11775 Next are formatting routines "whole", "fixed" and "float" for mode
11776 INT, LONG INT and LONG LONG INT, and REAL, LONG REAL and LONG LONG REAL.
11777 They are direct implementations of the routines described in the
11778 Revised Report, although those were only meant as a specification.
11779 The rest of Algol68G should only reference "genie_whole", "genie_fixed"
11780 or "genie_float" since internal routines like "sub_fixed" may leave the
11781 stack corrupted when called directly.
11782 */
11783 
11784 /**
11785 @brief Generate a string of error chars.
11786 @param s String to store error chars.
11787 @param n Number of error chars.
11788 @return See brief description.
11789 **/
11790 
11791 char *
error_chars(char * s,int n)11792 error_chars (char *s, int n)
11793 {
11794   int k = (n != 0 ? ABS (n) : 1);
11795   s[k] = NULL_CHAR;
11796   while (--k >= 0) {
11797     s[k] = ERROR_CHAR;
11798   }
11799   return (s);
11800 }
11801 
11802 /**
11803 @brief Convert temporary C string to A68 string.
11804 @param p Node in syntax tree.
11805 @param temp_string Temporary C string.
11806 @return See brief description.
11807 **/
11808 
11809 A68_REF
tmp_to_a68_string(NODE_T * p,char * temp_string)11810 tmp_to_a68_string (NODE_T * p, char *temp_string)
11811 {
11812   A68_REF z;
11813 /* no compaction allowed since temp_string might be up for garbage collecting .. */
11814   z = c_to_a_string (p, temp_string, DEFAULT_WIDTH);
11815   return (z);
11816 }
11817 
11818 /**
11819 @brief Add c to str, assuming that "str" is large enough.
11820 @param c Char to add before string.
11821 @param str String to add in front of.
11822 @return String.
11823 **/
11824 
11825 static char *
plusto(char c,char * str)11826 plusto (char c, char *str)
11827 {
11828   MOVE (&str[1], &str[0], (unsigned) (strlen (str) + 1));
11829   str[0] = c;
11830   return (str);
11831 }
11832 
11833 /**
11834 @brief Add c to str, assuming that "str" is large enough.
11835 @param str String to add to.
11836 @param c Char to add.
11837 @param strwid Width of 'str'.
11838 @return String.
11839 **/
11840 
11841 char *
string_plusab_char(char * str,char c,int strwid)11842 string_plusab_char (char *str, char c, int strwid)
11843 {
11844   char z[2];
11845   z[0] = c;
11846   z[1] = NULL_CHAR;
11847   bufcat (str, z, strwid);
11848   return (str);
11849 }
11850 
11851 /**
11852 @brief Add leading spaces to str until length is width.
11853 @param str String to add in front of.
11854 @param width Required width of 'str'.
11855 @return String.
11856 **/
11857 
11858 static char *
leading_spaces(char * str,int width)11859 leading_spaces (char *str, int width)
11860 {
11861   int j = width - (int) strlen (str);
11862   while (--j >= 0) {
11863     (void) plusto (BLANK_CHAR, str);
11864   }
11865   return (str);
11866 }
11867 
11868 /**
11869 @brief Convert int to char using a table.
11870 @param k Int to convert.
11871 @return Character.
11872 **/
11873 
11874 static char
digchar(int k)11875 digchar (int k)
11876 {
11877   char *s = "0123456789abcdef";
11878   if (k >= 0 && k < (int) strlen (s)) {
11879     return (s[k]);
11880   } else {
11881     return (ERROR_CHAR);
11882   }
11883 }
11884 
11885 /**
11886 @brief Standard string for LONG INT.
11887 @param p Node in syntax tree.
11888 @param m Mp number.
11889 @param digits Digits.
11890 @param width Width.
11891 @return See brief description.
11892 **/
11893 
11894 char *
long_sub_whole(NODE_T * p,MP_T * m,int digits,int width)11895 long_sub_whole (NODE_T * p, MP_T * m, int digits, int width)
11896 {
11897   ADDR_T pop_sp;
11898   char *s;
11899   MP_T *n;
11900   int len = 0;
11901   s = stack_string (p, 8 + width);
11902   s[0] = NULL_CHAR;
11903   pop_sp = stack_pointer;
11904   STACK_MP (n, p, digits);
11905   MOVE_MP (n, m, digits);
11906   do {
11907     if (len < width) {
11908 /* Sic transit gloria mundi */
11909       int n_mod_10 = (int) MP_DIGIT (n, (int) (1 + MP_EXPONENT (n))) % 10;
11910       (void) plusto (digchar (n_mod_10), s);
11911     }
11912     len++;
11913     (void) over_mp_digit (p, n, n, (MP_T) 10, digits);
11914   } while (MP_DIGIT (n, 1) > 0);
11915   if (len > width) {
11916     (void) error_chars (s, width);
11917   }
11918   stack_pointer = pop_sp;
11919   return (s);
11920 }
11921 
11922 /**
11923 @brief Standard string for INT.
11924 @param p Node in syntax tree.
11925 @param n Value.
11926 @param width Width.
11927 @return See brief description.
11928 **/
11929 
11930 char *
sub_whole(NODE_T * p,int n,int width)11931 sub_whole (NODE_T * p, int n, int width)
11932 {
11933   char *s = stack_string (p, 8 + width);
11934   int len = 0;
11935   s[0] = NULL_CHAR;
11936   do {
11937     if (len < width) {
11938       (void) plusto (digchar (n % 10), s);
11939     }
11940     len++;
11941     n /= 10;
11942   } while (n != 0);
11943   if (len > width) {
11944     (void) error_chars (s, width);
11945   }
11946   return (s);
11947 }
11948 
11949 /**
11950 @brief Formatted string for NUMBER.
11951 @param p Node in syntax tree.
11952 @return String.
11953 **/
11954 
11955 char *
whole(NODE_T * p)11956 whole (NODE_T * p)
11957 {
11958   int arg_sp;
11959   A68_INT width;
11960   MOID_T *mode;
11961   POP_OBJECT (p, &width, A68_INT);
11962   arg_sp = stack_pointer;
11963   DECREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)));
11964   mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP));
11965   if (mode == MODE (INT)) {
11966     int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE)));
11967     int length = ABS (VALUE (&width)) - (x < 0 || VALUE (&width) > 0 ? 1 : 0);
11968     int n = ABS (x);
11969     int size = (x < 0 ? 1 : (VALUE (&width) > 0 ? 1 : 0));
11970     char *s;
11971     if (VALUE (&width) == 0) {
11972       int m = n;
11973       length = 0;
11974       while ((m /= 10, length++, m != 0)) {
11975         ;
11976       }
11977     }
11978     size += length;
11979     size = 8 + (size > VALUE (&width) ? size : VALUE (&width));
11980     s = stack_string (p, size);
11981     bufcpy (s, sub_whole (p, n, length), size);
11982     if (length == 0 || a68g_strchr (s, ERROR_CHAR) != NO_TEXT) {
11983       (void) error_chars (s, VALUE (&width));
11984     } else {
11985       if (x < 0) {
11986         (void) plusto ('-', s);
11987       } else if (VALUE (&width) > 0) {
11988         (void) plusto ('+', s);
11989       }
11990       if (VALUE (&width) != 0) {
11991         (void) leading_spaces (s, ABS (VALUE (&width)));
11992       }
11993     }
11994     return (s);
11995   } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) {
11996     int digits = DIGITS (mode);
11997     int length, size;
11998     char *s;
11999     MP_T *n = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE));
12000     BOOL_T ltz;
12001     stack_pointer = arg_sp;     /* We keep the mp where it's at */
12002     if (MP_EXPONENT (n) >= (MP_T) digits) {
12003       int max_length = (mode == MODE (LONG_INT) ? LONG_INT_WIDTH : LONGLONG_INT_WIDTH);
12004       length = (VALUE (&width) == 0 ? max_length : VALUE (&width));
12005       s = stack_string (p, 1 + length);
12006       (void) error_chars (s, length);
12007       return (s);
12008     }
12009     ltz = (BOOL_T) (MP_DIGIT (n, 1) < 0);
12010     length = ABS (VALUE (&width)) - (ltz || VALUE (&width) > 0 ? 1 : 0);
12011     size = (ltz ? 1 : (VALUE (&width) > 0 ? 1 : 0));
12012     MP_DIGIT (n, 1) = ABS (MP_DIGIT (n, 1));
12013     if (VALUE (&width) == 0) {
12014       MP_T *m;
12015       STACK_MP (m, p, digits);
12016       MOVE_MP (m, n, digits);
12017       length = 0;
12018       while ((over_mp_digit (p, m, m, (MP_T) 10, digits), length++, MP_DIGIT (m, 1) != 0)) {
12019         ;
12020       }
12021     }
12022     size += length;
12023     size = 8 + (size > VALUE (&width) ? size : VALUE (&width));
12024     s = stack_string (p, size);
12025     bufcpy (s, long_sub_whole (p, n, digits, length), size);
12026     if (length == 0 || a68g_strchr (s, ERROR_CHAR) != NO_TEXT) {
12027       (void) error_chars (s, VALUE (&width));
12028     } else {
12029       if (ltz) {
12030         (void) plusto ('-', s);
12031       } else if (VALUE (&width) > 0) {
12032         (void) plusto ('+', s);
12033       }
12034       if (VALUE (&width) != 0) {
12035         (void) leading_spaces (s, ABS (VALUE (&width)));
12036       }
12037     }
12038     return (s);
12039   } else if (mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) {
12040     INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)));
12041     PUSH_PRIMITIVE (p, VALUE (&width), A68_INT);
12042     PUSH_PRIMITIVE (p, 0, A68_INT);
12043     return (fixed (p));
12044   }
12045   return (NO_TEXT);
12046 }
12047 
12048 /**
12049 @brief Fetch next digit from LONG.
12050 @param p Node in syntax tree.
12051 @param y Mp number.
12052 @param digits Digits.
12053 @return Next digit.
12054 **/
12055 
12056 static char
long_choose_dig(NODE_T * p,MP_T * y,int digits)12057 long_choose_dig (NODE_T * p, MP_T * y, int digits)
12058 {
12059 /* Assuming positive "y" */
12060   int pop_sp = stack_pointer, c;
12061   MP_T *t;
12062   STACK_MP (t, p, digits);
12063   (void) mul_mp_digit (p, y, y, (MP_T) 10, digits);
12064   c = MP_EXPONENT (y) == 0 ? (int) MP_DIGIT (y, 1) : 0;
12065   if (c > 9) {
12066     c = 9;
12067   }
12068   (void) set_mp_short (t, (MP_T) c, 0, digits);
12069   (void) sub_mp (p, y, y, t, digits);
12070 /* Reset the stack to prevent overflow, there may be many digits */
12071   stack_pointer = pop_sp;
12072   return (digchar (c));
12073 }
12074 
12075 /**
12076 @brief Standard string for LONG.
12077 @param p Node in syntax tree.
12078 @param x Mp digit.
12079 @param digits Digits.
12080 @param width Width.
12081 @param after After.
12082 @return See brief description.
12083 **/
12084 
12085 char *
long_sub_fixed(NODE_T * p,MP_T * x,int digits,int width,int after)12086 long_sub_fixed (NODE_T * p, MP_T * x, int digits, int width, int after)
12087 {
12088   int strwid = 8 + width;
12089   char *str = stack_string (p, strwid);
12090   int before = 0, j, len, pop_sp = stack_pointer;
12091   BOOL_T overflow;
12092   MP_T *y;
12093   MP_T *s;
12094   MP_T *t;
12095   STACK_MP (y, p, digits);
12096   STACK_MP (s, p, digits);
12097   STACK_MP (t, p, digits);
12098   (void) set_mp_short (t, (MP_T) (MP_RADIX / 10), -1, digits);
12099   (void) pow_mp_int (p, t, t, after, digits);
12100   (void) div_mp_digit (p, t, t, (MP_T) 2, digits);
12101   (void) add_mp (p, y, x, t, digits);
12102   (void) set_mp_short (s, (MP_T) 1, 0, digits);
12103   while ((sub_mp (p, t, y, s, digits), MP_DIGIT (t, 1) >= 0)) {
12104     before++;
12105     (void) mul_mp_digit (p, s, s, (MP_T) 10, digits);
12106   }
12107   (void) div_mp (p, y, y, s, digits);
12108   str[0] = NULL_CHAR;
12109   len = 0;
12110   overflow = A68_FALSE;
12111   for (j = 0; j < before && !overflow; j++) {
12112     if (!(overflow = (BOOL_T) (len >= width))) {
12113       (void) string_plusab_char (str, long_choose_dig (p, y, digits), strwid);
12114       len++;
12115     }
12116   }
12117   if (after > 0 && !(overflow = (BOOL_T) (len >= width))) {
12118     (void) string_plusab_char (str, POINT_CHAR, strwid);
12119   }
12120   for (j = 0; j < after && !overflow; j++) {
12121     if (!(overflow = (BOOL_T) (len >= width))) {
12122       (void) string_plusab_char (str, long_choose_dig (p, y, digits), strwid);
12123       len++;
12124     }
12125   }
12126   if (overflow || (int) strlen (str) > width) {
12127     (void) error_chars (str, width);
12128   }
12129   stack_pointer = pop_sp;
12130   return (str);
12131 }
12132 
12133 /**
12134 @brief Fetch next digit from REAL.
12135 @param y Value.
12136 @return Next digit.
12137 **/
12138 
12139 static char
choose_dig(double * y)12140 choose_dig (double *y)
12141 {
12142 /* Assuming positive "y" */
12143   int c = (int) (*y *= 10);
12144   if (c > 9) {
12145     c = 9;
12146   }
12147   *y -= c;
12148   return (digchar (c));
12149 }
12150 
12151 /**
12152 @brief Standard string for REAL.
12153 @param p Node in syntax tree.
12154 @param x Value.
12155 @param width Width.
12156 @param after After.
12157 @return String.
12158 **/
12159 
12160 char *
sub_fixed(NODE_T * p,double x,int width,int after)12161 sub_fixed (NODE_T * p, double x, int width, int after)
12162 {
12163   int strwid = 8 + width;
12164   char *str = stack_string (p, strwid);
12165   int before = 0, j, len, expo;
12166   BOOL_T overflow;
12167   double y, z;
12168 /* Round and scale */
12169   z = y = x + 0.5 * ten_up (-after);
12170   expo = 0;
12171   while (z >= 1) {
12172     expo++;
12173     z /= 10;
12174   }
12175   before += expo;
12176 /* Trick to avoid overflow */
12177   if (expo > 30) {
12178     expo -= 30;
12179     y /= ten_up (30);
12180   }
12181 /* Scale number */
12182   y /= ten_up (expo);
12183   len = 0;
12184 /* Put digits, prevent garbage from overstretching precision */
12185   overflow = A68_FALSE;
12186   for (j = 0; j < before && !overflow; j++) {
12187     if (!(overflow = (BOOL_T) (len >= width))) {
12188       char ch = (char) (len < REAL_WIDTH ? choose_dig (&y) : '0');
12189       (void) string_plusab_char (str, ch, strwid);
12190       len++;
12191     }
12192   }
12193   if (after > 0 && !(overflow = (BOOL_T) (len >= width))) {
12194     (void) string_plusab_char (str, POINT_CHAR, strwid);
12195   }
12196   for (j = 0; j < after && !overflow; j++) {
12197     if (!(overflow = (BOOL_T) (len >= width))) {
12198       char ch = (char) (len < REAL_WIDTH ? choose_dig (&y) : '0');
12199       (void) string_plusab_char (str, ch, strwid);
12200       len++;
12201     }
12202   }
12203   if (overflow || (int) strlen (str) > width) {
12204     (void) error_chars (str, width);
12205   }
12206   return (str);
12207 }
12208 
12209 /**
12210 @brief Formatted string for NUMBER.
12211 @param p Node in syntax tree.
12212 @return String.
12213 **/
12214 
12215 char *
fixed(NODE_T * p)12216 fixed (NODE_T * p)
12217 {
12218   A68_INT width, after;
12219   MOID_T *mode;
12220   int pop_sp, arg_sp;
12221   POP_OBJECT (p, &after, A68_INT);
12222   POP_OBJECT (p, &width, A68_INT);
12223   arg_sp = stack_pointer;
12224   DECREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)));
12225   mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP));
12226   pop_sp = stack_pointer;
12227   if (mode == MODE (REAL)) {
12228     double x = VALUE ((A68_REAL *) (STACK_OFFSET (A68_UNION_SIZE)));
12229     int length = ABS (VALUE (&width)) - (x < 0 || VALUE (&width) > 0 ? 1 : 0);
12230     char *s;
12231     CHECK_REAL_REPRESENTATION (p, x);
12232     stack_pointer = arg_sp;
12233     if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) {
12234       double y = ABS (x), z0, z1;
12235       if (VALUE (&width) == 0) {
12236         length = (VALUE (&after) == 0 ? 1 : 0);
12237         z0 = ten_up (-VALUE (&after));
12238         z1 = ten_up (length);
12239         while (y + 0.5 * z0 > z1) {
12240           length++;
12241           z1 *= 10.0;
12242         }
12243         length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1);
12244       }
12245       s = stack_string (p, 8 + length);
12246       s = sub_fixed (p, y, length, VALUE (&after));
12247       if (a68g_strchr (s, ERROR_CHAR) == NO_TEXT) {
12248         if (length > (int) strlen (s) && (s[0] != NULL_CHAR ? s[0] == POINT_CHAR : A68_TRUE) && y < 1.0) {
12249           (void) plusto ('0', s);
12250         }
12251         if (x < 0) {
12252           (void) plusto ('-', s);
12253         } else if (VALUE (&width) > 0) {
12254           (void) plusto ('+', s);
12255         }
12256         if (VALUE (&width) != 0) {
12257           (void) leading_spaces (s, ABS (VALUE (&width)));
12258         }
12259         return (s);
12260       } else if (VALUE (&after) > 0) {
12261         stack_pointer = arg_sp;
12262         PUSH_PRIMITIVE (p, VALUE (&width), A68_INT);
12263         PUSH_PRIMITIVE (p, VALUE (&after) - 1, A68_INT);
12264         return (fixed (p));
12265       } else {
12266         return (error_chars (s, VALUE (&width)));
12267       }
12268     } else {
12269       s = stack_string (p, 8 + ABS (VALUE (&width)));
12270       return (error_chars (s, VALUE (&width)));
12271     }
12272   } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) {
12273     int digits = DIGITS (mode);
12274     int length;
12275     BOOL_T ltz;
12276     char *s;
12277     MP_T *x = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE));
12278     stack_pointer = arg_sp;
12279     ltz = (BOOL_T) (MP_DIGIT (x, 1) < 0);
12280     MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1));
12281     length = ABS (VALUE (&width)) - (ltz || VALUE (&width) > 0 ? 1 : 0);
12282     if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) {
12283       MP_T *z0;
12284       MP_T *z1;
12285       MP_T *t;
12286       STACK_MP (z0, p, digits);
12287       STACK_MP (z1, p, digits);
12288       STACK_MP (t, p, digits);
12289       if (VALUE (&width) == 0) {
12290         length = (VALUE (&after) == 0 ? 1 : 0);
12291         (void) set_mp_short (z0, (MP_T) (MP_RADIX / 10), -1, digits);
12292         (void) set_mp_short (z1, (MP_T) 10, 0, digits);
12293         (void) pow_mp_int (p, z0, z0, VALUE (&after), digits);
12294         (void) pow_mp_int (p, z1, z1, length, digits);
12295         while ((div_mp_digit (p, t, z0, (MP_T) 2, digits), add_mp (p, t, x, t, digits), sub_mp (p, t, t, z1, digits), MP_DIGIT (t, 1) > 0)) {
12296           length++;
12297           (void) mul_mp_digit (p, z1, z1, (MP_T) 10, digits);
12298         }
12299         length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1);
12300       }
12301       s = stack_string (p, 8 + length);
12302       s = long_sub_fixed (p, x, digits, length, VALUE (&after));
12303       if (a68g_strchr (s, ERROR_CHAR) == NO_TEXT) {
12304         if (length > (int) strlen (s) && (s[0] != NULL_CHAR ? s[0] == POINT_CHAR : A68_TRUE) && (MP_EXPONENT (x) < 0 || MP_DIGIT (x, 1) == 0)) {
12305           (void) plusto ('0', s);
12306         }
12307         if (ltz) {
12308           (void) plusto ('-', s);
12309         } else if (VALUE (&width) > 0) {
12310           (void) plusto ('+', s);
12311         }
12312         if (VALUE (&width) != 0) {
12313           (void) leading_spaces (s, ABS (VALUE (&width)));
12314         }
12315         return (s);
12316       } else if (VALUE (&after) > 0) {
12317         stack_pointer = arg_sp;
12318         MP_DIGIT (x, 1) = ltz ? -ABS (MP_DIGIT (x, 1)) : ABS (MP_DIGIT (x, 1));
12319         PUSH_PRIMITIVE (p, VALUE (&width), A68_INT);
12320         PUSH_PRIMITIVE (p, VALUE (&after) - 1, A68_INT);
12321         return (fixed (p));
12322       } else {
12323         return (error_chars (s, VALUE (&width)));
12324       }
12325     } else {
12326       s = stack_string (p, 8 + ABS (VALUE (&width)));
12327       return (error_chars (s, VALUE (&width)));
12328     }
12329   } else if (mode == MODE (INT)) {
12330     int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE)));
12331     PUSH_UNION (p, MODE (REAL));
12332     PUSH_PRIMITIVE (p, (double) x, A68_REAL);
12333     INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (REAL))));
12334     PUSH_PRIMITIVE (p, VALUE (&width), A68_INT);
12335     PUSH_PRIMITIVE (p, VALUE (&after), A68_INT);
12336     return (fixed (p));
12337   } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) {
12338     stack_pointer = pop_sp;
12339     if (mode == MODE (LONG_INT)) {
12340       VALUE ((A68_UNION *) STACK_TOP) = (void *) MODE (LONG_REAL);
12341     } else {
12342       VALUE ((A68_UNION *) STACK_TOP) = (void *) MODE (LONGLONG_REAL);
12343     } INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)));
12344     PUSH_PRIMITIVE (p, VALUE (&width), A68_INT);
12345     PUSH_PRIMITIVE (p, VALUE (&after), A68_INT);
12346     return (fixed (p));
12347   }
12348   return (NO_TEXT);
12349 }
12350 
12351 /**
12352 @brief Scale LONG for formatting.
12353 @param p Node in syntax tree.
12354 @param y Mp number.
12355 @param digits Digits.
12356 @param before Before.
12357 @param after After.
12358 @param q Int multiplier.
12359 **/
12360 
12361 void
long_standardise(NODE_T * p,MP_T * y,int digits,int before,int after,int * q)12362 long_standardise (NODE_T * p, MP_T * y, int digits, int before, int after, int *q)
12363 {
12364   int j, pop_sp = stack_pointer;
12365   MP_T *f;
12366   MP_T *g;
12367   MP_T *h;
12368   MP_T *t;
12369   STACK_MP (f, p, digits);
12370   STACK_MP (g, p, digits);
12371   STACK_MP (h, p, digits);
12372   STACK_MP (t, p, digits);
12373   (void) set_mp_short (g, (MP_T) 1, 0, digits);
12374   for (j = 0; j < before; j++) {
12375     (void) mul_mp_digit (p, g, g, (MP_T) 10, digits);
12376   }
12377   (void) div_mp_digit (p, h, g, (MP_T) 10, digits);
12378 /* Speed huge exponents */
12379   if ((MP_EXPONENT (y) - MP_EXPONENT (g)) > 1) {
12380     (*q) += LOG_MP_BASE * ((int) MP_EXPONENT (y) - (int) MP_EXPONENT (g) - 1);
12381     MP_EXPONENT (y) = MP_EXPONENT (g) + 1;
12382   }
12383   while ((sub_mp (p, t, y, g, digits), MP_DIGIT (t, 1) >= 0)) {
12384     (void) div_mp_digit (p, y, y, (MP_T) 10, digits);
12385     (*q)++;
12386   }
12387   if (MP_DIGIT (y, 1) != 0) {
12388 /* Speed huge exponents */
12389     if ((MP_EXPONENT (y) - MP_EXPONENT (h)) < -1) {
12390       (*q) -= LOG_MP_BASE * ((int) MP_EXPONENT (h) - (int) MP_EXPONENT (y) - 1);
12391       MP_EXPONENT (y) = MP_EXPONENT (h) - 1;
12392     }
12393     while ((sub_mp (p, t, y, h, digits), MP_DIGIT (t, 1) < 0)) {
12394       (void) mul_mp_digit (p, y, y, (MP_T) 10, digits);
12395       (*q)--;
12396     }
12397   }
12398   (void) set_mp_short (f, (MP_T) 1, 0, digits);
12399   for (j = 0; j < after; j++) {
12400     (void) div_mp_digit (p, f, f, (MP_T) 10, digits);
12401   }
12402   (void) div_mp_digit (p, t, f, (MP_T) 2, digits);
12403   (void) add_mp (p, t, y, t, digits);
12404   (void) sub_mp (p, t, t, g, digits);
12405   if (MP_DIGIT (t, 1) >= 0) {
12406     MOVE_MP (y, h, digits);
12407     (*q)++;
12408   }
12409   stack_pointer = pop_sp;
12410 }
12411 
12412 /**
12413 @brief Scale REAL for formatting.
12414 @param y Value.
12415 @param before Before.
12416 @param after After.
12417 @param p Int multiplier.
12418 **/
12419 
12420 void
standardise(double * y,int before,int after,int * p)12421 standardise (double *y, int before, int after, int *p)
12422 {
12423   int j;
12424   double f, g = 1.0, h;
12425   for (j = 0; j < before; j++) {
12426     g *= 10.0;
12427   }
12428   h = g / 10.0;
12429   while (*y >= g) {
12430     *y *= 0.1;
12431     (*p)++;
12432   }
12433   if (*y != 0.0) {
12434     while (*y < h) {
12435       *y *= 10.0;
12436       (*p)--;
12437     }
12438   }
12439   f = 1.0;
12440   for (j = 0; j < after; j++) {
12441     f *= 0.1;
12442   }
12443   if (*y + 0.5 * f >= g) {
12444     *y = h;
12445     (*p)++;
12446   }
12447 }
12448 
12449 /**
12450 @brief Formatted string for NUMBER.
12451 @param p Node in syntax tree.
12452 @return String.
12453 **/
12454 
12455 char *
real(NODE_T * p)12456 real (NODE_T * p)
12457 {
12458   int pop_sp, arg_sp;
12459   A68_INT width, after, expo, frmt;
12460   MOID_T *mode;
12461 /* POP arguments */
12462   POP_OBJECT (p, &frmt, A68_INT);
12463   POP_OBJECT (p, &expo, A68_INT);
12464   POP_OBJECT (p, &after, A68_INT);
12465   POP_OBJECT (p, &width, A68_INT);
12466   arg_sp = stack_pointer;
12467   DECREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)));
12468   mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP));
12469   pop_sp = stack_pointer;
12470   if (mode == MODE (REAL)) {
12471     double x = VALUE ((A68_REAL *) (STACK_OFFSET (A68_UNION_SIZE)));
12472     int before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2;
12473     CHECK_REAL_REPRESENTATION (p, x);
12474     stack_pointer = arg_sp;
12475 #if defined HAVE_IEEE_754
12476     if (NOT_A_REAL (x)) {
12477       char *s = stack_string (p, 8 + ABS (VALUE (&width)));
12478       return (error_chars (s, VALUE (&width)));
12479     }
12480 #endif /*  */
12481     if (SIGN (before) + SIGN (VALUE (&after)) > 0) {
12482       int strwid;
12483       char *s, *t1, *t2;
12484       double y = ABS (x);
12485       int q = 0;
12486       standardise (&y, before, VALUE (&after), &q);
12487       if (VALUE (&frmt) > 0) {
12488         while (q % VALUE (&frmt) != 0) {
12489           y *= 10;
12490           q--;
12491           if (VALUE (&after) > 0) {
12492             VALUE (&after)--;
12493           }
12494         }
12495       } else {
12496         double upb = ten_up (-VALUE (&frmt)), lwb = ten_up (-VALUE (&frmt) - 1);
12497         while (y < lwb) {
12498           y *= 10;
12499           q--;
12500           if (VALUE (&after) > 0) {
12501             VALUE (&after)--;
12502           }
12503         }
12504         while (y > upb) {
12505           y /= 10;
12506           q++;
12507           if (VALUE (&after) > 0) {
12508             VALUE (&after)++;
12509           }
12510         }
12511       }
12512       PUSH_UNION (p, MODE (REAL));
12513       PUSH_PRIMITIVE (p, SIGN (x) * y, A68_REAL);
12514       INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (REAL))));
12515       PUSH_PRIMITIVE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT);
12516       PUSH_PRIMITIVE (p, VALUE (&after), A68_INT);
12517       t1 = fixed (p);
12518       PUSH_UNION (p, MODE (INT));
12519       PUSH_PRIMITIVE (p, q, A68_INT);
12520       INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (INT))));
12521       PUSH_PRIMITIVE (p, VALUE (&expo), A68_INT);
12522       t2 = whole (p);
12523       strwid = 8 + (int) strlen (t1) + 1 + (int) strlen (t2);
12524       s = stack_string (p, strwid);
12525       bufcpy (s, t1, strwid);
12526       (void) string_plusab_char (s, EXPONENT_CHAR, strwid);
12527       bufcat (s, t2, strwid);
12528       if (VALUE (&expo) == 0 || a68g_strchr (s, ERROR_CHAR) != NO_TEXT) {
12529         stack_pointer = arg_sp;
12530         PUSH_PRIMITIVE (p, VALUE (&width), A68_INT);
12531         PUSH_PRIMITIVE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT);
12532         PUSH_PRIMITIVE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT);
12533         PUSH_PRIMITIVE (p, VALUE (&frmt), A68_INT);
12534         return (real (p));
12535       } else {
12536         return (s);
12537       }
12538     } else {
12539       char *s = stack_string (p, 8 + ABS (VALUE (&width)));
12540       return (error_chars (s, VALUE (&width)));
12541     }
12542   } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) {
12543     int digits = DIGITS (mode);
12544     int before;
12545     MP_T *x = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE));
12546     BOOL_T ltz = (BOOL_T) (MP_DIGIT (x, 1) < 0);
12547     stack_pointer = arg_sp;
12548     MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1));
12549     before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2;
12550     if (SIGN (before) + SIGN (VALUE (&after)) > 0) {
12551       int strwid;
12552       char *s, *t1, *t2;
12553       MP_T *z;
12554       int q = 0;
12555       STACK_MP (z, p, digits);
12556       MOVE_MP (z, x, digits);
12557       long_standardise (p, z, digits, before, VALUE (&after), &q);
12558       if (VALUE (&frmt) > 0) {
12559         while (q % VALUE (&frmt) != 0) {
12560           (void) mul_mp_digit (p, z, z, (MP_T) 10, digits);
12561           q--;
12562           if (VALUE (&after) > 0) {
12563             VALUE (&after)--;
12564           }
12565         }
12566       } else {
12567         MP_T *dif, *lim;
12568         ADDR_T sp1 = stack_pointer;
12569         STACK_MP (dif, p, digits);
12570         STACK_MP (lim, p, digits);
12571         (void) mp_ten_up (p, lim, -VALUE (&frmt) - 1, digits);
12572         (void) sub_mp (p, dif, z, lim, digits);
12573         while (MP_DIGIT (dif, 1) < 0) {
12574           (void) mul_mp_digit (p, z, z, (MP_T) 10, digits);
12575           q--;
12576           if (VALUE (&after) > 0) {
12577             VALUE (&after)--;
12578           }
12579           (void) sub_mp (p, dif, z, lim, digits);
12580         }
12581         (void) mul_mp_digit (p, lim, lim, (MP_T) 10, digits);
12582         (void) sub_mp (p, dif, z, lim, digits);
12583         while (MP_DIGIT (dif, 1) > 0) {
12584           (void) div_mp_digit (p, z, z, (MP_T) 10, digits);
12585           q++;
12586           if (VALUE (&after) > 0) {
12587             VALUE (&after)++;
12588           }
12589           (void) sub_mp (p, dif, z, lim, digits);
12590         }
12591         stack_pointer = sp1;
12592       }
12593       PUSH_UNION (p, mode);
12594       MP_DIGIT (z, 1) = (ltz ? -MP_DIGIT (z, 1) : MP_DIGIT (z, 1));
12595       PUSH (p, z, SIZE_MP (digits));
12596       INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE_MP (digits)));
12597       PUSH_PRIMITIVE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT);
12598       PUSH_PRIMITIVE (p, VALUE (&after), A68_INT);
12599       t1 = fixed (p);
12600       PUSH_UNION (p, MODE (INT));
12601       PUSH_PRIMITIVE (p, q, A68_INT);
12602       INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (INT))));
12603       PUSH_PRIMITIVE (p, VALUE (&expo), A68_INT);
12604       t2 = whole (p);
12605       strwid = 8 + (int) strlen (t1) + 1 + (int) strlen (t2);
12606       s = stack_string (p, strwid);
12607       bufcpy (s, t1, strwid);
12608       (void) string_plusab_char (s, EXPONENT_CHAR, strwid);
12609       bufcat (s, t2, strwid);
12610       if (VALUE (&expo) == 0 || a68g_strchr (s, ERROR_CHAR) != NO_TEXT) {
12611         stack_pointer = arg_sp;
12612         PUSH_PRIMITIVE (p, VALUE (&width), A68_INT);
12613         PUSH_PRIMITIVE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT);
12614         PUSH_PRIMITIVE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT);
12615         PUSH_PRIMITIVE (p, VALUE (&frmt), A68_INT);
12616         return (real (p));
12617       } else {
12618         return (s);
12619       }
12620     } else {
12621       char *s = stack_string (p, 8 + ABS (VALUE (&width)));
12622       return (error_chars (s, VALUE (&width)));
12623     }
12624   } else if (mode == MODE (INT)) {
12625     int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE)));
12626     PUSH_UNION (p, MODE (REAL));
12627     PUSH_PRIMITIVE (p, (double) x, A68_REAL);
12628     INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (REAL))));
12629     PUSH_PRIMITIVE (p, VALUE (&width), A68_INT);
12630     PUSH_PRIMITIVE (p, VALUE (&after), A68_INT);
12631     PUSH_PRIMITIVE (p, VALUE (&expo), A68_INT);
12632     PUSH_PRIMITIVE (p, VALUE (&frmt), A68_INT);
12633     return (real (p));
12634   } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) {
12635     stack_pointer = pop_sp;
12636     if (mode == MODE (LONG_INT)) {
12637       VALUE ((A68_UNION *) STACK_TOP) = (void *) MODE (LONG_REAL);
12638     } else {
12639       VALUE ((A68_UNION *) STACK_TOP) = (void *) MODE (LONGLONG_REAL);
12640     } INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)));
12641     PUSH_PRIMITIVE (p, VALUE (&width), A68_INT);
12642     PUSH_PRIMITIVE (p, VALUE (&after), A68_INT);
12643     PUSH_PRIMITIVE (p, VALUE (&expo), A68_INT);
12644     PUSH_PRIMITIVE (p, VALUE (&frmt), A68_INT);
12645     return (real (p));
12646   }
12647   return (NO_TEXT);
12648 }
12649 
12650 /**
12651 @brief PROC (NUMBER, INT) STRING whole
12652 @param p Node in syntax tree.
12653 **/
12654 
12655 void
genie_whole(NODE_T * p)12656 genie_whole (NODE_T * p)
12657 {
12658   int pop_sp = stack_pointer;
12659   A68_REF ref;
12660   char *str = whole (p);
12661   stack_pointer = pop_sp - SIZE (MODE (INT)) - SIZE (MODE (NUMBER));
12662   ref = tmp_to_a68_string (p, str);
12663   PUSH_REF (p, ref);
12664 }
12665 
12666 /**
12667 @brief PROC (NUMBER, INT, INT) STRING fixed
12668 @param p Node in syntax tree.
12669 **/
12670 
12671 void
genie_fixed(NODE_T * p)12672 genie_fixed (NODE_T * p)
12673 {
12674   int pop_sp = stack_pointer;
12675   A68_REF ref;
12676   char *str = fixed (p);
12677   stack_pointer = pop_sp - 2 * SIZE (MODE (INT)) - SIZE (MODE (NUMBER));
12678   ref = tmp_to_a68_string (p, str);
12679   PUSH_REF (p, ref);
12680 }
12681 
12682 /**
12683 @brief PROC (NUMBER, INT, INT, INT) STRING eng
12684 @param p Node in syntax tree.
12685 **/
12686 
12687 void
genie_real(NODE_T * p)12688 genie_real (NODE_T * p)
12689 {
12690   int pop_sp = stack_pointer;
12691   A68_REF ref;
12692   char *str = real (p);
12693   stack_pointer = pop_sp - 4 * SIZE (MODE (INT)) - SIZE (MODE (NUMBER));
12694   ref = tmp_to_a68_string (p, str);
12695   PUSH_REF (p, ref);
12696 }
12697 
12698 /**
12699 @brief PROC (NUMBER, INT, INT, INT) STRING float
12700 @param p Node in syntax tree.
12701 **/
12702 
12703 void
genie_float(NODE_T * p)12704 genie_float (NODE_T * p)
12705 {
12706   PUSH_PRIMITIVE (p, 1, A68_INT);
12707   genie_real (p);
12708 }
12709 
12710 /* ALGOL68C routines */
12711 
12712 /**
12713 @def A68C_TRANSPUT
12714 @brief Generate Algol68C routines readint, getint, etcetera.
12715 **/
12716 
12717 #define A68C_TRANSPUT(n, m)\
12718  void genie_get_##n (NODE_T * p) {\
12719     A68_REF ref_file;\
12720     ADDR_T pop_sp;\
12721     BYTE_T *z;\
12722     POP_REF (p, &ref_file);\
12723     CHECK_REF (p, ref_file, MODE (REF_FILE));\
12724     z = STACK_TOP;\
12725     INCREMENT_STACK_POINTER (p, SIZE (MODE (m)));\
12726     pop_sp = stack_pointer;\
12727     open_for_reading (p, ref_file);\
12728     genie_read_standard (p, MODE (m), z, ref_file);\
12729     stack_pointer = pop_sp;}\
12730   void genie_put_##n (NODE_T * p) {\
12731     int size = SIZE (MODE (m)), sizf = SIZE (MODE (REF_FILE));\
12732     A68_REF ref_file = * (A68_REF *) STACK_OFFSET (- (size + sizf));\
12733     CHECK_REF (p, ref_file, MODE (REF_FILE));\
12734     reset_transput_buffer (UNFORMATTED_BUFFER);\
12735     open_for_writing (p, ref_file);\
12736     genie_write_standard (p, MODE (m), STACK_OFFSET (-size), ref_file);\
12737     write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);\
12738     DECREMENT_STACK_POINTER (p, size + sizf);}\
12739   void genie_read_##n (NODE_T * p) {\
12740     ADDR_T pop_sp;\
12741     BYTE_T *z = STACK_TOP;\
12742     INCREMENT_STACK_POINTER (p, SIZE (MODE (m)));\
12743     pop_sp = stack_pointer;\
12744     open_for_reading (p, stand_in);\
12745     genie_read_standard (p, MODE (m), z, stand_in);\
12746     stack_pointer = pop_sp;}\
12747   void genie_print_##n (NODE_T * p) {\
12748     int size = SIZE (MODE (m));\
12749     reset_transput_buffer (UNFORMATTED_BUFFER);\
12750     open_for_writing (p, stand_out);\
12751     genie_write_standard (p, MODE (m), STACK_OFFSET (-size), stand_out);\
12752     write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER);\
12753     DECREMENT_STACK_POINTER (p, size);}
12754 
A68C_TRANSPUT(int,INT)12755 A68C_TRANSPUT (int, INT)
12756 A68C_TRANSPUT (long_int, LONG_INT)
12757 A68C_TRANSPUT (longlong_int, LONGLONG_INT)
12758 A68C_TRANSPUT (real, REAL)
12759 A68C_TRANSPUT (long_real, LONG_REAL)
12760 A68C_TRANSPUT (longlong_real, LONGLONG_REAL)
12761 A68C_TRANSPUT (bits, BITS)
12762 A68C_TRANSPUT (long_bits, LONG_BITS)
12763 A68C_TRANSPUT (longlong_bits, LONGLONG_BITS)
12764 A68C_TRANSPUT (bool, BOOL)
12765 A68C_TRANSPUT (char, CHAR)
12766 A68C_TRANSPUT (string, STRING)
12767 #undef A68C_TRANSPUT
12768 #define A68C_TRANSPUT(n, s, m)\
12769  void genie_get_##n (NODE_T * p) {\
12770     A68_REF ref_file;\
12771     POP_REF (p, &ref_file);\
12772     CHECK_REF (p, ref_file, MODE (REF_FILE));\
12773     PUSH_REF (p, ref_file);\
12774     genie_get_##s (p);\
12775     PUSH_REF (p, ref_file);\
12776     genie_get_##s (p);}\
12777   void genie_put_##n (NODE_T * p) {\
12778     int size = SIZE (MODE (m)), sizf = SIZE (MODE (REF_FILE));\
12779     A68_REF ref_file = * (A68_REF *) STACK_OFFSET (- (size + sizf));\
12780     CHECK_REF (p, ref_file, MODE (REF_FILE));\
12781     reset_transput_buffer (UNFORMATTED_BUFFER);\
12782     open_for_writing (p, ref_file);\
12783     genie_write_standard (p, MODE (m), STACK_OFFSET (-size), ref_file);\
12784     write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);\
12785     DECREMENT_STACK_POINTER (p, size + sizf);}\
12786   void genie_read_##n (NODE_T * p) {\
12787     genie_read_##s (p);\
12788     genie_read_##s (p);}\
12789   void genie_print_##n (NODE_T * p) {\
12790     int size = SIZE (MODE (m));\
12791     reset_transput_buffer (UNFORMATTED_BUFFER);\
12792     open_for_writing (p, stand_out);\
12793     genie_write_standard (p, MODE (m), STACK_OFFSET (-size), stand_out);\
12794     write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER);\
12795     DECREMENT_STACK_POINTER (p, size);}
12796 A68C_TRANSPUT (complex, real, COMPLEX)
12797 A68C_TRANSPUT (long_complex, long_real, LONG_COMPLEX)
12798 A68C_TRANSPUT (longlong_complex, longlong_real, LONGLONG_COMPLEX)
12799 #undef A68C_TRANSPUT
12800 /**
12801 @brief PROC STRING read line
12802 @param p Node in syntax tree.
12803 **/
12804      void genie_read_line (NODE_T * p)
12805 {
12806 #if defined HAVE_READLINE
12807   char *line = readline ("");
12808   if (line != NO_TEXT && (int) strlen (line) > 0) {
12809     add_history (line);
12810   }
12811   PUSH_REF (p, c_to_a_string (p, line, DEFAULT_WIDTH));
12812   free (line);
12813 #else
12814   genie_read_string (p);
12815   genie_stand_in (p);
12816   genie_new_line (p);
12817 #endif
12818 }
12819 
12820 /*
12821 Transput library - Formatted transput
12822 In Algol68G, a value of mode FORMAT looks like a routine text. The value
12823 comprises a pointer to its environment in the stack, and a pointer where the
12824 format text is at in the syntax tree.
12825 */
12826 
12827 #define INT_DIGITS "0123456789"
12828 #define BITS_DIGITS "0123456789abcdefABCDEF"
12829 #define INT_DIGITS_BLANK " 0123456789"
12830 #define BITS_DIGITS_BLANK " 0123456789abcdefABCDEF"
12831 #define SIGN_DIGITS " +-"
12832 
12833 /**
12834 @brief Handle format error event.
12835 @param p Node in syntax tree.
12836 @param ref_file Fat pointer to A68 file.
12837 @param diag Diagnostic text.
12838 **/
12839 
12840 void
format_error(NODE_T * p,A68_REF ref_file,char * diag)12841 format_error (NODE_T * p, A68_REF ref_file, char *diag)
12842 {
12843   A68_FILE *f = FILE_DEREF (&ref_file);
12844   A68_BOOL z;
12845   on_event_handler (p, FORMAT_ERROR_MENDED (f), ref_file);
12846   POP_OBJECT (p, &z, A68_BOOL);
12847   if (VALUE (&z) == A68_FALSE) {
12848     diagnostic_node (A68_RUNTIME_ERROR, p, diag);
12849     exit_genie (p, A68_RUNTIME_ERROR);
12850   }
12851 }
12852 
12853 /**
12854 @brief Initialise processing of pictures.
12855 @param p Node in syntax tree.
12856 **/
12857 
12858 static void
initialise_collitems(NODE_T * p)12859 initialise_collitems (NODE_T * p)
12860 {
12861 
12862 /*
12863 Every picture has a counter that says whether it has not been used OR the number
12864 of times it can still be used.
12865 */
12866 
12867   for (; p != NO_NODE; FORWARD (p)) {
12868     if (IS (p, PICTURE)) {
12869       A68_COLLITEM *z = (A68_COLLITEM *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (p)));
12870       STATUS (z) = INIT_MASK;
12871       COUNT (z) = ITEM_NOT_USED;
12872     }
12873 /* Don't dive into f, g, n frames and collections */
12874     if (!(IS (p, ENCLOSED_CLAUSE) || IS (p, COLLECTION))) {
12875       initialise_collitems (SUB (p));
12876     }
12877   }
12878 }
12879 
12880 /**
12881 @brief Initialise processing of format text.
12882 @param p Node in syntax tree.
12883 @param ref_file File.
12884 @param fmt Format.
12885 @param embedded Whether embedded format.
12886 @param init Whether to initialise collitems.
12887 **/
12888 
12889 static void
open_format_frame(NODE_T * p,A68_REF ref_file,A68_FORMAT * fmt,BOOL_T embedded,BOOL_T init)12890 open_format_frame (NODE_T * p, A68_REF ref_file, A68_FORMAT * fmt, BOOL_T embedded, BOOL_T init)
12891 {
12892 /* Open a new frame for the format text and save for return to embedding one */
12893   A68_FILE *file = FILE_DEREF (&ref_file);
12894   NODE_T *dollar;
12895   A68_FORMAT *save;
12896 /* Integrity check */
12897   if ((STATUS (fmt) & SKIP_FORMAT_MASK) || (BODY (fmt) == NO_NODE)) {
12898     format_error (p, ref_file, ERROR_FORMAT_UNDEFINED);
12899   }
12900 /* Ok, seems usable */
12901   dollar = SUB (BODY (fmt));
12902   OPEN_PROC_FRAME (dollar, ENVIRON (fmt));
12903   INIT_STATIC_FRAME (dollar);
12904 /* Save old format */
12905   save = (A68_FORMAT *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (dollar)));
12906   *save = (embedded == EMBEDDED_FORMAT ? FORMAT (file) : nil_format);
12907   FORMAT (file) = *fmt;
12908 /* Reset all collitems */
12909   if (init) {
12910     initialise_collitems (dollar);
12911   }
12912 }
12913 
12914 /**
12915 @brief Handle end-of-format event.
12916 @param p Node in syntax tree.
12917 @param ref_file Fat pointer to A68 file.
12918 @return Whether format is embedded.
12919 **/
12920 
12921 int
end_of_format(NODE_T * p,A68_REF ref_file)12922 end_of_format (NODE_T * p, A68_REF ref_file)
12923 {
12924 /*
12925 Format-items return immediately to the embedding format text. The outermost
12926 format text calls "on format end".
12927 */
12928   A68_FILE *file = FILE_DEREF (&ref_file);
12929   NODE_T *dollar = SUB (BODY (&FORMAT (file)));
12930   A68_FORMAT *save = (A68_FORMAT *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (dollar)));
12931   if (IS_NIL_FORMAT (save)) {
12932 /* Not embedded, outermost format: execute event routine */
12933     A68_BOOL z;
12934     on_event_handler (p, FORMAT_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
12935     POP_OBJECT (p, &z, A68_BOOL);
12936     if (VALUE (&z) == A68_FALSE) {
12937 /* Restart format */
12938       frame_pointer = FRAME_POINTER (file);
12939       stack_pointer = STACK_POINTER (file);
12940       open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_TRUE);
12941     }
12942     return (NOT_EMBEDDED_FORMAT);
12943   } else {
12944 /* Embedded format, return to embedding format, cf. RR */
12945     CLOSE_FRAME;
12946     FORMAT (file) = *save;
12947     return (EMBEDDED_FORMAT);
12948   }
12949 }
12950 
12951 /**
12952 @brief Return integral value of replicator.
12953 @param p Node in syntax tree.
12954 @param check Whether to check value of replicator.
12955 @return See brief description.
12956 **/
12957 
12958 int
get_replicator_value(NODE_T * p,BOOL_T check)12959 get_replicator_value (NODE_T * p, BOOL_T check)
12960 {
12961   int z = 0;
12962   if (IS (p, STATIC_REPLICATOR)) {
12963     A68_INT u;
12964     if (genie_string_to_value_internal (p, MODE (INT), NSYMBOL (p), (BYTE_T *) & u) == A68_FALSE) {
12965       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, MODE (INT));
12966       exit_genie (p, A68_RUNTIME_ERROR);
12967     }
12968     z = VALUE (&u);
12969   } else if (IS (p, DYNAMIC_REPLICATOR)) {
12970     A68_INT u;
12971     EXECUTE_UNIT (NEXT_SUB (p));
12972     POP_OBJECT (p, &u, A68_INT);
12973     z = VALUE (&u);
12974   } else if (IS (p, REPLICATOR)) {
12975     z = get_replicator_value (SUB (p), check);
12976   }
12977 /* Not conform RR as Andrew Herbert rightfully pointed out.
12978   if (check && z < 0) {
12979     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INVALID_REPLICATOR);
12980     exit_genie (p, A68_RUNTIME_ERROR);
12981   }
12982 */
12983   if (z < 0) {
12984     z = 0;
12985   }
12986   return (z);
12987 }
12988 
12989 /**
12990 @brief Return first available pattern.
12991 @param p Node in syntax tree.
12992 @param ref_file Fat pointer to A68 file.
12993 @return See brief description.
12994 **/
12995 
12996 static NODE_T *
scan_format_pattern(NODE_T * p,A68_REF ref_file)12997 scan_format_pattern (NODE_T * p, A68_REF ref_file)
12998 {
12999   for (; p != NO_NODE; FORWARD (p)) {
13000     if (IS (p, PICTURE_LIST)) {
13001       NODE_T *prio = scan_format_pattern (SUB (p), ref_file);
13002       if (prio != NO_NODE) {
13003         return (prio);
13004       }
13005     }
13006     if (IS (p, PICTURE)) {
13007       NODE_T *picture = SUB (p);
13008       A68_COLLITEM *collitem = (A68_COLLITEM *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (p)));
13009       if (COUNT (collitem) != 0) {
13010         if (IS (picture, A68_PATTERN)) {
13011           COUNT (collitem) = 0; /* This pattern is now done */
13012           picture = SUB (picture);
13013           if (ATTRIBUTE (picture) != FORMAT_PATTERN) {
13014             return (picture);
13015           } else {
13016             NODE_T *pat;
13017             A68_FORMAT z;
13018             A68_FILE *file = FILE_DEREF (&ref_file);
13019             EXECUTE_UNIT (NEXT_SUB (picture));
13020             POP_OBJECT (p, &z, A68_FORMAT);
13021             open_format_frame (p, ref_file, &z, EMBEDDED_FORMAT, A68_TRUE);
13022             pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file);
13023             if (pat != NO_NODE) {
13024               return (pat);
13025             } else {
13026               (void) end_of_format (p, ref_file);
13027             }
13028           }
13029         } else if (IS (picture, INSERTION)) {
13030           A68_FILE *file = FILE_DEREF (&ref_file);
13031           if (READ_MOOD (file)) {
13032             read_insertion (picture, ref_file);
13033           } else if (WRITE_MOOD (file)) {
13034             write_insertion (picture, ref_file, INSERTION_NORMAL);
13035           } else {
13036             ABEND (A68_TRUE, "undetermined mood for insertion", NO_TEXT);
13037           }
13038           COUNT (collitem) = 0; /* This insertion is now done */
13039         } else if (IS (picture, REPLICATOR) || IS (picture, COLLECTION)) {
13040           BOOL_T go_on = A68_TRUE;
13041           NODE_T *a68g_select = NO_NODE;
13042           if (COUNT (collitem) == ITEM_NOT_USED) {
13043             if (IS (picture, REPLICATOR)) {
13044               COUNT (collitem) = get_replicator_value (SUB (p), A68_TRUE);
13045               go_on = (BOOL_T) (COUNT (collitem) > 0);
13046               FORWARD (picture);
13047             } else {
13048               COUNT (collitem) = 1;
13049             }
13050             initialise_collitems (NEXT_SUB (picture));
13051           } else if (IS (picture, REPLICATOR)) {
13052             FORWARD (picture);
13053           }
13054           while (go_on) {
13055 /* Get format item from collection. If collection is done, but repitition is not,
13056    then re-initialise the collection and repeat */
13057             a68g_select = scan_format_pattern (NEXT_SUB (picture), ref_file);
13058             if (a68g_select != NO_NODE) {
13059               return (a68g_select);
13060             } else {
13061               COUNT (collitem)--;
13062               go_on = (BOOL_T) (COUNT (collitem) > 0);
13063               if (go_on) {
13064                 initialise_collitems (NEXT_SUB (picture));
13065               }
13066             }
13067           }
13068         }
13069       }
13070     }
13071   }
13072   return (NO_NODE);
13073 }
13074 
13075 /**
13076 @brief Return first available pattern.
13077 @param p Node in syntax tree.
13078 @param ref_file Fat pointer to A68 file.
13079 @param mood Mode of operation.
13080 @return See brief description.
13081 **/
13082 
13083 NODE_T *
get_next_format_pattern(NODE_T * p,A68_REF ref_file,BOOL_T mood)13084 get_next_format_pattern (NODE_T * p, A68_REF ref_file, BOOL_T mood)
13085 {
13086 /*
13087 "mood" can be WANT_PATTERN: pattern needed by caller, so perform end-of-format
13088 if needed or SKIP_PATTERN: just emptying current pattern/collection/format.
13089 */
13090   A68_FILE *file = FILE_DEREF (&ref_file);
13091   if (BODY (&FORMAT (file)) == NO_NODE) {
13092     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_EXHAUSTED);
13093     exit_genie (p, A68_RUNTIME_ERROR);
13094     return (NO_NODE);
13095   } else {
13096     NODE_T *pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file);
13097     if (pat == NO_NODE) {
13098       if (mood == WANT_PATTERN) {
13099         int z;
13100         do {
13101           z = end_of_format (p, ref_file);
13102           pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file);
13103         } while (z == EMBEDDED_FORMAT && pat == NO_NODE);
13104         if (pat == NO_NODE) {
13105           diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_EXHAUSTED);
13106           exit_genie (p, A68_RUNTIME_ERROR);
13107         }
13108       }
13109     }
13110     return (pat);
13111   }
13112 }
13113 
13114 /**
13115 @brief Diagnostic_node in case mode does not match picture.
13116 @param p Node in syntax tree.
13117 @param mode Mode of object read or written.
13118 @param att Attribute.
13119 **/
13120 
13121 void
pattern_error(NODE_T * p,MOID_T * mode,int att)13122 pattern_error (NODE_T * p, MOID_T * mode, int att)
13123 {
13124   diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_CANNOT_TRANSPUT, mode, att);
13125   exit_genie (p, A68_RUNTIME_ERROR);
13126 }
13127 
13128 /**
13129 @brief Unite value at top of stack to NUMBER.
13130 @param p Node in syntax tree.
13131 @param mode Mode of value.
13132 @param item Pointer to value.
13133 **/
13134 
13135 static void
unite_to_number(NODE_T * p,MOID_T * mode,BYTE_T * item)13136 unite_to_number (NODE_T * p, MOID_T * mode, BYTE_T * item)
13137 {
13138   ADDR_T sp = stack_pointer;
13139   PUSH_UNION (p, mode);
13140   PUSH (p, item, (int) SIZE (mode));
13141   stack_pointer = sp + SIZE (MODE (NUMBER));
13142 }
13143 
13144 /**
13145 @brief Write a group of insertions.
13146 @param p Node in syntax tree.
13147 @param ref_file Fat pointer to A68 file.
13148 @param mood Mode of operation in case of error.
13149 **/
13150 
13151 void
write_insertion(NODE_T * p,A68_REF ref_file,unsigned mood)13152 write_insertion (NODE_T * p, A68_REF ref_file, unsigned mood)
13153 {
13154   for (; p != NO_NODE; FORWARD (p)) {
13155     write_insertion (SUB (p), ref_file, mood);
13156     if (IS (p, FORMAT_ITEM_L)) {
13157       add_char_transput_buffer (p, FORMATTED_BUFFER, NEWLINE_CHAR);
13158       write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
13159     } else if (IS (p, FORMAT_ITEM_P)) {
13160       add_char_transput_buffer (p, FORMATTED_BUFFER, FORMFEED_CHAR);
13161       write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
13162     } else if (IS (p, FORMAT_ITEM_X) || IS (p, FORMAT_ITEM_Q)) {
13163       add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
13164     } else if (IS (p, FORMAT_ITEM_Y)) {
13165       PUSH_REF (p, ref_file);
13166       PUSH_PRIMITIVE (p, -1, A68_INT);
13167       genie_set (p);
13168     } else if (IS (p, LITERAL)) {
13169       if (mood & INSERTION_NORMAL) {
13170         add_string_transput_buffer (p, FORMATTED_BUFFER, NSYMBOL (p));
13171       } else if (mood & INSERTION_BLANK) {
13172         int j, k = (int) strlen (NSYMBOL (p));
13173         for (j = 1; j <= k; j++) {
13174           add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
13175         }
13176       }
13177     } else if (IS (p, REPLICATOR)) {
13178       int j, k = get_replicator_value (SUB (p), A68_TRUE);
13179       if (ATTRIBUTE (SUB_NEXT (p)) != FORMAT_ITEM_K) {
13180         for (j = 1; j <= k; j++) {
13181           write_insertion (NEXT (p), ref_file, mood);
13182         }
13183       } else {
13184         int pos = get_transput_buffer_index (FORMATTED_BUFFER);
13185         for (j = 1; j < (k - pos); j++) {
13186           add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
13187         }
13188       }
13189       return;
13190     }
13191   }
13192 }
13193 
13194 /**
13195 @brief Convert to other radix, binary up to hexadecimal.
13196 @param p Node in syntax tree.
13197 @param z Value to convert.
13198 @param radix Radix.
13199 @param width Width of converted number.
13200 @return Whether conversion is successful.
13201 **/
13202 
13203 static BOOL_T
convert_radix(NODE_T * p,unsigned z,int radix,int width)13204 convert_radix (NODE_T * p, unsigned z, int radix, int width)
13205 {
13206   static char *images = "0123456789abcdef";
13207   if (width > 0 && (radix >= 2 && radix <= 16)) {
13208     int digit = (int) (z % (unsigned) radix);
13209     BOOL_T success = convert_radix (p, z / (unsigned) radix, radix, width - 1);
13210     add_char_transput_buffer (p, EDIT_BUFFER, images[digit]);
13211     return (success);
13212   } else {
13213     return ((BOOL_T) (z == 0));
13214   }
13215 }
13216 
13217 /**
13218 @brief Convert to other radix, binary up to hexadecimal.
13219 @param p Node in syntax tree.
13220 @param u Mp number.
13221 @param radix Radix.
13222 @param width Width of converted number.
13223 @param m Mode of 'u'.
13224 @param v Work mp number.
13225 @param w Work mp number.
13226 @return Whether conversion is successful.
13227 **/
13228 
13229 static BOOL_T
convert_radix_mp(NODE_T * p,MP_T * u,int radix,int width,MOID_T * m,MP_T * v,MP_T * w)13230 convert_radix_mp (NODE_T * p, MP_T * u, int radix, int width, MOID_T * m, MP_T * v, MP_T * w)
13231 {
13232   static char *images = "0123456789abcdef";
13233   if (width > 0 && (radix >= 2 && radix <= 16)) {
13234     int digit, digits = DIGITS (m);
13235     BOOL_T success;
13236     MOVE_MP (w, u, digits);
13237     (void) over_mp_digit (p, u, u, (MP_T) radix, digits);
13238     (void) mul_mp_digit (p, v, u, (MP_T) radix, digits);
13239     (void) sub_mp (p, v, w, v, digits);
13240     digit = (int) MP_DIGIT (v, 1);
13241     success = convert_radix_mp (p, u, radix, width - 1, m, v, w);
13242     add_char_transput_buffer (p, EDIT_BUFFER, images[digit]);
13243     return (success);
13244   } else {
13245     return ((BOOL_T) (MP_DIGIT (u, 1) == 0));
13246   }
13247 }
13248 
13249 /**
13250 @brief Write string to file following current format.
13251 @param p Node in syntax tree.
13252 @param mode Mode of value.
13253 @param ref_file Fat pointer to A68 file.
13254 @param str String to write.
13255 **/
13256 
13257 static void
write_string_pattern(NODE_T * p,MOID_T * mode,A68_REF ref_file,char ** str)13258 write_string_pattern (NODE_T * p, MOID_T * mode, A68_REF ref_file, char **str)
13259 {
13260   for (; p != NO_NODE; FORWARD (p)) {
13261     if (IS (p, INSERTION)) {
13262       write_insertion (SUB (p), ref_file, INSERTION_NORMAL);
13263     } else if (IS (p, FORMAT_ITEM_A)) {
13264       if ((*str)[0] != NULL_CHAR) {
13265         add_char_transput_buffer (p, FORMATTED_BUFFER, (*str)[0]);
13266         (*str)++;
13267       } else {
13268         value_error (p, mode, ref_file);
13269       }
13270     } else if (IS (p, FORMAT_ITEM_S)) {
13271       if ((*str)[0] != NULL_CHAR) {
13272         (*str)++;
13273       } else {
13274         value_error (p, mode, ref_file);
13275       }
13276       return;
13277     } else if (IS (p, REPLICATOR)) {
13278       int j, k = get_replicator_value (SUB (p), A68_TRUE);
13279       for (j = 1; j <= k; j++) {
13280         write_string_pattern (NEXT (p), mode, ref_file, str);
13281       }
13282       return;
13283     } else {
13284       write_string_pattern (SUB (p), mode, ref_file, str);
13285     }
13286   }
13287 }
13288 
13289 /**
13290 @brief Scan c_pattern.
13291 @param p Node in syntax tree.
13292 @param right_align Conform C place holder.
13293 @param sign Conform C place holder.
13294 @param width Conform C place holder.
13295 @param after Conform C place holder.
13296 @param letter Conform C place holder.
13297 **/
13298 
13299 void
scan_c_pattern(NODE_T * p,BOOL_T * right_align,BOOL_T * sign,int * width,int * after,int * letter)13300 scan_c_pattern (NODE_T * p, BOOL_T * right_align, BOOL_T * sign, int *width, int *after, int *letter)
13301 {
13302   if (IS (p, FORMAT_ITEM_ESCAPE)) {
13303     FORWARD (p);
13304   }
13305   if (IS (p, FORMAT_ITEM_MINUS)) {
13306     *right_align = A68_TRUE;
13307     FORWARD (p);
13308   } else {
13309     *right_align = A68_FALSE;
13310   }
13311   if (IS (p, FORMAT_ITEM_PLUS)) {
13312     *sign = A68_TRUE;
13313     FORWARD (p);
13314   } else {
13315     *sign = A68_FALSE;
13316   }
13317   if (IS (p, REPLICATOR)) {
13318     *width = get_replicator_value (SUB (p), A68_TRUE);
13319     FORWARD (p);
13320   }
13321   if (IS (p, FORMAT_ITEM_POINT)) {
13322     FORWARD (p);
13323   }
13324   if (IS (p, REPLICATOR)) {
13325     *after = get_replicator_value (SUB (p), A68_TRUE);
13326     FORWARD (p);
13327   }
13328   *letter = ATTRIBUTE (p);
13329 }
13330 
13331 /**
13332 @brief Write appropriate insertion from a choice pattern.
13333 @param p Node in syntax tree.
13334 @param ref_file Fat pointer to A68 file.
13335 @param count Count to reach.
13336 **/
13337 
13338 static void
write_choice_pattern(NODE_T * p,A68_REF ref_file,int * count)13339 write_choice_pattern (NODE_T * p, A68_REF ref_file, int *count)
13340 {
13341   for (; p != NO_NODE; FORWARD (p)) {
13342     write_choice_pattern (SUB (p), ref_file, count);
13343     if (IS (p, PICTURE)) {
13344       (*count)--;
13345       if (*count == 0) {
13346         write_insertion (SUB (p), ref_file, INSERTION_NORMAL);
13347       }
13348     }
13349   }
13350 }
13351 
13352 /**
13353 @brief Write appropriate insertion from a boolean pattern.
13354 @param p Node in syntax tree.
13355 @param ref_file Fat pointer to A68 file.
13356 @param z BOOL value
13357 **/
13358 
13359 static void
write_boolean_pattern(NODE_T * p,A68_REF ref_file,BOOL_T z)13360 write_boolean_pattern (NODE_T * p, A68_REF ref_file, BOOL_T z)
13361 {
13362   int k = (z ? 1 : 2);
13363   write_choice_pattern (p, ref_file, &k);
13364 }
13365 
13366 /**
13367 @brief Write value according to a general pattern.
13368 @param p Node in syntax tree.
13369 @param mode Mode of value.
13370 @param item Pointer to value.
13371 @param mod Format modifier.
13372 **/
13373 
13374 static void
write_number_generic(NODE_T * p,MOID_T * mode,BYTE_T * item,int mod)13375 write_number_generic (NODE_T * p, MOID_T * mode, BYTE_T * item, int mod)
13376 {
13377   A68_REF row;
13378   A68_ARRAY *arr;
13379   A68_TUPLE *tup;
13380   int size;
13381 /* Push arguments */
13382   unite_to_number (p, mode, item);
13383   EXECUTE_UNIT (NEXT_SUB (p));
13384   POP_REF (p, &row);
13385   GET_DESCRIPTOR (arr, tup, &row);
13386   size = ROW_SIZE (tup);
13387   if (size > 0) {
13388     int i;
13389     BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
13390     for (i = LWB (tup); i <= UPB (tup); i++) {
13391       int addr = INDEX_1_DIM (arr, tup, i);
13392       int arg = VALUE ((A68_INT *) & (base_address[addr]));
13393       PUSH_PRIMITIVE (p, arg, A68_INT);
13394     }
13395   }
13396 /* Make a string */
13397   if (mod == FORMAT_ITEM_G) {
13398     switch (size) {
13399     case 1:
13400       {
13401         genie_whole (p);
13402         break;
13403       }
13404     case 2:
13405       {
13406         genie_fixed (p);
13407         break;
13408       }
13409     case 3:
13410       {
13411         genie_float (p);
13412         break;
13413       }
13414     default:
13415       {
13416         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, MODE (INT));
13417         exit_genie (p, A68_RUNTIME_ERROR);
13418         break;
13419       }
13420     }
13421   } else if (mod == FORMAT_ITEM_H) {
13422     int def_expo = 0, def_mult;
13423     A68_INT a_width, a_after, a_expo, a_mult;
13424     STATUS (&a_width) = INIT_MASK;
13425     VALUE (&a_width) = 0;
13426     STATUS (&a_after) = INIT_MASK;
13427     VALUE (&a_after) = 0;
13428     STATUS (&a_expo) = INIT_MASK;
13429     VALUE (&a_expo) = 0;
13430     STATUS (&a_mult) = INIT_MASK;
13431     VALUE (&a_mult) = 0;
13432     /*
13433      * Set default values
13434      */
13435     if (mode == MODE (REAL) || mode == MODE (INT)) {
13436       def_expo = EXP_WIDTH + 1;
13437     } else if (mode == MODE (LONG_REAL) || mode == MODE (LONG_INT)) {
13438       def_expo = LONG_EXP_WIDTH + 1;
13439     } else if (mode == MODE (LONGLONG_REAL) || mode == MODE (LONGLONG_INT)) {
13440       def_expo = LONGLONG_EXP_WIDTH + 1;
13441     }
13442     def_mult = 3;
13443     /*
13444      * Pop user values
13445      */
13446     switch (size) {
13447     case 1:
13448       {
13449         POP_OBJECT (p, &a_after, A68_INT);
13450         VALUE (&a_width) = VALUE (&a_after) + def_expo + 4;
13451         VALUE (&a_expo) = def_expo;
13452         VALUE (&a_mult) = def_mult;
13453         break;
13454       }
13455     case 2:
13456       {
13457         POP_OBJECT (p, &a_mult, A68_INT);
13458         POP_OBJECT (p, &a_after, A68_INT);
13459         VALUE (&a_width) = VALUE (&a_after) + def_expo + 4;
13460         VALUE (&a_expo) = def_expo;
13461         break;
13462       }
13463     case 3:
13464       {
13465         POP_OBJECT (p, &a_mult, A68_INT);
13466         POP_OBJECT (p, &a_after, A68_INT);
13467         POP_OBJECT (p, &a_width, A68_INT);
13468         VALUE (&a_expo) = def_expo;
13469         break;
13470       }
13471     case 4:
13472       {
13473         POP_OBJECT (p, &a_mult, A68_INT);
13474         POP_OBJECT (p, &a_expo, A68_INT);
13475         POP_OBJECT (p, &a_after, A68_INT);
13476         POP_OBJECT (p, &a_width, A68_INT);
13477         break;
13478       }
13479     default:
13480       {
13481         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, MODE (INT));
13482         exit_genie (p, A68_RUNTIME_ERROR);
13483         break;
13484       }
13485     }
13486     PUSH_PRIMITIVE (p, VALUE (&a_width), A68_INT);
13487     PUSH_PRIMITIVE (p, VALUE (&a_after), A68_INT);
13488     PUSH_PRIMITIVE (p, VALUE (&a_expo), A68_INT);
13489     PUSH_PRIMITIVE (p, VALUE (&a_mult), A68_INT);
13490     genie_real (p);
13491   }
13492   add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
13493 }
13494 
13495 /**
13496 @brief Write %[-][+][w][.][d]s/d/i/f/e/b/o/x formats.
13497 @param p Node in syntax tree.
13498 @param mode Mode of value.
13499 @param item Pointer to value.
13500 @param ref_file Fat pointer to A68 file.
13501 **/
13502 
13503 static void
write_c_pattern(NODE_T * p,MOID_T * mode,BYTE_T * item,A68_REF ref_file)13504 write_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
13505 {
13506   BOOL_T right_align, sign, invalid;
13507   int width, after, letter;
13508   ADDR_T pop_sp = stack_pointer;
13509   char *str = NO_TEXT;
13510   if (IS (p, CHAR_C_PATTERN)) {
13511     A68_CHAR *z = (A68_CHAR *) item;
13512     char q[2];
13513     q[0] = (char) VALUE (z);
13514     q[1] = NULL_CHAR;
13515     str = (char *) &q;
13516     width = (int) strlen (str);
13517     scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
13518   } else if (IS (p, STRING_C_PATTERN)) {
13519     str = (char *) item;
13520     width = (int) strlen (str);
13521     scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
13522   } else if (IS (p, INTEGRAL_C_PATTERN)) {
13523     width = 0;
13524     scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
13525     unite_to_number (p, mode, item);
13526     PUSH_PRIMITIVE (p, (sign ? width : -width), A68_INT);
13527     str = whole (p);
13528   } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
13529     int att = ATTRIBUTE (p), expval = 0, expo = 0;
13530     if (att == FLOAT_C_PATTERN || att == GENERAL_C_PATTERN) {
13531       int digits = 0;
13532       if (mode == MODE (REAL) || mode == MODE (INT)) {
13533         width = REAL_WIDTH + EXP_WIDTH + 4;
13534         after = REAL_WIDTH - 1;
13535         expo = EXP_WIDTH + 1;
13536       } else if (mode == MODE (LONG_REAL) || mode == MODE (LONG_INT)) {
13537         width = LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4;
13538         after = LONG_REAL_WIDTH - 1;
13539         expo = LONG_EXP_WIDTH + 1;
13540       } else if (mode == MODE (LONGLONG_REAL) || mode == MODE (LONGLONG_INT)) {
13541         width = LONGLONG_REAL_WIDTH + LONGLONG_EXP_WIDTH + 4;
13542         after = LONGLONG_REAL_WIDTH - 1;
13543         expo = LONGLONG_EXP_WIDTH + 1;
13544       }
13545       scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter);
13546       if (digits == 0 && after > 0) {
13547         width = after + expo + 4;
13548       } else if (digits > 0) {
13549         width = digits;
13550       }
13551       unite_to_number (p, mode, item);
13552       PUSH_PRIMITIVE (p, (sign ? width : -width), A68_INT);
13553       PUSH_PRIMITIVE (p, after, A68_INT);
13554       PUSH_PRIMITIVE (p, expo, A68_INT);
13555       PUSH_PRIMITIVE (p, 1, A68_INT);
13556       str = real (p);
13557       stack_pointer = pop_sp;
13558     }
13559     if (att == GENERAL_C_PATTERN) {
13560       char *expch = strchr (str, EXPONENT_CHAR);
13561       if (expch != NO_TEXT) {
13562         expval = (int) strtol (&(expch[1]), NO_VAR, 10);
13563       }
13564     }
13565     if ((att == FIXED_C_PATTERN) || (att == GENERAL_C_PATTERN && (expval > -4 && expval <= after))) {
13566       int digits = 0;
13567       if (mode == MODE (REAL) || mode == MODE (INT)) {
13568         width = REAL_WIDTH + 2;
13569         after = REAL_WIDTH - 1;
13570       } else if (mode == MODE (LONG_REAL) || mode == MODE (LONG_INT)) {
13571         width = LONG_REAL_WIDTH + 2;
13572         after = LONG_REAL_WIDTH - 1;
13573       } else if (mode == MODE (LONGLONG_REAL) || mode == MODE (LONGLONG_INT)) {
13574         width = LONGLONG_REAL_WIDTH + 2;
13575         after = LONGLONG_REAL_WIDTH - 1;
13576       }
13577       scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter);
13578       if (digits == 0 && after > 0) {
13579         width = after + 2;
13580       } else if (digits > 0) {
13581         width = digits;
13582       }
13583       unite_to_number (p, mode, item);
13584       PUSH_PRIMITIVE (p, (sign ? width : -width), A68_INT);
13585       PUSH_PRIMITIVE (p, after, A68_INT);
13586       str = fixed (p);
13587       stack_pointer = pop_sp;
13588     }
13589   } else if (IS (p, BITS_C_PATTERN)) {
13590     int radix = 10, nibble = 1;
13591     width = 0;
13592     scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
13593     if (letter == FORMAT_ITEM_B) {
13594       radix = 2;
13595       nibble = 1;
13596     } else if (letter == FORMAT_ITEM_O) {
13597       radix = 8;
13598       nibble = 3;
13599     } else if (letter == FORMAT_ITEM_X) {
13600       radix = 16;
13601       nibble = 4;
13602     }
13603     if (width == 0) {
13604       if (mode == MODE (BITS)) {
13605         width = (int) ceil ((double) BITS_WIDTH / (double) nibble);
13606       } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) {
13607         width = (int) ceil ((double) get_mp_bits_width (mode) / (double) nibble);
13608       }
13609     }
13610     if (mode == MODE (BITS)) {
13611       A68_BITS *z = (A68_BITS *) item;
13612       reset_transput_buffer (EDIT_BUFFER);
13613       if (!convert_radix (p, VALUE (z), radix, width)) {
13614         errno = EDOM;
13615         value_error (p, mode, ref_file);
13616       }
13617       str = get_transput_buffer (EDIT_BUFFER);
13618     } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) {
13619       int digits = DIGITS (mode);
13620       MP_T *u = (MP_T *) item;
13621       MP_T *v;
13622       MP_T *w;
13623       STACK_MP (v, p, digits);
13624       STACK_MP (w, p, digits);
13625       reset_transput_buffer (EDIT_BUFFER);
13626       if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
13627         errno = EDOM;
13628         value_error (p, mode, ref_file);
13629       }
13630       str = get_transput_buffer (EDIT_BUFFER);
13631     }
13632   }
13633 /* Did the conversion succeed? */
13634   if (IS (p, CHAR_C_PATTERN) || IS (p, STRING_C_PATTERN)) {
13635     invalid = A68_FALSE;
13636   } else {
13637     invalid = (a68g_strchr (str, ERROR_CHAR) != NO_TEXT);
13638   }
13639   if (invalid) {
13640     value_error (p, mode, ref_file);
13641     (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
13642   } else {
13643 /* Align and output */
13644     if (width == 0) {
13645       add_string_transput_buffer (p, FORMATTED_BUFFER, str);
13646     } else {
13647       if (right_align == A68_TRUE) {
13648         int blanks = width - (int) strlen (str);
13649         if (blanks >= 0) {
13650           while (blanks--) {
13651             add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
13652           }
13653           add_string_transput_buffer (p, FORMATTED_BUFFER, str);
13654         } else {
13655           value_error (p, mode, ref_file);
13656           (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
13657         }
13658       } else {
13659         int blanks;
13660         while (str[0] == BLANK_CHAR) {
13661           str++;
13662         }
13663         blanks = width - (int) strlen (str);
13664         if (blanks >= 0) {
13665           add_string_transput_buffer (p, FORMATTED_BUFFER, str);
13666           while (blanks--) {
13667             add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
13668           }
13669         } else {
13670           value_error (p, mode, ref_file);
13671           (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
13672         }
13673       }
13674     }
13675   }
13676 }
13677 
13678 /**
13679 @brief Read one char from file.
13680 @param p Node in syntax tree.
13681 @param ref_file Fat pointer to A68 file.
13682 @return See brief description.
13683 **/
13684 
13685 static char
read_single_char(NODE_T * p,A68_REF ref_file)13686 read_single_char (NODE_T * p, A68_REF ref_file)
13687 {
13688   A68_FILE *file = FILE_DEREF (&ref_file);
13689   int ch = char_scanner (file);
13690   if (ch == EOF_CHAR) {
13691     end_of_file_error (p, ref_file);
13692   }
13693   return ((char) ch);
13694 }
13695 
13696 /**
13697 @brief Scan n chars from file to input buffer.
13698 @param p Node in syntax tree.
13699 @param n Chars to scan.
13700 @param m Mode being scanned.
13701 @param ref_file Fat pointer to A68 file.
13702 **/
13703 
13704 static void
scan_n_chars(NODE_T * p,int n,MOID_T * m,A68_REF ref_file)13705 scan_n_chars (NODE_T * p, int n, MOID_T * m, A68_REF ref_file)
13706 {
13707   int k;
13708   (void) m;
13709   for (k = 0; k < n; k++) {
13710     int ch = read_single_char (p, ref_file);
13711     add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
13712   }
13713 }
13714 
13715 /**
13716 @brief Read %[-][+][w][.][d]s/d/i/f/e/b/o/x formats.
13717 @param p Node in syntax tree.
13718 @param mode Mode of value.
13719 @param item Pointer to value.
13720 @param ref_file Fat pointer to A68 file.
13721 **/
13722 
13723 static void
read_c_pattern(NODE_T * p,MOID_T * mode,BYTE_T * item,A68_REF ref_file)13724 read_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
13725 {
13726   BOOL_T right_align, sign;
13727   int width, after, letter;
13728   ADDR_T pop_sp = stack_pointer;
13729   reset_transput_buffer (INPUT_BUFFER);
13730   if (IS (p, CHAR_C_PATTERN)) {
13731     width = 0;
13732     scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
13733     if (width == 0) {
13734       genie_read_standard (p, mode, item, ref_file);
13735     } else {
13736       scan_n_chars (p, width, mode, ref_file);
13737       if (width > 1 && right_align == A68_FALSE) {
13738         for (; width > 1; width--) {
13739           (void) pop_char_transput_buffer (INPUT_BUFFER);
13740         }
13741       }
13742       genie_string_to_value (p, mode, item, ref_file);
13743     }
13744   } else if (IS (p, STRING_C_PATTERN)) {
13745     width = 0;
13746     scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
13747     if (width == 0) {
13748       genie_read_standard (p, mode, item, ref_file);
13749     } else {
13750       scan_n_chars (p, width, mode, ref_file);
13751       genie_string_to_value (p, mode, item, ref_file);
13752     }
13753   } else if (IS (p, INTEGRAL_C_PATTERN)) {
13754     if (mode != MODE (INT) && mode != MODE (LONG_INT) && mode != MODE (LONGLONG_INT)) {
13755       pattern_error (p, mode, ATTRIBUTE (p));
13756     } else {
13757       width = 0;
13758       scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
13759       if (width == 0) {
13760         genie_read_standard (p, mode, item, ref_file);
13761       } else {
13762         scan_n_chars (p, (sign != 0) ? width + 1 : width, mode, ref_file);
13763         genie_string_to_value (p, mode, item, ref_file);
13764       }
13765     }
13766   } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
13767     if (mode != MODE (REAL) && mode != MODE (LONG_REAL) && mode != MODE (LONGLONG_REAL)) {
13768       pattern_error (p, mode, ATTRIBUTE (p));
13769     } else {
13770       width = 0;
13771       scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
13772       if (width == 0) {
13773         genie_read_standard (p, mode, item, ref_file);
13774       } else {
13775         scan_n_chars (p, (sign != 0) ? width + 1 : width, mode, ref_file);
13776         genie_string_to_value (p, mode, item, ref_file);
13777       }
13778     }
13779   } else if (IS (p, BITS_C_PATTERN)) {
13780     if (mode != MODE (BITS) && mode != MODE (LONG_BITS) && mode != MODE (LONGLONG_BITS)) {
13781       pattern_error (p, mode, ATTRIBUTE (p));
13782     } else {
13783       int radix = 10;
13784       char *str;
13785       width = 0;
13786       scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
13787       if (letter == FORMAT_ITEM_B) {
13788         radix = 2;
13789       } else if (letter == FORMAT_ITEM_O) {
13790         radix = 8;
13791       } else if (letter == FORMAT_ITEM_X) {
13792         radix = 16;
13793       }
13794       str = get_transput_buffer (INPUT_BUFFER);
13795       if (width == 0) {
13796         A68_FILE *file = FILE_DEREF (&ref_file);
13797         int ch;
13798         ASSERT (snprintf (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
13799         set_transput_buffer_index (INPUT_BUFFER, (int) strlen (str));
13800         ch = char_scanner (file);
13801         while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
13802           if (IS_NL_FF (ch)) {
13803             skip_nl_ff (p, &ch, ref_file);
13804           } else {
13805             ch = char_scanner (file);
13806           }
13807         }
13808         while (ch != EOF_CHAR && IS_XDIGIT (ch)) {
13809           add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
13810           ch = char_scanner (file);
13811         }
13812         unchar_scanner (p, file, (char) ch);
13813       } else {
13814         ASSERT (snprintf (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
13815         set_transput_buffer_index (INPUT_BUFFER, (int) strlen (str));
13816         scan_n_chars (p, width, mode, ref_file);
13817       }
13818       genie_string_to_value (p, mode, item, ref_file);
13819     }
13820   }
13821   stack_pointer = pop_sp;
13822 }
13823 
13824 /* INTEGRAL, REAL, COMPLEX and BITS patterns */
13825 
13826 /**
13827 @brief Count Z and D frames in a mould.
13828 @param p Node in syntax tree.
13829 @param z Counting integer.
13830 **/
13831 
13832 static void
count_zd_frames(NODE_T * p,int * z)13833 count_zd_frames (NODE_T * p, int *z)
13834 {
13835   for (; p != NO_NODE; FORWARD (p)) {
13836     if (IS (p, FORMAT_ITEM_D) || IS (p, FORMAT_ITEM_Z)) {
13837       (*z)++;
13838     } else if (IS (p, REPLICATOR)) {
13839       int j, k = get_replicator_value (SUB (p), A68_TRUE);
13840       for (j = 1; j <= k; j++) {
13841         count_zd_frames (NEXT (p), z);
13842       }
13843       return;
13844     } else {
13845       count_zd_frames (SUB (p), z);
13846     }
13847   }
13848 }
13849 
13850 /**
13851 @brief Get sign from sign mould.
13852 @param p Node in syntax tree.
13853 @return Position of sign in tree or NULL.
13854 **/
13855 
13856 static NODE_T *
get_sign(NODE_T * p)13857 get_sign (NODE_T * p)
13858 {
13859   for (; p != NO_NODE; FORWARD (p)) {
13860     NODE_T *q = get_sign (SUB (p));
13861     if (q != NO_NODE) {
13862       return (q);
13863     } else if (IS (p, FORMAT_ITEM_PLUS) || IS (p, FORMAT_ITEM_MINUS)) {
13864       return (p);
13865     }
13866   }
13867   return (NO_NODE);
13868 }
13869 
13870 /**
13871 @brief Shift sign through Z frames until non-zero digit or D frame.
13872 @param p Node in syntax tree.
13873 @param q String to propagate sign through.
13874 **/
13875 
13876 static void
shift_sign(NODE_T * p,char ** q)13877 shift_sign (NODE_T * p, char **q)
13878 {
13879   for (; p != NO_NODE && (*q) != NO_TEXT; FORWARD (p)) {
13880     shift_sign (SUB (p), q);
13881     if (IS (p, FORMAT_ITEM_Z)) {
13882       if (((*q)[0] == '+' || (*q)[0] == '-') && (*q)[1] == '0') {
13883         char ch = (*q)[0];
13884         (*q)[0] = (*q)[1];
13885         (*q)[1] = ch;
13886         (*q)++;
13887       }
13888     } else if (IS (p, FORMAT_ITEM_D)) {
13889       (*q) = NO_TEXT;
13890     } else if (IS (p, REPLICATOR)) {
13891       int j, k = get_replicator_value (SUB (p), A68_TRUE);
13892       for (j = 1; j <= k; j++) {
13893         shift_sign (NEXT (p), q);
13894       }
13895       return;
13896     }
13897   }
13898 }
13899 
13900 /**
13901 @brief Pad trailing blanks to integral until desired width.
13902 @param p Node in syntax tree.
13903 @param n Number of zeroes to pad.
13904 **/
13905 
13906 static void
put_zeroes_to_integral(NODE_T * p,int n)13907 put_zeroes_to_integral (NODE_T * p, int n)
13908 {
13909   for (; n > 0; n--) {
13910     add_char_transput_buffer (p, EDIT_BUFFER, '0');
13911   }
13912 }
13913 
13914 /**
13915 @brief Pad a sign to integral representation.
13916 @param p Node in syntax tree.
13917 @param sign Sign.
13918 **/
13919 
13920 static void
put_sign_to_integral(NODE_T * p,int sign)13921 put_sign_to_integral (NODE_T * p, int sign)
13922 {
13923   NODE_T *sign_node = get_sign (SUB (p));
13924   if (IS (sign_node, FORMAT_ITEM_PLUS)) {
13925     add_char_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? '+' : '-'));
13926   } else {
13927     add_char_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? BLANK_CHAR : '-'));
13928   }
13929 }
13930 
13931 /**
13932 @brief Write point, exponent or plus-i-times symbol.
13933 @param p Node in syntax tree.
13934 @param ref_file Fat pointer to A68 file.
13935 @param att Attribute.
13936 @param sym Symbol to print when matched.
13937 **/
13938 
13939 static void
write_pie_frame(NODE_T * p,A68_REF ref_file,int att,int sym)13940 write_pie_frame (NODE_T * p, A68_REF ref_file, int att, int sym)
13941 {
13942   for (; p != NO_NODE; FORWARD (p)) {
13943     if (IS (p, INSERTION)) {
13944       write_insertion (p, ref_file, INSERTION_NORMAL);
13945     } else if (IS (p, att)) {
13946       write_pie_frame (SUB (p), ref_file, att, sym);
13947       return;
13948     } else if (IS (p, sym)) {
13949       add_string_transput_buffer (p, FORMATTED_BUFFER, NSYMBOL (p));
13950     } else if (IS (p, FORMAT_ITEM_S)) {
13951       return;
13952     }
13953   }
13954 }
13955 
13956 /**
13957 @brief Write sign when appropriate.
13958 @param p Node in syntax tree.
13959 @param q String to write.
13960 **/
13961 
13962 static void
write_mould_put_sign(NODE_T * p,char ** q)13963 write_mould_put_sign (NODE_T * p, char **q)
13964 {
13965   if ((*q)[0] == '+' || (*q)[0] == '-' || (*q)[0] == BLANK_CHAR) {
13966     add_char_transput_buffer (p, FORMATTED_BUFFER, (*q)[0]);
13967     (*q)++;
13968   }
13969 }
13970 
13971 /**
13972 @brief Write character according to a mould.
13973 @param p Node in syntax tree.
13974 @param ch Character to write.
13975 @param q Pointer in mould.
13976 **/
13977 
13978 static void
add_char_mould(NODE_T * p,char ch,char ** q)13979 add_char_mould (NODE_T * p, char ch, char **q)
13980 {
13981   if (ch != NULL_CHAR) {
13982     add_char_transput_buffer (p, FORMATTED_BUFFER, ch);
13983     (*q)++;
13984   }
13985 }
13986 
13987 /**
13988 @brief Write string according to a mould.
13989 @param p Node in syntax tree.
13990 @param ref_file File descriptor.
13991 @param type Type of mould.
13992 @param q Pointer in mould.
13993 @param mood Mode of operation.
13994 **/
13995 
13996 static void
write_mould(NODE_T * p,A68_REF ref_file,int type,char ** q,unsigned * mood)13997 write_mould (NODE_T * p, A68_REF ref_file, int type, char **q, unsigned *mood)
13998 {
13999   for (; p != NO_NODE; FORWARD (p)) {
14000 /* Insertions are inserted straight away. Note that we can suppress them using "mood", which is not standard A68 */
14001     if (IS (p, INSERTION)) {
14002       write_insertion (SUB (p), ref_file, *mood);
14003     } else {
14004       write_mould (SUB (p), ref_file, type, q, mood);
14005 /* Z frames print blanks until first non-zero digits comes */
14006       if (IS (p, FORMAT_ITEM_Z)) {
14007         write_mould_put_sign (p, q);
14008         if ((*q)[0] == '0') {
14009           if (*mood & DIGIT_BLANK) {
14010             add_char_mould (p, BLANK_CHAR, q);
14011             *mood = (*mood & ~INSERTION_NORMAL) | INSERTION_BLANK;
14012           } else if (*mood & DIGIT_NORMAL) {
14013             add_char_mould (p, '0', q);
14014             *mood = (unsigned) (DIGIT_NORMAL | INSERTION_NORMAL);
14015           }
14016         } else {
14017           add_char_mould (p, (*q)[0], q);
14018           *mood = (unsigned) (DIGIT_NORMAL | INSERTION_NORMAL);
14019         }
14020       }
14021 /* D frames print a digit */
14022       else if (IS (p, FORMAT_ITEM_D)) {
14023         write_mould_put_sign (p, q);
14024         add_char_mould (p, (*q)[0], q);
14025         *mood = (unsigned) (DIGIT_NORMAL | INSERTION_NORMAL);
14026       }
14027 /* Suppressible frames */
14028       else if (IS (p, FORMAT_ITEM_S)) {
14029 /* Suppressible frames are ignored in a sign-mould */
14030         if (type == SIGN_MOULD) {
14031           write_mould (NEXT (p), ref_file, type, q, mood);
14032         } else if (type == INTEGRAL_MOULD) {
14033           if ((*q)[0] != NULL_CHAR) {
14034             (*q)++;
14035           }
14036         }
14037         return;
14038       }
14039 /* Replicator */
14040       else if (IS (p, REPLICATOR)) {
14041         int j, k = get_replicator_value (SUB (p), A68_TRUE);
14042         for (j = 1; j <= k; j++) {
14043           write_mould (NEXT (p), ref_file, type, q, mood);
14044         }
14045         return;
14046       }
14047     }
14048   }
14049 }
14050 
14051 /**
14052 @brief Write INT value using int pattern.
14053 @param p Node in syntax tree.
14054 @param mode Mode of value.
14055 @param root Root mode.
14056 @param item Pointer to value.
14057 @param ref_file Fat pointer to A68 file.
14058 **/
14059 
14060 static void
write_integral_pattern(NODE_T * p,MOID_T * mode,MOID_T * root,BYTE_T * item,A68_REF ref_file)14061 write_integral_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68_REF ref_file)
14062 {
14063   RESET_ERRNO;
14064   if (!(mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT))) {
14065     pattern_error (p, root, ATTRIBUTE (p));
14066   } else {
14067     ADDR_T old_stack_pointer = stack_pointer;
14068     char *str;
14069     int width = 0, sign = 0;
14070     unsigned mood;
14071 /* Dive into the pattern if needed */
14072     if (IS (p, INTEGRAL_PATTERN)) {
14073       p = SUB (p);
14074     }
14075 /* Find width */
14076     count_zd_frames (p, &width);
14077 /* Make string */
14078     reset_transput_buffer (EDIT_BUFFER);
14079     if (mode == MODE (INT)) {
14080       A68_INT *z = (A68_INT *) item;
14081       sign = SIGN (VALUE (z));
14082       str = sub_whole (p, ABS (VALUE (z)), width);
14083     } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) {
14084       MP_T *z = (MP_T *) item;
14085       sign = SIGN (z[2]);
14086       z[2] = ABS (z[2]);
14087       str = long_sub_whole (p, z, DIGITS (mode), width);
14088     }
14089 /* Edit string and output */
14090     if (a68g_strchr (str, ERROR_CHAR) != NO_TEXT) {
14091       value_error (p, root, ref_file);
14092     }
14093     if (IS (p, SIGN_MOULD)) {
14094       put_sign_to_integral (p, sign);
14095     } else if (sign < 0) {
14096       value_sign_error (p, root, ref_file);
14097     }
14098     put_zeroes_to_integral (p, width - (int) strlen (str));
14099     add_string_transput_buffer (p, EDIT_BUFFER, str);
14100     str = get_transput_buffer (EDIT_BUFFER);
14101     mood = (unsigned) (DIGIT_BLANK | INSERTION_NORMAL);
14102     if (IS (p, SIGN_MOULD)) {
14103       if (str[0] == '+' || str[0] == '-') {
14104         shift_sign (SUB (p), &str);
14105       }
14106       str = get_transput_buffer (EDIT_BUFFER);
14107       write_mould (SUB (p), ref_file, SIGN_MOULD, &str, &mood);
14108       FORWARD (p);
14109     }
14110     if (IS (p, INTEGRAL_MOULD)) {       /* This *should* be the case */
14111       write_mould (SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood);
14112     }
14113     stack_pointer = old_stack_pointer;
14114   }
14115 }
14116 
14117 /**
14118 @brief Write REAL value using real pattern.
14119 @param p Node in syntax tree.
14120 @param mode Mode of value.
14121 @param root Root mode.
14122 @param item Pointer to value.
14123 @param ref_file Fat pointer to A68 file.
14124 **/
14125 
14126 static void
write_real_pattern(NODE_T * p,MOID_T * mode,MOID_T * root,BYTE_T * item,A68_REF ref_file)14127 write_real_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68_REF ref_file)
14128 {
14129   RESET_ERRNO;
14130   if (!(mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL) || mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT))) {
14131     pattern_error (p, root, ATTRIBUTE (p));
14132   } else {
14133     ADDR_T old_stack_pointer = stack_pointer;
14134     int stag_digits = 0, frac_digits = 0, expo_digits = 0;
14135     int mant_length, sign = 0, exp_value;
14136     NODE_T *q, *sign_mould = NO_NODE, *stag_mould = NO_NODE, *point_frame = NO_NODE, *frac_mould = NO_NODE, *e_frame = NO_NODE, *expo_mould = NO_NODE;
14137     char *str = NO_TEXT, *stag_str = NO_TEXT, *frac_str = NO_TEXT;
14138     unsigned mood;
14139 /* Dive into pattern */
14140     q = ((IS (p, REAL_PATTERN)) ? SUB (p) : p);
14141 /* Dissect pattern and establish widths */
14142     if (q != NO_NODE && IS (q, SIGN_MOULD)) {
14143       sign_mould = q;
14144       count_zd_frames (SUB (sign_mould), &stag_digits);
14145       FORWARD (q);
14146     }
14147     if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
14148       stag_mould = q;
14149       count_zd_frames (SUB (stag_mould), &stag_digits);
14150       FORWARD (q);
14151     }
14152     if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) {
14153       point_frame = q;
14154       FORWARD (q);
14155     }
14156     if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
14157       frac_mould = q;
14158       count_zd_frames (SUB (frac_mould), &frac_digits);
14159       FORWARD (q);
14160     }
14161     if (q != NO_NODE && IS (q, EXPONENT_FRAME)) {
14162       e_frame = SUB (q);
14163       expo_mould = NEXT_SUB (q);
14164       q = expo_mould;
14165       if (IS (q, SIGN_MOULD)) {
14166         count_zd_frames (SUB (q), &expo_digits);
14167         FORWARD (q);
14168       }
14169       if (IS (q, INTEGRAL_MOULD)) {
14170         count_zd_frames (SUB (q), &expo_digits);
14171       }
14172     }
14173 /* Make string representation */
14174     if (point_frame == NO_NODE) {
14175       mant_length = stag_digits;
14176     } else {
14177       mant_length = 1 + stag_digits + frac_digits;
14178     }
14179     if (mode == MODE (REAL) || mode == MODE (INT)) {
14180       double x;
14181       if (mode == MODE (REAL)) {
14182         x = VALUE ((A68_REAL *) item);
14183       } else {
14184         x = (double) VALUE ((A68_INT *) item);
14185       }
14186 #if defined HAVE_IEEE_754
14187       if (NOT_A_REAL (x)) {
14188         char *s = stack_string (p, 8 + mant_length);
14189         (void) error_chars (s, mant_length);
14190         add_string_transput_buffer (p, FORMATTED_BUFFER, s);
14191         stack_pointer = old_stack_pointer;
14192         return;
14193       }
14194 #endif
14195       exp_value = 0;
14196       sign = SIGN (x);
14197       if (sign_mould != NO_NODE) {
14198         put_sign_to_integral (sign_mould, sign);
14199       }
14200       x = ABS (x);
14201       if (expo_mould != NO_NODE) {
14202         standardise (&x, stag_digits, frac_digits, &exp_value);
14203       }
14204       str = sub_fixed (p, x, mant_length, frac_digits);
14205     } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) {
14206       ADDR_T old_stack_pointer2 = stack_pointer;
14207       int digits = DIGITS (mode);
14208       MP_T *x;
14209       STACK_MP (x, p, digits);
14210       MOVE_MP (x, (MP_T *) item, digits);
14211       exp_value = 0;
14212       sign = SIGN (x[2]);
14213       if (sign_mould != NO_NODE) {
14214         put_sign_to_integral (sign_mould, sign);
14215       }
14216       x[2] = ABS (x[2]);
14217       if (expo_mould != NO_NODE) {
14218         long_standardise (p, x, DIGITS (mode), stag_digits, frac_digits, &exp_value);
14219       }
14220       str = long_sub_fixed (p, x, DIGITS (mode), mant_length, frac_digits);
14221       stack_pointer = old_stack_pointer2;
14222     }
14223 /* Edit and output the string */
14224     if (a68g_strchr (str, ERROR_CHAR) != NO_TEXT) {
14225       value_error (p, root, ref_file);
14226     }
14227     reset_transput_buffer (STRING_BUFFER);
14228     add_string_transput_buffer (p, STRING_BUFFER, str);
14229     stag_str = get_transput_buffer (STRING_BUFFER);
14230     if (a68g_strchr (stag_str, ERROR_CHAR) != NO_TEXT) {
14231       value_error (p, root, ref_file);
14232     }
14233     str = a68g_strchr (stag_str, POINT_CHAR);
14234     if (str != NO_TEXT) {
14235       frac_str = &str[1];
14236       str[0] = NULL_CHAR;
14237     } else {
14238       frac_str = NO_TEXT;
14239     }
14240 /* Stagnant part */
14241     reset_transput_buffer (EDIT_BUFFER);
14242     if (sign_mould != NO_NODE) {
14243       put_sign_to_integral (sign_mould, sign);
14244     } else if (sign < 0) {
14245       value_sign_error (sign_mould, root, ref_file);
14246     }
14247     put_zeroes_to_integral (p, stag_digits - (int) strlen (stag_str));
14248     add_string_transput_buffer (p, EDIT_BUFFER, stag_str);
14249     stag_str = get_transput_buffer (EDIT_BUFFER);
14250     mood = (unsigned) (DIGIT_BLANK | INSERTION_NORMAL);
14251     if (sign_mould != NO_NODE) {
14252       if (stag_str[0] == '+' || stag_str[0] == '-') {
14253         shift_sign (SUB (p), &stag_str);
14254       }
14255       stag_str = get_transput_buffer (EDIT_BUFFER);
14256       write_mould (SUB (sign_mould), ref_file, SIGN_MOULD, &stag_str, &mood);
14257     }
14258     if (stag_mould != NO_NODE) {
14259       write_mould (SUB (stag_mould), ref_file, INTEGRAL_MOULD, &stag_str, &mood);
14260     }
14261 /* Point frame */
14262     if (point_frame != NO_NODE) {
14263       write_pie_frame (point_frame, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT);
14264     }
14265 /* Fraction */
14266     if (frac_mould != NO_NODE) {
14267       reset_transput_buffer (EDIT_BUFFER);
14268       add_string_transput_buffer (p, EDIT_BUFFER, frac_str);
14269       frac_str = get_transput_buffer (EDIT_BUFFER);
14270       mood = (unsigned) (DIGIT_NORMAL | INSERTION_NORMAL);
14271       write_mould (SUB (frac_mould), ref_file, INTEGRAL_MOULD, &frac_str, &mood);
14272     }
14273 /* Exponent */
14274     if (expo_mould != NO_NODE) {
14275       A68_INT z;
14276       STATUS (&z) = INIT_MASK;
14277       VALUE (&z) = exp_value;
14278       if (e_frame != NO_NODE) {
14279         write_pie_frame (e_frame, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E);
14280       }
14281       write_integral_pattern (expo_mould, MODE (INT), root, (BYTE_T *) & z, ref_file);
14282     }
14283     stack_pointer = old_stack_pointer;
14284   }
14285 }
14286 
14287 /**
14288 @brief Write COMPLEX value using complex pattern.
14289 @param p Node in syntax tree.
14290 @param comp Mode of complex number.
14291 @param root Root mode.
14292 @param re Pointer to real part.
14293 @param im Pointer to imaginary part.
14294 @param ref_file Fat pointer to A68 file.
14295 **/
14296 
14297 static void
write_complex_pattern(NODE_T * p,MOID_T * comp,MOID_T * root,BYTE_T * re,BYTE_T * im,A68_REF ref_file)14298 write_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * root, BYTE_T * re, BYTE_T * im, A68_REF ref_file)
14299 {
14300   NODE_T *reel, *plus_i_times, *imag;
14301   RESET_ERRNO;
14302 /* Dissect pattern */
14303   reel = SUB (p);
14304   plus_i_times = NEXT (reel);
14305   imag = NEXT (plus_i_times);
14306 /* Write pattern */
14307   write_real_pattern (reel, comp, root, re, ref_file);
14308   write_pie_frame (plus_i_times, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I);
14309   write_real_pattern (imag, comp, root, im, ref_file);
14310 }
14311 
14312 /**
14313 @brief Write BITS value using bits pattern.
14314 @param p Node in syntax tree.
14315 @param mode Mode of value.
14316 @param item Pointer to value.
14317 @param ref_file Fat pointer to A68 file.
14318 **/
14319 
14320 static void
write_bits_pattern(NODE_T * p,MOID_T * mode,BYTE_T * item,A68_REF ref_file)14321 write_bits_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
14322 {
14323   if (mode == MODE (BITS)) {
14324     int width = 0, radix;
14325     unsigned mood;
14326     A68_BITS *z = (A68_BITS *) item;
14327     char *str;
14328 /* Establish width and radix */
14329     count_zd_frames (SUB (p), &width);
14330     radix = get_replicator_value (SUB_SUB (p), A68_TRUE);
14331     if (radix < 2 || radix > 16) {
14332       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
14333       exit_genie (p, A68_RUNTIME_ERROR);
14334     }
14335 /* Generate string of correct width */
14336     reset_transput_buffer (EDIT_BUFFER);
14337     if (!convert_radix (p, VALUE (z), radix, width)) {
14338       errno = EDOM;
14339       value_error (p, mode, ref_file);
14340     }
14341 /* Output the edited string */
14342     mood = (unsigned) (DIGIT_BLANK | INSERTION_NORMAL);
14343     str = get_transput_buffer (EDIT_BUFFER);
14344     write_mould (NEXT_SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood);
14345   } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) {
14346     ADDR_T pop_sp = stack_pointer;
14347     int width = 0, radix, digits = DIGITS (mode);
14348     unsigned mood;
14349     MP_T *u = (MP_T *) item;
14350     MP_T *v;
14351     MP_T *w;
14352     char *str;
14353     STACK_MP (v, p, digits);
14354     STACK_MP (w, p, digits);
14355 /* Establish width and radix */
14356     count_zd_frames (SUB (p), &width);
14357     radix = get_replicator_value (SUB_SUB (p), A68_TRUE);
14358     if (radix < 2 || radix > 16) {
14359       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
14360       exit_genie (p, A68_RUNTIME_ERROR);
14361     }
14362 /* Generate string of correct width */
14363     reset_transput_buffer (EDIT_BUFFER);
14364     if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
14365       errno = EDOM;
14366       value_error (p, mode, ref_file);
14367     }
14368 /* Output the edited string */
14369     mood = (unsigned) (DIGIT_BLANK | INSERTION_NORMAL);
14370     str = get_transput_buffer (EDIT_BUFFER);
14371     write_mould (NEXT_SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood);
14372     stack_pointer = pop_sp;
14373   }
14374 }
14375 
14376 /**
14377 @brief Write value to file.
14378 @param p Node in syntax tree.
14379 @param item Pointer to value.
14380 @param ref_file Fat pointer to A68 file.
14381 **/
14382 
14383 static void
genie_write_real_format(NODE_T * p,BYTE_T * item,A68_REF ref_file)14384 genie_write_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file)
14385 {
14386   if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
14387     genie_value_to_string (p, MODE (REAL), item, ATTRIBUTE (SUB (p)));
14388     add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
14389   } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
14390     write_number_generic (p, MODE (REAL), item, ATTRIBUTE (SUB (p)));
14391   } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
14392     write_c_pattern (p, MODE (REAL), item, ref_file);
14393   } else if (IS (p, REAL_PATTERN)) {
14394     write_real_pattern (p, MODE (REAL), MODE (REAL), item, ref_file);
14395   } else if (IS (p, COMPLEX_PATTERN)) {
14396     A68_REAL im;
14397     STATUS (&im) = INIT_MASK;
14398     VALUE (&im) = 0.0;
14399     write_complex_pattern (p, MODE (REAL), MODE (COMPLEX), (BYTE_T *) item, (BYTE_T *) & im, ref_file);
14400   } else {
14401     pattern_error (p, MODE (REAL), ATTRIBUTE (p));
14402   }
14403 }
14404 
14405 /**
14406 @brief Write value to file.
14407 @param p Node in syntax tree.
14408 @param item Pointer to value.
14409 @param ref_file Fat pointer to A68 file.
14410 **/
14411 
14412 static void
genie_write_long_real_format(NODE_T * p,BYTE_T * item,A68_REF ref_file)14413 genie_write_long_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file)
14414 {
14415   if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
14416     genie_value_to_string (p, MODE (LONG_REAL), item, ATTRIBUTE (SUB (p)));
14417     add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
14418   } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
14419     write_number_generic (p, MODE (LONG_REAL), item, ATTRIBUTE (SUB (p)));
14420   } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
14421     write_c_pattern (p, MODE (LONG_REAL), item, ref_file);
14422   } else if (IS (p, REAL_PATTERN)) {
14423     write_real_pattern (p, MODE (LONG_REAL), MODE (LONG_REAL), item, ref_file);
14424   } else if (IS (p, COMPLEX_PATTERN)) {
14425     ADDR_T old_stack_pointer = stack_pointer;
14426     MP_T *z;
14427     STACK_MP (z, p, DIGITS (MODE (LONG_REAL)));
14428     SET_MP_ZERO (z, DIGITS (MODE (LONG_REAL)));
14429     z[0] = (MP_T) INIT_MASK;
14430     write_complex_pattern (p, MODE (LONG_REAL), MODE (LONG_COMPLEX), item, (BYTE_T *) z, ref_file);
14431     stack_pointer = old_stack_pointer;
14432   } else {
14433     pattern_error (p, MODE (LONG_REAL), ATTRIBUTE (p));
14434   }
14435 }
14436 
14437 /**
14438 @brief Write value to file.
14439 @param p Node in syntax tree.
14440 @param item Pointer to value.
14441 @param ref_file Fat pointer to A68 file.
14442 **/
14443 
14444 static void
genie_write_longlong_real_format(NODE_T * p,BYTE_T * item,A68_REF ref_file)14445 genie_write_longlong_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file)
14446 {
14447   if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
14448     genie_value_to_string (p, MODE (LONGLONG_REAL), item, ATTRIBUTE (SUB (p)));
14449     add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
14450   } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
14451     write_number_generic (p, MODE (LONGLONG_REAL), item, ATTRIBUTE (SUB (p)));
14452   } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
14453     write_c_pattern (p, MODE (LONGLONG_REAL), item, ref_file);
14454   } else if (IS (p, REAL_PATTERN)) {
14455     write_real_pattern (p, MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), item, ref_file);
14456   } else if (IS (p, COMPLEX_PATTERN)) {
14457     ADDR_T old_stack_pointer = stack_pointer;
14458     MP_T *z;
14459     STACK_MP (z, p, DIGITS (MODE (LONGLONG_REAL)));
14460     SET_MP_ZERO (z, DIGITS (MODE (LONGLONG_REAL)));
14461     z[0] = (MP_T) INIT_MASK;
14462     write_complex_pattern (p, MODE (LONGLONG_REAL), MODE (LONGLONG_COMPLEX), item, (BYTE_T *) z, ref_file);
14463     stack_pointer = old_stack_pointer;
14464   } else {
14465     pattern_error (p, MODE (LONGLONG_REAL), ATTRIBUTE (p));
14466   }
14467 }
14468 
14469 /**
14470 @brief At end of write purge all insertions.
14471 @param p Node in syntax tree.
14472 @param ref_file Fat pointer to A68 file.
14473 **/
14474 
14475 static void
purge_format_write(NODE_T * p,A68_REF ref_file)14476 purge_format_write (NODE_T * p, A68_REF ref_file)
14477 {
14478 /* Problem here is shutting down embedded formats */
14479   BOOL_T go_on;
14480   do {
14481     A68_FILE *file;
14482     NODE_T *dollar, *pat;
14483     A68_FORMAT *old_fmt;
14484     while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) {
14485       format_error (p, ref_file, ERROR_FORMAT_PICTURES);
14486     }
14487     file = FILE_DEREF (&ref_file);
14488     dollar = SUB (BODY (&FORMAT (file)));
14489     old_fmt = (A68_FORMAT *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (dollar)));
14490     go_on = (BOOL_T) ! IS_NIL_FORMAT (old_fmt);
14491     if (go_on) {
14492 /* Pop embedded format and proceed */
14493       (void) end_of_format (p, ref_file);
14494     }
14495   } while (go_on);
14496 }
14497 
14498 /**
14499 @brief Write value to file.
14500 @param p Node in syntax tree.
14501 @param mode Mode of value.
14502 @param item Pointer to value.
14503 @param ref_file Fat pointer to A68 file.
14504 @param formats Format counter.
14505 **/
14506 
14507 static void
genie_write_standard_format(NODE_T * p,MOID_T * mode,BYTE_T * item,A68_REF ref_file,int * formats)14508 genie_write_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file, int *formats)
14509 {
14510   RESET_ERRNO;
14511   if (mode == MODE (FORMAT)) {
14512     A68_FILE *file;
14513     CHECK_REF (p, ref_file, MODE (REF_FILE));
14514     file = FILE_DEREF (&ref_file);
14515 /* Forget about eventual active formats and set up new one */
14516     if (*formats > 0) {
14517       purge_format_write (p, ref_file);
14518     }
14519     (*formats)++;
14520     frame_pointer = FRAME_POINTER (file);
14521     stack_pointer = STACK_POINTER (file);
14522     open_format_frame (p, ref_file, (A68_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68_TRUE);
14523   } else if (mode == MODE (PROC_REF_FILE_VOID)) {
14524     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (PROC_REF_FILE_VOID));
14525     exit_genie (p, A68_RUNTIME_ERROR);
14526   } else if (mode == MODE (SOUND)) {
14527     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (SOUND));
14528     exit_genie (p, A68_RUNTIME_ERROR);
14529   } else if (mode == MODE (INT)) {
14530     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
14531     if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
14532       genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
14533       add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
14534     } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
14535       write_number_generic (pat, MODE (INT), item, ATTRIBUTE (SUB (pat)));
14536     } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
14537       write_c_pattern (pat, MODE (INT), item, ref_file);
14538     } else if (IS (pat, INTEGRAL_PATTERN)) {
14539       write_integral_pattern (pat, MODE (INT), MODE (INT), item, ref_file);
14540     } else if (IS (pat, REAL_PATTERN)) {
14541       write_real_pattern (pat, MODE (INT), MODE (INT), item, ref_file);
14542     } else if (IS (pat, COMPLEX_PATTERN)) {
14543       A68_REAL re, im;
14544       STATUS (&re) = INIT_MASK;
14545       VALUE (&re) = (double) VALUE ((A68_INT *) item);
14546       STATUS (&im) = INIT_MASK;
14547       VALUE (&im) = 0.0;
14548       write_complex_pattern (pat, MODE (REAL), MODE (COMPLEX), (BYTE_T *) & re, (BYTE_T *) & im, ref_file);
14549     } else if (IS (pat, CHOICE_PATTERN)) {
14550       int k = VALUE ((A68_INT *) item);
14551       write_choice_pattern (NEXT_SUB (pat), ref_file, &k);
14552     } else {
14553       pattern_error (p, mode, ATTRIBUTE (pat));
14554     }
14555   } else if (mode == MODE (LONG_INT)) {
14556     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
14557     if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
14558       genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
14559       add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
14560     } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
14561       write_number_generic (pat, MODE (LONG_INT), item, ATTRIBUTE (SUB (pat)));
14562     } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
14563       write_c_pattern (pat, MODE (LONG_INT), item, ref_file);
14564     } else if (IS (pat, INTEGRAL_PATTERN)) {
14565       write_integral_pattern (pat, MODE (LONG_INT), MODE (LONG_INT), item, ref_file);
14566     } else if (IS (pat, REAL_PATTERN)) {
14567       write_real_pattern (pat, MODE (LONG_INT), MODE (LONG_INT), item, ref_file);
14568     } else if (IS (pat, COMPLEX_PATTERN)) {
14569       ADDR_T old_stack_pointer = stack_pointer;
14570       MP_T *z;
14571       STACK_MP (z, p, DIGITS (mode));
14572       SET_MP_ZERO (z, DIGITS (mode));
14573       z[0] = (MP_T) INIT_MASK;
14574       write_complex_pattern (pat, MODE (LONG_REAL), MODE (LONG_COMPLEX), item, (BYTE_T *) z, ref_file);
14575       stack_pointer = old_stack_pointer;
14576     } else if (IS (pat, CHOICE_PATTERN)) {
14577       int k = mp_to_int (p, (MP_T *) item, DIGITS (mode));
14578       write_choice_pattern (NEXT_SUB (pat), ref_file, &k);
14579     } else {
14580       pattern_error (p, mode, ATTRIBUTE (pat));
14581     }
14582   } else if (mode == MODE (LONGLONG_INT)) {
14583     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
14584     if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
14585       genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
14586       add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
14587     } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
14588       write_number_generic (pat, MODE (LONGLONG_INT), item, ATTRIBUTE (SUB (pat)));
14589     } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
14590       write_c_pattern (pat, MODE (LONGLONG_INT), item, ref_file);
14591     } else if (IS (pat, INTEGRAL_PATTERN)) {
14592       write_integral_pattern (pat, MODE (LONGLONG_INT), MODE (LONGLONG_INT), item, ref_file);
14593     } else if (IS (pat, REAL_PATTERN)) {
14594       write_real_pattern (pat, MODE (INT), MODE (INT), item, ref_file);
14595     } else if (IS (pat, REAL_PATTERN)) {
14596       write_real_pattern (pat, MODE (LONGLONG_INT), MODE (LONGLONG_INT), item, ref_file);
14597     } else if (IS (pat, COMPLEX_PATTERN)) {
14598       ADDR_T old_stack_pointer = stack_pointer;
14599       MP_T *z;
14600       STACK_MP (z, p, DIGITS (MODE (LONGLONG_REAL)));
14601       SET_MP_ZERO (z, DIGITS (mode));
14602       z[0] = (MP_T) INIT_MASK;
14603       write_complex_pattern (pat, MODE (LONGLONG_REAL), MODE (LONGLONG_COMPLEX), item, (BYTE_T *) z, ref_file);
14604       stack_pointer = old_stack_pointer;
14605     } else if (IS (pat, CHOICE_PATTERN)) {
14606       int k = mp_to_int (p, (MP_T *) item, DIGITS (mode));
14607       write_choice_pattern (NEXT_SUB (pat), ref_file, &k);
14608     } else {
14609       pattern_error (p, mode, ATTRIBUTE (pat));
14610     }
14611   } else if (mode == MODE (REAL)) {
14612     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
14613     genie_write_real_format (pat, item, ref_file);
14614   } else if (mode == MODE (LONG_REAL)) {
14615     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
14616     genie_write_long_real_format (pat, item, ref_file);
14617   } else if (mode == MODE (LONGLONG_REAL)) {
14618     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
14619     genie_write_longlong_real_format (pat, item, ref_file);
14620   } else if (mode == MODE (COMPLEX)) {
14621     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
14622     if (IS (pat, COMPLEX_PATTERN)) {
14623       write_complex_pattern (pat, MODE (REAL), MODE (COMPLEX), &item[0], &item[SIZE (MODE (REAL))], ref_file);
14624     } else {
14625 /* Try writing as two REAL values */
14626       genie_write_real_format (pat, item, ref_file);
14627       genie_write_standard_format (p, MODE (REAL), &item[SIZE (MODE (REAL))], ref_file, formats);
14628     }
14629   } else if (mode == MODE (LONG_COMPLEX)) {
14630     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
14631     if (IS (pat, COMPLEX_PATTERN)) {
14632       write_complex_pattern (pat, MODE (LONG_REAL), MODE (LONG_COMPLEX), &item[0], &item[SIZE (MODE (LONG_REAL))], ref_file);
14633     } else {
14634 /* Try writing as two LONG REAL values */
14635       genie_write_long_real_format (pat, item, ref_file);
14636       genie_write_standard_format (p, MODE (LONG_REAL), &item[SIZE (MODE (LONG_REAL))], ref_file, formats);
14637     }
14638   } else if (mode == MODE (LONGLONG_COMPLEX)) {
14639     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
14640     if (IS (pat, COMPLEX_PATTERN)) {
14641       write_complex_pattern (pat, MODE (LONGLONG_REAL), MODE (LONGLONG_COMPLEX), &item[0], &item[SIZE (MODE (LONGLONG_REAL))], ref_file);
14642     } else {
14643 /* Try writing as two LONG LONG REAL values */
14644       genie_write_longlong_real_format (pat, item, ref_file);
14645       genie_write_standard_format (p, MODE (LONGLONG_REAL), &item[SIZE (MODE (LONGLONG_REAL))], ref_file, formats);
14646     }
14647   } else if (mode == MODE (BOOL)) {
14648     A68_BOOL *z = (A68_BOOL *) item;
14649     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
14650     if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
14651       add_char_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR));
14652     } else if (IS (pat, BOOLEAN_PATTERN)) {
14653       if (NEXT_SUB (pat) == NO_NODE) {
14654         add_char_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR));
14655       } else {
14656         write_boolean_pattern (pat, ref_file, (BOOL_T) (VALUE (z) == A68_TRUE));
14657       }
14658     } else {
14659       pattern_error (p, mode, ATTRIBUTE (pat));
14660     }
14661   } else if (mode == MODE (BITS)) {
14662     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
14663     if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
14664       char *str = (char *) STACK_TOP;
14665       genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p)));
14666       add_string_transput_buffer (p, FORMATTED_BUFFER, str);
14667     } else if (IS (pat, BITS_PATTERN)) {
14668       write_bits_pattern (pat, MODE (BITS), item, ref_file);
14669     } else if (IS (pat, BITS_C_PATTERN)) {
14670       write_c_pattern (pat, MODE (BITS), item, ref_file);
14671     } else {
14672       pattern_error (p, mode, ATTRIBUTE (pat));
14673     }
14674   } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) {
14675     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
14676     if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
14677       char *str = (char *) STACK_TOP;
14678       genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p)));
14679       add_string_transput_buffer (p, FORMATTED_BUFFER, str);
14680     } else if (IS (pat, BITS_PATTERN)) {
14681       write_bits_pattern (pat, mode, item, ref_file);
14682     } else if (IS (pat, BITS_C_PATTERN)) {
14683       write_c_pattern (pat, mode, item, ref_file);
14684     } else {
14685       pattern_error (p, mode, ATTRIBUTE (pat));
14686     }
14687   } else if (mode == MODE (CHAR)) {
14688     A68_CHAR *z = (A68_CHAR *) item;
14689     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
14690     if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
14691       add_char_transput_buffer (p, FORMATTED_BUFFER, (char) VALUE (z));
14692     } else if (IS (pat, STRING_PATTERN)) {
14693       char *q = get_transput_buffer (EDIT_BUFFER);
14694       reset_transput_buffer (EDIT_BUFFER);
14695       add_char_transput_buffer (p, EDIT_BUFFER, (char) VALUE (z));
14696       write_string_pattern (pat, mode, ref_file, &q);
14697       if (q[0] != NULL_CHAR) {
14698         value_error (p, mode, ref_file);
14699       }
14700     } else if (IS (pat, STRING_C_PATTERN)) {
14701       A68_REF row;
14702       char zz[2];
14703       zz[0] = VALUE (z);
14704       zz[1] = '\0';
14705       row = c_to_a_string (pat, zz, 1);
14706       write_c_pattern (pat, mode, (BYTE_T *) zz, ref_file);
14707     } else {
14708       pattern_error (p, mode, ATTRIBUTE (pat));
14709     }
14710   } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) {
14711 /* Handle these separately instead of printing [] CHAR */
14712     A68_REF row = *(A68_REF *) item;
14713     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
14714     if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
14715       PUSH_REF (p, row);
14716       add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
14717     } else if (IS (pat, STRING_PATTERN)) {
14718       char *q;
14719       PUSH_REF (p, row);
14720       reset_transput_buffer (EDIT_BUFFER);
14721       add_string_from_stack_transput_buffer (p, EDIT_BUFFER);
14722       q = get_transput_buffer (EDIT_BUFFER);
14723       write_string_pattern (pat, mode, ref_file, &q);
14724       if (q[0] != NULL_CHAR) {
14725         value_error (p, mode, ref_file);
14726       }
14727     } else if (IS (pat, STRING_C_PATTERN)) {
14728       char *q;
14729       PUSH_REF (p, row);
14730       reset_transput_buffer (EDIT_BUFFER);
14731       add_string_from_stack_transput_buffer (p, EDIT_BUFFER);
14732       q = get_transput_buffer (EDIT_BUFFER);
14733       write_c_pattern (pat, mode, (BYTE_T *) q, ref_file);
14734     } else {
14735       pattern_error (p, mode, ATTRIBUTE (pat));
14736     }
14737   } else if (IS (mode, UNION_SYMBOL)) {
14738     A68_UNION *z = (A68_UNION *) item;
14739     genie_write_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file, formats);
14740   } else if (IS (mode, STRUCT_SYMBOL)) {
14741     PACK_T *q = PACK (mode);
14742     for (; q != NO_PACK; FORWARD (q)) {
14743       BYTE_T *elem = &item[OFFSET (q)];
14744       genie_check_initialisation (p, elem, MOID (q));
14745       genie_write_standard_format (p, MOID (q), elem, ref_file, formats);
14746     }
14747   } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) {
14748     MOID_T *deflexed = DEFLEX (mode);
14749     A68_ARRAY *arr;
14750     A68_TUPLE *tup;
14751     CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS));
14752     GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
14753     if (get_row_size (tup, DIM (arr)) > 0) {
14754       BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
14755       BOOL_T done = A68_FALSE;
14756       initialise_internal_index (tup, DIM (arr));
14757       while (!done) {
14758         ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
14759         ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
14760         BYTE_T *elem = &base_addr[elem_addr];
14761         genie_check_initialisation (p, elem, SUB (deflexed));
14762         genie_write_standard_format (p, SUB (deflexed), elem, ref_file, formats);
14763         done = increment_internal_index (tup, DIM (arr));
14764       }
14765     }
14766   }
14767   if (errno != 0) {
14768     transput_error (p, ref_file, mode);
14769   }
14770 }
14771 
14772 /**
14773 @brief PROC ([] SIMPLOUT) VOID print f, write f
14774 @param p Node in syntax tree.
14775 **/
14776 
14777 void
genie_write_format(NODE_T * p)14778 genie_write_format (NODE_T * p)
14779 {
14780   A68_REF row;
14781   POP_REF (p, &row);
14782   genie_stand_out (p);
14783   PUSH_REF (p, row);
14784   genie_write_file_format (p);
14785 }
14786 
14787 /**
14788 @brief PROC (REF FILE, [] SIMPLOUT) VOID put f
14789 @param p Node in syntax tree.
14790 **/
14791 
14792 void
genie_write_file_format(NODE_T * p)14793 genie_write_file_format (NODE_T * p)
14794 {
14795   A68_REF ref_file;
14796   A68_FILE *file;
14797   A68_REF row;
14798   A68_ARRAY *arr;
14799   A68_TUPLE *tup;
14800   BYTE_T *base_address;
14801   int elems, k, elem_index, formats;
14802   ADDR_T save_frame_pointer, save_stack_pointer;
14803   POP_REF (p, &row);
14804   CHECK_REF (p, row, MODE (ROW_SIMPLOUT));
14805   GET_DESCRIPTOR (arr, tup, &row);
14806   elems = ROW_SIZE (tup);
14807   POP_REF (p, &ref_file);
14808   CHECK_REF (p, ref_file, MODE (REF_FILE));
14809   file = FILE_DEREF (&ref_file);
14810   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
14811   if (!OPENED (file)) {
14812     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
14813     exit_genie (p, A68_RUNTIME_ERROR);
14814   }
14815   if (DRAW_MOOD (file)) {
14816     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
14817     exit_genie (p, A68_RUNTIME_ERROR);
14818   }
14819   if (READ_MOOD (file)) {
14820     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
14821     exit_genie (p, A68_RUNTIME_ERROR);
14822   }
14823   if (!PUT (&CHANNEL (file))) {
14824     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
14825     exit_genie (p, A68_RUNTIME_ERROR);
14826   }
14827   if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
14828     if (IS_NIL (STRING (file))) {
14829       if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, A68_PROTECTION)) == A68_NO_FILENO) {
14830         open_error (p, ref_file, "putting");
14831       }
14832     } else {
14833       FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, 0);
14834     }
14835     DRAW_MOOD (file) = A68_FALSE;
14836     READ_MOOD (file) = A68_FALSE;
14837     WRITE_MOOD (file) = A68_TRUE;
14838     CHAR_MOOD (file) = A68_TRUE;
14839   }
14840   if (!CHAR_MOOD (file)) {
14841     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
14842     exit_genie (p, A68_RUNTIME_ERROR);
14843   }
14844 /* Save stack state since formats have frames */
14845   save_frame_pointer = FRAME_POINTER (file);
14846   save_stack_pointer = STACK_POINTER (file);
14847   FRAME_POINTER (file) = frame_pointer;
14848   STACK_POINTER (file) = stack_pointer;
14849 /* Process [] SIMPLOUT */
14850   if (BODY (&FORMAT (file)) != NO_NODE) {
14851     open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE);
14852   }
14853   if (elems <= 0) {
14854     return;
14855   }
14856   formats = 0;
14857   base_address = DEREF (BYTE_T, &ARRAY (arr));
14858   elem_index = 0;
14859   for (k = 0; k < elems; k++) {
14860     A68_UNION *z = (A68_UNION *) & (base_address[elem_index]);
14861     MOID_T *mode = (MOID_T *) (VALUE (z));
14862     BYTE_T *item = &(base_address[elem_index + A68_UNION_SIZE]);
14863     genie_write_standard_format (p, mode, item, ref_file, &formats);
14864     elem_index += SIZE (MODE (SIMPLOUT));
14865   }
14866 /* Empty the format to purge insertions */
14867   purge_format_write (p, ref_file);
14868   BODY (&FORMAT (file)) = NO_NODE;
14869 /* Dump the buffer */
14870   write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
14871 /* Forget about active formats */
14872   frame_pointer = FRAME_POINTER (file);
14873   stack_pointer = STACK_POINTER (file);
14874   FRAME_POINTER (file) = save_frame_pointer;
14875   STACK_POINTER (file) = save_stack_pointer;
14876 }
14877 
14878 /**
14879 @brief Give a value error in case a character is not among expected ones.
14880 @param p Node in syntax tree.
14881 @param m Mode of value read or written.
14882 @param ref_file Fat pointer to A68 file.
14883 @param items Expected characters.
14884 @param ch Actual character.
14885 @return Whether character is expected.
14886 **/
14887 
14888 static BOOL_T
expect(NODE_T * p,MOID_T * m,A68_REF ref_file,const char * items,char ch)14889 expect (NODE_T * p, MOID_T * m, A68_REF ref_file, const char *items, char ch)
14890 {
14891   if (a68g_strchr ((char *) items, ch) == NO_TEXT) {
14892     value_error (p, m, ref_file);
14893     return (A68_FALSE);
14894   } else {
14895     return (A68_TRUE);
14896   }
14897 }
14898 
14899 /**
14900 @brief Read a group of insertions.
14901 @param p Node in syntax tree.
14902 @param ref_file Fat pointer to A68 file.
14903 **/
14904 
14905 void
read_insertion(NODE_T * p,A68_REF ref_file)14906 read_insertion (NODE_T * p, A68_REF ref_file)
14907 {
14908 
14909 /*
14910 Algol68G does not check whether the insertions are textually there. It just
14911 skips them. This because we blank literals in sign moulds before the sign is
14912 put, which is non-standard Algol68, but convenient.
14913 */
14914 
14915   A68_FILE *file = FILE_DEREF (&ref_file);
14916   for (; p != NO_NODE; FORWARD (p)) {
14917     read_insertion (SUB (p), ref_file);
14918     if (IS (p, FORMAT_ITEM_L)) {
14919       BOOL_T go_on = (BOOL_T) ! END_OF_FILE (file);
14920       while (go_on) {
14921         int ch = read_single_char (p, ref_file);
14922         go_on = (BOOL_T) ((ch != NEWLINE_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
14923       }
14924     } else if (IS (p, FORMAT_ITEM_P)) {
14925       BOOL_T go_on = (BOOL_T) ! END_OF_FILE (file);
14926       while (go_on) {
14927         int ch = read_single_char (p, ref_file);
14928         go_on = (BOOL_T) ((ch != FORMFEED_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
14929       }
14930     } else if (IS (p, FORMAT_ITEM_X) || IS (p, FORMAT_ITEM_Q)) {
14931       if (!END_OF_FILE (file)) {
14932         (void) read_single_char (p, ref_file);
14933       }
14934     } else if (IS (p, FORMAT_ITEM_Y)) {
14935       PUSH_REF (p, ref_file);
14936       PUSH_PRIMITIVE (p, -1, A68_INT);
14937       genie_set (p);
14938     } else if (IS (p, LITERAL)) {
14939       /* Skip characters, but don't check the literal. */
14940       int len = (int) strlen (NSYMBOL (p));
14941       while (len-- && !END_OF_FILE (file)) {
14942         (void) read_single_char (p, ref_file);
14943       }
14944     } else if (IS (p, REPLICATOR)) {
14945       int j, k = get_replicator_value (SUB (p), A68_TRUE);
14946       if (ATTRIBUTE (SUB_NEXT (p)) != FORMAT_ITEM_K) {
14947         for (j = 1; j <= k; j++) {
14948           read_insertion (NEXT (p), ref_file);
14949         }
14950       } else {
14951         int pos = get_transput_buffer_index (INPUT_BUFFER);
14952         for (j = 1; j < (k - pos); j++) {
14953           if (!END_OF_FILE (file)) {
14954             (void) read_single_char (p, ref_file);
14955           }
14956         }
14957       }
14958       return;                   /* Don't delete this! */
14959     }
14960   }
14961 }
14962 
14963 /**
14964 @brief Read string from file according current format.
14965 @param p Node in syntax tree.
14966 @param m Mode being read.
14967 @param ref_file Fat pointer to A68 file.
14968 **/
14969 
14970 static void
read_string_pattern(NODE_T * p,MOID_T * m,A68_REF ref_file)14971 read_string_pattern (NODE_T * p, MOID_T * m, A68_REF ref_file)
14972 {
14973   for (; p != NO_NODE; FORWARD (p)) {
14974     if (IS (p, INSERTION)) {
14975       read_insertion (SUB (p), ref_file);
14976     } else if (IS (p, FORMAT_ITEM_A)) {
14977       scan_n_chars (p, 1, m, ref_file);
14978     } else if (IS (p, FORMAT_ITEM_S)) {
14979       add_char_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
14980       return;
14981     } else if (IS (p, REPLICATOR)) {
14982       int j, k = get_replicator_value (SUB (p), A68_TRUE);
14983       for (j = 1; j <= k; j++) {
14984         read_string_pattern (NEXT (p), m, ref_file);
14985       }
14986       return;
14987     } else {
14988       read_string_pattern (SUB (p), m, ref_file);
14989     }
14990   }
14991 }
14992 
14993 /**
14994 @brief Traverse choice pattern.
14995 @param p Node in syntax tree.
14996 @param str String to match.
14997 @param len Length to match.
14998 @param count Counts literals.
14999 @param matches Matching literals.
15000 @param first_match First matching literal.
15001 @param full_match Whether match is complete (beyond 'len').
15002 **/
15003 
15004 static void
traverse_choice_pattern(NODE_T * p,char * str,int len,int * count,int * matches,int * first_match,BOOL_T * full_match)15005 traverse_choice_pattern (NODE_T * p, char *str, int len, int *count, int *matches, int *first_match, BOOL_T * full_match)
15006 {
15007   for (; p != NO_NODE; FORWARD (p)) {
15008     traverse_choice_pattern (SUB (p), str, len, count, matches, first_match, full_match);
15009     if (IS (p, LITERAL)) {
15010       (*count)++;
15011       if (strncmp (NSYMBOL (p), str, (size_t) len) == 0) {
15012         (*matches)++;
15013         (*full_match) = (BOOL_T) ((*full_match) | (strcmp (NSYMBOL (p), str) == 0));
15014         if (*first_match == 0 && *full_match) {
15015           *first_match = *count;
15016         }
15017       }
15018     }
15019   }
15020 }
15021 
15022 /**
15023 @brief Read appropriate insertion from a choice pattern.
15024 @param p Node in syntax tree.
15025 @param ref_file Fat pointer to A68 file.
15026 @return Length of longest match.
15027 **/
15028 
15029 static int
read_choice_pattern(NODE_T * p,A68_REF ref_file)15030 read_choice_pattern (NODE_T * p, A68_REF ref_file)
15031 {
15032 
15033 /*
15034 This implementation does not have the RR peculiarity that longest
15035 matching literal must be first, in case of non-unique first chars.
15036 */
15037 
15038   A68_FILE *file = FILE_DEREF (&ref_file);
15039   BOOL_T cont = A68_TRUE;
15040   int longest_match = 0, longest_match_len = 0;
15041   while (cont) {
15042     int ch = char_scanner (file);
15043     if (!END_OF_FILE (file)) {
15044       int len, count = 0, matches = 0, first_match = 0;
15045       BOOL_T full_match = A68_FALSE;
15046       add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
15047       len = get_transput_buffer_index (INPUT_BUFFER);
15048       traverse_choice_pattern (p, get_transput_buffer (INPUT_BUFFER), len, &count, &matches, &first_match, &full_match);
15049       if (full_match && matches == 1 && first_match > 0) {
15050         return (first_match);
15051       } else if (full_match && matches > 1 && first_match > 0) {
15052         longest_match = first_match;
15053         longest_match_len = len;
15054       } else if (matches == 0) {
15055         cont = A68_FALSE;
15056       }
15057     } else {
15058       cont = A68_FALSE;
15059     }
15060   }
15061   if (longest_match > 0) {
15062 /* Push back look-ahead chars */
15063     if (get_transput_buffer_index (INPUT_BUFFER) > 0) {
15064       char *z = get_transput_buffer (INPUT_BUFFER);
15065       END_OF_FILE (file) = A68_FALSE;
15066       add_string_transput_buffer (p, TRANSPUT_BUFFER (file), &z[longest_match_len]);
15067     }
15068     return (longest_match);
15069   } else {
15070     value_error (p, MODE (INT), ref_file);
15071     return (0);
15072   }
15073 }
15074 
15075 /**
15076 @brief Read value according to a general-pattern.
15077 @param p Node in syntax tree.
15078 @param mode Mode of value.
15079 @param item Pointer to value.
15080 @param ref_file Fat pointer to A68 file.
15081 **/
15082 
15083 static void
read_number_generic(NODE_T * p,MOID_T * mode,BYTE_T * item,A68_REF ref_file)15084 read_number_generic (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
15085 {
15086   A68_REF row;
15087   EXECUTE_UNIT (NEXT_SUB (p));
15088 /* RR says to ignore parameters just calculated, so we will */
15089   POP_REF (p, &row);
15090   genie_read_standard (p, mode, item, ref_file);
15091 }
15092 
15093 /* INTEGRAL, REAL, COMPLEX and BITS patterns */
15094 
15095 /**
15096 @brief Read sign-mould according current format.
15097 @param p Node in syntax tree.
15098 @param m Mode of value.
15099 @param ref_file Fat pointer to A68 file.
15100 @param sign Value of sign (-1, 0, 1).
15101 **/
15102 
15103 static void
read_sign_mould(NODE_T * p,MOID_T * m,A68_REF ref_file,int * sign)15104 read_sign_mould (NODE_T * p, MOID_T * m, A68_REF ref_file, int *sign)
15105 {
15106   for (; p != NO_NODE; FORWARD (p)) {
15107     if (IS (p, INSERTION)) {
15108       read_insertion (SUB (p), ref_file);
15109     } else if (IS (p, REPLICATOR)) {
15110       int j, k = get_replicator_value (SUB (p), A68_TRUE);
15111       for (j = 1; j <= k; j++) {
15112         read_sign_mould (NEXT (p), m, ref_file, sign);
15113       }
15114       return;                   /* Leave this! */
15115     } else {
15116       switch (ATTRIBUTE (p)) {
15117       case FORMAT_ITEM_Z:
15118       case FORMAT_ITEM_D:
15119       case FORMAT_ITEM_S:
15120       case FORMAT_ITEM_PLUS:
15121       case FORMAT_ITEM_MINUS:
15122         {
15123           int ch = read_single_char (p, ref_file);
15124 /* When a sign has been read, digits are expected */
15125           if (*sign != 0) {
15126             if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) {
15127               add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
15128             } else {
15129               add_char_transput_buffer (p, INPUT_BUFFER, '0');
15130             }
15131 /* When a sign has not been read, a sign is expected.  If there is a digit
15132    in stead of a sign, the digit is accepted and '+' is assumed; RR demands a
15133    space to preceed the digit, Algol68G does not */
15134           } else {
15135             if (a68g_strchr (SIGN_DIGITS, ch) != NO_TEXT) {
15136               if (ch == '+') {
15137                 *sign = 1;
15138               } else if (ch == '-') {
15139                 *sign = -1;
15140               } else if (ch == BLANK_CHAR) {
15141                 /*
15142                  * skip.
15143                  */ ;
15144               }
15145             } else if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) {
15146               add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
15147               *sign = 1;
15148             }
15149           }
15150           break;
15151         }
15152       default:
15153         {
15154           read_sign_mould (SUB (p), m, ref_file, sign);
15155           break;
15156         }
15157       }
15158     }
15159   }
15160 }
15161 
15162 /**
15163 @brief Read mould according current format.
15164 @param p Node in syntax tree.
15165 @param m Mode of value.
15166 @param ref_file Fat pointer to A68 file.
15167 **/
15168 
15169 static void
read_integral_mould(NODE_T * p,MOID_T * m,A68_REF ref_file)15170 read_integral_mould (NODE_T * p, MOID_T * m, A68_REF ref_file)
15171 {
15172   for (; p != NO_NODE; FORWARD (p)) {
15173     if (IS (p, INSERTION)) {
15174       read_insertion (SUB (p), ref_file);
15175     } else if (IS (p, REPLICATOR)) {
15176       int j, k = get_replicator_value (SUB (p), A68_TRUE);
15177       for (j = 1; j <= k; j++) {
15178         read_integral_mould (NEXT (p), m, ref_file);
15179       }
15180       return;                   /* Leave this! */
15181     } else if (IS (p, FORMAT_ITEM_Z)) {
15182       int ch = read_single_char (p, ref_file);
15183       const char *digits = (m == MODE (BITS) || m == MODE (LONG_BITS) || m == MODE (LONGLONG_BITS)) ? BITS_DIGITS_BLANK : INT_DIGITS_BLANK;
15184       if (expect (p, m, ref_file, digits, (char) ch)) {
15185         add_char_transput_buffer (p, INPUT_BUFFER, (char) ((ch == BLANK_CHAR) ? '0' : ch));
15186       } else {
15187         add_char_transput_buffer (p, INPUT_BUFFER, '0');
15188       }
15189     } else if (IS (p, FORMAT_ITEM_D)) {
15190       int ch = read_single_char (p, ref_file);
15191       const char *digits = (m == MODE (BITS) || m == MODE (LONG_BITS) || m == MODE (LONGLONG_BITS)) ? BITS_DIGITS : INT_DIGITS;
15192       if (expect (p, m, ref_file, digits, (char) ch)) {
15193         add_char_transput_buffer (p, INPUT_BUFFER, (char) ch);
15194       } else {
15195         add_char_transput_buffer (p, INPUT_BUFFER, '0');
15196       }
15197     } else if (IS (p, FORMAT_ITEM_S)) {
15198       add_char_transput_buffer (p, INPUT_BUFFER, '0');
15199     } else {
15200       read_integral_mould (SUB (p), m, ref_file);
15201     }
15202   }
15203 }
15204 
15205 /**
15206 @brief Read mould according current format.
15207 @param p Node in syntax tree.
15208 @param m Mode of value.
15209 @param item Pointer to value.
15210 @param ref_file Fat pointer to A68 file.
15211 **/
15212 
15213 static void
read_integral_pattern(NODE_T * p,MOID_T * m,BYTE_T * item,A68_REF ref_file)15214 read_integral_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file)
15215 {
15216   NODE_T *q = SUB (p);
15217   if (q != NO_NODE && IS (q, SIGN_MOULD)) {
15218     int sign = 0;
15219     char *z;
15220     add_char_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
15221     read_sign_mould (SUB (q), m, ref_file, &sign);
15222     z = get_transput_buffer (INPUT_BUFFER);
15223     z[0] = (char) ((sign == -1) ? '-' : '+');
15224     FORWARD (q);
15225   }
15226   if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
15227     read_integral_mould (SUB (q), m, ref_file);
15228   }
15229   genie_string_to_value (p, m, item, ref_file);
15230 }
15231 
15232 /**
15233 @brief Read point, exponent or i-frame.
15234 @param p Node in syntax tree.
15235 @param m Mode of value.
15236 @param ref_file Fat pointer to A68 file.
15237 @param att Frame attribute.
15238 @param item Format item.
15239 @param ch Representation of 'item'.
15240 **/
15241 
15242 static void
read_pie_frame(NODE_T * p,MOID_T * m,A68_REF ref_file,int att,int item,char ch)15243 read_pie_frame (NODE_T * p, MOID_T * m, A68_REF ref_file, int att, int item, char ch)
15244 {
15245 /* Widen ch to a stringlet */
15246   char sym[3];
15247   sym[0] = ch;
15248   sym[1] = (char) TO_LOWER (ch);
15249   sym[2] = NULL_CHAR;
15250 /* Now read the frame */
15251   for (; p != NO_NODE; FORWARD (p)) {
15252     if (IS (p, INSERTION)) {
15253       read_insertion (p, ref_file);
15254     } else if (IS (p, att)) {
15255       read_pie_frame (SUB (p), m, ref_file, att, item, ch);
15256       return;
15257     } else if (IS (p, FORMAT_ITEM_S)) {
15258       add_char_transput_buffer (p, INPUT_BUFFER, sym[0]);
15259       return;
15260     } else if (IS (p, item)) {
15261       int ch0 = read_single_char (p, ref_file);
15262       if (expect (p, m, ref_file, sym, (char) ch0)) {
15263         add_char_transput_buffer (p, INPUT_BUFFER, sym[0]);
15264       } else {
15265         add_char_transput_buffer (p, INPUT_BUFFER, sym[0]);
15266       }
15267     }
15268   }
15269 }
15270 
15271 /**
15272 @brief Read REAL value using real pattern.
15273 @param p Node in syntax tree.
15274 @param m Mode of value.
15275 @param item Pointer to value.
15276 @param ref_file Fat pointer to A68 file.
15277 **/
15278 
15279 static void
read_real_pattern(NODE_T * p,MOID_T * m,BYTE_T * item,A68_REF ref_file)15280 read_real_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file)
15281 {
15282 /* Dive into pattern */
15283   NODE_T *q = (IS (p, REAL_PATTERN)) ? SUB (p) : p;
15284 /* Dissect pattern */
15285   if (q != NO_NODE && IS (q, SIGN_MOULD)) {
15286     int sign = 0;
15287     char *z;
15288     add_char_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
15289     read_sign_mould (SUB (q), m, ref_file, &sign);
15290     z = get_transput_buffer (INPUT_BUFFER);
15291     z[0] = (char) ((sign == -1) ? '-' : '+');
15292     FORWARD (q);
15293   }
15294   if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
15295     read_integral_mould (SUB (q), m, ref_file);
15296     FORWARD (q);
15297   }
15298   if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) {
15299     read_pie_frame (SUB (q), m, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT, POINT_CHAR);
15300     FORWARD (q);
15301   }
15302   if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
15303     read_integral_mould (SUB (q), m, ref_file);
15304     FORWARD (q);
15305   }
15306   if (q != NO_NODE && IS (q, EXPONENT_FRAME)) {
15307     read_pie_frame (SUB (q), m, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E, EXPONENT_CHAR);
15308     q = NEXT_SUB (q);
15309     if (q != NO_NODE && IS (q, SIGN_MOULD)) {
15310       int k, sign = 0;
15311       char *z;
15312       add_char_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
15313       k = get_transput_buffer_index (INPUT_BUFFER);
15314       read_sign_mould (SUB (q), m, ref_file, &sign);
15315       z = get_transput_buffer (INPUT_BUFFER);
15316       z[k - 1] = (char) ((sign == -1) ? '-' : '+');
15317       FORWARD (q);
15318     }
15319     if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
15320       read_integral_mould (SUB (q), m, ref_file);
15321       FORWARD (q);
15322     }
15323   }
15324   genie_string_to_value (p, m, item, ref_file);
15325 }
15326 
15327 /**
15328 @brief Read COMPLEX value using complex pattern.
15329 @param p Node in syntax tree.
15330 @param comp Mode of complex value.
15331 @param m Mode of value fields.
15332 @param re Pointer to real part.
15333 @param im Pointer to imaginary part.
15334 @param ref_file Fat pointer to A68 file.
15335 **/
15336 
15337 static void
read_complex_pattern(NODE_T * p,MOID_T * comp,MOID_T * m,BYTE_T * re,BYTE_T * im,A68_REF ref_file)15338 read_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * m, BYTE_T * re, BYTE_T * im, A68_REF ref_file)
15339 {
15340   NODE_T *reel, *plus_i_times, *imag;
15341 /* Dissect pattern */
15342   reel = SUB (p);
15343   plus_i_times = NEXT (reel);
15344   imag = NEXT (plus_i_times);
15345 /* Read pattern */
15346   read_real_pattern (reel, m, re, ref_file);
15347   reset_transput_buffer (INPUT_BUFFER);
15348   read_pie_frame (plus_i_times, comp, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I, 'I');
15349   reset_transput_buffer (INPUT_BUFFER);
15350   read_real_pattern (imag, m, im, ref_file);
15351 }
15352 
15353 /**
15354 @brief Read BITS value according pattern.
15355 @param p Node in syntax tree.
15356 @param m Mode of value.
15357 @param item Pointer to value.
15358 @param ref_file Fat pointer to A68 file.
15359 **/
15360 
15361 static void
read_bits_pattern(NODE_T * p,MOID_T * m,BYTE_T * item,A68_REF ref_file)15362 read_bits_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file)
15363 {
15364   int radix;
15365   char *z;
15366   radix = get_replicator_value (SUB_SUB (p), A68_TRUE);
15367   if (radix < 2 || radix > 16) {
15368     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
15369     exit_genie (p, A68_RUNTIME_ERROR);
15370   }
15371   z = get_transput_buffer (INPUT_BUFFER);
15372   ASSERT (snprintf (z, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
15373   set_transput_buffer_index (INPUT_BUFFER, (int) strlen (z));
15374   read_integral_mould (NEXT_SUB (p), m, ref_file);
15375   genie_string_to_value (p, m, item, ref_file);
15376 }
15377 
15378 /**
15379 @brief Read object with from file and store.
15380 @param p Node in syntax tree.
15381 @param mode Mode of value.
15382 @param item Pointer to value.
15383 @param ref_file Fat pointer to A68 file.
15384 **/
15385 
15386 static void
genie_read_real_format(NODE_T * p,MOID_T * mode,BYTE_T * item,A68_REF ref_file)15387 genie_read_real_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
15388 {
15389   if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
15390     genie_read_standard (p, mode, item, ref_file);
15391   } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
15392     read_number_generic (p, mode, item, ref_file);
15393   } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
15394     read_c_pattern (p, mode, item, ref_file);
15395   } else if (IS (p, REAL_PATTERN)) {
15396     read_real_pattern (p, mode, item, ref_file);
15397   } else {
15398     pattern_error (p, mode, ATTRIBUTE (p));
15399   }
15400 }
15401 
15402 /**
15403 @brief At end of read purge all insertions.
15404 @param p Node in syntax tree.
15405 @param ref_file Fat pointer to A68 file.
15406 **/
15407 
15408 static void
purge_format_read(NODE_T * p,A68_REF ref_file)15409 purge_format_read (NODE_T * p, A68_REF ref_file)
15410 {
15411   BOOL_T go_on;
15412   do {
15413     A68_FILE *file;
15414     NODE_T *dollar, *pat;
15415     A68_FORMAT *old_fmt;
15416 /*
15417     while (get_next_format_pattern (p, ref_file, SKIP_PATTERN) != NO_NODE) {
15418 	;
15419     }
15420 */
15421     while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) {
15422       format_error (p, ref_file, ERROR_FORMAT_PICTURES);
15423     }
15424     file = FILE_DEREF (&ref_file);
15425     dollar = SUB (BODY (&FORMAT (file)));
15426     old_fmt = (A68_FORMAT *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (dollar)));
15427     go_on = (BOOL_T) ! IS_NIL_FORMAT (old_fmt);
15428     if (go_on) {
15429 /* Pop embedded format and proceed */
15430       (void) end_of_format (p, ref_file);
15431     }
15432   } while (go_on);
15433 }
15434 
15435 /**
15436 @brief Read object with from file and store.
15437 @param p Node in syntax tree.
15438 @param mode Mode of value.
15439 @param item Pointer to value.
15440 @param ref_file Fat pointer to A68 file.
15441 @param formats Format counter.
15442 **/
15443 
15444 static void
genie_read_standard_format(NODE_T * p,MOID_T * mode,BYTE_T * item,A68_REF ref_file,int * formats)15445 genie_read_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file, int *formats)
15446 {
15447   RESET_ERRNO;
15448   reset_transput_buffer (INPUT_BUFFER);
15449   if (mode == MODE (FORMAT)) {
15450     A68_FILE *file;
15451     CHECK_REF (p, ref_file, MODE (REF_FILE));
15452     file = FILE_DEREF (&ref_file);
15453 /* Forget about eventual active formats and set up new one */
15454     if (*formats > 0) {
15455       purge_format_read (p, ref_file);
15456     }
15457     (*formats)++;
15458     frame_pointer = FRAME_POINTER (file);
15459     stack_pointer = STACK_POINTER (file);
15460     open_format_frame (p, ref_file, (A68_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68_TRUE);
15461   } else if (mode == MODE (PROC_REF_FILE_VOID)) {
15462     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (PROC_REF_FILE_VOID));
15463     exit_genie (p, A68_RUNTIME_ERROR);
15464   } else if (mode == MODE (REF_SOUND)) {
15465     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (REF_SOUND));
15466     exit_genie (p, A68_RUNTIME_ERROR);
15467   } else if (IS (mode, REF_SYMBOL)) {
15468     CHECK_REF (p, *(A68_REF *) item, mode);
15469     genie_read_standard_format (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file, formats);
15470   } else if (mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) {
15471     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
15472     if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
15473       genie_read_standard (pat, mode, item, ref_file);
15474     } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
15475       read_number_generic (pat, mode, item, ref_file);
15476     } else if (IS (pat, INTEGRAL_C_PATTERN)) {
15477       read_c_pattern (pat, mode, item, ref_file);
15478     } else if (IS (pat, INTEGRAL_PATTERN)) {
15479       read_integral_pattern (pat, mode, item, ref_file);
15480     } else if (IS (pat, CHOICE_PATTERN)) {
15481       int k = read_choice_pattern (pat, ref_file);
15482       if (mode == MODE (INT)) {
15483         A68_INT *z = (A68_INT *) item;
15484         VALUE (z) = k;
15485         STATUS (z) = (STATUS_MASK) ((VALUE (z) > 0) ? INIT_MASK : NULL_MASK);
15486       } else {
15487         MP_T *z = (MP_T *) item;
15488         if (k > 0) {
15489           (void) int_to_mp (p, z, k, DIGITS (mode));
15490           z[0] = (MP_T) INIT_MASK;
15491         } else {
15492           z[0] = (MP_T) NULL_MASK;
15493         }
15494       }
15495     } else {
15496       pattern_error (p, mode, ATTRIBUTE (pat));
15497     }
15498   } else if (mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) {
15499     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
15500     genie_read_real_format (pat, mode, item, ref_file);
15501   } else if (mode == MODE (COMPLEX)) {
15502     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
15503     if (IS (pat, COMPLEX_PATTERN)) {
15504       read_complex_pattern (pat, mode, MODE (REAL), item, &item[SIZE (MODE (REAL))], ref_file);
15505     } else {
15506 /* Try reading as two REAL values */
15507       genie_read_real_format (pat, MODE (REAL), item, ref_file);
15508       genie_read_standard_format (p, MODE (REAL), &item[SIZE (MODE (REAL))], ref_file, formats);
15509     }
15510   } else if (mode == MODE (LONG_COMPLEX)) {
15511     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
15512     if (IS (pat, COMPLEX_PATTERN)) {
15513       read_complex_pattern (pat, mode, MODE (LONG_REAL), item, &item[SIZE (MODE (LONG_REAL))], ref_file);
15514     } else {
15515 /* Try reading as two LONG REAL values */
15516       genie_read_real_format (pat, MODE (LONG_REAL), item, ref_file);
15517       genie_read_standard_format (p, MODE (LONG_REAL), &item[SIZE (MODE (LONG_REAL))], ref_file, formats);
15518     }
15519   } else if (mode == MODE (LONGLONG_COMPLEX)) {
15520     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
15521     if (IS (pat, COMPLEX_PATTERN)) {
15522       read_complex_pattern (pat, mode, MODE (LONGLONG_REAL), item, &item[SIZE (MODE (LONGLONG_REAL))], ref_file);
15523     } else {
15524 /* Try reading as two LONG LONG REAL values */
15525       genie_read_real_format (pat, MODE (LONGLONG_REAL), item, ref_file);
15526       genie_read_standard_format (p, MODE (LONGLONG_REAL), &item[SIZE (MODE (LONGLONG_REAL))], ref_file, formats);
15527     }
15528   } else if (mode == MODE (BOOL)) {
15529     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
15530     if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
15531       genie_read_standard (p, mode, item, ref_file);
15532     } else if (IS (pat, BOOLEAN_PATTERN)) {
15533       if (NEXT_SUB (pat) == NO_NODE) {
15534         genie_read_standard (p, mode, item, ref_file);
15535       } else {
15536         A68_BOOL *z = (A68_BOOL *) item;
15537         int k = read_choice_pattern (pat, ref_file);
15538         if (k == 1 || k == 2) {
15539           VALUE (z) = (BOOL_T) ((k == 1) ? A68_TRUE : A68_FALSE);
15540           STATUS (z) = INIT_MASK;
15541         } else {
15542           STATUS (z) = NULL_MASK;
15543         }
15544       }
15545     } else {
15546       pattern_error (p, mode, ATTRIBUTE (pat));
15547     }
15548   } else if (mode == MODE (BITS) || mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) {
15549     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
15550     if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
15551       genie_read_standard (p, mode, item, ref_file);
15552     } else if (IS (pat, BITS_PATTERN)) {
15553       read_bits_pattern (pat, mode, item, ref_file);
15554     } else if (IS (pat, BITS_C_PATTERN)) {
15555       read_c_pattern (pat, mode, item, ref_file);
15556     } else {
15557       pattern_error (p, mode, ATTRIBUTE (pat));
15558     }
15559   } else if (mode == MODE (CHAR)) {
15560     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
15561     if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
15562       genie_read_standard (p, mode, item, ref_file);
15563     } else if (IS (pat, STRING_PATTERN)) {
15564       read_string_pattern (pat, MODE (CHAR), ref_file);
15565       genie_string_to_value (p, mode, item, ref_file);
15566     } else if (IS (pat, CHAR_C_PATTERN)) {
15567       read_c_pattern (pat, mode, item, ref_file);
15568     } else {
15569       pattern_error (p, mode, ATTRIBUTE (pat));
15570     }
15571   } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) {
15572 /* Handle these separately instead of reading [] CHAR */
15573     NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
15574     if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
15575       genie_read_standard (p, mode, item, ref_file);
15576     } else if (IS (pat, STRING_PATTERN)) {
15577       read_string_pattern (pat, mode, ref_file);
15578       genie_string_to_value (p, mode, item, ref_file);
15579     } else if (IS (pat, STRING_C_PATTERN)) {
15580       read_c_pattern (pat, mode, item, ref_file);
15581     } else {
15582       pattern_error (p, mode, ATTRIBUTE (pat));
15583     }
15584   } else if (IS (mode, UNION_SYMBOL)) {
15585     A68_UNION *z = (A68_UNION *) item;
15586     genie_read_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file, formats);
15587   } else if (IS (mode, STRUCT_SYMBOL)) {
15588     PACK_T *q = PACK (mode);
15589     for (; q != NO_PACK; FORWARD (q)) {
15590       BYTE_T *elem = &item[OFFSET (q)];
15591       genie_read_standard_format (p, MOID (q), elem, ref_file, formats);
15592     }
15593   } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) {
15594     MOID_T *deflexed = DEFLEX (mode);
15595     A68_ARRAY *arr;
15596     A68_TUPLE *tup;
15597     CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS));
15598     GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
15599     if (get_row_size (tup, DIM (arr)) > 0) {
15600       BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
15601       BOOL_T done = A68_FALSE;
15602       initialise_internal_index (tup, DIM (arr));
15603       while (!done) {
15604         ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
15605         ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
15606         BYTE_T *elem = &base_addr[elem_addr];
15607         genie_read_standard_format (p, SUB (deflexed), elem, ref_file, formats);
15608         done = increment_internal_index (tup, DIM (arr));
15609       }
15610     }
15611   }
15612   if (errno != 0) {
15613     transput_error (p, ref_file, mode);
15614   }
15615 }
15616 
15617 /**
15618 @brief PROC ([] SIMPLIN) VOID read f
15619 @param p Node in syntax tree.
15620 **/
15621 
15622 void
genie_read_format(NODE_T * p)15623 genie_read_format (NODE_T * p)
15624 {
15625   A68_REF row;
15626   POP_REF (p, &row);
15627   genie_stand_in (p);
15628   PUSH_REF (p, row);
15629   genie_read_file_format (p);
15630 }
15631 
15632 /**
15633 @brief PROC (REF FILE, [] SIMPLIN) VOID get f
15634 @param p Node in syntax tree.
15635 **/
15636 
15637 void
genie_read_file_format(NODE_T * p)15638 genie_read_file_format (NODE_T * p)
15639 {
15640   A68_REF ref_file;
15641   A68_FILE *file;
15642   A68_REF row;
15643   A68_ARRAY *arr;
15644   A68_TUPLE *tup;
15645   BYTE_T *base_address;
15646   int elems, k, elem_index, formats;
15647   ADDR_T save_frame_pointer, save_stack_pointer;
15648   POP_REF (p, &row);
15649   CHECK_REF (p, row, MODE (ROW_SIMPLIN));
15650   GET_DESCRIPTOR (arr, tup, &row);
15651   elems = ROW_SIZE (tup);
15652   POP_REF (p, &ref_file);
15653   CHECK_REF (p, ref_file, MODE (REF_FILE));
15654   file = FILE_DEREF (&ref_file);
15655   CHECK_INIT (p, INITIALISED (file), MODE (FILE));
15656   if (!OPENED (file)) {
15657     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
15658     exit_genie (p, A68_RUNTIME_ERROR);
15659   }
15660   if (DRAW_MOOD (file)) {
15661     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
15662     exit_genie (p, A68_RUNTIME_ERROR);
15663   }
15664   if (WRITE_MOOD (file)) {
15665     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
15666     exit_genie (p, A68_RUNTIME_ERROR);
15667   }
15668   if (!GET (&CHANNEL (file))) {
15669     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
15670     exit_genie (p, A68_RUNTIME_ERROR);
15671   }
15672   if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
15673     if (IS_NIL (STRING (file))) {
15674       if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0)) == A68_NO_FILENO) {
15675         open_error (p, ref_file, "getting");
15676       }
15677     } else {
15678       FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0);
15679     }
15680     DRAW_MOOD (file) = A68_FALSE;
15681     READ_MOOD (file) = A68_TRUE;
15682     WRITE_MOOD (file) = A68_FALSE;
15683     CHAR_MOOD (file) = A68_TRUE;
15684   }
15685   if (!CHAR_MOOD (file)) {
15686     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
15687     exit_genie (p, A68_RUNTIME_ERROR);
15688   }
15689 /* Save stack state since formats have frames */
15690   save_frame_pointer = FRAME_POINTER (file);
15691   save_stack_pointer = STACK_POINTER (file);
15692   FRAME_POINTER (file) = frame_pointer;
15693   STACK_POINTER (file) = stack_pointer;
15694 /* Process [] SIMPLIN */
15695   if (BODY (&FORMAT (file)) != NO_NODE) {
15696     open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE);
15697   }
15698   if (elems <= 0) {
15699     return;
15700   }
15701   formats = 0;
15702   base_address = DEREF (BYTE_T, &ARRAY (arr));
15703   elem_index = 0;
15704   for (k = 0; k < elems; k++) {
15705     A68_UNION *z = (A68_UNION *) & (base_address[elem_index]);
15706     MOID_T *mode = (MOID_T *) (VALUE (z));
15707     BYTE_T *item = (BYTE_T *) & (base_address[elem_index + A68_UNION_SIZE]);
15708     genie_read_standard_format (p, mode, item, ref_file, &formats);
15709     elem_index += SIZE (MODE (SIMPLIN));
15710   }
15711 /* Empty the format to purge insertions */
15712   purge_format_read (p, ref_file);
15713   BODY (&FORMAT (file)) = NO_NODE;
15714 /* Forget about active formats */
15715   frame_pointer = FRAME_POINTER (file);
15716   stack_pointer = STACK_POINTER (file);
15717   FRAME_POINTER (file) = save_frame_pointer;
15718   STACK_POINTER (file) = save_stack_pointer;
15719 }
15720 
15721 /*********************/
15722 /* Numerical library */
15723 /*********************/
15724 
15725 /*
15726 Note that the interpreter has its own routines for these simple tasks that
15727 often are optimised to work with values pushed on the stack, and that
15728 perform runtime checks. These functions are not mangled to fit below routines.
15729 */
15730 
15731 /**
15732 @brief Sqrt (x^2 + y^2) that does not needlessly overflow.
15733 @param x X.
15734 @param y Y.
15735 @return See brief description.
15736 **/
15737 
15738 double
a68g_hypot(double x,double y)15739 a68g_hypot (double x, double y)
15740 {
15741   double xabs = ABS (x), yabs = ABS (y);
15742   double min, max;
15743   if (xabs < yabs) {
15744     min = xabs;
15745     max = yabs;
15746   } else {
15747     min = yabs;
15748     max = xabs;
15749   }
15750   if (min == 0.0) {
15751     return (max);
15752   } else {
15753     double u = min / max;
15754     return (max * sqrt (1.0 + u * u));
15755   }
15756 }
15757 
15758 /**
15759 @brief Log (1 + x) with anti-cancellation for IEEE 754.
15760 @param x X.
15761 @return See brief description.
15762 **/
15763 
15764 double
a68g_log1p(double x)15765 a68g_log1p (double x)
15766 {
15767   volatile double y;
15768   y = 1 + x;
15769   return log (y) - ((y - 1) - x) / y;   /* cancel errors with IEEE arithmetic */
15770 }
15771 
15772 /**
15773 @brief OP ROUND = (REAL) INT
15774 **/
15775 
15776 int
a68g_round(double x)15777 a68g_round (double x)
15778 {
15779   if (x >= 0) {
15780     return ((int) (x + 0.5));
15781   } else {
15782     return ((int) (x - 0.5));
15783   }
15784 }
15785 
15786 /**
15787 PROC exp = (REAL) REAL
15788 **/
15789 
15790 double
a68g_exp(double x)15791 a68g_exp (double x)
15792 {
15793   if (x < log (DBL_MIN)) {
15794     return (0.0);
15795   } else {
15796     return (exp (x));
15797   }
15798 }
15799 
15800 /**
15801 @brief PROC atan2 (REAL, REAL) REAL
15802 **/
15803 
15804 double
a68g_atan2(double x,double y)15805 a68g_atan2 (double x, double y)
15806 {
15807   if (x == 0.0 && y == 0.0) {
15808     errno = EDOM;
15809     return (0.0);
15810   } else {
15811     BOOL_T flip = (BOOL_T) (y < 0.0);
15812     double z;
15813     y = ABS (y);
15814     if (x == 0.0) {
15815       z = A68_PI / 2.0;
15816     } else {
15817       BOOL_T flop = (BOOL_T) (x < 0.0);
15818       x = ABS (x);
15819       z = atan (y / x);
15820       if (flop) {
15821         z = A68_PI - z;
15822       }
15823     }
15824     if (flip) {
15825       z = -z;
15826     }
15827     return (z);
15828   }
15829 }
15830 
15831 /**
15832 @brief PROC asinh = (REAL) REAL
15833 **/
15834 
15835 double
a68g_asinh(double x)15836 a68g_asinh (double x)
15837 {
15838   double a = ABS (x), s = (x < 0.0 ? -1.0 : 1.0);
15839   if (a > 1.0 / sqrt (DBL_EPSILON)) {
15840     return (s * (log (a) + log (2.0)));
15841   } else if (a > 2.0) {
15842     return (s * log (2.0 * a + 1.0 / (a + sqrt (a * a + 1.0))));
15843   } else if (a > sqrt (DBL_EPSILON)) {
15844     double a2 = a * a;
15845     return (s * a68g_log1p (a + a2 / (1.0 + sqrt (1.0 + a2))));
15846   } else {
15847     return (x);
15848   }
15849 }
15850 
15851 /**
15852 @brief PROC acosh = (REAL) REAL
15853 **/
15854 
15855 double
a68g_acosh(double x)15856 a68g_acosh (double x)
15857 {
15858   if (x > 1.0 / sqrt (DBL_EPSILON)) {
15859     return (log (x) + log (2.0));
15860   } else if (x > 2.0) {
15861     return (log (2.0 * x - 1.0 / (sqrt (x * x - 1.0) + x)));
15862   } else if (x > 1.0) {
15863     double t = x - 1.0;
15864     return (a68g_log1p (t + sqrt (2.0 * t + t * t)));
15865   } else if (x == 1.0) {
15866     return (0.0);
15867   } else {
15868     errno = EDOM;
15869     return (0.0);
15870   }
15871 }
15872 
15873 /**
15874 @brief PROC atanh = (REAL) REAL
15875 **/
15876 
15877 double
a68g_atanh(double x)15878 a68g_atanh (double x)
15879 {
15880   double a = ABS (x);
15881   double s = (double) (x < 0 ? -1 : 1);
15882   if (a >= 1.0) {
15883     errno = EDOM;
15884     return (0.0);
15885   } else if (a >= 0.5) {
15886     return (s * 0.5 * a68g_log1p (2 * a / (1.0 - a)));
15887   } else if (a > DBL_EPSILON) {
15888     return (s * 0.5 * a68g_log1p (2.0 * a + 2.0 * a * a / (1.0 - a)));
15889   } else {
15890     return (x);
15891   }
15892 }
15893 
15894 /**
15895 @brief OP ** = (REAL, REAL) REAL
15896 **/
15897 
15898 double
a68g_pow_real(double x,double y)15899 a68g_pow_real (double x, double y)
15900 {
15901   return (exp (y * log (x)));
15902 }
15903 
15904 /**
15905 @brief OP ** = (REAL, INT) REAL
15906 **/
15907 
15908 double
a68g_pow_real_int(double x,int n)15909 a68g_pow_real_int (double x, int n)
15910 {
15911   switch (n) {
15912   case 2:
15913     return (x * x);
15914   case 3:
15915     return (x * x * x);
15916   case 4:{
15917       double y = x * x;
15918       return (y * y);
15919     }
15920   case 5:{
15921       double y = x * x;
15922       return (x * y * y);
15923     }
15924   case 6:{
15925       double y = x * x * x;
15926       return (y * y);
15927     }
15928   default:{
15929       int expo = 1, m = (int) labs (n);
15930       BOOL_T cont = (m > 0);
15931       double mult = x, prod = 1;
15932       while (cont) {
15933         if ((m & expo) != 0) {
15934           prod *= mult;
15935         }
15936         expo *= 2;
15937         cont = (expo <= m);
15938         if (cont) {
15939           mult *= mult;
15940         }
15941       }
15942       return (n < 0 ? 1 / prod : prod);
15943     }
15944   }
15945 }
15946 
15947 /**
15948 @brief OP / = (COMPLEX, COMPLEX) COMPLEX
15949 **/
15950 
15951 void
a68g_div_complex(A68_REAL * z,A68_REAL * x,A68_REAL * y)15952 a68g_div_complex (A68_REAL * z, A68_REAL * x, A68_REAL * y)
15953 {
15954   if (RE (y) == 0 && IM (y) == 0) {
15955     RE (z) = 0.0;
15956     IM (z) = 0.0;
15957     errno = EDOM;
15958   } else if (fabs (RE (y)) >= fabs (IM (y))) {
15959     double r = IM (y) / RE (y), den = RE (y) + r * IM (y);
15960     STATUS_RE (z) = INIT_MASK;
15961     STATUS_IM (z) = INIT_MASK;
15962     RE (z) = (RE (x) + r * IM (x)) / den;
15963     IM (z) = (IM (x) - r * RE (x)) / den;
15964   } else {
15965     double r = RE (y) / IM (y), den = IM (y) + r * RE (y);
15966     STATUS_RE (z) = INIT_MASK;
15967     STATUS_IM (z) = INIT_MASK;
15968     RE (z) = (RE (x) * r + IM (x)) / den;
15969     IM (z) = (IM (x) * r - RE (x)) / den;
15970   }
15971 }
15972 
15973 /**
15974 @brief PROC csqrt = (COMPLEX) COMPLEX
15975 **/
15976 
15977 void
a68g_sqrt_complex(A68_REAL * z,A68_REAL * x)15978 a68g_sqrt_complex (A68_REAL * z, A68_REAL * x)
15979 {
15980   STATUS_RE (z) = INIT_MASK;
15981   STATUS_IM (z) = INIT_MASK;
15982   if (RE (x) == 0.0 && IM (x) == 0.0) {
15983     RE (z) = 0.0;
15984     IM (z) = 0.0;
15985   } else {
15986     double re = fabs (RE (x)), im = fabs (IM (x)), w;
15987     if (re >= im) {
15988       double t = im / re;
15989       w = sqrt (re) * sqrt (0.5 * (1.0 + sqrt (1.0 + t * t)));
15990     } else {
15991       double t = re / im;
15992       w = sqrt (im) * sqrt (0.5 * (t + sqrt (1.0 + t * t)));
15993     }
15994     if (RE (x) >= 0.0) {
15995       RE (z) = w;
15996       IM (z) = IM (x) / (2.0 * w);
15997     } else {
15998       double ai = IM (x);
15999       double vi = (ai >= 0.0 ? w : -w);
16000       RE (z) = ai / (2.0 * vi);
16001       IM (z) = vi;
16002     }
16003   }
16004 }
16005 
16006 /**
16007 @brief PROC cexp = (COMPLEX) COMPLEX
16008 **/
16009 
16010 void
a68g_exp_complex(A68_REAL * z,A68_REAL * x)16011 a68g_exp_complex (A68_REAL * z, A68_REAL * x)
16012 {
16013   double r = exp (RE (x));
16014   STATUS_RE (z) = INIT_MASK;
16015   STATUS_IM (z) = INIT_MASK;
16016   RE (z) = r * cos (IM (x));
16017   IM (z) = r * sin (IM (x));
16018 }
16019 
16020 /**
16021 @brief PROC cln = (COMPLEX) COMPLEX
16022 **/
16023 
16024 void
a68g_ln_complex(A68_REAL * z,A68_REAL * x)16025 a68g_ln_complex (A68_REAL * z, A68_REAL * x)
16026 {
16027   STATUS_RE (z) = INIT_MASK;
16028   STATUS_IM (z) = INIT_MASK;
16029   RE (z) = log (a68g_abs_complex (x));
16030   IM (z) = a68g_arg_complex (x);
16031 }
16032 
16033 
16034 /**
16035 @brief PROC csin = (COMPLEX) COMPLEX
16036 **/
16037 
16038 void
a68g_sin_complex(A68_REAL * z,A68_REAL * x)16039 a68g_sin_complex (A68_REAL * z, A68_REAL * x)
16040 {
16041   STATUS_RE (z) = INIT_MASK;
16042   STATUS_IM (z) = INIT_MASK;
16043   if (IM (x) == 0) {
16044     RE (z) = sin (RE (x));
16045     IM (z) = 0;
16046   } else {
16047     RE (z) = sin (RE (x)) * cosh (IM (x));
16048     IM (z) = cos (RE (x)) * sinh (IM (x));
16049   }
16050 }
16051 
16052 /**
16053 @brief PROC ccos = (COMPLEX) COMPLEX
16054 **/
16055 
16056 void
a68g_cos_complex(A68_REAL * z,A68_REAL * x)16057 a68g_cos_complex (A68_REAL * z, A68_REAL * x)
16058 {
16059   STATUS_RE (z) = INIT_MASK;
16060   STATUS_IM (z) = INIT_MASK;
16061   if (IM (x) == 0) {
16062     RE (z) = cos (RE (x));
16063     IM (z) = 0;
16064   } else {
16065     RE (z) = cos (RE (x)) * cosh (IM (x));
16066     IM (z) = sin (RE (x)) * sinh (-IM (x));
16067   }
16068 }
16069 
16070 /**
16071 @brief PROC ctan = (COMPLEX) COMPLEX
16072 **/
16073 
16074 void
a68g_tan_complex(A68_REAL * z,A68_REAL * x)16075 a68g_tan_complex (A68_REAL * z, A68_REAL * x)
16076 {
16077   A68_COMPLEX u, v;
16078   STATUS_RE (u) = INIT_MASK;
16079   STATUS_IM (u) = INIT_MASK;
16080   STATUS_RE (v) = INIT_MASK;
16081   STATUS_IM (v) = INIT_MASK;
16082   if (IM (x) == 0) {
16083     RE (u) = sin (RE (x));
16084     IM (u) = 0;
16085     RE (v) = cos (RE (x));
16086     IM (v) = 0;
16087   } else {
16088     RE (u) = sin (RE (x)) * cosh (IM (x));
16089     IM (u) = cos (RE (x)) * sinh (IM (x));
16090     RE (v) = cos (RE (x)) * cosh (IM (x));
16091     IM (v) = sin (RE (x)) * sinh (-IM (x));
16092   }
16093   a68g_div_complex (z, u, v);
16094 }
16095 
16096 /**
16097 @brief PROC casin = (COMPLEX) COMPLEX
16098 **/
16099 
16100 void
a68g_arcsin_complex(A68_REAL * z,A68_REAL * x)16101 a68g_arcsin_complex (A68_REAL * z, A68_REAL * x)
16102 {
16103   double r = RE (x), i = IM (x);
16104   if (i == 0) {
16105     RE (z) = asin (r);
16106     IM (z) = 0;
16107   } else {
16108     double u = a68g_hypot (r + 1, i), v = a68g_hypot (r - 1, i);
16109     double a = 0.5 * (u + v), b = 0.5 * (u - v);
16110     RE (z) = asin (b);
16111     IM (z) = log (a + sqrt (a * a - 1));
16112   }
16113 
16114 }
16115 
16116 /**
16117 @brief PROC cacos = (COMPLEX) COMPLEX
16118 **/
16119 
16120 void
a68g_arccos_complex(A68_REAL * z,A68_REAL * x)16121 a68g_arccos_complex (A68_REAL * z, A68_REAL * x)
16122 {
16123   double r = RE (x), i = IM (x);
16124   if (i == 0) {
16125     RE (z) = acos (r);
16126     IM (z) = 0;
16127   } else {
16128     double u = a68g_hypot (r + 1, i), v = a68g_hypot (r - 1, i);
16129     double a = 0.5 * (u + v), b = 0.5 * (u - v);
16130     RE (z) = acos (b);
16131     IM (z) = -log (a + sqrt (a * a - 1));
16132   }
16133 
16134 }
16135 
16136 /**
16137 @brief PROC catan = (COMPLEX) COMPLEX
16138 **/
16139 
16140 void
a68g_arctan_complex(A68_REAL * z,A68_REAL * x)16141 a68g_arctan_complex (A68_REAL * z, A68_REAL * x)
16142 {
16143   double r = RE (x), i = IM (x);
16144   if (i == 0) {
16145     RE (z) = atan (r);
16146     IM (z) = 0;
16147   } else {
16148     double a = a68g_hypot (r, i + 1), b = a68g_hypot (r, i - 1);
16149     RE (z) = 0.5 * atan (2 * r / (1 - r * r - i * i));
16150     IM (z) = 0.5 * log (a / b);
16151   }
16152 }
16153 
16154 /* Operators for ROWS */
16155 
16156 /**
16157 @brief OP ELEMS = (ROWS) INT
16158 @param p Position in syntax tree.
16159 **/
16160 
16161 void
genie_monad_elems(NODE_T * p)16162 genie_monad_elems (NODE_T * p)
16163 {
16164   A68_REF z;
16165   A68_ARRAY *x;
16166   A68_TUPLE *t;
16167   POP_REF (p, &z);
16168 /* Decrease pointer since a UNION is on the stack */
16169   DECREMENT_STACK_POINTER (p, A68_UNION_SIZE);
16170   CHECK_REF (p, z, MODE (ROWS));
16171   GET_DESCRIPTOR (x, t, &z);
16172   PUSH_PRIMITIVE (p, get_row_size (t, DIM (x)), A68_INT);
16173 }
16174 
16175 /**
16176 @brief OP LWB = (ROWS) INT
16177 @param p Position in syntax tree.
16178 **/
16179 
16180 void
genie_monad_lwb(NODE_T * p)16181 genie_monad_lwb (NODE_T * p)
16182 {
16183   A68_REF z;
16184   A68_ARRAY *x;
16185   A68_TUPLE *t;
16186   POP_REF (p, &z);
16187 /* Decrease pointer since a UNION is on the stack */
16188   DECREMENT_STACK_POINTER (p, A68_UNION_SIZE);
16189   CHECK_REF (p, z, MODE (ROWS));
16190   GET_DESCRIPTOR (x, t, &z);
16191   PUSH_PRIMITIVE (p, LWB (t), A68_INT);
16192 }
16193 
16194 /**
16195 @brief OP UPB = (ROWS) INT
16196 @param p Position in syntax tree.
16197 **/
16198 
16199 void
genie_monad_upb(NODE_T * p)16200 genie_monad_upb (NODE_T * p)
16201 {
16202   A68_REF z;
16203   A68_ARRAY *x;
16204   A68_TUPLE *t;
16205   POP_REF (p, &z);
16206 /* Decrease pointer since a UNION is on the stack */
16207   DECREMENT_STACK_POINTER (p, A68_UNION_SIZE);
16208   CHECK_REF (p, z, MODE (ROWS));
16209   GET_DESCRIPTOR (x, t, &z);
16210   PUSH_PRIMITIVE (p, UPB (t), A68_INT);
16211 }
16212 
16213 /**
16214 @brief OP ELEMS = (INT, ROWS) INT
16215 @param p Position in syntax tree.
16216 **/
16217 
16218 void
genie_dyad_elems(NODE_T * p)16219 genie_dyad_elems (NODE_T * p)
16220 {
16221   A68_REF z;
16222   A68_ARRAY *x;
16223   A68_TUPLE *t, *u;
16224   A68_INT k;
16225   POP_REF (p, &z);
16226 /* Decrease pointer since a UNION is on the stack */
16227   DECREMENT_STACK_POINTER (p, A68_UNION_SIZE);
16228   CHECK_REF (p, z, MODE (ROWS));
16229   POP_OBJECT (p, &k, A68_INT);
16230   GET_DESCRIPTOR (x, t, &z);
16231   if (VALUE (&k) < 1 || VALUE (&k) > DIM (x)) {
16232     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_DIMENSION, (int) VALUE (&k));
16233     exit_genie (p, A68_RUNTIME_ERROR);
16234   }
16235   u = &(t[VALUE (&k) - 1]);
16236   PUSH_PRIMITIVE (p, ROW_SIZE (u), A68_INT);
16237 }
16238 
16239 /**
16240 @brief OP LWB = (INT, ROWS) INT
16241 @param p Position in syntax tree.
16242 **/
16243 
16244 void
genie_dyad_lwb(NODE_T * p)16245 genie_dyad_lwb (NODE_T * p)
16246 {
16247   A68_REF z;
16248   A68_ARRAY *x;
16249   A68_TUPLE *t;
16250   A68_INT k;
16251   POP_REF (p, &z);
16252 /* Decrease pointer since a UNION is on the stack */
16253   DECREMENT_STACK_POINTER (p, A68_UNION_SIZE);
16254   CHECK_REF (p, z, MODE (ROWS));
16255   POP_OBJECT (p, &k, A68_INT);
16256   GET_DESCRIPTOR (x, t, &z);
16257   if (VALUE (&k) < 1 || VALUE (&k) > DIM (x)) {
16258     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_DIMENSION, (int) VALUE (&k));
16259     exit_genie (p, A68_RUNTIME_ERROR);
16260   }
16261   PUSH_PRIMITIVE (p, LWB (&(t[VALUE (&k) - 1])), A68_INT);
16262 }
16263 
16264 /**
16265 @brief OP UPB = (INT, ROWS) INT
16266 @param p Position in syntax tree.
16267 **/
16268 
16269 void
genie_dyad_upb(NODE_T * p)16270 genie_dyad_upb (NODE_T * p)
16271 {
16272   A68_REF z;
16273   A68_ARRAY *x;
16274   A68_TUPLE *t;
16275   A68_INT k;
16276   POP_REF (p, &z);
16277 /* Decrease pointer since a UNION is on the stack */
16278   DECREMENT_STACK_POINTER (p, A68_UNION_SIZE);
16279   CHECK_REF (p, z, MODE (ROWS));
16280   POP_OBJECT (p, &k, A68_INT);
16281   GET_DESCRIPTOR (x, t, &z);
16282   if (VALUE (&k) < 1 || VALUE (&k) > DIM (x)) {
16283     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_DIMENSION, (int) VALUE (&k));
16284     exit_genie (p, A68_RUNTIME_ERROR);
16285   }
16286   PUSH_PRIMITIVE (p, UPB (&(t[VALUE (&k) - 1])), A68_INT);
16287 }
16288 
16289 /*
16290 Implements SOUND values.
16291 */
16292 
16293 #define MAX_BYTES 4
16294 #define A68_LITTLE_ENDIAN A68_TRUE
16295 #define A68_BIG_ENDIAN A68_FALSE
16296 
16297 /* From public Microsoft RIFF documentation */
16298 
16299 #define	WAVE_FORMAT_UNKNOWN		(0x0000)
16300 #define	WAVE_FORMAT_PCM			(0x0001)
16301 #define	WAVE_FORMAT_ADPCM		(0x0002)
16302 #define WAVE_FORMAT_IEEE_FLOAT          (0x0003)
16303 #define WAVE_FORMAT_IBM_FORMAT_CVSD	(0x0005)
16304 #define	WAVE_FORMAT_ALAW		(0x0006)
16305 #define	WAVE_FORMAT_MULAW		(0x0007)
16306 #define	WAVE_FORMAT_OKI_ADPCM		(0x0010)
16307 #define WAVE_FORMAT_DVI_ADPCM		(0x0011)
16308 #define WAVE_FORMAT_MEDIASPACE_ADPCM	(0x0012)
16309 #define WAVE_FORMAT_SIERRA_ADPCM	(0x0013)
16310 #define WAVE_FORMAT_G723_ADPCM		(0X0014)
16311 #define	WAVE_FORMAT_DIGISTD		(0x0015)
16312 #define	WAVE_FORMAT_DIGIFIX		(0x0016)
16313 #define WAVE_FORMAT_YAMAHA_ADPCM	(0x0020)
16314 #define WAVE_FORMAT_SONARC		(0x0021)
16315 #define WAVE_FORMAT_DSPGROUP_TRUESPEECH	(0x0022)
16316 #define WAVE_FORMAT_ECHOSCI1		(0x0023)
16317 #define WAVE_FORMAT_AUDIOFILE_AF36	(0x0024)
16318 #define WAVE_FORMAT_APTX		(0x0025)
16319 #define WAVE_FORMAT_AUDIOFILE_AF10	(0x0026)
16320 #define WAVE_FORMAT_DOLBY_AC2           (0x0030)
16321 #define WAVE_FORMAT_GSM610              (0x0031)
16322 #define WAVE_FORMAT_ANTEX_ADPCME	(0x0033)
16323 #define WAVE_FORMAT_CONTROL_RES_VQLPC	(0x0034)
16324 #define WAVE_FORMAT_DIGIREAL		(0x0035)
16325 #define WAVE_FORMAT_DIGIADPCM		(0x0036)
16326 #define WAVE_FORMAT_CONTROL_RES_CR10	(0x0037)
16327 #define WAVE_FORMAT_NMS_VBXADPCM	(0x0038)
16328 #define WAVE_FORMAT_ROCKWELL_ADPCM      (0x003b)
16329 #define WAVE_FORMAT_ROCKWELL_DIGITALK   (0x003c)
16330 #define WAVE_FORMAT_G721_ADPCM          (0x0040)
16331 #define WAVE_FORMAT_G728_CELP           (0x0041)
16332 #define WAVE_FORMAT_MPEG                (0x0050)
16333 #define WAVE_FORMAT_MPEGLAYER3          (0x0055)
16334 #define WAVE_FORMAT_G726_ADPCM          (0x0064)
16335 #define WAVE_FORMAT_G722_ADPCM          (0x0065)
16336 #define WAVE_FORMAT_IBM_FORMAT_MULAW	(0x0101)
16337 #define WAVE_FORMAT_IBM_FORMAT_ALAW	(0x0102)
16338 #define WAVE_FORMAT_IBM_FORMAT_ADPCM	(0x0103)
16339 #define WAVE_FORMAT_CREATIVE_ADPCM	(0x0200)
16340 #define WAVE_FORMAT_FM_TOWNS_SND	(0x0300)
16341 #define WAVE_FORMAT_OLIGSM		(0x1000)
16342 #define WAVE_FORMAT_OLIADPCM		(0x1001)
16343 #define WAVE_FORMAT_OLICELP		(0x1002)
16344 #define WAVE_FORMAT_OLISBC		(0x1003)
16345 #define WAVE_FORMAT_OLIOPR		(0x1004)
16346 #define WAVE_FORMAT_EXTENSIBLE          (0xfffe)
16347 
16348 static unsigned pow256[] = { 1, 256, 65536, 16777216 };
16349 
16350 /**
16351 @brief Test bits per sample.
16352 @param p Node in syntax tree.
16353 @param bps Bits per second.
16354 **/
16355 
16356 static void
test_bits_per_sample(NODE_T * p,unsigned bps)16357 test_bits_per_sample (NODE_T * p, unsigned bps)
16358 {
16359   if (bps <= 0 || bps > 24) {
16360     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "unsupported number of bits per sample");
16361     exit_genie (p, A68_RUNTIME_ERROR);
16362   }
16363 }
16364 
16365 /**
16366 @brief Code string into big-endian unsigned.
16367 @param p Node in syntax tree.
16368 @param s String to code.
16369 @param n Chars to code.
16370 **/
16371 
16372 static unsigned
code_string(NODE_T * p,char * s,int n)16373 code_string (NODE_T * p, char *s, int n)
16374 {
16375   unsigned v;
16376   int k, m;
16377   if (n > MAX_BYTES) {
16378     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "too long word length");
16379     exit_genie (p, A68_RUNTIME_ERROR);
16380   }
16381   for (k = 0, m = n - 1, v = 0; k < n; k++, m--) {
16382     v += ((unsigned) s[k]) * pow256[m];
16383   } return (v);
16384 }
16385 
16386 /**
16387 @brief Code unsigned into string.
16388 @param p Node in syntax tree.
16389 @param n Value to code.
16390 **/
16391 
16392 static char *
code_unsigned(NODE_T * p,unsigned n)16393 code_unsigned (NODE_T * p, unsigned n)
16394 {
16395   static char text[MAX_BYTES + 1];
16396   int k;
16397   (void) p;
16398   for (k = 0; k < MAX_BYTES; k++) {
16399     char ch = (char) (n % 0x100);
16400     if (ch == NULL_CHAR) {
16401       ch = BLANK_CHAR;
16402     } else if (ch < BLANK_CHAR) {
16403       ch = '?';
16404     }
16405     text[MAX_BYTES - k - 1] = ch;
16406     n >>= 8;
16407   }
16408   text[MAX_BYTES] = NULL_CHAR;
16409   return (text);
16410 }
16411 
16412 /**
16413 @brief WAVE format category
16414 @param n Category number.
16415 **/
16416 
16417 static char *
format_category(unsigned n)16418 format_category (unsigned n)
16419 {
16420   switch (n) {
16421   case WAVE_FORMAT_UNKNOWN:
16422     {
16423       return ("WAVE_FORMAT_UNKNOWN");
16424     }
16425   case WAVE_FORMAT_PCM:
16426     {
16427       return ("WAVE_FORMAT_PCM	");
16428     }
16429   case WAVE_FORMAT_ADPCM:
16430     {
16431       return ("WAVE_FORMAT_ADPCM");
16432     }
16433   case WAVE_FORMAT_IEEE_FLOAT:
16434     {
16435       return ("WAVE_FORMAT_IEEE_FLOAT");
16436     }
16437   case WAVE_FORMAT_IBM_FORMAT_CVSD:
16438     {
16439       return ("WAVE_FORMAT_IBM_FORMAT_CVSD");
16440     }
16441   case WAVE_FORMAT_ALAW:
16442     {
16443       return ("WAVE_FORMAT_ALAW");
16444     }
16445   case WAVE_FORMAT_MULAW:
16446     {
16447       return ("WAVE_FORMAT_MULAW");
16448     }
16449   case WAVE_FORMAT_OKI_ADPCM:
16450     {
16451       return ("WAVE_FORMAT_OKI_ADPCM");
16452     }
16453   case WAVE_FORMAT_DVI_ADPCM:
16454     {
16455       return ("WAVE_FORMAT_DVI_ADPCM");
16456     }
16457   case WAVE_FORMAT_MEDIASPACE_ADPCM:
16458     {
16459       return ("WAVE_FORMAT_MEDIASPACE_ADPCM");
16460     }
16461   case WAVE_FORMAT_SIERRA_ADPCM:
16462     {
16463       return ("WAVE_FORMAT_SIERRA_ADPCM");
16464     }
16465   case WAVE_FORMAT_G723_ADPCM:
16466     {
16467       return ("WAVE_FORMAT_G723_ADPCM");
16468     }
16469   case WAVE_FORMAT_DIGISTD:
16470     {
16471       return ("WAVE_FORMAT_DIGISTD");
16472     }
16473   case WAVE_FORMAT_DIGIFIX:
16474     {
16475       return ("WAVE_FORMAT_DIGIFIX");
16476     }
16477   case WAVE_FORMAT_YAMAHA_ADPCM:
16478     {
16479       return ("WAVE_FORMAT_YAMAHA_ADPCM");
16480     }
16481   case WAVE_FORMAT_SONARC:
16482     {
16483       return ("WAVE_FORMAT_SONARC");
16484     }
16485   case WAVE_FORMAT_DSPGROUP_TRUESPEECH:
16486     {
16487       return ("WAVE_FORMAT_DSPGROUP_TRUESPEECH");
16488     }
16489   case WAVE_FORMAT_ECHOSCI1:
16490     {
16491       return ("WAVE_FORMAT_ECHOSCI1");
16492     }
16493   case WAVE_FORMAT_AUDIOFILE_AF36:
16494     {
16495       return ("WAVE_FORMAT_AUDIOFILE_AF36");
16496     }
16497   case WAVE_FORMAT_APTX:
16498     {
16499       return ("WAVE_FORMAT_APTX");
16500     }
16501   case WAVE_FORMAT_AUDIOFILE_AF10:
16502     {
16503       return ("WAVE_FORMAT_AUDIOFILE_AF10");
16504     }
16505   case WAVE_FORMAT_DOLBY_AC2:
16506     {
16507       return ("WAVE_FORMAT_DOLBY_AC2");
16508     }
16509   case WAVE_FORMAT_GSM610:
16510     {
16511       return ("WAVE_FORMAT_GSM610 ");
16512     }
16513   case WAVE_FORMAT_ANTEX_ADPCME:
16514     {
16515       return ("WAVE_FORMAT_ANTEX_ADPCME");
16516     }
16517   case WAVE_FORMAT_CONTROL_RES_VQLPC:
16518     {
16519       return ("WAVE_FORMAT_CONTROL_RES_VQLPC");
16520     }
16521   case WAVE_FORMAT_DIGIREAL:
16522     {
16523       return ("WAVE_FORMAT_DIGIREAL");
16524     }
16525   case WAVE_FORMAT_DIGIADPCM:
16526     {
16527       return ("WAVE_FORMAT_DIGIADPCM");
16528     }
16529   case WAVE_FORMAT_CONTROL_RES_CR10:
16530     {
16531       return ("WAVE_FORMAT_CONTROL_RES_CR10");
16532     }
16533   case WAVE_FORMAT_NMS_VBXADPCM:
16534     {
16535       return ("WAVE_FORMAT_NMS_VBXADPCM");
16536     }
16537   case WAVE_FORMAT_ROCKWELL_ADPCM:
16538     {
16539       return ("WAVE_FORMAT_ROCKWELL_ADPCM");
16540     }
16541   case WAVE_FORMAT_ROCKWELL_DIGITALK:
16542     {
16543       return ("WAVE_FORMAT_ROCKWELL_DIGITALK");
16544     }
16545   case WAVE_FORMAT_G721_ADPCM:
16546     {
16547       return ("WAVE_FORMAT_G721_ADPCM");
16548     }
16549   case WAVE_FORMAT_G728_CELP:
16550     {
16551       return ("WAVE_FORMAT_G728_CELP");
16552     }
16553   case WAVE_FORMAT_MPEG:
16554     {
16555       return ("WAVE_FORMAT_MPEG");
16556     }
16557   case WAVE_FORMAT_MPEGLAYER3:
16558     {
16559       return ("WAVE_FORMAT_MPEGLAYER3");
16560     }
16561   case WAVE_FORMAT_G726_ADPCM:
16562     {
16563       return ("WAVE_FORMAT_G726_ADPCM");
16564     }
16565   case WAVE_FORMAT_G722_ADPCM:
16566     {
16567       return ("WAVE_FORMAT_G722_ADPCM");
16568     }
16569   case WAVE_FORMAT_IBM_FORMAT_MULAW:
16570     {
16571       return ("WAVE_FORMAT_IBM_FORMAT_MULAW");
16572     }
16573   case WAVE_FORMAT_IBM_FORMAT_ALAW:
16574     {
16575       return ("WAVE_FORMAT_IBM_FORMAT_ALAW");
16576     }
16577   case WAVE_FORMAT_IBM_FORMAT_ADPCM:
16578     {
16579       return ("WAVE_FORMAT_IBM_FORMAT_ADPCM");
16580     }
16581   case WAVE_FORMAT_CREATIVE_ADPCM:
16582     {
16583       return ("WAVE_FORMAT_CREATIVE_ADPCM");
16584     }
16585   case WAVE_FORMAT_FM_TOWNS_SND:
16586     {
16587       return ("WAVE_FORMAT_FM_TOWNS_SND");
16588     }
16589   case WAVE_FORMAT_OLIGSM:
16590     {
16591       return ("WAVE_FORMAT_OLIGSM");
16592     }
16593   case WAVE_FORMAT_OLIADPCM:
16594     {
16595       return ("WAVE_FORMAT_OLIADPCM");
16596     }
16597   case WAVE_FORMAT_OLICELP:
16598     {
16599       return ("WAVE_FORMAT_OLICELP");
16600     }
16601   case WAVE_FORMAT_OLISBC:
16602     {
16603       return ("WAVE_FORMAT_OLISBC");
16604     }
16605   case WAVE_FORMAT_OLIOPR:
16606     {
16607       return ("WAVE_FORMAT_OLIOPR");
16608     }
16609   case WAVE_FORMAT_EXTENSIBLE:
16610     {
16611       return ("WAVE_FORMAT_EXTENSIBLE");
16612     }
16613   default:
16614     {
16615       return ("other");
16616     }
16617   }
16618 }
16619 
16620 /**
16621 @brief Read RIFF item.
16622 @param p Node in syntax tree.
16623 @param fd File number.
16624 @param n Word length.
16625 @param little Whether little-endian.
16626 **/
16627 
16628 static unsigned
read_riff_item(NODE_T * p,FILE_T fd,int n,BOOL_T little)16629 read_riff_item (NODE_T * p, FILE_T fd, int n, BOOL_T little)
16630 {
16631   unsigned v, z;
16632   int k, m, r;
16633   if (n > MAX_BYTES) {
16634     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "too long word length");
16635     exit_genie (p, A68_RUNTIME_ERROR);
16636   }
16637   if (little) {
16638     for (k = 0, m = 0, v = 0; k < n; k++, m++) {
16639       z = 0;
16640       r = (int) io_read (fd, &z, (size_t) 1);
16641       if (r != 1 || errno != 0) {
16642         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "error while reading file");
16643         exit_genie (p, A68_RUNTIME_ERROR);
16644       }
16645       v += z * pow256[m];
16646     }
16647   } else {
16648     for (k = 0, m = n - 1, v = 0; k < n; k++, m--) {
16649       z = 0;
16650       r = (int) io_read (fd, &z, (size_t) 1);
16651       if (r != 1 || errno != 0) {
16652         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "error while reading file");
16653         exit_genie (p, A68_RUNTIME_ERROR);
16654       }
16655       v += z * pow256[m];
16656     }
16657   }
16658   return (v);
16659 }
16660 
16661 /**
16662 @brief Read sound from file.
16663 @param p Node in syntax tree.
16664 @param ref_file Pointer to file.
16665 @param w Sound object.
16666 **/
16667 
16668 void
read_sound(NODE_T * p,A68_REF ref_file,A68_SOUND * w)16669 read_sound (NODE_T * p, A68_REF ref_file, A68_SOUND * w)
16670 {
16671   A68_FILE *f = FILE_DEREF (&ref_file);
16672   int r;
16673   unsigned fmt_cat;
16674   unsigned blockalign, byterate, chunksize, subchunk2size, z;
16675   BOOL_T data_read = A68_FALSE;
16676   if (read_riff_item (p, FD (f), 4, A68_BIG_ENDIAN) != code_string (p, "RIFF", 4)) {
16677     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "file format is not RIFF");
16678     exit_genie (p, A68_RUNTIME_ERROR);
16679   }
16680   chunksize = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN);
16681   if ((z = read_riff_item (p, FD (f), 4, A68_BIG_ENDIAN)) != code_string (p, "WAVE", 4)) {
16682     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL_STRING, MODE (SOUND), "file format is not \"WAVE\" but", code_unsigned (p, z));
16683     exit_genie (p, A68_RUNTIME_ERROR);
16684   }
16685 /* Now read chunks */
16686   while (data_read == A68_FALSE) {
16687     z = read_riff_item (p, FD (f), 4, A68_BIG_ENDIAN);
16688     if (z == code_string (p, "fmt ", 4)) {
16689 /* Read fmt chunk */
16690       int k, skip;
16691       z = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN);
16692       skip = (int) z - 0x10;    /* Bytes to skip in extended wave format */
16693       fmt_cat = read_riff_item (p, FD (f), 2, A68_LITTLE_ENDIAN);
16694       if (fmt_cat != WAVE_FORMAT_PCM) {
16695         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL_STRING, MODE (SOUND), "category is not WAVE_FORMAT_PCM but", format_category (fmt_cat));
16696         exit_genie (p, A68_RUNTIME_ERROR);
16697       }
16698       NUM_CHANNELS (w) = read_riff_item (p, FD (f), 2, A68_LITTLE_ENDIAN);
16699       SAMPLE_RATE (w) = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN);
16700       byterate = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN);
16701       blockalign = read_riff_item (p, FD (f), 2, A68_LITTLE_ENDIAN);
16702       BITS_PER_SAMPLE (w) = read_riff_item (p, FD (f), 2, A68_LITTLE_ENDIAN);
16703       test_bits_per_sample (p, BITS_PER_SAMPLE (w));
16704       for (k = 0; k < skip; k++) {
16705         z = read_riff_item (p, FD (f), 1, A68_LITTLE_ENDIAN);
16706       }
16707     } else if (z == code_string (p, "LIST", 4)) {
16708 /* Skip a LIST chunk */
16709       int k, skip;
16710       z = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN);
16711       skip = (int) z;
16712       for (k = 0; k < skip; k++) {
16713         z = read_riff_item (p, FD (f), 1, A68_LITTLE_ENDIAN);
16714       }
16715     } else if (z == code_string (p, "cue ", 4)) {
16716 /* Skip a cue chunk */
16717       int k, skip;
16718       z = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN);
16719       skip = (int) z;
16720       for (k = 0; k < skip; k++) {
16721         z = read_riff_item (p, FD (f), 1, A68_LITTLE_ENDIAN);
16722       }
16723     } else if (z == code_string (p, "fact", 4)) {
16724 /* Skip a fact chunk */
16725       int k, skip;
16726       z = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN);
16727       skip = (int) z;
16728       for (k = 0; k < skip; k++) {
16729         z = read_riff_item (p, FD (f), 1, A68_LITTLE_ENDIAN);
16730       }
16731     } else if (z == code_string (p, "data", 4)) {
16732 /* Read data chunk */
16733       subchunk2size = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN);
16734       NUM_SAMPLES (w) = subchunk2size / NUM_CHANNELS (w) / (unsigned) A68_SOUND_BYTES (w);
16735       DATA (w) = heap_generator (p, MODE (SOUND_DATA), (int) subchunk2size);
16736       r = (int) io_read (FD (f), ADDRESS (&(DATA (w))), subchunk2size);
16737       if (r != (int) subchunk2size) {
16738         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "cannot read all of the data");
16739         exit_genie (p, A68_RUNTIME_ERROR);
16740       }
16741       data_read = A68_TRUE;
16742     } else {
16743       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL_STRING, MODE (SOUND), "chunk is", code_unsigned (p, z));
16744       exit_genie (p, A68_RUNTIME_ERROR);
16745     }
16746   }
16747   (void) blockalign;
16748   (void) byterate;
16749   (void) chunksize;
16750   (void) subchunk2size;
16751   STATUS (w) = INIT_MASK;
16752 }
16753 
16754 /**
16755 @brief Write RIFF item.
16756 @param p Node in syntax tree.
16757 @param fd File number.
16758 @param z Item.
16759 @param n Number of chars.
16760 @param little Whether little endian.
16761 **/
16762 
16763 void
write_riff_item(NODE_T * p,FILE_T fd,unsigned z,int n,BOOL_T little)16764 write_riff_item (NODE_T * p, FILE_T fd, unsigned z, int n, BOOL_T little)
16765 {
16766   int k, r;
16767   unsigned char y[MAX_BYTES];
16768   if (n > MAX_BYTES) {
16769     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "too long word length");
16770     exit_genie (p, A68_RUNTIME_ERROR);
16771   }
16772   for (k = 0; k < n; k++) {
16773     y[k] = (unsigned char) (z & 0xff);
16774     z >>= 8;
16775   }
16776   if (little) {
16777     for (k = 0; k < n; k++) {
16778       ASSERT (io_write (fd, &(y[k]), 1) != -1);
16779     }
16780   } else {
16781     for (k = n - 1; k >= 0; k--) {
16782       r = (int) io_write (fd, &(y[k]), 1);
16783       if (r != 1) {
16784         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "error while writing file");
16785         exit_genie (p, A68_RUNTIME_ERROR);
16786       }
16787     }
16788   }
16789 }
16790 
16791 /**
16792 @brief Write sound to file.
16793 @param p Node in syntax tree.
16794 @param ref_file Pointer to file.
16795 @param w Sound object.
16796 **/
16797 
16798 void
write_sound(NODE_T * p,A68_REF ref_file,A68_SOUND * w)16799 write_sound (NODE_T * p, A68_REF ref_file, A68_SOUND * w)
16800 {
16801   A68_FILE *f = FILE_DEREF (&ref_file);
16802   int r;
16803   unsigned blockalign = NUM_CHANNELS (w) * (unsigned) (A68_SOUND_BYTES (w));
16804   unsigned byterate = SAMPLE_RATE (w) * blockalign;
16805   unsigned subchunk2size = NUM_SAMPLES (w) * blockalign;
16806   unsigned chunksize = 4 + (8 + 16) + (8 + subchunk2size);
16807   write_riff_item (p, FD (f), code_string (p, "RIFF", 4), 4, A68_BIG_ENDIAN);
16808   write_riff_item (p, FD (f), chunksize, 4, A68_LITTLE_ENDIAN);
16809   write_riff_item (p, FD (f), code_string (p, "WAVE", 4), 4, A68_BIG_ENDIAN);
16810   write_riff_item (p, FD (f), code_string (p, "fmt ", 4), 4, A68_BIG_ENDIAN);
16811   write_riff_item (p, FD (f), 16, 4, A68_LITTLE_ENDIAN);
16812   write_riff_item (p, FD (f), 1, 2, A68_LITTLE_ENDIAN);
16813   write_riff_item (p, FD (f), NUM_CHANNELS (w), 2, A68_LITTLE_ENDIAN);
16814   write_riff_item (p, FD (f), SAMPLE_RATE (w), 4, A68_LITTLE_ENDIAN);
16815   write_riff_item (p, FD (f), byterate, 4, A68_LITTLE_ENDIAN);
16816   write_riff_item (p, FD (f), blockalign, 2, A68_LITTLE_ENDIAN);
16817   write_riff_item (p, FD (f), BITS_PER_SAMPLE (w), 2, A68_LITTLE_ENDIAN);
16818   write_riff_item (p, FD (f), code_string (p, "data", 4), 4, A68_BIG_ENDIAN);
16819   write_riff_item (p, FD (f), subchunk2size, 4, A68_LITTLE_ENDIAN);
16820   if (IS_NIL (DATA (w))) {
16821     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sound has no data");
16822     exit_genie (p, A68_RUNTIME_ERROR);
16823   }
16824   r = (int) io_write (FD (f), ADDRESS (&(DATA (w))), subchunk2size);
16825   if (r != (int) subchunk2size) {
16826     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "error while writing file");
16827     exit_genie (p, A68_RUNTIME_ERROR);
16828   }
16829 }
16830 
16831 /**
16832 @brief PROC new sound = (INT bits, INT sample rate, INT channels, INT samples) SOUND
16833 @param p Node in syntax tree.
16834 **/
16835 
16836 void
genie_new_sound(NODE_T * p)16837 genie_new_sound (NODE_T * p)
16838 {
16839   A68_INT num_channels, sample_rate, bits_per_sample, num_samples;
16840   A68_SOUND w;
16841   POP_OBJECT (p, &num_samples, A68_INT);
16842   POP_OBJECT (p, &num_channels, A68_INT);
16843   POP_OBJECT (p, &sample_rate, A68_INT);
16844   POP_OBJECT (p, &bits_per_sample, A68_INT);
16845   NUM_SAMPLES (&w) = (unsigned) (VALUE (&num_samples));
16846   NUM_CHANNELS (&w) = (unsigned) (VALUE (&num_channels));
16847   SAMPLE_RATE (&w) = (unsigned) (VALUE (&sample_rate));
16848   BITS_PER_SAMPLE (&w) = (unsigned) (VALUE (&bits_per_sample));
16849   test_bits_per_sample (p, BITS_PER_SAMPLE (&w));
16850   DATA_SIZE (&w) = (unsigned) A68_SOUND_DATA_SIZE (&w);
16851   DATA (&w) = heap_generator (p, MODE (SOUND_DATA), (int) DATA_SIZE (&w));
16852   STATUS (&w) = INIT_MASK;
16853   PUSH_OBJECT (p, w, A68_SOUND);
16854 }
16855 
16856 /**
16857 @brief PROC get sound = (SOUND w, INT channel, sample) INT
16858 @param p Node in syntax tree.
16859 **/
16860 
16861 void
genie_get_sound(NODE_T * p)16862 genie_get_sound (NODE_T * p)
16863 {
16864   A68_INT channel, sample;
16865   A68_SOUND w;
16866   int addr, k, n, z, m;
16867   BYTE_T *d;
16868   POP_OBJECT (p, &sample, A68_INT);
16869   POP_OBJECT (p, &channel, A68_INT);
16870   POP_OBJECT (p, &w, A68_SOUND);
16871   if (!(VALUE (&channel) >= 1 && VALUE (&channel) <= (int) NUM_CHANNELS (&w))) {
16872     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "channel index out of range");
16873     exit_genie (p, A68_RUNTIME_ERROR);
16874   }
16875   if (!(VALUE (&sample) >= 1 && VALUE (&sample) <= (int) NUM_SAMPLES (&w))) {
16876     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sample index out of range");
16877     exit_genie (p, A68_RUNTIME_ERROR);
16878   }
16879   if (IS_NIL (DATA (&w))) {
16880     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sound has no data");
16881     exit_genie (p, A68_RUNTIME_ERROR);
16882   }
16883   n = A68_SOUND_BYTES (&w);
16884   addr = ((VALUE (&sample) - 1) * (int) (NUM_CHANNELS (&w)) + (VALUE (&channel) - 1)) * n;
16885   ABEND (addr < 0 || addr >= (int) DATA_SIZE (&w), ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
16886   d = &(ADDRESS (&(DATA (&w)))[addr]);
16887 /* Convert from little-endian, irrespective from the platform we work on */
16888   for (k = 0, z = 0, m = 0; k < n; k++) {
16889     z += ((int) (d[k]) * (int) (pow256[k]));
16890     m = k;
16891   }
16892   PUSH_PRIMITIVE (p, (d[m] & 0x80 ? (n == 4 ? z : z - (int) pow256[m + 1]) : z), A68_INT);
16893 }
16894 
16895 /**
16896 @brief PROC set sound = (SOUND w, INT channel, sample, value) VOID
16897 @param p Node in syntax tree.
16898 **/
16899 
16900 void
genie_set_sound(NODE_T * p)16901 genie_set_sound (NODE_T * p)
16902 {
16903   A68_INT channel, sample, value;
16904   int addr, k, n, z;
16905   BYTE_T *d;
16906   A68_SOUND w;
16907   POP_OBJECT (p, &value, A68_INT);
16908   POP_OBJECT (p, &sample, A68_INT);
16909   POP_OBJECT (p, &channel, A68_INT);
16910   POP_OBJECT (p, &w, A68_SOUND);
16911   if (!(VALUE (&channel) >= 1 && VALUE (&channel) <= (int) NUM_CHANNELS (&w))) {
16912     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "channel index out of range");
16913     exit_genie (p, A68_RUNTIME_ERROR);
16914   }
16915   if (!(VALUE (&sample) >= 1 && VALUE (&sample) <= (int) NUM_SAMPLES (&w))) {
16916     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sample index out of range");
16917     exit_genie (p, A68_RUNTIME_ERROR);
16918   }
16919   if (IS_NIL (DATA (&w))) {
16920     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sound has no data");
16921     exit_genie (p, A68_RUNTIME_ERROR);
16922   }
16923   n = A68_SOUND_BYTES (&w);
16924   addr = ((VALUE (&sample) - 1) * (int) (NUM_CHANNELS (&w)) + (VALUE (&channel) - 1)) * n;
16925   ABEND (addr < 0 || addr >= (int) DATA_SIZE (&w), ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
16926   d = &(ADDRESS (&(DATA (&w)))[addr]);
16927 /* Convert to little-endian */
16928   for (k = 0, z = VALUE (&value); k < n; k++) {
16929     d[k] = (BYTE_T) (z & 0xff);
16930     z >>= 8;
16931   }
16932 }
16933 
16934 /**
16935 @brief OP SOUND = (SOUND) INT
16936 @param p Node in syntax tree.
16937 **/
16938 
16939 void
genie_sound_samples(NODE_T * p)16940 genie_sound_samples (NODE_T * p)
16941 {
16942   A68_SOUND w;
16943   POP_OBJECT (p, &w, A68_SOUND);
16944   PUSH_PRIMITIVE (p, (int) (NUM_SAMPLES (&w)), A68_INT);
16945 }
16946 
16947 /**
16948 @brief OP RATE = (SOUND) INT
16949 @param p Node in syntax tree.
16950 **/
16951 
16952 void
genie_sound_rate(NODE_T * p)16953 genie_sound_rate (NODE_T * p)
16954 {
16955   A68_SOUND w;
16956   POP_OBJECT (p, &w, A68_SOUND);
16957   PUSH_PRIMITIVE (p, (int) (SAMPLE_RATE (&w)), A68_INT);
16958 }
16959 
16960 /**
16961 @brief OP CHANNELS = (SOUND) INT
16962 @param p Node in syntax tree.
16963 **/
16964 
16965 void
genie_sound_channels(NODE_T * p)16966 genie_sound_channels (NODE_T * p)
16967 {
16968   A68_SOUND w;
16969   POP_OBJECT (p, &w, A68_SOUND);
16970   PUSH_PRIMITIVE (p, (int) (NUM_CHANNELS (&w)), A68_INT);
16971 }
16972 
16973 /**
16974 @brief OP RESOLUTION = (SOUND) INT
16975 @param p Node in syntax tree.
16976 **/
16977 
16978 void
genie_sound_resolution(NODE_T * p)16979 genie_sound_resolution (NODE_T * p)
16980 {
16981   A68_SOUND w;
16982   POP_OBJECT (p, &w, A68_SOUND);
16983   PUSH_PRIMITIVE (p, (int) (BITS_PER_SAMPLE (&w)), A68_INT);
16984 }
16985 
16986 /**
16987 Unix extensions to A68G
16988 */
16989 
16990 #define MAX_RESTART 256
16991 
16992 BOOL_T halt_typing;
16993 static int chars_in_tty_line;
16994 
16995 char output_line[BUFFER_SIZE], edit_line[BUFFER_SIZE], input_line[BUFFER_SIZE];
16996 
16997 /**
16998 @brief Initialise output to STDOUT.
16999 **/
17000 
17001 void
init_tty(void)17002 init_tty (void)
17003 {
17004   chars_in_tty_line = 0;
17005   halt_typing = A68_FALSE;
17006   change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_FALSE);
17007 }
17008 
17009 /**
17010 @brief Terminate current line on STDOUT.
17011 **/
17012 
17013 void
io_close_tty_line(void)17014 io_close_tty_line (void)
17015 {
17016   if (chars_in_tty_line > 0) {
17017     io_write_string (STDOUT_FILENO, NEWLINE_STRING);
17018   }
17019 }
17020 
17021 /**
17022 @brief Get a char from STDIN.
17023 @return See brief description.
17024 **/
17025 
17026 char
get_stdin_char(void)17027 get_stdin_char (void)
17028 {
17029   ssize_t j;
17030   char ch[4];
17031   RESET_ERRNO;
17032   j = io_read_conv (STDIN_FILENO, &(ch[0]), 1);
17033   ABEND (j < 0, "cannot read char from stdin", NO_TEXT);
17034   return ((char) (j == 1 ? ch[0] : EOF_CHAR));
17035 }
17036 
17037 /**
17038 @brief Read string from STDIN, until NEWLINE_STRING.
17039 @param prompt Prompt string.
17040 @return Input line buffer.
17041 **/
17042 
17043 char *
read_string_from_tty(char * prompt)17044 read_string_from_tty (char *prompt)
17045 {
17046 #if defined HAVE_READLINE
17047   char *line = readline (prompt);
17048   if (line != NO_TEXT && (int) strlen (line) > 0) {
17049     add_history (line);
17050   }
17051   bufcpy (input_line, line, BUFFER_SIZE);
17052   chars_in_tty_line = (int) strlen (input_line);
17053   free (line);
17054   return (input_line);
17055 
17056 #else
17057   int ch, k = 0, n;
17058   if (prompt != NO_TEXT) {
17059     io_close_tty_line ();
17060     io_write_string (STDOUT_FILENO, prompt);
17061   }
17062   ch = get_stdin_char ();
17063   while (ch != NEWLINE_CHAR && k < BUFFER_SIZE - 1) {
17064     if (ch == EOF_CHAR) {
17065       input_line[0] = EOF_CHAR;
17066       input_line[1] = NULL_CHAR;
17067       chars_in_tty_line = 1;
17068       return (input_line);
17069     } else {
17070       input_line[k++] = (char) ch;
17071       ch = get_stdin_char ();
17072     }
17073   }
17074   input_line[k] = NULL_CHAR;
17075   n = (int) strlen (input_line);
17076   chars_in_tty_line = (ch == NEWLINE_CHAR ? 0 : (n > 0 ? n : 1));
17077   return (input_line);
17078 #endif
17079 }
17080 
17081 /**
17082 @brief Write string to file.
17083 @param f File number.
17084 @param z String to write.
17085 **/
17086 
17087 void
io_write_string(FILE_T f,const char * z)17088 io_write_string (FILE_T f, const char *z)
17089 {
17090   ssize_t j;
17091   RESET_ERRNO;
17092   if (f != STDOUT_FILENO && f != STDERR_FILENO) {
17093 /* Writing to file */
17094     j = io_write_conv (f, z, strlen (z));
17095     ABEND (j < 0, "cannot write", NO_TEXT);
17096   } else {
17097 /* Writing to TTY */
17098     int first, k;
17099 /* Write parts until end-of-string */
17100     first = 0;
17101     do {
17102       k = first;
17103 /* How far can we get? */
17104       while (z[k] != NULL_CHAR && z[k] != NEWLINE_CHAR) {
17105         k++;
17106       }
17107       if (k > first) {
17108 /* Write these characters */
17109         int n = k - first;
17110         j = io_write_conv (f, &(z[first]), (size_t) n);
17111         ABEND (j < 0, "cannot write", NO_TEXT);
17112         chars_in_tty_line += n;
17113       }
17114       if (z[k] == NEWLINE_CHAR) {
17115 /* Pretty-print newline */
17116         k++;
17117         first = k;
17118         j = io_write_conv (f, NEWLINE_STRING, 1);
17119         ABEND (j < 0, "cannot write", NO_TEXT);
17120         chars_in_tty_line = 0;
17121       }
17122     } while (z[k] != NULL_CHAR);
17123   }
17124 }
17125 
17126 /**
17127 @brief Read bytes from file into buffer.
17128 @param fd File descriptor, must be open.
17129 @param buf Character buffer, size must be >= n.
17130 @param n Maximum number of bytes to read.
17131 @return Number of bytes read or -1 in case of error.
17132 **/
17133 
17134 ssize_t
io_read(FILE_T fd,void * buf,size_t n)17135 io_read (FILE_T fd, void *buf, size_t n)
17136 {
17137   size_t to_do = n;
17138   int restarts = 0;
17139   char *z = (char *) buf;
17140   while (to_do > 0) {
17141 #if defined HAVE_WIN32
17142     int bytes_read;
17143 #else
17144     ssize_t bytes_read;
17145 #endif
17146     RESET_ERRNO;
17147     bytes_read = read (fd, z, to_do);
17148     if (bytes_read < 0) {
17149       if (errno == EINTR) {
17150 /* interrupt, retry */
17151         bytes_read = 0;
17152         if (restarts++ > MAX_RESTART) {
17153           return (-1);
17154         }
17155       } else {
17156 /* read error */
17157         return (-1);
17158       }
17159     } else if (bytes_read == 0) {
17160       break;                    /* EOF_CHAR */
17161     }
17162     to_do -= (size_t) bytes_read;
17163     z += bytes_read;
17164   }
17165   return ((ssize_t) n - (ssize_t) to_do);       /* return >= 0 */
17166 }
17167 
17168 /**
17169 @brief Writes n bytes from buffer to file.
17170 @param fd File descriptor, must be open.
17171 @param buf Character buffer, size must be >= n.
17172 @param n Maximum number of bytes to write.
17173 @return N or -1 in case of error.
17174 **/
17175 
17176 ssize_t
io_write(FILE_T fd,const void * buf,size_t n)17177 io_write (FILE_T fd, const void *buf, size_t n)
17178 {
17179   size_t to_do = n;
17180   int restarts = 0;
17181   char *z = (char *) buf;
17182   while (to_do > 0) {
17183     ssize_t bytes_written;
17184     RESET_ERRNO;
17185     bytes_written = write (fd, z, to_do);
17186     if (bytes_written <= 0) {
17187       if (errno == EINTR) {
17188 /* interrupt, retry */
17189         bytes_written = 0;
17190         if (restarts++ > MAX_RESTART) {
17191           return (-1);
17192         }
17193       } else {
17194 /* write error */
17195         return (-1);
17196       }
17197     }
17198     to_do -= (size_t) bytes_written;
17199     z += bytes_written;
17200   }
17201   return ((ssize_t) n);
17202 }
17203 
17204 /**
17205 @brief Read bytes from file into buffer.
17206 @param fd File descriptor, must be open.
17207 @param buf Character buffer, size must be >= n.
17208 @param n Maximum number of bytes to read.
17209 @return Number of bytes read or -1 in case of error.
17210 **/
17211 
17212 ssize_t
io_read_conv(FILE_T fd,void * buf,size_t n)17213 io_read_conv (FILE_T fd, void *buf, size_t n)
17214 {
17215   size_t to_do = n;
17216   int restarts = 0;
17217   char *z = (char *) buf;
17218   while (to_do > 0) {
17219 #if defined HAVE_WIN32
17220     int bytes_read;
17221 #else
17222     ssize_t bytes_read;
17223 #endif
17224     RESET_ERRNO;
17225     bytes_read = read (fd, z, to_do);
17226     if (bytes_read < 0) {
17227       if (errno == EINTR) {
17228 /* interrupt, retry */
17229         bytes_read = 0;
17230         if (restarts++ > MAX_RESTART) {
17231           return (-1);
17232         }
17233       } else {
17234 /* read error */
17235         return (-1);
17236       }
17237     } else if (bytes_read == 0) {
17238       break;                    /* EOF_CHAR */
17239     }
17240     to_do -= (size_t) bytes_read;
17241     z += bytes_read;
17242   }
17243   return ((ssize_t) n - (ssize_t) to_do);
17244 }
17245 
17246 /**
17247 @brief Writes n bytes from buffer to file.
17248 @param fd File descriptor, must be open.
17249 @param buf Character buffer, size must be >= n.
17250 @param n Maximum number of bytes to write.
17251 @return N or -1 in case of error.
17252 **/
17253 
17254 ssize_t
io_write_conv(FILE_T fd,const void * buf,size_t n)17255 io_write_conv (FILE_T fd, const void *buf, size_t n)
17256 {
17257   size_t to_do = n;
17258   int restarts = 0;
17259   char *z = (char *) buf;
17260   while (to_do > 0) {
17261     ssize_t bytes_written;
17262     RESET_ERRNO;
17263     bytes_written = write (fd, z, to_do);
17264     if (bytes_written <= 0) {
17265       if (errno == EINTR) {
17266 /* interrupt, retry */
17267         bytes_written = 0;
17268         if (restarts++ > MAX_RESTART) {
17269           return (-1);
17270         }
17271       } else {
17272 /* write error */
17273         return (-1);
17274       }
17275     }
17276     to_do -= (size_t) bytes_written;
17277     z += bytes_written;
17278   }
17279   return ((ssize_t) n);
17280 }
17281 
17282 /*
17283 This code implements some UNIX/Linux/BSD related routines.
17284 In part contributed by Sian Leitch.
17285 */
17286 
17287 #define VECTOR_SIZE 512
17288 #define FD_READ 0
17289 #define FD_WRITE 1
17290 
17291 extern A68_REF tmp_to_a68_string (NODE_T *, char *);
17292 
17293 extern A68_CHANNEL stand_in_channel, stand_out_channel, stand_draw_channel, stand_back_channel, stand_error_channel;
17294 
17295 #if defined HAVE_DIRENT_H
17296 
17297 /**
17298 @brief PROC (STRING) [] STRING directory
17299 @param p Node in syntax tree.
17300 **/
17301 
17302 void
genie_directory(NODE_T * p)17303 genie_directory (NODE_T * p)
17304 {
17305   A68_REF name;
17306   char *buffer;
17307   RESET_ERRNO;
17308   POP_REF (p, &name);
17309   CHECK_INIT (p, INITIALISED (&name), MODE (STRING));
17310   buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name)));
17311   if (buffer == NO_TEXT) {
17312     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
17313     exit_genie (p, A68_RUNTIME_ERROR);
17314     PUSH_PRIMITIVE (p, A68_MAX_INT, A68_INT);
17315   } else {
17316     char *dir_name = a_to_c_string (p, buffer, name);
17317     A68_REF z, row;
17318     A68_ARRAY arr;
17319     A68_TUPLE tup;
17320     int k, n = 0;
17321     A68_REF *base;
17322     DIR *dir;
17323     struct dirent *entry;
17324     dir = opendir (dir_name);
17325     if (dir == NULL) {
17326       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS);
17327       exit_genie (p, A68_RUNTIME_ERROR);
17328     }
17329     do {
17330       entry = readdir (dir);
17331       if (errno != 0) {
17332         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS);
17333         exit_genie (p, A68_RUNTIME_ERROR);
17334       }
17335       if (entry != NULL) {
17336         n++;
17337       }
17338     } while (entry != NULL);
17339     rewinddir (dir);
17340     if (errno != 0) {
17341       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS);
17342       exit_genie (p, A68_RUNTIME_ERROR);
17343     }
17344     z = heap_generator (p, MODE (ROW_STRING), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE));
17345     row = heap_generator (p, MODE (ROW_STRING), n * SIZE (MODE (STRING)));
17346     DIM (&arr) = 1;
17347     MOID (&arr) = MODE (STRING);
17348     ELEM_SIZE (&arr) = SIZE (MODE (STRING));
17349     SLICE_OFFSET (&arr) = 0;
17350     FIELD_OFFSET (&arr) = 0;
17351     ARRAY (&arr) = row;
17352     LWB (&tup) = 1;
17353     UPB (&tup) = n;
17354     SHIFT (&tup) = LWB (&tup);
17355     SPAN (&tup) = 1;
17356     K (&tup) = 0;
17357     PUT_DESCRIPTOR (arr, tup, &z);
17358     base = DEREF (A68_REF, &row);
17359     for (k = 0; k < n; k++) {
17360       entry = readdir (dir);
17361       if (errno != 0) {
17362         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS);
17363         exit_genie (p, A68_RUNTIME_ERROR);
17364       }
17365       base[k] = c_to_a_string (p, D_NAME (entry), DEFAULT_WIDTH);
17366     }
17367     if (closedir (dir) != 0) {
17368       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS);
17369       exit_genie (p, A68_RUNTIME_ERROR);
17370     }
17371     PUSH_REF (p, z);
17372     free (buffer);
17373   }
17374 }
17375 
17376 #endif
17377 
17378 /**
17379 @brief PROC [] INT utc time
17380 @param p Node in syntax tree.
17381 **/
17382 
17383 void
genie_utctime(NODE_T * p)17384 genie_utctime (NODE_T * p)
17385 {
17386   time_t dt;
17387   if (time (&dt) == (time_t) - 1) {
17388     (void) empty_row (p, MODE (ROW_INT));
17389   } else {
17390     A68_REF row;
17391     ADDR_T sp = stack_pointer;
17392     struct tm *tod = gmtime (&dt);
17393     PUSH_PRIMITIVE (p, TM_YEAR (tod) + 1900, A68_INT);
17394     PUSH_PRIMITIVE (p, TM_MON (tod) + 1, A68_INT);
17395     PUSH_PRIMITIVE (p, TM_MDAY (tod), A68_INT);
17396     PUSH_PRIMITIVE (p, TM_HOUR (tod), A68_INT);
17397     PUSH_PRIMITIVE (p, TM_MIN (tod), A68_INT);
17398     PUSH_PRIMITIVE (p, TM_SEC (tod), A68_INT);
17399     PUSH_PRIMITIVE (p, TM_WDAY (tod) + 1, A68_INT);
17400     PUSH_PRIMITIVE (p, TM_ISDST (tod), A68_INT);
17401     row = genie_make_row (p, MODE (INT), 8, sp);
17402     stack_pointer = sp;
17403     PUSH_REF (p, row);
17404   }
17405 }
17406 
17407 /**
17408 @brief PROC [] INT local time
17409 @param p Node in syntax tree.
17410 **/
17411 
17412 void
genie_localtime(NODE_T * p)17413 genie_localtime (NODE_T * p)
17414 {
17415   time_t dt;
17416   if (time (&dt) == (time_t) - 1) {
17417     (void) empty_row (p, MODE (ROW_INT));
17418   } else {
17419     A68_REF row;
17420     ADDR_T sp = stack_pointer;
17421     struct tm *tod = localtime (&dt);
17422     PUSH_PRIMITIVE (p, TM_YEAR (tod) + 1900, A68_INT);
17423     PUSH_PRIMITIVE (p, TM_MON (tod) + 1, A68_INT);
17424     PUSH_PRIMITIVE (p, TM_MDAY (tod), A68_INT);
17425     PUSH_PRIMITIVE (p, TM_HOUR (tod), A68_INT);
17426     PUSH_PRIMITIVE (p, TM_MIN (tod), A68_INT);
17427     PUSH_PRIMITIVE (p, TM_SEC (tod), A68_INT);
17428     PUSH_PRIMITIVE (p, TM_WDAY (tod) + 1, A68_INT);
17429     PUSH_PRIMITIVE (p, TM_ISDST (tod), A68_INT);
17430     row = genie_make_row (p, MODE (INT), 8, sp);
17431     stack_pointer = sp;
17432     PUSH_REF (p, row);
17433   }
17434 }
17435 
17436 /**
17437 @brief PROC INT rows
17438 @param p Node in syntax tree.
17439 **/
17440 
17441 void
genie_rows(NODE_T * p)17442 genie_rows (NODE_T * p)
17443 {
17444   RESET_ERRNO;
17445   PUSH_PRIMITIVE (p, term_heigth, A68_INT);
17446 }
17447 
17448 /**
17449 @brief PROC INT columns
17450 @param p Node in syntax tree.
17451 **/
17452 
17453 void
genie_columns(NODE_T * p)17454 genie_columns (NODE_T * p)
17455 {
17456   RESET_ERRNO;
17457   PUSH_PRIMITIVE (p, term_width, A68_INT);
17458 }
17459 
17460 /**
17461 @brief PROC INT argc
17462 @param p Node in syntax tree.
17463 **/
17464 
17465 void
genie_argc(NODE_T * p)17466 genie_argc (NODE_T * p)
17467 {
17468   RESET_ERRNO;
17469   PUSH_PRIMITIVE (p, global_argc, A68_INT);
17470 }
17471 
17472 /**
17473 @brief PROC (INT) STRING argv
17474 @param p Node in syntax tree.
17475 **/
17476 
17477 void
genie_argv(NODE_T * p)17478 genie_argv (NODE_T * p)
17479 {
17480   A68_INT a68g_index;
17481   RESET_ERRNO;
17482   POP_OBJECT (p, &a68g_index, A68_INT);
17483   if (VALUE (&a68g_index) >= 1 && VALUE (&a68g_index) <= global_argc) {
17484     char *q = global_argv[VALUE (&a68g_index) - 1];
17485     int n = (int) strlen (q);
17486 /* Allow for spaces ending in # to have A68 comment syntax with '#!' */
17487     while (n > 0 && (IS_SPACE (q[n - 1]) || q[n - 1] == '#')) {
17488       q[--n] = NULL_CHAR;
17489     }
17490     PUSH_REF (p, c_to_a_string (p, q, DEFAULT_WIDTH));
17491   } else {
17492     PUSH_REF (p, empty_string (p));
17493   }
17494 }
17495 
17496 /**
17497 @brief Find good argument
17498 @param k
17499 **/
17500 
17501 int
find_good_arg(void)17502 find_good_arg (void)
17503 {
17504   int i;
17505   for (i = 0; i < global_argc; i++) {
17506     char *q = global_argv[i];
17507     if (strncmp (q, "--script", 8) == 0) {
17508       return (i + 1);
17509     }
17510     if (strncmp (q, "--run-script", 12) == 0) {
17511       return (i + 1);
17512     }
17513     if (strcmp (q, "--") == 0) {
17514       return (i);
17515     }
17516     if (strcmp (q, "--exit") == 0) {
17517       return (i);
17518     }
17519   }
17520   return (0);
17521 }
17522 
17523 /**
17524 @brief PROC INT a68g argc
17525 @param p Node in syntax tree.
17526 **/
17527 
17528 void
genie_a68g_argc(NODE_T * p)17529 genie_a68g_argc (NODE_T * p)
17530 {
17531   RESET_ERRNO;
17532   PUSH_PRIMITIVE (p, global_argc - find_good_arg (), A68_INT);
17533 }
17534 
17535 /**
17536 @brief PROC (INT) STRING a68g_argv
17537 @param p Node in syntax tree.
17538 **/
17539 
17540 void
genie_a68g_argv(NODE_T * p)17541 genie_a68g_argv (NODE_T * p)
17542 {
17543   A68_INT a68g_index;
17544   int k;
17545   RESET_ERRNO;
17546   POP_OBJECT (p, &a68g_index, A68_INT);
17547   k = VALUE (&a68g_index);
17548   if (k > 1) {
17549     k += find_good_arg ();
17550   }
17551   if (k >= 1 && k <= global_argc) {
17552     char *q = global_argv[k - 1];
17553     int n = (int) strlen (q);
17554 /* Allow for spaces ending in # to have A68 comment syntax with '#!' */
17555     while (n > 0 && (IS_SPACE (q[n - 1]) || q[n - 1] == '#')) {
17556       q[--n] = NULL_CHAR;
17557     }
17558     PUSH_REF (p, c_to_a_string (p, q, DEFAULT_WIDTH));
17559   } else {
17560     PUSH_REF (p, empty_string (p));
17561   }
17562 }
17563 
17564 /**
17565 @brief PROC STRING pwd
17566 @param p Node in syntax tree.
17567 **/
17568 
17569 void
genie_pwd(NODE_T * p)17570 genie_pwd (NODE_T * p)
17571 {
17572   size_t size = BUFFER_SIZE;
17573   char *buffer = NO_TEXT;
17574   BOOL_T cont = A68_TRUE;
17575   RESET_ERRNO;
17576   while (cont) {
17577     buffer = (char *) malloc (size);
17578     if (buffer == NO_TEXT) {
17579       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
17580       exit_genie (p, A68_RUNTIME_ERROR);
17581     }
17582     if (getcwd (buffer, size) == buffer) {
17583       cont = A68_FALSE;
17584     } else {
17585       free (buffer);
17586       cont = (BOOL_T) (errno == 0);
17587       size *= 2;
17588     }
17589   }
17590   if (buffer != NO_TEXT && errno == 0) {
17591     PUSH_REF (p, c_to_a_string (p, buffer, DEFAULT_WIDTH));
17592     free (buffer);
17593   } else {
17594     PUSH_REF (p, empty_string (p));
17595   }
17596 }
17597 
17598 /**
17599 @brief PROC (STRING) INT cd
17600 @param p Node in syntax tree.
17601 **/
17602 
17603 void
genie_cd(NODE_T * p)17604 genie_cd (NODE_T * p)
17605 {
17606   A68_REF dir;
17607   char *buffer;
17608   RESET_ERRNO;
17609   POP_REF (p, &dir);
17610   CHECK_INIT (p, INITIALISED (&dir), MODE (STRING));
17611   buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, dir)));
17612   if (buffer == NO_TEXT) {
17613     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
17614     exit_genie (p, A68_RUNTIME_ERROR);
17615   } else {
17616     int rc = chdir (a_to_c_string (p, buffer, dir));
17617     if (rc == 0) {
17618       PUSH_PRIMITIVE (p, chdir (a_to_c_string (p, buffer, dir)), A68_INT);
17619     } else {
17620       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS);
17621       exit_genie (p, A68_RUNTIME_ERROR);
17622     }
17623     free (buffer);
17624   }
17625 }
17626 
17627 /**
17628 @brief PROC (STRING) BITS
17629 @param p Node in syntax tree.
17630 **/
17631 
17632 void
genie_file_mode(NODE_T * p)17633 genie_file_mode (NODE_T * p)
17634 {
17635   A68_REF name;
17636   char *buffer;
17637   RESET_ERRNO;
17638   POP_REF (p, &name);
17639   CHECK_INIT (p, INITIALISED (&name), MODE (STRING));
17640   buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name)));
17641   if (buffer == NO_TEXT) {
17642     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
17643     exit_genie (p, A68_RUNTIME_ERROR);
17644   } else {
17645     struct stat status;
17646     if (stat (a_to_c_string (p, buffer, name), &status) == 0) {
17647       PUSH_PRIMITIVE (p, (unsigned) (ST_MODE (&status)), A68_BITS);
17648     } else {
17649       PUSH_PRIMITIVE (p, 0x0, A68_BITS);
17650     }
17651     free (buffer);
17652   }
17653 }
17654 
17655 /**
17656 @brief PROC (STRING) BOOL file is block device
17657 @param p Node in syntax tree.
17658 **/
17659 
17660 void
genie_file_is_block_device(NODE_T * p)17661 genie_file_is_block_device (NODE_T * p)
17662 {
17663   A68_REF name;
17664   char *buffer;
17665   RESET_ERRNO;
17666   POP_REF (p, &name);
17667   CHECK_INIT (p, INITIALISED (&name), MODE (STRING));
17668   buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name)));
17669   if (buffer == NO_TEXT) {
17670     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
17671     exit_genie (p, A68_RUNTIME_ERROR);
17672   } else {
17673     struct stat status;
17674     if (stat (a_to_c_string (p, buffer, name), &status) == 0) {
17675       PUSH_PRIMITIVE (p, (BOOL_T) (S_ISBLK (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
17676     } else {
17677       PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL);
17678     }
17679     free (buffer);
17680   }
17681 }
17682 
17683 /**
17684 @brief PROC (STRING) BOOL file is char device
17685 @param p Node in syntax tree.
17686 **/
17687 
17688 void
genie_file_is_char_device(NODE_T * p)17689 genie_file_is_char_device (NODE_T * p)
17690 {
17691   A68_REF name;
17692   char *buffer;
17693   RESET_ERRNO;
17694   POP_REF (p, &name);
17695   CHECK_INIT (p, INITIALISED (&name), MODE (STRING));
17696   buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name)));
17697   if (buffer == NO_TEXT) {
17698     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
17699     exit_genie (p, A68_RUNTIME_ERROR);
17700   } else {
17701     struct stat status;
17702     if (stat (a_to_c_string (p, buffer, name), &status) == 0) {
17703       PUSH_PRIMITIVE (p, (BOOL_T) (S_ISCHR (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
17704     } else {
17705       PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL);
17706     }
17707     free (buffer);
17708   }
17709 }
17710 
17711 /**
17712 @brief PROC (STRING) BOOL file is directory
17713 @param p Node in syntax tree.
17714 **/
17715 
17716 void
genie_file_is_directory(NODE_T * p)17717 genie_file_is_directory (NODE_T * p)
17718 {
17719   A68_REF name;
17720   char *buffer;
17721   RESET_ERRNO;
17722   POP_REF (p, &name);
17723   CHECK_INIT (p, INITIALISED (&name), MODE (STRING));
17724   buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name)));
17725   if (buffer == NO_TEXT) {
17726     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
17727     exit_genie (p, A68_RUNTIME_ERROR);
17728   } else {
17729     struct stat status;
17730     if (stat (a_to_c_string (p, buffer, name), &status) == 0) {
17731       PUSH_PRIMITIVE (p, (BOOL_T) (S_ISDIR (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
17732     } else {
17733       PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL);
17734     }
17735     free (buffer);
17736   }
17737 }
17738 
17739 /**
17740 @brief PROC (STRING) BOOL file is regular
17741 @param p Node in syntax tree.
17742 **/
17743 
17744 void
genie_file_is_regular(NODE_T * p)17745 genie_file_is_regular (NODE_T * p)
17746 {
17747   A68_REF name;
17748   char *buffer;
17749   RESET_ERRNO;
17750   POP_REF (p, &name);
17751   CHECK_INIT (p, INITIALISED (&name), MODE (STRING));
17752   buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name)));
17753   if (buffer == NO_TEXT) {
17754     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
17755     exit_genie (p, A68_RUNTIME_ERROR);
17756   } else {
17757     struct stat status;
17758     if (stat (a_to_c_string (p, buffer, name), &status) == 0) {
17759       PUSH_PRIMITIVE (p, (BOOL_T) (S_ISREG (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
17760     } else {
17761       PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL);
17762     }
17763     free (buffer);
17764   }
17765 }
17766 
17767 #if defined __S_IFIFO
17768 
17769 /**
17770 @brief PROC (STRING) BOOL file is fifo
17771 @param p Node in syntax tree.
17772 **/
17773 
17774 void
genie_file_is_fifo(NODE_T * p)17775 genie_file_is_fifo (NODE_T * p)
17776 {
17777   A68_REF name;
17778   char *buffer;
17779   RESET_ERRNO;
17780   POP_REF (p, &name);
17781   CHECK_INIT (p, INITIALISED (&name), MODE (STRING));
17782   buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name)));
17783   if (buffer == NO_TEXT) {
17784     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
17785     exit_genie (p, A68_RUNTIME_ERROR);
17786   } else {
17787     struct stat status;
17788     if (stat (a_to_c_string (p, buffer, name), &status) == 0) {
17789       PUSH_PRIMITIVE (p, (BOOL_T) (S_ISFIFO (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
17790     } else {
17791       PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL);
17792     }
17793     free (buffer);
17794   }
17795 }
17796 
17797 #endif
17798 
17799 #if defined S_ISLNK
17800 
17801 /**
17802 @brief PROC (STRING) BOOL file is link
17803 @param p Node in syntax tree.
17804 **/
17805 
17806 void
genie_file_is_link(NODE_T * p)17807 genie_file_is_link (NODE_T * p)
17808 {
17809   A68_REF name;
17810   char *buffer;
17811   RESET_ERRNO;
17812   POP_REF (p, &name);
17813   CHECK_INIT (p, INITIALISED (&name), MODE (STRING));
17814   buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name)));
17815   if (buffer == NO_TEXT) {
17816     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
17817     exit_genie (p, A68_RUNTIME_ERROR);
17818   } else {
17819     struct stat status;
17820     if (stat (a_to_c_string (p, buffer, name), &status) == 0) {
17821       PUSH_PRIMITIVE (p, (BOOL_T) (S_ISLNK (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
17822     } else {
17823       PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL);
17824     }
17825     free (buffer);
17826   }
17827 }
17828 
17829 #endif
17830 
17831 /**
17832 @brief Convert [] STRING row to char *vec[].
17833 @param p Node in syntax tree.
17834 @param vec String vector.
17835 @param row [] STRING
17836 **/
17837 
17838 static void
convert_string_vector(NODE_T * p,char * vec[],A68_REF row)17839 convert_string_vector (NODE_T * p, char *vec[], A68_REF row)
17840 {
17841   BYTE_T *z = ADDRESS (&row);
17842   A68_ARRAY *arr = (A68_ARRAY *) & z[0];
17843   A68_TUPLE *tup = (A68_TUPLE *) & z[SIZE_AL (A68_ARRAY)];
17844   int k = 0;
17845   if (get_row_size (tup, DIM (arr)) > 0) {
17846     BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
17847     BOOL_T done = A68_FALSE;
17848     initialise_internal_index (tup, DIM (arr));
17849     while (!done) {
17850       ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
17851       ADDR_T elem_addr = (a68g_index + SLICE_OFFSET (arr)) * ELEM_SIZE (arr) + FIELD_OFFSET (arr);
17852       BYTE_T *elem = &base_addr[elem_addr];
17853       int size = a68_string_size (p, *(A68_REF *) elem);
17854       CHECK_INIT (p, INITIALISED ((A68_REF *) elem), MODE (STRING));
17855       vec[k] = (char *) get_heap_space ((size_t) (1 + size));
17856       ASSERT (a_to_c_string (p, vec[k], *(A68_REF *) elem) != NO_TEXT);
17857       if (k == VECTOR_SIZE - 1) {
17858         diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_TOO_MANY_ARGUMENTS);
17859         exit_genie (p, A68_RUNTIME_ERROR);
17860       }
17861       if (strlen (vec[k]) > 0) {
17862         k++;
17863       }
17864       done = increment_internal_index (tup, DIM (arr));
17865     }
17866   }
17867   vec[k] = NO_TEXT;
17868 }
17869 
17870 /**
17871 @brief Free char *vec[].
17872 @param vec String vector.
17873 **/
17874 
17875 static void
free_vector(char * vec[])17876 free_vector (char *vec[])
17877 {
17878   int k = 0;
17879   while (vec[k] != NO_TEXT) {
17880     free (vec[k]);
17881     k++;
17882   }
17883 }
17884 
17885 /**
17886 @brief Reset error number.
17887 @param p Node in syntax tree.
17888 **/
17889 
17890 void
genie_reset_errno(NODE_T * p)17891 genie_reset_errno (NODE_T * p)
17892 {
17893   (void) *p;
17894   RESET_ERRNO;
17895 }
17896 
17897 /**
17898 @brief Error number.
17899 @param p Node in syntax tree.
17900 **/
17901 
17902 void
genie_errno(NODE_T * p)17903 genie_errno (NODE_T * p)
17904 {
17905   PUSH_PRIMITIVE (p, errno, A68_INT);
17906 }
17907 
17908 /**
17909 @brief PROC strerror = (INT) STRING
17910 @param p Node in syntax tree.
17911 **/
17912 
17913 void
genie_strerror(NODE_T * p)17914 genie_strerror (NODE_T * p)
17915 {
17916   A68_INT i;
17917   POP_OBJECT (p, &i, A68_INT);
17918   PUSH_REF (p, c_to_a_string (p, strerror (VALUE (&i)), DEFAULT_WIDTH));
17919 }
17920 
17921 /**
17922 @brief Set up file for usage in pipe.
17923 @param p Node in syntax tree.
17924 @param z Pointer to file.
17925 @param fd File number.
17926 @param chan Channel.
17927 @param r_mood Read mood.
17928 @param w_mood Write mood.
17929 @param pid Pid.
17930 **/
17931 
17932 static void
set_up_file(NODE_T * p,A68_REF * z,int fd,A68_CHANNEL chan,BOOL_T r_mood,BOOL_T w_mood,int pid)17933 set_up_file (NODE_T * p, A68_REF * z, int fd, A68_CHANNEL chan, BOOL_T r_mood, BOOL_T w_mood, int pid)
17934 {
17935   A68_FILE *f;
17936   *z = heap_generator (p, MODE (REF_FILE), SIZE (MODE (FILE)));
17937   f = FILE_DEREF (z);
17938   STATUS (f) = (STATUS_MASK) ((pid < 0) ? 0 : INIT_MASK);
17939   IDENTIFICATION (f) = nil_ref;
17940   TERMINATOR (f) = nil_ref;
17941   CHANNEL (f) = chan;
17942   FD (f) = fd;
17943   STREAM (&DEVICE (f)) = NO_STREAM;
17944   OPENED (f) = A68_TRUE;
17945   OPEN_EXCLUSIVE (f) = A68_FALSE;
17946   READ_MOOD (f) = r_mood;
17947   WRITE_MOOD (f) = w_mood;
17948   CHAR_MOOD (f) = A68_TRUE;
17949   DRAW_MOOD (f) = A68_FALSE;
17950   FORMAT (f) = nil_format;
17951   TRANSPUT_BUFFER (f) = get_unblocked_transput_buffer (p);
17952   STRING (f) = nil_ref;
17953   reset_transput_buffer (TRANSPUT_BUFFER (f));
17954   set_default_event_procedures (f);
17955 }
17956 
17957 /**
17958 @brief Create and push a pipe.
17959 @param p Node in syntax tree.
17960 @param fd_r Read file number.
17961 @param fd_w Write file number.
17962 @param pid Pid.
17963 **/
17964 
17965 static void
genie_mkpipe(NODE_T * p,int fd_r,int fd_w,int pid)17966 genie_mkpipe (NODE_T * p, int fd_r, int fd_w, int pid)
17967 {
17968   A68_REF r, w;
17969   RESET_ERRNO;
17970 /* Set up pipe */
17971   set_up_file (p, &r, fd_r, stand_in_channel, A68_TRUE, A68_FALSE, pid);
17972   set_up_file (p, &w, fd_w, stand_out_channel, A68_FALSE, A68_TRUE, pid);
17973 /* push pipe */
17974   PUSH_REF (p, r);
17975   PUSH_REF (p, w);
17976   PUSH_PRIMITIVE (p, pid, A68_INT);
17977 }
17978 
17979 /**
17980 @brief Push an environment string.
17981 @param p Node in syntax tree.
17982 **/
17983 
17984 void
genie_getenv(NODE_T * p)17985 genie_getenv (NODE_T * p)
17986 {
17987   A68_REF a_env;
17988   char *val, *z, *z_env;
17989   RESET_ERRNO;
17990   POP_REF (p, &a_env);
17991   CHECK_INIT (p, INITIALISED (&a_env), MODE (STRING));
17992   z_env = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_env)));
17993   z = a_to_c_string (p, z_env, a_env);
17994   val = getenv (z);
17995   if (val == NO_TEXT) {
17996     a_env = empty_string (p);
17997   } else {
17998     a_env = tmp_to_a68_string (p, val);
17999   }
18000   PUSH_REF (p, a_env);
18001 }
18002 
18003 /**
18004 @brief PROC fork = INT
18005 @param p Node in syntax tree.
18006 **/
18007 
18008 void
genie_fork(NODE_T * p)18009 genie_fork (NODE_T * p)
18010 {
18011 #if defined HAVE_WIN32
18012   PUSH_PRIMITIVE (p, -1, A68_INT);
18013 #else
18014   int pid;
18015   RESET_ERRNO;
18016   pid = (int) fork ();
18017   PUSH_PRIMITIVE (p, pid, A68_INT);
18018 #endif
18019 }
18020 
18021 /**
18022 @brief PROC execve = (STRING, [] STRING, [] STRING) INT
18023 @param p Node in syntax tree.
18024 **/
18025 
18026 void
genie_execve(NODE_T * p)18027 genie_execve (NODE_T * p)
18028 {
18029   int ret;
18030   A68_REF a_prog, a_args, a_env;
18031   char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE];
18032   RESET_ERRNO;
18033 /* Pop parameters */
18034   POP_REF (p, &a_env);
18035   POP_REF (p, &a_args);
18036   POP_REF (p, &a_prog);
18037 /* Convert strings and hasta el infinito */
18038   prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog)));
18039   ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT);
18040   convert_string_vector (p, argv, a_args);
18041   convert_string_vector (p, envp, a_env);
18042   if (argv[0] == NO_TEXT) {
18043     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT);
18044     exit_genie (p, A68_RUNTIME_ERROR);
18045   }
18046 #if defined HAVE_WIN32
18047   ret = execve (prog, (const char *const *) argv, (const char *const *) envp);
18048 #else
18049   ret = execve (prog, argv, envp);
18050 #endif
18051 /* execve only returns if it fails */
18052   free_vector (argv);
18053   free_vector (envp);
18054   free (prog);
18055   PUSH_PRIMITIVE (p, ret, A68_INT);
18056 }
18057 
18058 /**
18059 @brief PROC execve child = (STRING, [] STRING, [] STRING) INT
18060 @param p Node in syntax tree.
18061 **/
18062 
18063 void
genie_execve_child(NODE_T * p)18064 genie_execve_child (NODE_T * p)
18065 {
18066   int pid;
18067   A68_REF a_prog, a_args, a_env;
18068   RESET_ERRNO;
18069 /* Pop parameters */
18070   POP_REF (p, &a_env);
18071   POP_REF (p, &a_args);
18072   POP_REF (p, &a_prog);
18073 /* Now create the pipes and fork */
18074 #if defined HAVE_WIN32
18075   pid = -1;
18076   PUSH_PRIMITIVE (p, -1, A68_INT);
18077   return;
18078 #else
18079   pid = (int) fork ();
18080   if (pid == -1) {
18081     PUSH_PRIMITIVE (p, -1, A68_INT);
18082   } else if (pid == 0) {
18083 /* Child process */
18084     char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE];
18085 /* Convert  strings */
18086     prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog)));
18087     ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT);
18088     convert_string_vector (p, argv, a_args);
18089     convert_string_vector (p, envp, a_env);
18090     if (argv[0] == NO_TEXT) {
18091       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT);
18092       exit_genie (p, A68_RUNTIME_ERROR);
18093     }
18094     (void) execve (prog, argv, envp);
18095 /* execve only returns if it fails - end child process */
18096     a68g_exit (EXIT_FAILURE);
18097     PUSH_PRIMITIVE (p, 0, A68_INT);
18098   } else {
18099 /* parent process */
18100     PUSH_PRIMITIVE (p, pid, A68_INT);
18101   }
18102 #endif /* defined HAVE_WIN32 */
18103 }
18104 
18105 /**
18106 @brief PROC execve child pipe = (STRING, [] STRING, [] STRING) PIPE
18107 @param p Node in syntax tree.
18108 **/
18109 
18110 void
genie_execve_child_pipe(NODE_T * p)18111 genie_execve_child_pipe (NODE_T * p)
18112 {
18113 /*
18114 Child redirects STDIN and STDOUT.
18115 Return a PIPE that contains the descriptors for the parent.
18116 
18117        pipe ptoc
18118        ->W...R->
18119  PARENT         CHILD
18120        <-R...W<-
18121        pipe ctop
18122 */
18123   int pid;
18124 #if ! defined HAVE_WIN32
18125   int ptoc_fd[2], ctop_fd[2];
18126 #endif /* ! defined HAVE_WIN32 */
18127   A68_REF a_prog, a_args, a_env;
18128   RESET_ERRNO;
18129 /* Pop parameters */
18130   POP_REF (p, &a_env);
18131   POP_REF (p, &a_args);
18132   POP_REF (p, &a_prog);
18133 #if defined HAVE_WIN32
18134   pid = -1;
18135   genie_mkpipe (p, -1, -1, -1);
18136   return;
18137 #else
18138 /* Create the pipes and fork */
18139   if ((pipe (ptoc_fd) == -1) || (pipe (ctop_fd) == -1)) {
18140     genie_mkpipe (p, -1, -1, -1);
18141     return;
18142   }
18143   pid = (int) fork ();
18144   if (pid == -1) {
18145 /* Fork failure */
18146     genie_mkpipe (p, -1, -1, -1);
18147     return;
18148   }
18149   if (pid == 0) {
18150 /* Child process */
18151     char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE];
18152 /* Convert  strings */
18153     prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog)));
18154     ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT);
18155     convert_string_vector (p, argv, a_args);
18156     convert_string_vector (p, envp, a_env);
18157 /* Set up redirection */
18158     ASSERT (close (ctop_fd[FD_READ]) == 0);
18159     ASSERT (close (ptoc_fd[FD_WRITE]) == 0);
18160     ASSERT (close (STDIN_FILENO) == 0);
18161     ASSERT (close (STDOUT_FILENO) == 0);
18162     ASSERT (dup2 (ptoc_fd[FD_READ], STDIN_FILENO) != -1);
18163     ASSERT (dup2 (ctop_fd[FD_WRITE], STDOUT_FILENO) != -1);
18164     if (argv[0] == NO_TEXT) {
18165       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT);
18166       exit_genie (p, A68_RUNTIME_ERROR);
18167     }
18168     (void) execve (prog, argv, envp);
18169 /* execve only returns if it fails - end child process */
18170     a68g_exit (EXIT_FAILURE);
18171     genie_mkpipe (p, -1, -1, -1);
18172   } else {
18173 /* Parent process */
18174     ASSERT (close (ptoc_fd[FD_READ]) == 0);
18175     ASSERT (close (ctop_fd[FD_WRITE]) == 0);
18176     genie_mkpipe (p, ctop_fd[FD_READ], ptoc_fd[FD_WRITE], pid);
18177   }
18178 #endif /* defined HAVE_WIN32 */
18179 }
18180 
18181 /**
18182 @brief PROC execve_output = (STRING, [] STRING, [] STRING, REF_STRING) INT
18183 @param p Node in syntax tree.
18184 **/
18185 
18186 void
genie_execve_output(NODE_T * p)18187 genie_execve_output (NODE_T * p)
18188 {
18189 /*
18190 Child redirects STDIN and STDOUT.
18191 
18192        pipe ptoc
18193        ->W...R->
18194  PARENT         CHILD
18195        <-R...W<-
18196        pipe ctop
18197 */
18198   int pid;
18199 #if ! defined HAVE_WIN32
18200   int ptoc_fd[2], ctop_fd[2];
18201 #endif /* ! defined HAVE_WIN32 */
18202   A68_REF a_prog, a_args, a_env, dest;
18203   RESET_ERRNO;
18204 /* Pop parameters */
18205   POP_REF (p, &dest);
18206   POP_REF (p, &a_env);
18207   POP_REF (p, &a_args);
18208   POP_REF (p, &a_prog);
18209 #if defined HAVE_WIN32
18210   pid = -1;
18211   PUSH_PRIMITIVE (p, -1, A68_INT);
18212   return;
18213 #else
18214 /* Create the pipes and fork */
18215   if ((pipe (ptoc_fd) == -1) || (pipe (ctop_fd) == -1)) {
18216     PUSH_PRIMITIVE (p, -1, A68_INT);
18217     return;
18218   }
18219   pid = (int) fork ();
18220   if (pid == -1) {
18221 /* Fork failure */
18222     PUSH_PRIMITIVE (p, -1, A68_INT);
18223     return;
18224   }
18225   if (pid == 0) {
18226 /* Child process */
18227     char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE];
18228 /* Convert  strings */
18229     prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog)));
18230     ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT);
18231     convert_string_vector (p, argv, a_args);
18232     convert_string_vector (p, envp, a_env);
18233 /* Set up redirection */
18234     ASSERT (close (ctop_fd[FD_READ]) == 0);
18235     ASSERT (close (ptoc_fd[FD_WRITE]) == 0);
18236     ASSERT (close (STDIN_FILENO) == 0);
18237     ASSERT (close (STDOUT_FILENO) == 0);
18238     ASSERT (dup2 (ptoc_fd[FD_READ], STDIN_FILENO) != -1);
18239     ASSERT (dup2 (ctop_fd[FD_WRITE], STDOUT_FILENO) != -1);
18240     if (argv[0] == NO_TEXT) {
18241       diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT);
18242       exit_genie (p, A68_RUNTIME_ERROR);
18243     }
18244     (void) execve (prog, argv, envp);
18245 /* execve only returns if it fails - end child process */
18246     a68g_exit (EXIT_FAILURE);
18247     PUSH_PRIMITIVE (p, -1, A68_INT);
18248   } else {
18249 /* Parent process */
18250     char ch;
18251     int pipe_read, ret, status;
18252     ASSERT (close (ptoc_fd[FD_READ]) == 0);
18253     ASSERT (close (ctop_fd[FD_WRITE]) == 0);
18254     reset_transput_buffer (INPUT_BUFFER);
18255     do {
18256       pipe_read = (int) io_read_conv (ctop_fd[FD_READ], &ch, 1);
18257       if (pipe_read > 0) {
18258         add_char_transput_buffer (p, INPUT_BUFFER, ch);
18259       }
18260     } while (pipe_read > 0);
18261     do {
18262       ret = (int) waitpid ((a68g_pid_t) pid, &status, 0);
18263     } while (ret == -1 && errno == EINTR);
18264     if (ret != pid) {
18265       status = -1;
18266     }
18267     if (!IS_NIL (dest)) {
18268       *DEREF (A68_REF, &dest) = c_to_a_string (p, get_transput_buffer (INPUT_BUFFER), get_transput_buffer_index (INPUT_BUFFER));
18269     }
18270     ASSERT (close (ptoc_fd[FD_WRITE]) == 0);
18271     ASSERT (close (ctop_fd[FD_READ]) == 0);
18272     PUSH_PRIMITIVE (p, ret, A68_INT);
18273   }
18274 #endif /* defined HAVE_WIN32 */
18275 }
18276 
18277 /**
18278 @brief PROC create pipe = PIPE
18279 @param p Node in syntax tree.
18280 **/
18281 
18282 void
genie_create_pipe(NODE_T * p)18283 genie_create_pipe (NODE_T * p)
18284 {
18285   RESET_ERRNO;
18286   genie_stand_in (p);
18287   genie_stand_out (p);
18288   PUSH_PRIMITIVE (p, -1, A68_INT);
18289 }
18290 
18291 /**
18292 @brief PROC wait pid = (INT) VOID
18293 @param p Node in syntax tree.
18294 **/
18295 
18296 void
genie_waitpid(NODE_T * p)18297 genie_waitpid (NODE_T * p)
18298 {
18299   A68_INT k;
18300   RESET_ERRNO;
18301   POP_OBJECT (p, &k, A68_INT);
18302 #if ! defined HAVE_WIN32
18303   ASSERT (waitpid ((a68g_pid_t) VALUE (&k), NULL, 0) != -1);
18304 #endif
18305 }
18306 
18307 /*
18308 Next part contains some routines that interface Algol68G and the curses library.
18309 Be sure to know what you are doing when you use this, but on the other hand,
18310 "reset" will always restore your terminal.
18311 */
18312 
18313 #if defined HAVE_CURSES
18314 
18315 #define CHECK_CURSES_RETVAL(f) {\
18316   if (!(f)) {\
18317     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CURSES);\
18318     exit_genie (p, A68_RUNTIME_ERROR);\
18319   }}
18320 
18321 BOOL_T a68g_curses_mode = A68_FALSE;
18322 
18323 /**
18324 @brief Clean_curses.
18325 **/
18326 
18327 void
clean_curses(void)18328 clean_curses (void)
18329 {
18330   if (a68g_curses_mode == A68_TRUE) {
18331     (void) wattrset (stdscr, A_NORMAL);
18332     (void) endwin ();
18333     a68g_curses_mode = A68_FALSE;
18334   }
18335 }
18336 
18337 /**
18338 @brief Init_curses.
18339 **/
18340 
18341 void
init_curses(void)18342 init_curses (void)
18343 {
18344   (void) initscr ();
18345   (void) cbreak ();             /* raw () would cut off ctrl-c */
18346   (void) noecho ();
18347   (void) nonl ();
18348   (void) curs_set (0);
18349   if (has_colors ()) {
18350     (void) start_color ();
18351   }
18352 }
18353 
18354 /**
18355 @brief Watch stdin for input, do not wait very long.
18356 @return Character read.
18357 **/
18358 
18359 int
rgetchar(void)18360 rgetchar (void)
18361 {
18362 #if defined HAVE_WIN32
18363   if (kbhit ()) {
18364     return (getch ());
18365   } else {
18366     return (NULL_CHAR);
18367   }
18368 #else
18369   int retval;
18370   struct timeval tv;
18371   fd_set rfds;
18372   TV_SEC (&tv) = 0;
18373   TV_USEC (&tv) = 100;
18374   FD_ZERO (&rfds);
18375   FD_SET (0, &rfds);
18376   retval = select (1, &rfds, NULL, NULL, &tv);
18377   if (retval) {
18378     /* FD_ISSET(0, &rfds) will be true.  */
18379     return (getch ());
18380   } else {
18381     return (NULL_CHAR);
18382   }
18383 #endif
18384 }
18385 
18386 /**
18387 @brief PROC curses start = VOID
18388 @param p Node in syntax tree.
18389 **/
18390 
18391 void
genie_curses_start(NODE_T * p)18392 genie_curses_start (NODE_T * p)
18393 {
18394   (void) p;
18395   init_curses ();
18396   a68g_curses_mode = A68_TRUE;
18397 }
18398 
18399 /**
18400 @brief PROC curses end = VOID
18401 @param p Node in syntax tree.
18402 **/
18403 
18404 void
genie_curses_end(NODE_T * p)18405 genie_curses_end (NODE_T * p)
18406 {
18407   (void) p;
18408   clean_curses ();
18409 }
18410 
18411 /**
18412 @brief PROC curses clear = VOID
18413 @param p Node in syntax tree.
18414 **/
18415 
18416 void
genie_curses_clear(NODE_T * p)18417 genie_curses_clear (NODE_T * p)
18418 {
18419   if (a68g_curses_mode == A68_FALSE) {
18420     genie_curses_start (p);
18421   }
18422   CHECK_CURSES_RETVAL (clear () != ERR);
18423 }
18424 
18425 /**
18426 @brief PROC curses refresh = VOID
18427 @param p Node in syntax tree.
18428 **/
18429 
18430 void
genie_curses_refresh(NODE_T * p)18431 genie_curses_refresh (NODE_T * p)
18432 {
18433   if (a68g_curses_mode == A68_FALSE) {
18434     genie_curses_start (p);
18435   }
18436   CHECK_CURSES_RETVAL (refresh () != ERR);
18437 }
18438 
18439 /**
18440 @brief PROC curses lines = INT
18441 @param p Node in syntax tree.
18442 **/
18443 
18444 void
genie_curses_lines(NODE_T * p)18445 genie_curses_lines (NODE_T * p)
18446 {
18447   if (a68g_curses_mode == A68_FALSE) {
18448     genie_curses_start (p);
18449   }
18450   PUSH_PRIMITIVE (p, LINES, A68_INT);
18451 }
18452 
18453 /**
18454 @brief PROC curses columns = INT
18455 @param p Node in syntax tree.
18456 **/
18457 
18458 void
genie_curses_columns(NODE_T * p)18459 genie_curses_columns (NODE_T * p)
18460 {
18461   if (a68g_curses_mode == A68_FALSE) {
18462     genie_curses_start (p);
18463   }
18464   PUSH_PRIMITIVE (p, COLS, A68_INT);
18465 }
18466 
18467 /**
18468 @brief PROC curses getchar = CHAR
18469 @param p Node in syntax tree.
18470 **/
18471 
18472 void
genie_curses_getchar(NODE_T * p)18473 genie_curses_getchar (NODE_T * p)
18474 {
18475   if (a68g_curses_mode == A68_FALSE) {
18476     genie_curses_start (p);
18477   }
18478   PUSH_PRIMITIVE (p, (char) rgetchar (), A68_CHAR);
18479 }
18480 
18481 
18482 /*
18483 @brief PROC curses colour = VOID
18484 @param p Node in syntax tree.
18485 */
18486 
18487 #define GENIE_COLOUR(f, n, fg, bg)\
18488 void f (NODE_T *p) {\
18489   (void) p;\
18490   if ((n) < COLOR_PAIRS) {\
18491     (void) init_pair (n, (fg), (bg));\
18492     wattrset (stdscr, COLOR_PAIR ((n)) | A_BOLD);\
18493   }\
18494 }\
18495 void f##_inverse (NODE_T *p) {\
18496   (void) p;\
18497   if ((n + 8) < COLOR_PAIRS) {\
18498     (void) init_pair ((n) + 8, (bg), (fg));\
18499     wattrset (stdscr, COLOR_PAIR (((n) + 8)));\
18500   }\
18501 }
18502 
18503 GENIE_COLOUR (genie_curses_blue, 1, COLOR_BLUE, COLOR_BLACK)
18504   GENIE_COLOUR (genie_curses_cyan, 2, COLOR_CYAN, COLOR_BLACK)
18505   GENIE_COLOUR (genie_curses_green, 3, COLOR_GREEN, COLOR_BLACK)
18506   GENIE_COLOUR (genie_curses_magenta, 4, COLOR_MAGENTA, COLOR_BLACK)
18507   GENIE_COLOUR (genie_curses_red, 5, COLOR_RED, COLOR_BLACK)
18508   GENIE_COLOUR (genie_curses_white, 6, COLOR_WHITE, COLOR_BLACK)
18509   GENIE_COLOUR (genie_curses_yellow, 7, COLOR_YELLOW, COLOR_BLACK)
18510 
18511 /**
18512 @brief PROC curses delchar = (CHAR) BOOL
18513 @param p Node in syntax tree.
18514 **/
genie_curses_del_char(NODE_T * p)18515      void genie_curses_del_char (NODE_T * p)
18516 {
18517   A68_CHAR ch;
18518   int v;
18519   POP_OBJECT (p, &ch, A68_CHAR);
18520   v = (int) VALUE (&ch);
18521   PUSH_PRIMITIVE (p, (BOOL_T) (v == 8 || v == 127 || v == KEY_BACKSPACE), A68_BOOL);
18522 }
18523 
18524 /**
18525 @brief PROC curses putchar = (CHAR) VOID
18526 @param p Node in syntax tree.
18527 **/
18528 
18529 void
genie_curses_putchar(NODE_T * p)18530 genie_curses_putchar (NODE_T * p)
18531 {
18532   A68_CHAR ch;
18533   if (a68g_curses_mode == A68_FALSE) {
18534     genie_curses_start (p);
18535   }
18536   POP_OBJECT (p, &ch, A68_CHAR);
18537   (void) (addch ((chtype) (VALUE (&ch))));
18538 /*
18539   if (addch ((chtype) (VALUE (&ch))) == ERR) {
18540     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CURSES_OFF_SCREEN);
18541     exit_genie (p, A68_RUNTIME_ERROR);
18542   }
18543 */
18544 }
18545 
18546 /**
18547 @brief PROC curses move = (INT, INT) VOID
18548 @param p Node in syntax tree.
18549 **/
18550 
18551 void
genie_curses_move(NODE_T * p)18552 genie_curses_move (NODE_T * p)
18553 {
18554   A68_INT i, j;
18555   if (a68g_curses_mode == A68_FALSE) {
18556     genie_curses_start (p);
18557   }
18558   POP_OBJECT (p, &j, A68_INT);
18559   POP_OBJECT (p, &i, A68_INT);
18560   if (VALUE (&i) < 0 || VALUE (&i) >= LINES) {
18561     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CURSES_OFF_SCREEN);
18562     exit_genie (p, A68_RUNTIME_ERROR);
18563   }
18564   if (VALUE (&j) < 0 || VALUE (&j) >= COLS) {
18565     diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CURSES_OFF_SCREEN);
18566     exit_genie (p, A68_RUNTIME_ERROR);
18567   }
18568   CHECK_CURSES_RETVAL (move (VALUE (&i), VALUE (&j)) != ERR);
18569 }
18570 
18571 #endif /* HAVE_CURSES */
18572 
18573 #if defined HAVE_REGEX_H
18574 /**
18575 @brief Return code for regex interface.
18576 @param p Position in syntax tree.
18577 @param rc Return code from regex routine.
18578 @return 0: match, 1: no match, 2: no core, 3: other error
18579 **/
18580 
18581 void
push_grep_rc(NODE_T * p,int rc)18582 push_grep_rc (NODE_T * p, int rc)
18583 {
18584   switch (rc) {
18585   case 0:
18586     {
18587       PUSH_PRIMITIVE (p, 0, A68_INT);
18588       return;
18589     }
18590   case REG_NOMATCH:
18591     {
18592       PUSH_PRIMITIVE (p, 1, A68_INT);
18593       return;
18594     }
18595   case REG_ESPACE:
18596     {
18597       PUSH_PRIMITIVE (p, 3, A68_INT);
18598       return;
18599     }
18600   default:
18601     {
18602       PUSH_PRIMITIVE (p, 2, A68_INT);
18603       return;
18604     }
18605   }
18606 }
18607 
18608 /**
18609 @brief PROC grep in string = (STRING, STRING, REF INT, REF INT) INT
18610 @param p Node in syntax tree.
18611 @return 0: match, 1: no match, 2: no core, 3: other error
18612 **/
18613 
18614 void
genie_grep_in_string(NODE_T * p)18615 genie_grep_in_string (NODE_T * p)
18616 {
18617   A68_REF ref_pat, ref_beg, ref_end, ref_str, row;
18618   A68_ARRAY *arr;
18619   A68_TUPLE *tup;
18620   int rc, nmatch, k, max_k, widest;
18621   regex_t compiled;
18622   regmatch_t *matches;
18623   POP_REF (p, &ref_end);
18624   POP_REF (p, &ref_beg);
18625   POP_REF (p, &ref_str);
18626   POP_REF (p, &ref_pat);
18627   row = *(A68_REF *) & ref_str;
18628   CHECK_INIT (p, INITIALISED (&row), MODE (ROWS));
18629   GET_DESCRIPTOR (arr, tup, &row);
18630   reset_transput_buffer (PATTERN_BUFFER);
18631   reset_transput_buffer (STRING_BUFFER);
18632   add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_pat);
18633   add_a_string_transput_buffer (p, STRING_BUFFER, (BYTE_T *) & ref_str);
18634   rc = regcomp (&compiled, get_transput_buffer (PATTERN_BUFFER), REG_NEWLINE | REG_EXTENDED);
18635   if (rc != 0) {
18636     push_grep_rc (p, rc);
18637     regfree (&compiled);
18638     return;
18639   }
18640   nmatch = (int) (RE_NSUB (&compiled));
18641   if (nmatch == 0) {
18642     nmatch = 1;
18643   }
18644   matches = malloc ((size_t) (nmatch * SIZE_AL (regmatch_t)));
18645   if (nmatch > 0 && matches == NULL) {
18646     rc = 2;
18647     PUSH_PRIMITIVE (p, rc, A68_INT);
18648     regfree (&compiled);
18649     return;
18650   }
18651   rc = regexec (&compiled, get_transput_buffer (STRING_BUFFER), (size_t) nmatch, matches, 0);
18652   if (rc != 0) {
18653     push_grep_rc (p, rc);
18654     regfree (&compiled);
18655     return;
18656   }
18657 /* Find widest match. Do not assume it is the first one */
18658   widest = 0;
18659   max_k = 0;
18660   for (k = 0; k < nmatch; k++) {
18661     int dif = (int) (RM_EO (&(matches[k]))) - (int) (RM_SO (&(matches[k])));
18662     if (dif > widest) {
18663       widest = dif;
18664       max_k = k;
18665     }
18666   }
18667   if (!IS_NIL (ref_beg)) {
18668     A68_INT *i = DEREF (A68_INT, &ref_beg);
18669     STATUS (i) = INIT_MASK;
18670     VALUE (i) = (int) (RM_SO (&(matches[max_k]))) + (int) (LOWER_BOUND (tup));
18671   }
18672   if (!IS_NIL (ref_end)) {
18673     A68_INT *i = DEREF (A68_INT, &ref_end);
18674     STATUS (i) = INIT_MASK;
18675     VALUE (i) = (int) (RM_EO (&(matches[max_k]))) + (int) (LOWER_BOUND (tup)) - 1;
18676   }
18677   free (matches);
18678   push_grep_rc (p, 0);
18679 }
18680 
18681 /**
18682 @brief PROC grep in substring = (STRING, STRING, REF INT, REF INT) INT
18683 @param p Node in syntax tree.
18684 @return 0: match, 1: no match, 2: no core, 3: other error
18685 **/
18686 
18687 void
genie_grep_in_substring(NODE_T * p)18688 genie_grep_in_substring (NODE_T * p)
18689 {
18690   A68_REF ref_pat, ref_beg, ref_end, ref_str, row;
18691   A68_ARRAY *arr;
18692   A68_TUPLE *tup;
18693   int rc, nmatch, k, max_k, widest;
18694   regex_t compiled;
18695   regmatch_t *matches;
18696   POP_REF (p, &ref_end);
18697   POP_REF (p, &ref_beg);
18698   POP_REF (p, &ref_str);
18699   POP_REF (p, &ref_pat);
18700   row = *(A68_REF *) & ref_str;
18701   CHECK_INIT (p, INITIALISED (&row), MODE (ROWS));
18702   GET_DESCRIPTOR (arr, tup, &row);
18703   reset_transput_buffer (PATTERN_BUFFER);
18704   reset_transput_buffer (STRING_BUFFER);
18705   add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_pat);
18706   add_a_string_transput_buffer (p, STRING_BUFFER, (BYTE_T *) & ref_str);
18707   rc = regcomp (&compiled, get_transput_buffer (PATTERN_BUFFER), REG_NEWLINE | REG_EXTENDED);
18708   if (rc != 0) {
18709     push_grep_rc (p, rc);
18710     regfree (&compiled);
18711     return;
18712   }
18713   nmatch = (int) (RE_NSUB (&compiled));
18714   if (nmatch == 0) {
18715     nmatch = 1;
18716   }
18717   matches = malloc ((size_t) (nmatch * SIZE_AL (regmatch_t)));
18718   if (nmatch > 0 && matches == NULL) {
18719     rc = 2;
18720     PUSH_PRIMITIVE (p, rc, A68_INT);
18721     regfree (&compiled);
18722     return;
18723   }
18724   rc = regexec (&compiled, get_transput_buffer (STRING_BUFFER), (size_t) nmatch, matches, REG_NOTBOL);
18725   if (rc != 0) {
18726     push_grep_rc (p, rc);
18727     regfree (&compiled);
18728     return;
18729   }
18730 /* Find widest match. Do not assume it is the first one */
18731   widest = 0;
18732   max_k = 0;
18733   for (k = 0; k < nmatch; k++) {
18734     int dif = (int) (RM_EO (&(matches[k]))) - (int) (RM_SO (&(matches[k])));
18735     if (dif > widest) {
18736       widest = dif;
18737       max_k = k;
18738     }
18739   }
18740   if (!IS_NIL (ref_beg)) {
18741     A68_INT *i = DEREF (A68_INT, &ref_beg);
18742     STATUS (i) = INIT_MASK;
18743     VALUE (i) = (int) (RM_SO (&(matches[max_k]))) + (int) (LOWER_BOUND (tup));
18744   }
18745   if (!IS_NIL (ref_end)) {
18746     A68_INT *i = DEREF (A68_INT, &ref_end);
18747     STATUS (i) = INIT_MASK;
18748     VALUE (i) = (int) (RM_EO (&(matches[max_k]))) + (int) (LOWER_BOUND (tup)) - 1;
18749   }
18750   free (matches);
18751   push_grep_rc (p, 0);
18752 }
18753 
18754 /**
18755 @brief PROC sub in string = (STRING, STRING, REF STRING) INT
18756 @param p Node in syntax tree.
18757 @return 0: match, 1: no match, 2: no core, 3: other error
18758 **/
18759 
18760 void
genie_sub_in_string(NODE_T * p)18761 genie_sub_in_string (NODE_T * p)
18762 {
18763   A68_REF ref_pat, ref_rep, ref_str;
18764   int rc, nmatch, k, max_k, widest, begin, end;
18765   char *txt;
18766   regex_t compiled;
18767   regmatch_t *matches;
18768   POP_REF (p, &ref_str);
18769   POP_REF (p, &ref_rep);
18770   POP_REF (p, &ref_pat);
18771   if (IS_NIL (ref_str)) {
18772     PUSH_PRIMITIVE (p, 3, A68_INT);
18773     return;
18774   }
18775   reset_transput_buffer (STRING_BUFFER);
18776   reset_transput_buffer (REPLACE_BUFFER);
18777   reset_transput_buffer (PATTERN_BUFFER);
18778   add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_pat);
18779   add_a_string_transput_buffer (p, STRING_BUFFER, (BYTE_T *) DEREF (A68_REF, &ref_str));
18780   rc = regcomp (&compiled, get_transput_buffer (PATTERN_BUFFER), REG_NEWLINE | REG_EXTENDED);
18781   if (rc != 0) {
18782     push_grep_rc (p, rc);
18783     regfree (&compiled);
18784     return;
18785   }
18786   nmatch = (int) (RE_NSUB (&compiled));
18787   if (nmatch == 0) {
18788     nmatch = 1;
18789   }
18790   matches = malloc ((size_t) (nmatch * SIZE_AL (regmatch_t)));
18791   if (nmatch > 0 && matches == NULL) {
18792     PUSH_PRIMITIVE (p, rc, A68_INT);
18793     regfree (&compiled);
18794     return;
18795   }
18796   rc = regexec (&compiled, get_transput_buffer (STRING_BUFFER), (size_t) nmatch, matches, 0);
18797   if (rc != 0) {
18798     push_grep_rc (p, rc);
18799     regfree (&compiled);
18800     return;
18801   }
18802 /* Find widest match. Do not assume it is the first one */
18803   widest = 0;
18804   max_k = 0;
18805   for (k = 0; k < nmatch; k++) {
18806     int dif = (int) RM_EO (&(matches[k])) - (int) RM_SO (&(matches[k]));
18807     if (dif > widest) {
18808       widest = dif;
18809       max_k = k;
18810     }
18811   }
18812   begin = (int) RM_SO (&(matches[max_k])) + 1;
18813   end = (int) RM_EO (&(matches[max_k]));
18814 /* Substitute text */
18815   txt = get_transput_buffer (STRING_BUFFER);
18816   for (k = 0; k < begin - 1; k++) {
18817     add_char_transput_buffer (p, REPLACE_BUFFER, txt[k]);
18818   }
18819   add_a_string_transput_buffer (p, REPLACE_BUFFER, (BYTE_T *) & ref_rep);
18820   for (k = end; k < get_transput_buffer_size (STRING_BUFFER); k++) {
18821     add_char_transput_buffer (p, REPLACE_BUFFER, txt[k]);
18822   }
18823   *DEREF (A68_REF, &ref_str) = c_to_a_string (p, get_transput_buffer (REPLACE_BUFFER), DEFAULT_WIDTH);
18824   free (matches);
18825   push_grep_rc (p, 0);
18826 }
18827 
18828 #endif /* HAVE_REGEX_H */
18829