single-torrix.c
You can download the current version of Algol 68 Genie and its documentation here.
1 //! @file single-torrix.c
2 //! @author J. Marcel van der Veer
3 //!
4 //! @section Copyright
5 //!
6 //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
7 //! Copyright 2001-2023 J. Marcel van der Veer .
8 //!
9 //! @section License
10 //!
11 //! This program is free software; you can redistribute it and/or modify it
12 //! under the terms of the GNU General Public License as published by the
13 //! Free Software Foundation; either version 3 of the License, or
14 //! (at your option) any later version.
15 //!
16 //! This program is distributed in the hope that it will be useful, but
17 //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 //! more details. You should have received a copy of the GNU General Public
20 //! License along with this program. If not, see .
21
22 //! @section Synopsis
23 //!
24 //! REAL vector and matrix support.
25
26 #include "a68g.h"
27 #include "a68g-torrix.h"
28
29 //! @brief Push description for diagonal of square matrix.
30
31 PROP_T genie_diagonal_function (NODE_T * p)
32 {
33 NODE_T *q = SUB (p);
34 BOOL_T name = (BOOL_T) (IS_REF (MOID (p)));
35 int k = 0;
36 if (IS (q, TERTIARY)) {
37 A68_INT x;
38 EXECUTE_UNIT (q);
39 POP_OBJECT (p, &x, A68_INT);
40 k = VALUE (&x);
41 FORWARD (q);
42 }
43 EXECUTE_UNIT (NEXT (q));
44 MOID_T *m = (name ? SUB_MOID (NEXT (q)) : MOID (NEXT (q)));
45 ADDR_T scope = PRIMAL_SCOPE;
46 if (name) {
47 A68_REF z;
48 POP_REF (p, &z);
49 CHECK_REF (p, z, MOID (SUB (p)));
50 scope = REF_SCOPE (&z);
51 PUSH_REF (p, *DEREF (A68_REF, &z));
52 }
53 A68_ROW row; A68_ARRAY *arr; A68_TUPLE *tup1, *tup2;
54 POP_OBJECT (p, &row, A68_ROW);
55 GET_DESCRIPTOR2 (arr, tup1, tup2, &row);
56 if (ROW_SIZE (tup1) != ROW_SIZE (tup2)) {
57 diagnostic (A68_RUNTIME_ERROR, p, ERROR_NO_SQUARE_MATRIX, m);
58 exit_genie (p, A68_RUNTIME_ERROR);
59 }
60 if (ABS (k) >= ROW_SIZE (tup1)) {
61 diagnostic (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS);
62 exit_genie (p, A68_RUNTIME_ERROR);
63 }
64 m = (name ? SUB_MOID (p) : MOID (p));
65 A68_ROW new_row = heap_generator (p, m, DESCRIPTOR_SIZE (1));
66 A68_ARRAY new_arr;
67 DIM (&new_arr) = 1;
68 MOID (&new_arr) = m;
69 ELEM_SIZE (&new_arr) = ELEM_SIZE (arr);
70 SLICE_OFFSET (&new_arr) = SLICE_OFFSET (arr);
71 FIELD_OFFSET (&new_arr) = FIELD_OFFSET (arr);
72 ARRAY (&new_arr) = ARRAY (arr);
73 A68_TUPLE new_tup;
74 LWB (&new_tup) = 1;
75 UPB (&new_tup) = ROW_SIZE (tup1) - ABS (k);
76 SHIFT (&new_tup) = SHIFT (tup1) + SHIFT (tup2) - k * SPAN (tup2);
77 if (k < 0) {
78 SHIFT (&new_tup) -= (-k) * (SPAN (tup1) + SPAN (tup2));
79 }
80 SPAN (&new_tup) = SPAN (tup1) + SPAN (tup2);
81 K (&new_tup) = 0;
82 PUT_DESCRIPTOR (new_arr, new_tup, &new_row);
83 if (name) {
84 A68_REF ref_new = heap_generator (p, MOID (p), A68_REF_SIZE);
85 *DEREF (A68_REF, &ref_new) = new_row;
86 REF_SCOPE (&ref_new) = scope;
87 PUSH_REF (p, ref_new);
88 } else {
89 PUSH_OBJECT (p, new_row, A68_ROW);
90 }
91 PROP_T self;
92 UNIT (&self) = genie_diagonal_function;
93 SOURCE (&self) = p;
94 return self;
95 }
96
97 //! @brief Push description for transpose of matrix.
98
99 PROP_T genie_transpose_function (NODE_T * p)
100 {
101 NODE_T *q = SUB (p);
102 BOOL_T name = (BOOL_T) (IS_REF (MOID (p)));
103 MOID_T *m = (name ? SUB_MOID (NEXT (q)) : MOID (NEXT (q)));
104 EXECUTE_UNIT (NEXT (q));
105 ADDR_T scope = PRIMAL_SCOPE;
106 if (name) {
107 A68_REF z;
108 POP_REF (p, &z);
109 CHECK_REF (p, z, MOID (SUB (p)));
110 scope = REF_SCOPE (&z);
111 PUSH_REF (p, *DEREF (A68_REF, &z));
112 }
113 A68_ROW row; A68_ARRAY *arr; A68_TUPLE *tup1, *tup2;
114 POP_OBJECT (p, &row, A68_ROW);
115 GET_DESCRIPTOR2 (arr, tup1, tup2, &row);
116 A68_ROW new_row = heap_generator (p, m, DESCRIPTOR_SIZE (2));
117 A68_ARRAY new_arr = *arr;
118 A68_TUPLE new_tup1 = *tup2, new_tup2 = *tup1;
119 PUT_DESCRIPTOR2 (new_arr, new_tup1, new_tup2, &new_row);
120 if (name) {
121 A68_REF ref_new = heap_generator (p, MOID (p), A68_REF_SIZE);
122 *DEREF (A68_REF, &ref_new) = new_row;
123 REF_SCOPE (&ref_new) = scope;
124 PUSH_REF (p, ref_new);
125 } else {
126 PUSH_OBJECT (p, new_row, A68_ROW);
127 }
128 PROP_T self;
129 UNIT (&self) = genie_transpose_function;
130 SOURCE (&self) = p;
131 return self;
132 }
133
134 //! @brief Push description for row vector.
135
136 PROP_T genie_row_function (NODE_T * p)
137 {
138 NODE_T *q = SUB (p);
139 ADDR_T scope = PRIMAL_SCOPE;
140 BOOL_T name = (BOOL_T) (IS_REF (MOID (p)));
141 int k = 1;
142 if (IS (q, TERTIARY)) {
143 A68_INT x;
144 EXECUTE_UNIT (q);
145 POP_OBJECT (p, &x, A68_INT);
146 k = VALUE (&x);
147 FORWARD (q);
148 }
149 EXECUTE_UNIT (NEXT (q));
150 MOID_T *m = (name ? SUB_MOID (NEXT (q)) : MOID (NEXT (q)));
151 if (name) {
152 A68_REF z;
153 POP_REF (p, &z);
154 CHECK_REF (p, z, MOID (SUB (p)));
155 scope = REF_SCOPE (&z);
156 PUSH_REF (p, *DEREF (A68_REF, &z));
157 }
158 A68_ROW row; A68_ARRAY *arr; A68_TUPLE *tup;
159 POP_OBJECT (p, &row, A68_ROW);
160 GET_DESCRIPTOR (arr, tup, &row);
161 if (DIM (arr) != 1) {
162 diagnostic (A68_RUNTIME_ERROR, p, ERROR_NO_VECTOR, m, PRIMARY);
163 exit_genie (p, A68_RUNTIME_ERROR);
164 }
165 m = (name ? SUB_MOID (p) : MOID (p));
166 A68_ROW new_row = heap_generator (p, m, DESCRIPTOR_SIZE (2));
167 A68_ARRAY new_arr;
168 DIM (&new_arr) = 2;
169 MOID (&new_arr) = m;
170 ELEM_SIZE (&new_arr) = ELEM_SIZE (arr);
171 SLICE_OFFSET (&new_arr) = SLICE_OFFSET (arr);
172 FIELD_OFFSET (&new_arr) = FIELD_OFFSET (arr);
173 ARRAY (&new_arr) = ARRAY (arr);
174 A68_TUPLE tup1, tup2;
175 LWB (&tup1) = k;
176 UPB (&tup1) = k;
177 SPAN (&tup1) = 1;
178 SHIFT (&tup1) = k * SPAN (&tup1);
179 K (&tup1) = 0;
180 LWB (&tup2) = 1;
181 UPB (&tup2) = ROW_SIZE (tup);
182 SPAN (&tup2) = SPAN (tup);
183 SHIFT (&tup2) = SPAN (tup);
184 K (&tup2) = 0;
185 PUT_DESCRIPTOR2 (new_arr, tup1, tup2, &new_row);
186 if (name) {
187 A68_REF ref_new = heap_generator (p, MOID (p), A68_REF_SIZE);
188 *DEREF (A68_REF, &ref_new) = new_row;
189 REF_SCOPE (&ref_new) = scope;
190 PUSH_REF (p, ref_new);
191 } else {
192 PUSH_OBJECT (p, new_row, A68_ROW);
193 }
194 PROP_T self;
195 UNIT (&self) = genie_row_function;
196 SOURCE (&self) = p;
197 return self;
198 }
199
200 //! @brief Push description for column vector.
201
202 PROP_T genie_column_function (NODE_T * p)
203 {
204 NODE_T *q = SUB (p);
205 BOOL_T name = (BOOL_T) (IS_REF (MOID (p)));
206 ADDR_T scope = PRIMAL_SCOPE;
207 int k = 1;
208 if (IS (q, TERTIARY)) {
209 A68_INT x;
210 EXECUTE_UNIT (q);
211 POP_OBJECT (p, &x, A68_INT);
212 k = VALUE (&x);
213 FORWARD (q);
214 }
215 EXECUTE_UNIT (NEXT (q));
216 MOID_T *m = (name ? SUB_MOID (NEXT (q)) : MOID (NEXT (q)));
217 if (name) {
218 A68_REF z;
219 POP_REF (p, &z);
220 CHECK_REF (p, z, MOID (SUB (p)));
221 scope = REF_SCOPE (&z);
222 PUSH_REF (p, *DEREF (A68_REF, &z));
223 }
224 A68_ROW row; A68_ARRAY *arr; A68_TUPLE *tup;
225 POP_OBJECT (p, &row, A68_ROW);
226 GET_DESCRIPTOR (arr, tup, &row);
227 m = (name ? SUB_MOID (p) : MOID (p));
228 A68_ROW new_row = heap_generator (p, m, DESCRIPTOR_SIZE (2));
229 A68_ARRAY new_arr;
230 DIM (&new_arr) = 2;
231 MOID (&new_arr) = m;
232 ELEM_SIZE (&new_arr) = ELEM_SIZE (arr);
233 SLICE_OFFSET (&new_arr) = SLICE_OFFSET (arr);
234 FIELD_OFFSET (&new_arr) = FIELD_OFFSET (arr);
235 ARRAY (&new_arr) = ARRAY (arr);
236 A68_TUPLE tup1, tup2;
237 LWB (&tup1) = 1;
238 UPB (&tup1) = ROW_SIZE (tup);
239 SPAN (&tup1) = SPAN (tup);
240 SHIFT (&tup1) = SPAN (tup);
241 K (&tup1) = 0;
242 LWB (&tup2) = k;
243 UPB (&tup2) = k;
244 SPAN (&tup2) = 1;
245 SHIFT (&tup2) = k * SPAN (&tup2);
246 K (&tup2) = 0;
247 PUT_DESCRIPTOR2 (new_arr, tup1, tup2, &new_row);
248 if (name) {
249 A68_REF ref_new = heap_generator (p, MOID (p), A68_REF_SIZE);
250 *DEREF (A68_REF, &ref_new) = new_row;
251 REF_SCOPE (&ref_new) = scope;
252 PUSH_REF (p, ref_new);
253 } else {
254 PUSH_OBJECT (p, new_row, A68_ROW);
255 }
256 PROP_T self;
257 UNIT (&self) = genie_column_function;
258 SOURCE (&self) = p;
259 return self;
260 }
jmvdveer@xs4all.nl