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