1 /*
2 * $Id: yapi.c,v 1.27 2010-08-29 00:39:57 dhmunro Exp $
3 * API implementation for interfacing yorick packages to the interpreter
4 * - yorick package source should not need to include anything
5 * not here or in the play headers
6 */
7 /* Copyright (c) 2005, The Regents of the University of California.
8 * All rights reserved.
9 * This file is part of yorick (http://yorick.sourceforge.net).
10 * Read the accompanying LICENSE file for details.
11 */
12
13 #include "ydata.h"
14 #include "yio.h"
15 #include "bcast.h"
16
17 #include "pstdlib.h"
18 #include <string.h>
19 #include <stdio.h>
20
21 int
yarg_subroutine(void)22 yarg_subroutine(void)
23 {
24 extern VMaction DropTop;
25 return pc->Action == &DropTop;
26 }
27
28 void
yarg_kw_init(char ** knames,long * kglobs,int * kiargs)29 yarg_kw_init(char **knames, long *kglobs, int *kiargs)
30 {
31 long n = kglobs[0];
32 if (!n) {
33 long *globs = kglobs+1;
34 char *name;
35 for (name=*knames++ ; name ; n++, name=*knames++)
36 *(globs++) = yget_global(name, 0);
37 kglobs[0] = n;
38 }
39 while (n-- > 0) *(kiargs++) = -1;
40 }
41
42 int
yarg_kw(int iarg,long * kglobs,int * kiargs)43 yarg_kw(int iarg, long *kglobs, int *kiargs)
44 {
45 long n, *globs, vndex;
46 while (iarg>=0 && !sp[-iarg].ops) {
47 if (!iarg)
48 y_error("(BUG) stack corrupted in yarg_kw");
49 vndex = sp[-iarg].index;
50 n = kglobs[0];
51 for (globs=kglobs+1 ; --n >= 0 ; globs++)
52 if (globs[0] == vndex) break;
53 if (n < 0)
54 y_errorq("unrecognized keyword: %s", globalTable.names[vndex]);
55 kiargs[kglobs[0]-1-n] = --iarg;
56 --iarg;
57 }
58 return iarg;
59 }
60
61 long
yarg_key(int iarg)62 yarg_key(int iarg)
63 {
64 if (iarg>=0 && !sp[-iarg].ops) {
65 if (!iarg) y_error("(BUG) stack corrupted in yarg_key");
66 return sp[-iarg].index;
67 }
68 return -1;
69 }
70
71 int
yarg_nil(int iarg)72 yarg_nil(int iarg)
73 {
74 if (iarg >= 0) {
75 Symbol *s = sp - iarg;
76 if (s->ops==&referenceSym) s = &globTab[s->index];
77 return s->ops==&dataBlockSym && s->value.db==&nilDB;
78 }
79 return 0;
80 }
81
82 int
yarg_rank(int iarg)83 yarg_rank(int iarg)
84 {
85 if (iarg >= 0) {
86 Symbol *s = sp - iarg;
87 if (s->ops==&referenceSym) s = &globTab[s->index];
88 if (s->ops == &dataBlockSym) {
89 Dimension *d;
90 int rank;
91 if (s->value.db->ops->isArray)
92 d = ((Array *)s->value.db)->type.dims;
93 else if (s->value.db->ops == &lvalueOps)
94 d = ((LValue *)s->value.db)->type.dims;
95 else
96 return -1;
97 for (rank=0 ; d ; d=d->next) rank++;
98 return rank;
99 } else if (s->ops==&doubleScalar || s->ops==&longScalar
100 || s->ops==&intScalar) {
101 return 0;
102 }
103 }
104 return -1;
105 }
106
107 int
yarg_number(int iarg)108 yarg_number(int iarg)
109 {
110 unsigned int id = yarg_typeid(iarg);
111 if (id > T_COMPLEX) return 0;
112 else if (id < T_FLOAT) return 1;
113 else if (id < T_COMPLEX) return 2;
114 else return 3;
115 }
116
117 int
yarg_string(int iarg)118 yarg_string(int iarg)
119 {
120 int is_string = 0;
121 if (iarg >= 0) {
122 Symbol *s = sp - iarg;
123 if (s->ops==&referenceSym) s = &globTab[s->index];
124 if (s->ops == &dataBlockSym) {
125 if (s->value.db->ops == &stringOps) {
126 is_string = ((Array *)s->value.db)->type.dims? 2 : 1;
127 } else if (s->value.db->ops == &lvalueOps) {
128 StructDef *base= ((LValue *)s->value.db)->type.base;
129 while (base->model) base = base->model;
130 if (base->dataOps == &stringOps)
131 is_string = ((LValue *)s->value.db)->type.dims? 2 : 1;
132 }
133 }
134 }
135 return is_string;
136 }
137
138 /* yarg_func moved to fwrap.c */
139
140 int
yarg_typeid(int iarg)141 yarg_typeid(int iarg)
142 {
143 if (iarg >= 0) {
144 Symbol *s = sp - iarg;
145 if (s->ops==&referenceSym) s = &globTab[s->index];
146 if (s->ops == &dataBlockSym) {
147 int id = s->value.db->ops->typeID;
148 if (id == T_LVALUE) {
149 StructDef *base= ((LValue *)s->value.db)->type.base;
150 while (base->model) base = base->model;
151 id = base->dataOps->typeID;
152 }
153 return id;
154 } else if (s->ops==&doubleScalar) {
155 return T_DOUBLE;
156 } else if (s->ops==&longScalar) {
157 return T_LONG;
158 } else if (s->ops==&intScalar) {
159 return T_INT;
160 }
161 }
162 return T_OPAQUE + 100;
163 }
164
165 int
yarg_true(int iarg)166 yarg_true(int iarg)
167 {
168 Symbol *s = (iarg>=0)? sp - iarg : 0;
169 int x = 0;
170 if (s) {
171 CheckStack(1);
172 sp[1].ops = &intScalar;
173 if (s->ops==&referenceSym) s = &globTab[s->index];
174 if (s->ops != &dataBlockSym) sp[1].value = s->value;
175 else sp[1].value.db = Ref(s->value.db);
176 sp++;
177 sp->ops = s->ops;
178 sp->ops->True();
179 x = (int)ygets_l(0);
180 yarg_drop(1);
181 }
182 return x;
183 }
184
185 int
yarg_scratch(int iarg)186 yarg_scratch(int iarg)
187 {
188 if (iarg >= 0) {
189 Symbol *s = sp - iarg;
190 if (s->ops==&referenceSym) return 1;
191 if (s->ops == &dataBlockSym) {
192 if (s->value.db->ops == &lvalueOps) {
193 LValue *lv = (LValue *)s->value.db;
194 if (lv->strider || lv->type.base->model) return 1;
195 return 0;
196 } else {
197 if (s->value.db->references) return 0;
198 if (s->value.db->ops->isArray) return 1;
199 }
200 } else if (s->ops==&doubleScalar
201 || s->ops==&longScalar || s->ops==&intScalar) {
202 return 1;
203 }
204 return 2;
205 }
206 return -1;
207 }
208
209 static void *ygeta_array(int iarg, Operations **pops, Member **ptype);
210 static void yget_dims(long *ntot, long *dims, Member *type);
211 static Dimension *ypush_dims(long *dims);
212 static void *ypush_array(StructDef *base, Dimension *dims);
213
y_s_c(void * x,unsigned char * y,long n)214 static void y_s_c(void *x,unsigned char *y,long n)
215 { short *z=x; while (n--) *y++ = (unsigned char)*z++; }
y_i_c(void * x,unsigned char * y,long n)216 static void y_i_c(void *x,unsigned char *y,long n)
217 { int *z=x; while (n--) *y++ = (unsigned char)*z++; }
y_l_c(void * x,unsigned char * y,long n)218 static void y_l_c(void *x,unsigned char *y,long n)
219 { long *z=x; while (n--) *y++ = (unsigned char)*z++; }
y_f_c(void * x,unsigned char * y,long n)220 static void y_f_c(void *x,unsigned char *y,long n)
221 { float *z=x; while (n--) *y++ = (unsigned char)*z++; }
y_d_c(void * x,unsigned char * y,long n)222 static void y_d_c(void *x,unsigned char *y,long n)
223 { double *z=x; while (n--) *y++ = (unsigned char)*z++; }
y_z_c(void * x,unsigned char * y,long n)224 static void y_z_c(void *x,unsigned char *y,long n)
225 { unsigned char *z=x; while (n--) *y++ = (unsigned char)*z++, z++; }
y_x_c(void * x,unsigned char * y,long n)226 static void y_x_c(void *x,unsigned char *y,long n)
227 { y_error("cannot convert non-number to char"); }
228 static void (*y_to_c[])(void *,unsigned char *,long) = {
229 0, y_s_c, y_i_c, y_l_c, y_f_c, y_d_c, y_z_c, y_x_c };
230
231 char *
ygeta_c(int iarg,long * ntot,long * dims)232 ygeta_c(int iarg, long *ntot, long *dims)
233 {
234 Operations *ops;
235 Member *type;
236 void *p;
237 if (iarg < 0) return 0;
238 p = ygeta_array(iarg, &ops, &type);
239 yget_dims(ntot, dims, type);
240 if (ops != &charOps) {
241 int is_db = (sp[-iarg].ops == &dataBlockSym);
242 unsigned char *q = ypush_array(&charStruct, type->dims);
243 y_to_c[ops->promoteID](p, q, type->number);
244 if (is_db) {
245 sp[-iarg-1].ops = &intScalar;
246 Unref(sp[-iarg-1].value.db);
247 }
248 sp--;
249 sp[-iarg].value.db = sp[1].value.db;
250 sp[-iarg].ops = &dataBlockSym;
251 return (char *)q;
252 }
253 return p;
254 }
255
y_c_s(void * x,short * y,long n)256 static void y_c_s(void *x,short *y,long n)
257 { unsigned char *z=x; while (n--) *y++ = (short)*z++; }
y_i_s(void * x,short * y,long n)258 static void y_i_s(void *x,short *y,long n)
259 { int *z=x; while (n--) *y++ = (short)*z++; }
y_l_s(void * x,short * y,long n)260 static void y_l_s(void *x,short *y,long n)
261 { long *z=x; while (n--) *y++ = (short)*z++; }
y_f_s(void * x,short * y,long n)262 static void y_f_s(void *x,short *y,long n)
263 { float *z=x; while (n--) *y++ = (short)*z++; }
y_d_s(void * x,short * y,long n)264 static void y_d_s(void *x,short *y,long n)
265 { double *z=x; while (n--) *y++ = (short)*z++; }
y_z_s(void * x,short * y,long n)266 static void y_z_s(void *x,short *y,long n)
267 { double *z=x; while (n--) *y++ = (short)*z++, z++; }
y_x_s(void * x,short * y,long n)268 static void y_x_s(void *x,short *y,long n)
269 { y_error("cannot convert non-number to short"); }
270 static void (*y_to_s[])(void *,short *,long) = {
271 y_c_s, 0, y_i_s, y_l_s, y_f_s, y_d_s, y_z_s, y_x_s };
272
273 short *
ygeta_s(int iarg,long * ntot,long * dims)274 ygeta_s(int iarg, long *ntot, long *dims)
275 {
276 Operations *ops;
277 Member *type;
278 void *p;
279 if (iarg < 0) return 0;
280 p = ygeta_array(iarg, &ops, &type);
281 yget_dims(ntot, dims, type);
282 if (ops != &shortOps) {
283 int is_db = (sp[-iarg].ops == &dataBlockSym);
284 short *q = ypush_array(&shortStruct, type->dims);
285 y_to_s[ops->promoteID](p, q, type->number);
286 if (is_db) {
287 sp[-iarg-1].ops = &intScalar;
288 Unref(sp[-iarg-1].value.db);
289 }
290 sp--;
291 sp[-iarg].value.db = sp[1].value.db;
292 sp[-iarg].ops = &dataBlockSym;
293 return q;
294 }
295 return p;
296 }
297
y_c_i(void * x,int * y,long n)298 static void y_c_i(void *x,int *y,long n)
299 { unsigned char *z=x; while (n--) *y++ = (int)*z++; }
y_s_i(void * x,int * y,long n)300 static void y_s_i(void *x,int *y,long n)
301 { short *z=x; while (n--) *y++ = (int)*z++; }
y_l_i(void * x,int * y,long n)302 static void y_l_i(void *x,int *y,long n)
303 { long *z=x; while (n--) *y++ = (int)*z++; }
y_f_i(void * x,int * y,long n)304 static void y_f_i(void *x,int *y,long n)
305 { float *z=x; while (n--) *y++ = (int)*z++; }
y_d_i(void * x,int * y,long n)306 static void y_d_i(void *x,int *y,long n)
307 { double *z=x; while (n--) *y++ = (int)*z++; }
y_z_i(void * x,int * y,long n)308 static void y_z_i(void *x,int *y,long n)
309 { double *z=x; while (n--) *y++ = (int)*z++, z++; }
y_x_i(void * x,int * y,long n)310 static void y_x_i(void *x,int *y,long n)
311 { y_error("cannot convert non-number to int"); }
312 static void (*y_to_i[])(void *,int *,long) = {
313 y_c_i, y_s_i, 0, y_l_i, y_f_i, y_d_i, y_z_i, y_x_i };
314
315 int *
ygeta_i(int iarg,long * ntot,long * dims)316 ygeta_i(int iarg, long *ntot, long *dims)
317 {
318 Operations *ops;
319 Member *type;
320 void *p;
321 if (iarg < 0) return 0;
322 p = ygeta_array(iarg, &ops, &type);
323 yget_dims(ntot, dims, type);
324 if (ops != &intOps) {
325 if (type->dims) {
326 int *q = ypush_array(&intStruct, type->dims);
327 y_to_i[ops->promoteID](p, q, type->number);
328 sp[-iarg-1].ops = &intScalar;
329 Unref(sp[-iarg-1].value.db);
330 sp--;
331 sp[-iarg].value.db = sp[1].value.db;
332 sp[-iarg].ops = &dataBlockSym;
333 return q;
334 } else {
335 int is_db = (sp[-iarg].ops == &dataBlockSym);
336 int x;
337 y_to_i[ops->promoteID](p, &x, type->number);
338 sp[-iarg].ops = &intScalar;
339 if (is_db) Unref(sp[-iarg].value.db);
340 sp[-iarg].value.i = x;
341 return &(sp[-iarg].value.i);
342 }
343 }
344 return p;
345 }
346
y_c_l(void * x,long * y,long n)347 static void y_c_l(void *x,long *y,long n)
348 { unsigned char *z=x; while (n--) *y++ = (long)*z++; }
y_s_l(void * x,long * y,long n)349 static void y_s_l(void *x,long *y,long n)
350 { short *z=x; while (n--) *y++ = (long)*z++; }
y_i_l(void * x,long * y,long n)351 static void y_i_l(void *x,long *y,long n)
352 { int *z=x; while (n--) *y++ = (long)*z++; }
y_f_l(void * x,long * y,long n)353 static void y_f_l(void *x,long *y,long n)
354 { float *z=x; while (n--) *y++ = (long)*z++; }
y_d_l(void * x,long * y,long n)355 static void y_d_l(void *x,long *y,long n)
356 { double *z=x; while (n--) *y++ = (long)*z++; }
y_z_l(void * x,long * y,long n)357 static void y_z_l(void *x,long *y,long n)
358 { double *z=x; while (n--) *y++ = (long)*z++, z++; }
y_x_l(void * x,long * y,long n)359 static void y_x_l(void *x,long *y,long n)
360 { y_error("cannot convert non-number to long"); }
361 static void (*y_to_l[])(void *,long *,long) = {
362 y_c_l, y_s_l, y_i_l, 0, y_f_l, y_d_l, y_z_l, y_x_l };
363
364 long *
ygeta_l(int iarg,long * ntot,long * dims)365 ygeta_l(int iarg, long *ntot, long *dims)
366 {
367 Operations *ops;
368 Member *type;
369 void *p;
370 if (iarg < 0) return 0;
371 p = ygeta_array(iarg, &ops, &type);
372 yget_dims(ntot, dims, type);
373 if (ops != &longOps) {
374 if (type->dims) {
375 long *q = ypush_array(&longStruct, type->dims);
376 y_to_l[ops->promoteID](p, q, type->number);
377 sp[-iarg-1].ops = &intScalar;
378 Unref(sp[-iarg-1].value.db);
379 sp--;
380 sp[-iarg].value.db = sp[1].value.db;
381 sp[-iarg].ops = &dataBlockSym;
382 return q;
383 } else {
384 int is_db = (sp[-iarg].ops == &dataBlockSym);
385 long x;
386 y_to_l[ops->promoteID](p, &x, type->number);
387 sp[-iarg].ops = &longScalar;
388 if (is_db) Unref(sp[-iarg].value.db);
389 sp[-iarg].value.l = x;
390 return &(sp[-iarg].value.l);
391 }
392 }
393 return p;
394 }
395
396 long
ygets_l(int iarg)397 ygets_l(int iarg)
398 {
399 Operations *ops;
400 Member *type;
401 void *p;
402 if (iarg < 0) return 0;
403 p = ygeta_array(iarg, &ops, &type);
404 if (!type->dims && ops->promoteID<T_FLOAT) {
405 if (ops != &longOps) {
406 int is_db = (sp[-iarg].ops == &dataBlockSym);
407 long x;
408 y_to_l[ops->promoteID](p, &x, type->number);
409 sp[-iarg].ops = &longScalar;
410 if (is_db) Unref(sp[-iarg].value.db);
411 sp[-iarg].value.l = x;
412 return x;
413 }
414 return *(long *)p;
415 }
416 y_error("expecting scalar integer argument");
417 return 0;
418 }
419
y_c_f(void * x,float * y,long n)420 static void y_c_f(void *x,float *y,long n)
421 { unsigned char *z=x; while (n--) *y++ = (float)*z++; }
y_s_f(void * x,float * y,long n)422 static void y_s_f(void *x,float *y,long n)
423 { short *z=x; while (n--) *y++ = (float)*z++; }
y_i_f(void * x,float * y,long n)424 static void y_i_f(void *x,float *y,long n)
425 { int *z=x; while (n--) *y++ = (float)*z++; }
y_l_f(void * x,float * y,long n)426 static void y_l_f(void *x,float *y,long n)
427 { long *z=x; while (n--) *y++ = (float)*z++; }
y_d_f(void * x,float * y,long n)428 static void y_d_f(void *x,float *y,long n)
429 { double *z=x; while (n--) *y++ = (float)*z++; }
y_z_f(void * x,float * y,long n)430 static void y_z_f(void *x,float *y,long n)
431 { double *z=x; while (n--) *y++ = (float)*z++, z++; }
y_x_f(void * x,float * y,long n)432 static void y_x_f(void *x,float *y,long n)
433 { y_error("cannot convert non-number to float"); }
434 static void (*y_to_f[])(void *,float *,long) = {
435 y_c_f, y_s_f, y_i_f, y_l_f, 0, y_d_f, y_z_f, y_x_f };
436
437 float *
ygeta_f(int iarg,long * ntot,long * dims)438 ygeta_f(int iarg, long *ntot, long *dims)
439 {
440 Operations *ops;
441 Member *type;
442 void *p;
443 if (iarg < 0) return 0;
444 p = ygeta_array(iarg, &ops, &type);
445 yget_dims(ntot, dims, type);
446 if (ops != &floatOps) {
447 int is_db = (sp[-iarg].ops == &dataBlockSym);
448 float *q = ypush_array(&floatStruct, type->dims);
449 y_to_f[ops->promoteID](p, q, type->number);
450 if (is_db) {
451 sp[-iarg-1].ops = &intScalar;
452 Unref(sp[-iarg-1].value.db);
453 }
454 sp--;
455 sp[-iarg].value.db = sp[1].value.db;
456 sp[-iarg].ops = &dataBlockSym;
457 return q;
458 }
459 return p;
460 }
461
y_c_d(void * x,double * y,long n)462 static void y_c_d(void *x,double *y,long n)
463 { unsigned char *z=x; while (n--) *y++ = (double)*z++; }
y_s_d(void * x,double * y,long n)464 static void y_s_d(void *x,double *y,long n)
465 { short *z=x; while (n--) *y++ = (double)*z++; }
y_i_d(void * x,double * y,long n)466 static void y_i_d(void *x,double *y,long n)
467 { int *z=x; while (n--) *y++ = (double)*z++; }
y_l_d(void * x,double * y,long n)468 static void y_l_d(void *x,double *y,long n)
469 { long *z=x; while (n--) *y++ = (double)*z++; }
y_f_d(void * x,double * y,long n)470 static void y_f_d(void *x,double *y,long n)
471 { float *z=x; while (n--) *y++ = (double)*z++; }
y_z_d(void * x,double * y,long n)472 static void y_z_d(void *x,double *y,long n)
473 { double *z=x; while (n--) *y++ = (double)*z++, z++; }
y_x_d(void * x,double * y,long n)474 static void y_x_d(void *x,double *y,long n)
475 { y_error("cannot convert non-number to double"); }
476 static void (*y_to_d[])(void *,double *,long) = {
477 y_c_d, y_s_d, y_i_d, y_l_d, y_f_d, 0, y_z_d, y_x_d };
478
479 double *
ygeta_d(int iarg,long * ntot,long * dims)480 ygeta_d(int iarg, long *ntot, long *dims)
481 {
482 Operations *ops;
483 Member *type;
484 void *p;
485 if (iarg < 0) return 0;
486 p = ygeta_array(iarg, &ops, &type);
487 yget_dims(ntot, dims, type);
488 if (ops != &doubleOps) {
489 if (type->dims) {
490 double *q = ypush_array(&doubleStruct, type->dims);
491 y_to_d[ops->promoteID](p, q, type->number);
492 sp[-iarg-1].ops = &intScalar;
493 Unref(sp[-iarg-1].value.db);
494 sp--;
495 sp[-iarg].value.db = sp[1].value.db;
496 sp[-iarg].ops = &dataBlockSym;
497 return q;
498 } else {
499 int is_db = (sp[-iarg].ops == &dataBlockSym);
500 double x;
501 y_to_d[ops->promoteID](p, &x, type->number);
502 sp[-iarg].ops = &doubleScalar;
503 if (is_db) Unref(sp[-iarg].value.db);
504 sp[-iarg].value.d = x;
505 return &(sp[-iarg].value.d);
506 }
507 }
508 return p;
509 }
510
511 double
ygets_d(int iarg)512 ygets_d(int iarg)
513 {
514 Operations *ops;
515 Member *type;
516 void *p;
517 if (iarg < 0) return 0;
518 p = ygeta_array(iarg, &ops, &type);
519 if (!type->dims && ops->promoteID<T_COMPLEX) {
520 if (ops != &doubleOps) {
521 int is_db = (sp[-iarg].ops == &dataBlockSym);
522 double x;
523 y_to_d[ops->promoteID](p, &x, type->number);
524 sp[-iarg].ops = &doubleScalar;
525 if (is_db) Unref(sp[-iarg].value.db);
526 sp[-iarg].value.d = x;
527 return x;
528 }
529 return *(double *)p;
530 }
531 y_error("expecting scalar real argument");
532 return 0;
533 }
534
y_c_z(void * x,double * y,long n)535 static void y_c_z(void *x,double *y,long n)
536 { unsigned char *z=x; while (n--) *y++ = (double)*z++, *y++ = 0.; }
y_s_z(void * x,double * y,long n)537 static void y_s_z(void *x,double *y,long n)
538 { short *z=x; while (n--) *y++ = (double)*z++, *y++ = 0.; }
y_i_z(void * x,double * y,long n)539 static void y_i_z(void *x,double *y,long n)
540 { int *z=x; while (n--) *y++ = (double)*z++, *y++ = 0.; }
y_l_z(void * x,double * y,long n)541 static void y_l_z(void *x,double *y,long n)
542 { long *z=x; while (n--) *y++ = (double)*z++, *y++ = 0.; }
y_f_z(void * x,double * y,long n)543 static void y_f_z(void *x,double *y,long n)
544 { float *z=x; while (n--) *y++ = (double)*z++, *y++ = 0.; }
y_d_z(void * x,double * y,long n)545 static void y_d_z(void *x,double *y,long n)
546 { double *z=x; while (n--) *y++ = (double)*z++, *y++ = 0.; }
y_x_z(void * x,double * y,long n)547 static void y_x_z(void *x,double *y,long n)
548 { y_error("cannot convert non-number to complex"); }
549 static void (*y_to_z[])(void *,double *,long) = {
550 y_c_z, y_s_z, y_i_z, y_l_z, y_f_z, y_d_z, 0, y_x_z };
551
552 double *
ygeta_z(int iarg,long * ntot,long * dims)553 ygeta_z(int iarg, long *ntot, long *dims)
554 {
555 Operations *ops;
556 Member *type;
557 void *p;
558 if (iarg < 0) return 0;
559 p = ygeta_array(iarg, &ops, &type);
560 yget_dims(ntot, dims, type);
561 if (ops != &complexOps) {
562 int is_db = (sp[-iarg].ops == &dataBlockSym);
563 double *q = ypush_array(&complexStruct, type->dims);
564 y_to_z[ops->promoteID](p, q, type->number);
565 if (is_db) {
566 sp[-iarg-1].ops = &intScalar;
567 Unref(sp[-iarg-1].value.db);
568 }
569 sp--;
570 sp[-iarg].value.db = sp[1].value.db;
571 sp[-iarg].ops = &dataBlockSym;
572 return q;
573 }
574 return p;
575 }
576
577 ystring_t *
ygeta_q(int iarg,long * ntot,long * dims)578 ygeta_q(int iarg, long *ntot, long *dims)
579 {
580 Operations *ops;
581 Member *type;
582 void *p;
583 if (iarg < 0) return 0;
584 p = ygeta_array(iarg, &ops, &type);
585 yget_dims(ntot, dims, type);
586 if (ops != &stringOps)
587 y_error("expecting string argument");
588 return p;
589 }
590
591 ystring_t
ygets_q(int iarg)592 ygets_q(int iarg)
593 {
594 Operations *ops;
595 Member *type;
596 char **q;
597 if (iarg < 0) return 0;
598 q = ygeta_array(iarg, &ops, &type);
599 if (ops!=&stringOps || type->dims)
600 y_error("expecting scalar string argument");
601 return q[0];
602 }
603
604 ypointer_t *
ygeta_p(int iarg,long * ntot,long * dims)605 ygeta_p(int iarg, long *ntot, long *dims)
606 {
607 Operations *ops;
608 Member *type;
609 void *p;
610 if (iarg < 0) return 0;
611 p = ygeta_array(iarg, &ops, &type);
612 yget_dims(ntot, dims, type);
613 if (ops != &pointerOps)
614 y_error("expecting pointer argument");
615 return p;
616 }
617
618 ypointer_t
ygets_p(int iarg)619 ygets_p(int iarg)
620 {
621 Operations *ops;
622 Member *type;
623 void **p;
624 if (iarg < 0) return 0;
625 p = ygeta_array(iarg, &ops, &type);
626 if (ops!=&pointerOps || type->dims)
627 y_error("expecting scalar pointer argument");
628 return p[0];
629 }
630
631 double *
ygeta_dz(int iarg,long * ntot,long * dims,int * is_z)632 ygeta_dz(int iarg, long *ntot, long *dims, int *is_z)
633 {
634 Operations *ops;
635 Member *type;
636 void *p;
637 if (iarg < 0) return 0;
638 p = ygeta_array(iarg, &ops, &type);
639 yget_dims(ntot, dims, type);
640 *is_z = (ops==&complexOps);
641 if (ops!=&doubleOps && !*is_z) {
642 if (type->dims) {
643 double *q = ypush_array(&doubleStruct, type->dims);
644 y_to_d[ops->promoteID](p, q, type->number);
645 sp[-iarg-1].ops = &intScalar;
646 Unref(sp[-iarg-1].value.db);
647 sp--;
648 sp[-iarg].value.db = sp[1].value.db;
649 sp[-iarg].ops = &dataBlockSym;
650 return q;
651 } else {
652 int is_db = (sp[-iarg].ops == &dataBlockSym);
653 double x;
654 y_to_d[ops->promoteID](p, &x, type->number);
655 sp[-iarg].ops = &doubleScalar;
656 if (is_db) Unref(sp[-iarg].value.db);
657 sp[-iarg].value.d = x;
658 return &(sp[-iarg].value.d);
659 }
660 }
661 return p;
662 }
663
664 void *
ygeta_any(int iarg,long * ntot,long * dims,int * typeid)665 ygeta_any(int iarg, long *ntot, long *dims, int *typeid)
666 {
667 if (iarg >= 0) {
668 Operations *ops;
669 Member *type;
670 void *p = ygeta_array(iarg, &ops, &type);
671 yget_dims(ntot, dims, type);
672 if (typeid) *typeid = ops->typeID;
673 return p;
674 }
675 return 0;
676 }
677
678 static void *
ypush_array(StructDef * base,Dimension * dims)679 ypush_array(StructDef *base, Dimension *dims)
680 {
681 Array *a = PushDataBlock(NewArray(base, dims));
682 return a->value.c;
683 }
684
685 void *
ygeta_coerce(int iarg,void * p,long ntot,long * dims,int oldid,int newid)686 ygeta_coerce(int iarg, void *p, long ntot, long *dims, int oldid, int newid)
687 {
688 if (oldid == newid) {
689 return p;
690 } else if (oldid<0 || oldid>T_COMPLEX || newid<0 || newid>T_COMPLEX) {
691 y_error("non-numeric typeid illegal in ygeta_coerce");
692 } else if (iarg < 0) {
693 y_error("illegal iarg in ygeta_coerce");
694 } else {
695 static StructDef *types[] = {
696 &charStruct, &shortStruct, &intStruct, &longStruct,
697 &floatStruct, &doubleStruct, &complexStruct };
698 static void (**converters[])(void*,void*,long) = {
699 (void(**)(void*,void*,long))y_to_c, (void(**)(void*,void*,long))y_to_s,
700 (void(**)(void*,void*,long))y_to_i, (void(**)(void*,void*,long))y_to_l,
701 (void(**)(void*,void*,long))y_to_f, (void(**)(void*,void*,long))y_to_d,
702 (void(**)(void*,void*,long))y_to_z };
703 Array *a = PushDataBlock(NewArray(types[newid], ypush_dims(dims)));
704 void *q = a->value.c;
705 int is_db = (sp[-iarg].ops == &dataBlockSym);
706 converters[newid][oldid](p, q, ntot);
707 if (is_db) {
708 sp[-iarg-1].ops = &intScalar;
709 Unref(sp[-iarg-1].value.db);
710 }
711 sp--;
712 sp[-iarg].value.db = sp[1].value.db;
713 sp[-iarg].ops = &dataBlockSym;
714 return q;
715 }
716 return 0;
717 }
718
719 static void
yget_dims(long * ntot,long * dims,Member * type)720 yget_dims(long *ntot, long *dims, Member *type)
721 {
722 if (ntot) *ntot = type->number;
723 if (dims) {
724 Dimension *d = type->dims;
725 int i, rank;
726 long n;
727 for (rank=0 ; d ; d=d->next) dims[++rank] = d->number;
728 dims[0] = rank;
729 for (i=1 ; i<rank ; i++,rank--)
730 n = dims[i], dims[i] = dims[rank], dims[rank] = n;
731 }
732 }
733
734 static Member y_i_type = { &intStruct, 0, 1L };
735 static Member y_l_type = { &longStruct, 0, 1L };
736 static Member y_d_type = { &doubleStruct, 0, 1L };
737
738 int
yarg_reform(int iarg,long * dims)739 yarg_reform(int iarg, long *dims)
740 {
741 if (iarg >= 0) {
742 Operations *ops;
743 Member *type;
744 int i, rank = dims? dims[0] : 0;
745 long n = 1;
746 ygeta_array(iarg, &ops, &type);
747 if (rank) for (n=dims[1],i=2 ; i<=rank ; i++) n *= dims[i];
748 if (n == type->number) {
749 Dimension *d = type->dims;
750 if (n == 1) {
751 Array *a;
752 if (type==&y_d_type || type==&y_l_type || type==&y_i_type) {
753 if (!rank) return 1;
754 a = (Array *)ForceToDB(sp - iarg);
755 type = &a->type;
756 d = type->dims;
757 }
758 }
759 type->dims = 0;
760 if (d) FreeDimension(d);
761 type->dims = ypush_dims(dims);
762 if (type->dims) type->dims->references++;
763 return 1;
764 }
765 }
766 return 0;
767 }
768
769 extern void ReadGather(void *dst, void *srcM, long srcD, StructDef *base,
770 long number, const Strider *strider);
771
772 static void *
ygeta_array(int iarg,Operations ** pops,Member ** ptype)773 ygeta_array(int iarg, Operations **pops, Member **ptype)
774 {
775 Symbol *s = sp - iarg;
776 if (s->ops==&referenceSym) {
777 /* change reference to global object into object itself */
778 Symbol *g = &globTab[s->index];
779 if (g->ops == &dataBlockSym) s->value.db = Ref(g->value.db);
780 else s->value = g->value;
781 s->ops = g->ops;
782 }
783
784 if (s->ops == &dataBlockSym) {
785 Operations *ops = s->value.db->ops;
786 if (ops->isArray) {
787 /* whole array in memory */
788 *pops = ops;
789 *ptype = &((Array *)s->value.db)->type;
790 return ((Array *)s->value.db)->value.c;
791
792 } else if (ops == &lvalueOps) {
793 LValue *lv = (LValue *)s->value.db;
794 StructDef *base = lv->type.base;
795 if (lv->strider || base->model) {
796 /* read array from file or as subset of another array to stack */
797 StructDef *model = base->model;
798 IOStream *file = base->file;
799 Array *a;
800 if (model)
801 while (model->model) model = model->model;
802 else
803 model = base;
804 a = PushDataBlock(NewArray(model, lv->type.dims));
805 ReadGather(a->value.c, file? 0 : lv->address.m, lv->address.d,
806 base, lv->type.number, lv->strider);
807 if (file && file->pointeeList.table.nItems) ClearPointees(file, 0);
808 /* pop array back to iarg on stack */
809 s->ops = &intScalar;
810 Unref(s->value.db);
811 sp--;
812 s->value.db = (DataBlock *)a;
813 s->ops = &dataBlockSym;
814 *pops = a->ops;
815 *ptype = &a->type;
816 return a->value.c;
817
818 } else {
819 /* array in unmanaged memory */
820 *pops = base->dataOps;
821 *ptype = &lv->type;
822 return lv->address.m;
823 }
824 }
825
826 } else if (s->ops == &doubleScalar) {
827 *pops = &doubleOps;
828 *ptype = &y_d_type;
829 return &s->value.d;
830 } else if (s->ops == &longScalar) {
831 *pops = &longOps;
832 *ptype = &y_l_type;
833 return &s->value.l;
834 } else if (s->ops == &intScalar) {
835 *pops = &intOps;
836 *ptype = &y_i_type;
837 return &s->value.i;
838 }
839
840 y_error("expecting array argument");
841 return 0;
842 }
843
844 int
yget_range(int iarg,long min_max_step[3])845 yget_range(int iarg, long min_max_step[3])
846 {
847 if (iarg >= 0) {
848 Symbol *s = sp - iarg;
849 if (s->ops==&referenceSym) s = &globTab[s->index];
850 if (s->ops==&dataBlockSym && s->value.db->ops==&rangeOps) {
851 Range *r = (Range *)s->value.db;
852 int flags = 0;
853 min_max_step[0] = r->min;
854 min_max_step[1] = r->max;
855 min_max_step[2] = r->inc;
856 if (r->nilFlags & R_MINNIL) flags |= Y_MIN_DFLT;
857 if (r->nilFlags & R_MAXNIL) flags |= Y_MAX_DFLT;
858 if (r->nilFlags & R_PSEUDO) {
859 flags |= (r->nilFlags & R_RUBBER)? Y_RUBBER1 : Y_PSEUDO;
860 } else if (r->nilFlags & R_RUBBER) {
861 flags |= Y_RUBBER;
862 } else if (r->nilFlags & R_NULLER) {
863 flags |= Y_NULLER;
864 } else if (r->nilFlags & R_MARKED) {
865 flags |= Y_MMMARK;
866 } else if (r->rf) {
867 flags |= 7;
868 } else {
869 flags |= 1;
870 }
871 return flags;
872 }
873 }
874 return 0;
875 }
876
877 void
ypush_check(int n)878 ypush_check(int n)
879 {
880 CheckStack(n);
881 }
882
883 void
ypush_nil(void)884 ypush_nil(void)
885 {
886 PushDataBlock(RefNC(&nilDB));
887 }
888
889 void
ypush_int(int value)890 ypush_int(int value)
891 {
892 sp[1].value.i = value;
893 (++sp)->ops = &intScalar;
894 }
895
896 void
ypush_long(long value)897 ypush_long(long value)
898 {
899 sp[1].value.l = value;
900 (++sp)->ops = &longScalar;
901 }
902
903 void
ypush_double(double value)904 ypush_double(double value)
905 {
906 sp[1].value.d = value;
907 (++sp)->ops = &doubleScalar;
908 }
909
910 char *
ypush_c(long * dims)911 ypush_c(long *dims)
912 {
913 Array *a = PushDataBlock(NewArray(&charStruct, ypush_dims(dims)));
914 memset(a->value.c, 0, a->type.number*a->type.base->size);
915 return a->value.c;
916 }
917
918 short *
ypush_s(long * dims)919 ypush_s(long *dims)
920 {
921 Array *a = PushDataBlock(NewArray(&shortStruct, ypush_dims(dims)));
922 memset(a->value.c, 0, a->type.number*a->type.base->size);
923 return a->value.s;
924 }
925
926 int *
ypush_i(long * dims)927 ypush_i(long *dims)
928 {
929 if (!dims || !dims[0]) {
930 sp[1].value.i = 0;
931 (++sp)->ops = &intScalar;
932 return &sp[0].value.i;
933 } else {
934 Array *a = PushDataBlock(NewArray(&intStruct, ypush_dims(dims)));
935 memset(a->value.c, 0, a->type.number*a->type.base->size);
936 return a->value.i;
937 }
938 }
939
940 long *
ypush_l(long * dims)941 ypush_l(long *dims)
942 {
943 if (!dims || !dims[0]) {
944 sp[1].value.l = 0;
945 (++sp)->ops = &longScalar;
946 return &sp[0].value.l;
947 } else {
948 Array *a = PushDataBlock(NewArray(&longStruct, ypush_dims(dims)));
949 memset(a->value.c, 0, a->type.number*a->type.base->size);
950 return a->value.l;
951 }
952 }
953
954 float *
ypush_f(long * dims)955 ypush_f(long *dims)
956 {
957 Array *a = PushDataBlock(NewArray(&floatStruct, ypush_dims(dims)));
958 memset(a->value.c, 0, a->type.number*a->type.base->size);
959 return a->value.f;
960 }
961
962 double *
ypush_d(long * dims)963 ypush_d(long *dims)
964 {
965 if (!dims || !dims[0]) {
966 sp[1].value.d = 0.;
967 (++sp)->ops = &doubleScalar;
968 return &sp[0].value.d;
969 } else {
970 Array *a = PushDataBlock(NewArray(&doubleStruct, ypush_dims(dims)));
971 memset(a->value.c, 0, a->type.number*a->type.base->size);
972 return a->value.d;
973 }
974 }
975
976 double *
ypush_z(long * dims)977 ypush_z(long *dims)
978 {
979 Array *a = PushDataBlock(NewArray(&complexStruct, ypush_dims(dims)));
980 memset(a->value.c, 0, a->type.number*a->type.base->size);
981 return a->value.d;
982 }
983
984 ystring_t *
ypush_q(long * dims)985 ypush_q(long *dims)
986 {
987 Array *a = PushDataBlock(NewArray(&stringStruct, ypush_dims(dims)));
988 return a->value.q;
989 }
990
991 ypointer_t *
ypush_p(long * dims)992 ypush_p(long *dims)
993 {
994 Array *a = PushDataBlock(NewArray(&pointerStruct, ypush_dims(dims)));
995 return a->value.p;
996 }
997
998 static Dimension *
ypush_dims(long * dims)999 ypush_dims(long *dims)
1000 {
1001 if (dims && dims[0]>0) {
1002 long rank = *dims++;
1003 Dimension *d = tmpDims;
1004 tmpDims = 0;
1005 FreeDimension(d);
1006 while (rank--) tmpDims = NewDimension(*dims++, 1L, tmpDims);
1007 return tmpDims;
1008 } else {
1009 return 0;
1010 }
1011 }
1012
1013 void
ypush_range(long mnmxst[3],int flags)1014 ypush_range(long mnmxst[3], int flags)
1015 {
1016 int flgs = 0;
1017 if (flags & Y_MIN_DFLT) flgs |= R_MINNIL;
1018 if (flags & Y_MAX_DFLT) flgs |= R_MAXNIL;
1019 flags &= 15;
1020 if (flags == Y_MMMARK) flgs |= R_MARKED;
1021 else if (flags == Y_PSEUDO) flgs |= R_PSEUDO;
1022 else if (flags == Y_RUBBER) flgs |= R_RUBBER;
1023 else if (flags == Y_RUBBER1) flgs |= R_PSEUDO | R_RUBBER;
1024 else if (flags == Y_NULLER) flgs |= R_NULLER;
1025 PushDataBlock(NewRange(mnmxst[0], mnmxst[1], mnmxst[2], flgs));
1026 }
1027
1028 int
ypush_ptr(ypointer_t ptr,long * ntot)1029 ypush_ptr(ypointer_t ptr, long *ntot)
1030 {
1031 int typeid = Y_VOID;
1032 Array *a = Pointee(ptr);
1033 PushDataBlock(Ref(a));
1034 if (a && (a != (Array*)&nilDB)) {
1035 yget_dims(ntot, (long*)0, &a->type);
1036 typeid = a->ops->typeID;
1037 } else {
1038 if (ntot) *ntot = 0;
1039 }
1040 return typeid;
1041 }
1042
1043 void
yarg_drop(int n)1044 yarg_drop(int n)
1045 {
1046 while (n-- > 0) {
1047 sp--;
1048 if (sp[1].ops==&dataBlockSym) Unref(sp[1].value.db);
1049 }
1050 }
1051
1052 void
yarg_swap(int iarg1,int iarg2)1053 yarg_swap(int iarg1, int iarg2)
1054 {
1055 OpTable *ops1 = sp[-iarg1].ops;
1056 long index1 = sp[-iarg1].index;
1057 SymbolValue value1 = sp[-iarg1].value;
1058 OpTable *ops2 = sp[-iarg2].ops;
1059 sp[-iarg1].ops = &intScalar;
1060 sp[-iarg1].index = sp[-iarg2].index;
1061 sp[-iarg1].value = sp[-iarg2].value;
1062 sp[-iarg2].ops = &intScalar;
1063 sp[-iarg1].ops = ops2;
1064 sp[-iarg2].value = value1;
1065 sp[-iarg2].index = index1;
1066 sp[-iarg2].ops = ops1;
1067 }
1068
1069 /* result bits:
1070 * Y_1_BCAST if dims1 must be broadcast
1071 * Y_2_BCAST if dims2 must be broadcast
1072 * Y_1_EXTEND if rank1 < rank2
1073 * Y_2_EXTEND if rank1 > rank2
1074 */
1075 int
yarg_conform(long * dims1,long * dims2,long * cfmdims)1076 yarg_conform(long *dims1, long *dims2, long *cfmdims)
1077 {
1078 int flags = 0;
1079 long len1, len2;
1080 long n1 = *dims1++;
1081 long n2 = *dims2++;
1082 long cdims[Y_DIMSIZE];
1083 if (!cfmdims) cfmdims = cdims;
1084 *cfmdims++ = (n1>n2)? n1 : n2;
1085 while (n1>0 && n2>0) {
1086 n1--;
1087 n2--;
1088 len1 = *dims1++;
1089 len2 = *dims2++;
1090 if (len1 == len2) *cfmdims++ = len1;
1091 else if (len2 == 1) flags |= Y_2_BCAST, *cfmdims++ = len1;
1092 else if (len1 == 1) flags |= Y_1_BCAST, *cfmdims++ = len2;
1093 else flags = -1, *cfmdims++ = 0;
1094 }
1095 if (n1 > 0) {
1096 flags |= Y_2_EXTEND;
1097 do {
1098 len1 = *dims1++;
1099 if (len1 != 1) flags |= Y_2_BCAST;
1100 *cfmdims++ = len1;
1101 } while (--n1 > 0);
1102 } else if (n2 > 0) {
1103 flags |= Y_1_EXTEND;
1104 do {
1105 len2 = *dims2++;
1106 if (len2 != 1) flags |= Y_1_BCAST;
1107 *cfmdims++ = len2;
1108 } while (--n2 > 0);
1109 }
1110 return flags;
1111 }
1112
1113 int
yarg_dims(int iarg,long * dims,long * cfmdims)1114 yarg_dims(int iarg, long *dims, long *cfmdims)
1115 {
1116 if (iarg >= 0) {
1117 Symbol *s = sp - iarg;
1118 long tdims[Y_DIMSIZE];
1119 if (!dims) dims = tdims;
1120 if (s->ops==&referenceSym) s = &globTab[s->index];
1121 if (s->ops == &dataBlockSym) {
1122 if (s->value.db->ops->isArray)
1123 yget_dims(0, dims, &((Array *)s->value.db)->type);
1124 else if (s->value.db->ops == &lvalueOps)
1125 yget_dims(0, dims, &((LValue *)s->value.db)->type);
1126 else
1127 return -1;
1128 } else if (s->ops==&doubleScalar) {
1129 yget_dims(0, dims, &y_d_type);
1130 } else if (s->ops==&longScalar) {
1131 yget_dims(0, dims, &y_l_type);
1132 } else if (s->ops==&intScalar) {
1133 yget_dims(0, dims, &y_i_type);
1134 } else {
1135 return -1;
1136 }
1137 return cfmdims? yarg_conform(dims, cfmdims, cfmdims) : 0;
1138 }
1139 return -1;
1140 }
1141
1142 int
yarg_bcast(int iarg,long * newdims)1143 yarg_bcast(int iarg, long *newdims)
1144 {
1145 if (iarg >= 0) {
1146 Operations *ops;
1147 Member *type;
1148 void *p = ygeta_array(iarg, &ops, &type);
1149 if (p) {
1150 Symbol *s = sp - iarg;
1151 Array *a = PushDataBlock(NewArray(type->base, ypush_dims(newdims)));
1152 if (!Broadcast(a->value.c, a->type.dims, p, type->dims, type->base)) {
1153 if (s->ops == &dataBlockSym) {
1154 s->ops = &intScalar;
1155 Unref(s->value.db);
1156 }
1157 s->value = sp->value;
1158 s->ops = (sp--)->ops;
1159 return 0;
1160 }
1161 yarg_drop(1);
1162 }
1163 }
1164 return -1;
1165 }
1166
1167 char *
yfind_name(long vndex)1168 yfind_name(long vndex)
1169 {
1170 return (vndex>=0 && vndex<globalTable.nItems)?
1171 globalTable.names[vndex] : 0;
1172 }
1173
1174 long
yfind_global(const char * name,long len)1175 yfind_global(const char *name, long len)
1176 {
1177 if (HashFind(&globalTable, name, len))
1178 return hashIndex;
1179 else
1180 return -1;
1181 }
1182
1183 long
yget_global(const char * name,long len)1184 yget_global(const char *name, long len)
1185 {
1186 if (!HashAdd(&globalTable, name, len)) {
1187 HASH_MANAGE(globalTable, Symbol, globTab);
1188 globTab[hashIndex].ops= &dataBlockSym;
1189 globTab[hashIndex].value.db= RefNC(&nilDB);
1190 }
1191 return hashIndex;
1192 }
1193
1194 int
ypush_global(long vndex)1195 ypush_global(long vndex)
1196 {
1197 if (vndex>=0 && vndex<globalTable.nItems) {
1198 if (globTab[vndex].ops == &dataBlockSym)
1199 sp[1].value.db = Ref(globTab[vndex].value.db);
1200 else
1201 sp[1].value = globTab[vndex].value;
1202 sp[1].ops = globTab[vndex].ops;
1203 sp++;
1204 return 0;
1205 } else {
1206 return 1;
1207 }
1208 }
1209
1210 void
yput_global(long vndex,int iarg)1211 yput_global(long vndex, int iarg)
1212 {
1213 if (vndex>=0 && iarg>=0) {
1214 Symbol *s = sp -iarg;
1215 if (s->ops == &referenceSym) {
1216 if (s->index == vndex) return;
1217 s = &globTab[s->index];
1218 } else if (s->ops!=&dataBlockSym && s->ops!=&doubleScalar &&
1219 s->ops!=&longScalar && s->ops!=&intScalar) {
1220 y_error("illegal stack element type in yput_global");
1221 }
1222 if (globTab[vndex].ops == &dataBlockSym) {
1223 globTab[vndex].ops = &intScalar;
1224 Unref(globTab[vndex].value.db);
1225 }
1226 if (s->ops == &dataBlockSym)
1227 globTab[vndex].value.db = Ref(s->value.db);
1228 else
1229 globTab[vndex].value = s->value;
1230 globTab[vndex].ops = s->ops;
1231 }
1232 }
1233
1234 long
yget_ref(int iarg)1235 yget_ref(int iarg)
1236 {
1237 if (iarg>=0 && sp[-iarg].ops==&referenceSym)
1238 return sp[-iarg].index;
1239 else
1240 return -1;
1241 }
1242
1243 typedef struct y_userinst_t y_userinst_t;
1244
1245 union y_uo_body_t {
1246 char c[8];
1247 double d;
1248 void *p;
1249 void (*f)(void);
1250 };
1251
1252 typedef struct y_uo_t y_uo_t;
1253 struct y_uo_t {
1254 int references; /* reference counter */
1255 Operations *ops; /* virtual function table */
1256 y_userobj_t *uo_type;
1257 union y_uo_body_t body;
1258 };
1259
1260 static void y_uo_free(void *vuo);
1261 static void y_uo_eval(Operand *op);
1262 static void y_uo_extract(Operand *op, char *name);
1263 static void y_uo_print(Operand *op);
1264
1265 static void y_scratch_free(void *vuo);
1266
1267 static Operations y_uo_ops = {
1268 &y_uo_free, T_OPAQUE, 0, T_STRING, "scratch_object",
1269 {&PromXX, &PromXX, &PromXX, &PromXX, &PromXX, &PromXX, &PromXX, &PromXX},
1270 &ToAnyX, &ToAnyX, &ToAnyX, &ToAnyX, &ToAnyX, &ToAnyX, &ToAnyX,
1271 &NegateX, &ComplementX, &NotX, &TrueX,
1272 &AddX, &SubtractX, &MultiplyX, &DivideX, &ModuloX, &PowerX,
1273 &EqualX, &NotEqualX, &GreaterX, &GreaterEQX,
1274 &ShiftLX, &ShiftRX, &OrX, &AndX, &XorX,
1275 &AssignX, &y_uo_eval, &SetupX, &y_uo_extract, &MatMultX, &y_uo_print
1276 };
1277
ypush_obj(y_userobj_t * uo_type,unsigned long size)1278 void *ypush_obj(y_userobj_t *uo_type, unsigned long size)
1279 {
1280 y_uo_t *uo;
1281 if (! uo_type->uo_ops) {
1282 /* side effect on first call -- somewhat dangerous! */
1283 Operations *ops = p_malloc(sizeof(Operations));
1284 memcpy(ops, &y_uo_ops, sizeof(Operations));
1285 ops->typeName = uo_type->type_name;
1286 uo_type->uo_ops = ops; /* AFTER ops properly initialized */
1287 }
1288 uo = p_malloc(sizeof(y_uo_t) - sizeof(union y_uo_body_t) + size);
1289 memset(uo, 0, sizeof(y_uo_t) - sizeof(union y_uo_body_t) + size);
1290 uo->ops = uo_type->uo_ops;
1291 uo->uo_type = uo_type;
1292 PushDataBlock(uo);
1293 return uo->body.c;
1294 }
1295
1296 /* The function yfunc_obj initializes uo_ops member in a special way
1297 * for function like objects. It must be applied prior to the first
1298 * call to ypush_obj. Alternatively, you may push a new
1299 * function-like object by:
1300 * user_object = ypush_obj(yfunc_obj(uo_type), sizeof(user_object_type))
1301 */
1302 y_userobj_t *
yfunc_obj(y_userobj_t * uo_type)1303 yfunc_obj(y_userobj_t *uo_type)
1304 {
1305 Operations *ops;
1306 if (! uo_type->uo_ops) {
1307 if (! uo_type->on_eval) {
1308 y_error("(BUG) foreign function-like object with no on_eval method makes no sense");
1309 }
1310 ops = p_malloc(sizeof(Operations));
1311 memcpy(ops, &y_uo_ops, sizeof(Operations));
1312 ops->Setup = y_setup_func_hack;
1313 ops->typeName = uo_type->type_name;
1314 uo_type->uo_ops = ops; /* AFTER ops properly initialized */
1315 }
1316 return uo_type;
1317 }
1318
1319 static void
y_uo_free(void * vuo)1320 y_uo_free(void *vuo)
1321 {
1322 y_uo_t *uo = vuo;
1323 if (uo->uo_type->uo_ops != uo->ops)
1324 y_error("(BUG) corrupted user object in y_uo_free");
1325 if (uo->uo_type->on_free)
1326 uo->uo_type->on_free(uo->body.c);
1327 p_free(uo);
1328 }
1329
1330 static void
y_uo_eval(Operand * op)1331 y_uo_eval(Operand *op)
1332 {
1333 y_uo_t *uo = op->value;
1334 if (uo->uo_type->uo_ops != uo->ops)
1335 y_error("(BUG) corrupted user object in y_uo_eval");
1336 if (uo->uo_type->on_eval) {
1337 Symbol *stack;
1338 long owner = op->owner - spBottom;
1339 uo->uo_type->on_eval(uo->body.c, op->references); /*argc in references*/
1340 /* put result in correct place on stack, unless an interpreted
1341 * function has been pushed into place, in which case assume on_eval
1342 * took care of proper stack alignment
1343 */
1344 if (sp>spBottom+owner && sp->ops!=&returnSym) {
1345 Symbol *s = spBottom + owner;
1346 PopTo(s);
1347 while (sp - s > 0) {
1348 stack = sp--; /* sp decremented BEFORE stack element is deleted */
1349 if (stack->ops == &dataBlockSym) Unref(stack->value.db);
1350 }
1351 }
1352 } else {
1353 y_error("user object has no on_eval method");
1354 }
1355 }
1356
1357 static void
y_uo_extract(Operand * op,char * name)1358 y_uo_extract(Operand *op, char *name)
1359 {
1360 y_uo_t *uo = op->value;
1361 if (uo->uo_type->uo_ops != uo->ops)
1362 y_error("(BUG) corrupted user object in y_uo_extract");
1363 if (uo->uo_type->on_extract) {
1364 Symbol *stack;
1365 long owner = op->owner - spBottom, sp0 = sp - spBottom;
1366 uo->uo_type->on_extract(uo->body.c, name);
1367 PopTo(spBottom+owner);
1368 while (sp - spBottom > sp0) {
1369 stack = sp--; /* sp decremented BEFORE stack element is deleted */
1370 if (stack->ops == &dataBlockSym) Unref(stack->value.db);
1371 }
1372 } else {
1373 y_error("user object has no on_extract method");
1374 }
1375 }
1376
1377 static void
y_uo_print(Operand * op)1378 y_uo_print(Operand *op)
1379 {
1380 y_uo_t *uo = op->value;
1381 if (uo->uo_type->uo_ops != uo->ops)
1382 y_error("(BUG) corrupted user object in y_uo_print");
1383 if (uo->uo_type->on_print) {
1384 ForceNewline();
1385 uo->uo_type->on_print(uo->body.c);
1386 ForceNewline();
1387 } else {
1388 PrintX(op);
1389 }
1390 }
1391
1392 /* similar to yget_use, but no use increment */
1393 void *
yget_obj_s(DataBlock * db)1394 yget_obj_s(DataBlock *db)
1395 {
1396 y_uo_t *uo = (y_uo_t *)db;
1397 if (uo->uo_type->uo_ops != uo->ops)
1398 y_error("(BUG) corrupted user object in yget_obj_s");
1399 return uo->body.c;
1400 }
1401
1402 void *
yget_obj(int iarg,y_userobj_t * uo_type)1403 yget_obj(int iarg, y_userobj_t *uo_type)
1404 {
1405 if (iarg >= 0) {
1406 Symbol *s = sp - iarg;
1407 if (s->ops==&referenceSym) {
1408 /* change reference to global object into object itself */
1409 Symbol *g = &globTab[s->index];
1410 if (g->ops == &dataBlockSym) s->value.db = Ref(g->value.db);
1411 else s->value = g->value;
1412 s->ops = g->ops;
1413 }
1414 if (s->ops == &dataBlockSym) {
1415 if (!uo_type) {
1416 return s->value.db->ops->typeName;
1417 } else if (s->value.db->ops == uo_type->uo_ops) {
1418 y_uo_t *uo = (y_uo_t *)s->value.db;
1419 if (uo->uo_type->uo_ops != uo->ops)
1420 y_error("(BUG) corrupted user object in yget_obj");
1421 return uo->body.c;
1422 }
1423 }
1424 if (uo_type)
1425 y_errorq("expecting argument of type %s", uo_type->type_name);
1426 }
1427 return 0;
1428 }
1429
1430 void
y_print(const char * text,int newline)1431 y_print(const char *text, int newline)
1432 {
1433 PrintFunc(text);
1434 if (newline) ForceNewline();
1435 }
1436
1437 static Operations y_scratch_ops = {
1438 &y_scratch_free, T_OPAQUE, 0, T_STRING, "scratch_object",
1439 {&PromXX, &PromXX, &PromXX, &PromXX, &PromXX, &PromXX, &PromXX, &PromXX},
1440 &ToAnyX, &ToAnyX, &ToAnyX, &ToAnyX, &ToAnyX, &ToAnyX, &ToAnyX,
1441 &NegateX, &ComplementX, &NotX, &TrueX,
1442 &AddX, &SubtractX, &MultiplyX, &DivideX, &ModuloX, &PowerX,
1443 &EqualX, &NotEqualX, &GreaterX, &GreaterEQX,
1444 &ShiftLX, &ShiftRX, &OrX, &AndX, &XorX,
1445 &AssignX, &y_uo_eval, &SetupX, &y_uo_extract, &MatMultX, &y_uo_print
1446 };
1447
1448 y_userobj_t y_scratch_obj = { "scratch", 0, 0, 0, 0, &y_scratch_ops };
1449
1450 typedef struct y_scratch_t y_scratch_t;
1451 struct y_scratch_t {
1452 y_userobj_t uot;
1453 union y_uo_body_t body;
1454 };
1455
1456 static void
y_scratch_free(void * vuo)1457 y_scratch_free(void *vuo)
1458 {
1459 y_uo_t *uo = vuo;
1460 y_scratch_t *obj = (y_scratch_t *)uo->body.c;
1461 if (uo->uo_type->uo_ops != uo->ops)
1462 y_error("(BUG) corrupted user object in y_uo_free");
1463 if (obj->uot.on_free)
1464 obj->uot.on_free(obj->body.c);
1465 p_free(uo);
1466 }
1467
1468 void *
ypush_scratch(unsigned long size,void (* on_free)(void *))1469 ypush_scratch(unsigned long size, void (*on_free)(void *))
1470 {
1471 y_uo_t *uo;
1472 y_scratch_t *obj;
1473 uo = p_malloc(sizeof(y_uo_t) + sizeof(y_scratch_t)
1474 - 2*sizeof(union y_uo_body_t) + size);
1475 /* uo is a y_uo_t whose body begins with a copy of y_scratch_obj,
1476 * which is a y_userobj_t -- the specified on_free method gets
1477 * inserted into this copy, becoming a special y_userobj_t for
1478 * this scratch object only
1479 * after y_scratch_obj comes the size bytes of scratch space
1480 */
1481 uo->references = 0;
1482 uo->ops = &y_scratch_ops;
1483 obj = (y_scratch_t *)uo->body.c;
1484 uo->uo_type = &obj->uot;
1485 memcpy(&obj->uot, &y_scratch_obj, sizeof(y_userobj_t));
1486 obj->uot.on_free = on_free;
1487 memset(obj->body.c, 0, size);
1488 PushDataBlock(uo);
1489 return obj->body.c;
1490 }
1491
1492 void *
yget_use(int iarg)1493 yget_use(int iarg)
1494 {
1495 if (iarg >= 0) {
1496 DataBlock *db = ForceToDB(sp - iarg);
1497 if (db != &nilDB) return Ref(db);
1498 }
1499 return 0;
1500 }
1501
1502 void
ypush_use(void * handle)1503 ypush_use(void *handle)
1504 {
1505 if (!handle) ypush_nil();
1506 else PushDataBlock(handle);
1507 }
1508
1509 void
ykeep_use(void * handle)1510 ykeep_use(void *handle)
1511 {
1512 if (handle) {
1513 DataBlock *db = handle;
1514 PushDataBlock(RefNC(db));
1515 } else {
1516 ypush_nil();
1517 }
1518 }
1519
1520 void
ydrop_use(void * handle)1521 ydrop_use(void *handle)
1522 {
1523 DataBlock *db = handle;
1524 Unref(db);
1525 }
1526
1527 /* defined in task.c */
1528 extern void (*CleanUpForExit)(void);
1529 static void (*y_obsolete_cleanup)(void) = 0;
1530 static void yon_quit_caller(void);
1531 static struct yon_quit_t {
1532 void (*on_quit)(void);
1533 struct yon_quit_t *next;
1534 } *yon_quit_stack = 0;
1535 static
yon_quit_caller(void)1536 void yon_quit_caller(void)
1537 {
1538 struct yon_quit_t *oqcb = yon_quit_stack;
1539 while (oqcb) {
1540 oqcb->on_quit();
1541 oqcb = oqcb->next;
1542 }
1543 if (y_obsolete_cleanup) y_obsolete_cleanup();
1544 }
1545 static int yon_quit_installed = 0;
1546
1547 void
ycall_on_quit(void (* on_quit)(void))1548 ycall_on_quit(void (*on_quit)(void))
1549 {
1550 struct yon_quit_t *oqcb = yon_quit_stack;
1551 while (oqcb) {
1552 if (oqcb->on_quit == on_quit) return;
1553 oqcb = oqcb->next;
1554 }
1555 oqcb = p_malloc(sizeof(struct yon_quit_t));
1556 oqcb->on_quit = on_quit;
1557 oqcb->next = yon_quit_stack;
1558 yon_quit_stack = oqcb;
1559 if (!yon_quit_installed) {
1560 y_obsolete_cleanup = CleanUpForExit;
1561 CleanUpForExit = &yon_quit_caller;
1562 yon_quit_installed = 1;
1563 }
1564 }
1565
1566 void
ycancel_on_quit(void (* on_quit)(void))1567 ycancel_on_quit(void (*on_quit)(void))
1568 {
1569 struct yon_quit_t *oqcb = yon_quit_stack, **prev = &yon_quit_stack;
1570 while (oqcb) {
1571 if (oqcb->on_quit == on_quit) {
1572 *prev = oqcb->next;
1573 p_free(oqcb);
1574 return;
1575 }
1576 prev = &oqcb->next;
1577 oqcb = *prev;
1578 }
1579 }
1580
1581 void
y_error(const char * msg)1582 y_error(const char *msg)
1583 {
1584 YError(msg);
1585 }
1586
1587 static void y_ew_n(const char *msg_format, long n, int warn);
1588 static void y_ew_q(const char *msg_format, const char *q, int warn);
1589
1590 void
y_errorn(const char * msg_format,long n)1591 y_errorn(const char *msg_format, long n)
1592 {
1593 y_ew_n(msg_format, n, 0);
1594 }
1595
1596 void
y_errorq(const char * msg_format,const char * q)1597 y_errorq(const char *msg_format, const char *q)
1598 {
1599 y_ew_q(msg_format, q, 0);
1600 }
1601
1602 void
y_warn(const char * msg)1603 y_warn(const char *msg)
1604 {
1605 YWarning(msg);
1606 }
1607
1608 void
y_warnn(const char * msg_format,long n)1609 y_warnn(const char *msg_format, long n)
1610 {
1611 y_ew_n(msg_format, n, 1);
1612 }
1613
1614 void
y_warnq(const char * msg_format,const char * q)1615 y_warnq(const char *msg_format, const char *q)
1616 {
1617 y_ew_q(msg_format, q, 1);
1618 }
1619
1620 static void
y_ew_n(const char * msg_format,long n,int warn)1621 y_ew_n(const char *msg_format, long n, int warn)
1622 {
1623 char msg[192];
1624 long nmax = 130;
1625 long nmsg = 0;
1626 const char *fmt = strstr(msg_format, "%ld");
1627 if (!fmt) {
1628 fmt = strstr(msg_format, "%d");
1629 if (!fmt) fmt = msg_format + strlen(msg_format);
1630 }
1631 msg[0] = '\0';
1632 if (nmax > nmsg) {
1633 long len = fmt-msg_format;
1634 if (len > nmax-nmsg) len = nmax-nmsg;
1635 strncat(msg+nmsg, msg_format, len);
1636 nmsg += len;
1637 }
1638 if (nmax > nmsg) {
1639 sprintf(msg+nmsg, "%ld", n);
1640 nmsg += strlen(msg+nmsg);
1641 }
1642 if (nmax>nmsg && fmt[0]=='%') {
1643 fmt += 2;
1644 if (fmt[-1]=='l') fmt++;
1645 strncat(msg+nmsg, fmt, nmax-nmsg);
1646 }
1647 if (warn) YWarning(msg);
1648 else YError(msg);
1649 }
1650
1651 static void
y_ew_q(const char * msg_format,const char * q,int warn)1652 y_ew_q(const char *msg_format, const char *q, int warn)
1653 {
1654 char msg[192];
1655 long nmax = 130;
1656 long nmsg = 0;
1657 const char *fmt = strstr(msg_format, "%s");
1658 if (!fmt)
1659 fmt = msg_format + strlen(msg_format);
1660 msg[0] = '\0';
1661 if (nmax > nmsg) {
1662 long len = fmt-msg_format;
1663 if (len > nmax-nmsg) len = nmax-nmsg;
1664 strncat(msg+nmsg, msg_format, len);
1665 nmsg += len;
1666 }
1667 if (nmax > nmsg) {
1668 strncat(msg+nmsg, q, nmax-nmsg);
1669 nmsg += strlen(msg+nmsg);
1670 }
1671 if (nmax>nmsg && fmt[0]=='%') {
1672 fmt += 2;
1673 strncat(msg+nmsg, fmt, nmax-nmsg);
1674 }
1675 if (warn) YWarning(msg);
1676 else YError(msg);
1677 }
1678
1679 void
y_errquiet(void)1680 y_errquiet(void)
1681 {
1682 YError(".SYNC.");
1683 }
1684