1 /*
2 * $Id: ydata.c,v 1.6 2010-06-02 15:06:49 dhmunro Exp $
3 * Implement functions for Yorick-specific types of data.
4 */
5 /* Copyright (c) 2005, The Regents of the University of California.
6 * All rights reserved.
7 * This file is part of yorick (http://yorick.sourceforge.net).
8 * Read the accompanying LICENSE file for details.
9 */
10
11 #include "bcast.h"
12 #include "defmem.h"
13 #include "pstdlib.h"
14 #include <string.h>
15
16 /* Intended for use by the print() and grow() functions -- dangerous
17 because it zeroes the contents of the source array to avoid
18 having to deal with pointers. */
19 extern Array *GrowArray(Array *array, long extra);
20
21 extern BuiltIn Y_yorick_stats, Y_symbol_def, Y_symbol_set;
22 extern BuiltIn Y_symbol_names, Y_symbol_exists, Y_errs2caller;
23
24 /* Required for FetchLValue, StoreLValue */
25 extern void ReadGather(void *dst, void *srcM, long srcD, StructDef *base,
26 long number, const Strider *strider);
27 extern void WriteScatter(void *src, void *dstM, long dstD, StructDef *base,
28 long number, const Strider *strider);
29
30 /* function defined in yrdwr.c required for StoreLValue */
31 extern void SetSequentialWrite(IOStream *file, long last);
32
33 /*--------------------------------------------------------------------------*/
34
GrowArray(Array * array,long extra)35 Array *GrowArray(Array *array, long extra)
36 {
37 Array *result;
38 StructDef *base= array->type.base;
39 long number= array->type.number;
40 Dimension *tmp= tmpDims;
41 if (extra<=0) return array;
42 if (!array->type.dims)
43 array->type.dims= NewDimension(1L, 1L, (Dimension *)0);
44 tmpDims= 0;
45 FreeDimension(tmp);
46 tmpDims= CopyDims(array->type.dims, (Dimension *)0, 1);
47 tmpDims->number+= extra;
48 result= NewArray(base, tmpDims);
49
50 /* do direct copy of array to result, then ZERO array -- this avoids
51 potential cost of pointer copies */
52 memcpy(result->value.c, array->value.c, number*base->size);
53 if (base->Copy!=&CopyX) memset(array->value.c, 0, number*base->size);
54 return result;
55 }
56
NewFunction(Symbol * consts,long nConsts,int nPos,int nKey,int nLocal,long hasPL,int maxStackDepth,Instruction * code,long codeSize)57 Function *NewFunction(Symbol *consts, long nConsts, int nPos, int nKey,
58 int nLocal, long hasPL, int maxStackDepth,
59 Instruction *code, long codeSize)
60 {
61 Function *func= p_malloc(sizeof(Function)+codeSize*sizeof(Instruction));
62 long frameSize= 1+nPos+(hasPL&1)+nKey+nLocal;
63 Instruction *fcode= &func->code[frameSize];
64 long i;
65 func->references= 0;
66 func->ops= &functionOps;
67 func->constantTable= consts;
68 func->nConstants= nConsts;
69 /* guarantee 8 stack slots available for builtins, plus 2 for good luck */
70 func->nReq= frameSize+maxStackDepth+10;
71 func->nPos= nPos;
72 func->nKey= nKey;
73 func->nLocal= nLocal;
74 func->hasPosList= hasPL;
75 func->errup = 0;
76 func->isrc = -1;
77 codeSize-= frameSize-1;
78 /* YpFunc puts the frame variables (parameters and locals) at the end
79 of the code, switch them to the beginning now. */
80 for (i=0 ; i<codeSize ; i++) fcode[i]= code[i];
81 code+= codeSize;
82 fcode= func->code;
83 for (i=0 ; i<frameSize ; i++) fcode[i]= code[i];
84 return func;
85 }
86
FreeFunction(void * v)87 void FreeFunction(void *v) /* ******* Use Unref(func) ******* */
88 {
89 Function *func= v;
90 Symbol *cnst= func->constantTable;
91 if (cnst) { /* must free any string constants */
92 long n= func->nConstants;
93 while (n--) {
94 if (cnst->ops==&dataBlockSym) Unref(cnst->value.db);
95 cnst++;
96 }
97 p_free(func->constantTable);
98 }
99 p_free(func);
100 }
101
102 void
Y_errs2caller(int argc)103 Y_errs2caller(int argc)
104 {
105 Function *f;
106 int i;
107 for (i=argc-1 ; i>=0 ; i--) {
108 if (sp[-i].ops == &referenceSym) ReplaceRef(sp-i);
109 if (sp[-i].ops!=&dataBlockSym || sp[-i].value.db->ops!=&functionOps)
110 YError("errs2caller accepts only function arguments");
111 f = (Function *)sp[-i].value.db;
112 f->errup = 1;
113 }
114 }
115
116 /* Set up a block allocator which grabs space for 64 range objects
117 at a time. Since Range contains an ops pointer, the alignment
118 of a Range must be at least as strict as a void*. */
119 static MemryBlock rangeBlock= {0, 0, sizeof(Range),
120 64*sizeof(Range)};
121
NewRange(long min,long max,long inc,int nilFlags)122 Range *NewRange(long min, long max, long inc, int nilFlags)
123 {
124 Range *range= NextUnit(&rangeBlock);
125 range->references= 0;
126 range->ops= &rangeOps;
127 range->min= min;
128 range->max= max;
129 range->inc= inc;
130 range->nilFlags= nilFlags;
131 range->rf= 0;
132 return range;
133 }
134
FreeRange(void * range)135 void FreeRange(void *range) /* ******* Use Unref(range) ******* */
136 {
137 FreeUnit(&rangeBlock , range);
138 }
139
140 /* Set up a block allocator which grabs space for 64 lvalue objects
141 at a time. Since LValue contains several pointers, the alignment
142 of an LValue must be at least as strict as a void*. */
143 static MemryBlock lvalueBlock= {0, 0, sizeof(LValue),
144 64*sizeof(LValue)};
145
NewLValueD(long address,StructDef * base,Dimension * dims)146 LValue *NewLValueD(long address, StructDef *base, Dimension *dims)
147 {
148 long number= TotalNumber(dims);
149 LValue *lvalue= NextUnit(&lvalueBlock);
150 lvalue->references= 0;
151 lvalue->ops= &lvalueOps;
152 lvalue->owner= 0;
153 lvalue->type.base= Ref(base);
154 lvalue->type.dims= Ref(dims);
155 lvalue->type.number= number;
156 lvalue->address.d= address;
157 lvalue->strider= 0;
158 return lvalue;
159 }
160
NewLValueM(Array * owner,void * address,StructDef * base,Dimension * dims)161 LValue *NewLValueM(Array *owner, void *address,
162 StructDef *base, Dimension *dims)
163 {
164 long number= TotalNumber(dims);
165 LValue *lvalue= NextUnit(&lvalueBlock);
166 lvalue->references= 0;
167 lvalue->ops= &lvalueOps;
168 lvalue->owner= Ref(owner);
169 lvalue->type.base= Ref(base);
170 lvalue->type.dims= Ref(dims);
171 lvalue->type.number= number;
172 lvalue->address.m= address;
173 lvalue->strider= 0;
174 return lvalue;
175 }
176
FreeLValue(void * v)177 void FreeLValue(void *v) /* ******* Use Unref(lvalue) ******* */
178 {
179 LValue *lvalue= v;
180 Unref(lvalue->owner);
181 Unref(lvalue->type.base);
182 FreeDimension(lvalue->type.dims);
183 FreeStrider(lvalue->strider);
184 FreeUnit(&lvalueBlock, lvalue);
185 }
186
187 /* Set up a block allocator which grabs space for 16 BIFunction
188 objeccts at a time. */
189 static MemryBlock bifBlock= {0, 0, sizeof(BIFunction),
190 16*sizeof(BIFunction)};
191
NewBIFunction(BuiltIn * bi,long index)192 BIFunction *NewBIFunction(BuiltIn *bi, long index)
193 {
194 BIFunction *func= NextUnit(&bifBlock);
195 func->references= 0;
196 func->ops= &builtinOps;
197 func->function= bi;
198 func->index= index;
199 return func;
200 }
201
202 static char warning[72];
203
FreeBIFunction(void * bif)204 void FreeBIFunction(void *bif)
205 {
206 BIFunction *func= bif;
207 strcpy(warning, "freeing builtin function ");
208 strncat(warning,
209 func->index>=0? globalTable.names[func->index] : "<nameless>", 40L);
210 YWarning(warning);
211 FreeUnit(&bifBlock, func);
212 }
213
214 /*--------------------------------------------------------------------------*/
215
216 /* The basic idea of FetchLValue is to convert an LValue into an Array.
217 This Array is created on the stack, but then popped into the given
218 destination Symbol (usually the one holding the input LValue). */
FetchLValue(void * db,Symbol * dsts)219 Array *FetchLValue(void *db, Symbol *dsts)
220 {
221 LValue *lvalue= db;
222 StructDef *base= lvalue->type.base;
223 StructDef *model= base;
224 IOStream *file= base->file;
225 char *memory= file? 0 : lvalue->address.m;
226 Array *darray;
227 void *data;
228
229 while (model->model) model= model->model;
230
231 darray= PushDataBlock(NewArray(model, lvalue->type.dims));
232 data= darray->value.c;
233
234 ReadGather(data, memory, lvalue->address.d,
235 base, lvalue->type.number, lvalue->strider);
236 if (file && file->pointeeList.table.nItems) ClearPointees(file, 0);
237
238 PopTo(dsts);
239 return darray;
240 }
241
242 /* StoreLValue stores the data in data to the specified LValue.
243 This may require data conversion operations. The input data
244 MUST be of the type given by base->model->...->model, NOT base. */
StoreLValue(void * db,void * data)245 void StoreLValue(void *db, void *data)
246 {
247 LValue *lvalue= db;
248 StructDef *base= lvalue->type.base;
249 IOStream *file= base->file;
250 char *memory;
251 long disk, number= lvalue->type.number;
252
253 if (file) {
254 disk= lvalue->address.d;
255 memory= 0; /* signal for WriteScatter to call WritePointees */
256 if (base->addressType==2)
257 SetSequentialWrite(file, disk+base->size*number);
258 } else {
259 memory= lvalue->address.m;
260 disk= 0;
261 }
262
263 WriteScatter(data, memory, disk, base, number, lvalue->strider);
264 if (file && file->pointeeList.table.nItems) ClearPointees(file, 1);
265 }
266
267 /*--------------------------------------------------------------------------*/
268
269 Symbol *globTab= 0;
270 HashTable globalTable;
271
Globalize(const char * name,long n)272 long Globalize(const char *name, long n)
273 {
274 if (!HashAdd(&globalTable, name, n)) {
275 HASH_MANAGE(globalTable, Symbol, globTab);
276 globTab[hashIndex].ops= &dataBlockSym;
277 globTab[hashIndex].value.db= RefNC(&nilDB);
278 }
279 return hashIndex;
280 }
281
GlobalizeDB(const char * name,long n,void * db)282 long GlobalizeDB(const char *name, long n, void *db)
283 {
284 long index= Globalize(name, n);
285 if (globTab[index].ops==&dataBlockSym) {
286 Unref(globTab[index].value.db);
287 globTab[index].value.db= db;
288 } else {
289 globTab[index].value.db= db;
290 globTab[index].ops= &dataBlockSym;
291 }
292 return index;
293 }
294
295 /*--------------------------------------------------------------------------*/
296
297 extern long yStackBlock, yStackSize;
298 long yStackBlock= 64; /* number of stack elements to allocate at a time */
299 long yStackSize= 0; /* current virtual machine stack size */
300
301 Symbol *spBottom= 0; /* bottom of virtual machine stack */
302 Symbol *sp= 0; /* current top of stack */
303 /* spBottom may change if the stack must be lengthened by CheckStack -
304 spBottom is an extern so that the comination sp-spBottom may be
305 computed and saved to refer to a given stack element */
306
CheckStack(int n)307 int CheckStack(int n)
308 {
309 long nNow= sp-spBottom;
310 long nRequired= nNow + n;
311 if (nRequired >= yStackSize) {
312 nRequired= yStackBlock*(1 + nRequired/yStackBlock);
313 sp= p_realloc(spBottom, sizeof(Symbol)*nRequired);
314 if (!sp) YError("memory manager failed in CheckStack");
315 spBottom= sp;
316 spBottom->ops= &intScalar;
317 spBottom->value.i= 0;
318 sp+= nNow;
319 yStackSize= nRequired;
320 return 1;
321 } else {
322 return 0;
323 }
324 }
325
PushIntValue(int i)326 void PushIntValue(int i)
327 {
328 register Symbol *stack= sp+1;
329 stack->ops= &intScalar;
330 stack->value.i= i;
331 sp= stack; /* sp updated AFTER new stack element intact */
332 }
333
PushLongValue(long l)334 void PushLongValue(long l)
335 {
336 register Symbol *stack= sp+1;
337 stack->ops= &longScalar;
338 stack->value.l= l;
339 sp= stack; /* sp updated AFTER new stack element intact */
340 }
341
PushDoubleValue(double d)342 void PushDoubleValue(double d)
343 {
344 register Symbol *stack= sp+1;
345 stack->ops= &doubleScalar;
346 stack->value.d= d;
347 sp= stack; /* sp updated AFTER new stack element intact */
348 }
349
PushCopy(Symbol * s)350 int PushCopy(Symbol *s)
351 {
352 register int isDB= (s->ops==&dataBlockSym);
353 register Symbol *stack= sp+1;
354 stack->ops= s->ops;
355 if (isDB) stack->value.db= Ref(s->value.db);
356 else stack->value= s->value;
357 sp= stack; /* sp updated AFTER new stack element intact */
358 return isDB;
359 }
360
PushDataBlock(void * db)361 void *PushDataBlock(void *db)
362 {
363 register Symbol *stack= sp+1;
364 stack->ops= &dataBlockSym;
365 stack->value.db= db; /* does NOT increment reference counter */
366 sp= stack; /* sp updated AFTER new stack element intact */
367 return db;
368 }
369
Drop(int n)370 void Drop(int n)
371 {
372 register Symbol *stack;
373 while (n--) {
374 stack= sp--;
375 /* sp decremented BEFORE stack element is deleted */
376 if (stack->ops==&dataBlockSym) Unref(stack->value.db);
377 }
378 }
379
PopTo(Symbol * s)380 void PopTo(Symbol *s)
381 {
382 DataBlock *old= s->ops==&dataBlockSym? s->value.db : 0;
383 Symbol *stack= sp--;
384 s->value= stack->value;
385 s->ops= stack->ops;
386 Unref(old);
387 }
388
389 /*--------------------------------------------------------------------------*/
390
ReplaceRef(Symbol * stack)391 void ReplaceRef(Symbol *stack)
392 {
393 Symbol *ref;
394 if (stack->ops!=&referenceSym) return;
395 ref= &globTab[stack->index];
396 if (ref->ops==&dataBlockSym) stack->value.db= Ref(ref->value.db);
397 else stack->value= ref->value;
398 stack->ops= ref->ops; /* change ops only AFTER value updated */
399 }
400
401 /*--------------------------------------------------------------------------*/
402
403 static int EvenConform(Dimension *ldims, Dimension *rdims);
404 static void BdCast(Operand *op, Dimension *ddims);
405
406 /* Conform returns a bit mask indicating the status of the conformability
407 test:
408 1 - right operand must be broadcast
409 2 - left operand must be broadcast
410 4 - not conformable
411 8 - right operand has at least as many dimensions as left
412 16 - left operand has at least as many dimensions as right */
Conform(Dimension * ldims,Dimension * rdims)413 int Conform(Dimension *ldims, Dimension *rdims)
414 {
415 int nl= CountDims(ldims);
416 int nr= CountDims(rdims);
417 int n= nl-nr;
418 int casts;
419
420 Dimension *prev, *next= tmpDims;
421 tmpDims= 0;
422 FreeDimension(next);
423
424 if (n==0) {
425 /* same number of dimensions */
426 if (nl==0) return 24; /* both scalar */
427 casts= 24 | EvenConform(ldims, rdims);
428
429 } else if (n>0) {
430 /* left array is higher rank */
431 casts= 16;
432 while (n--) {
433 if (ldims->number>1) casts|= 1; /* must broadcast right operand */
434 tmpDims= NewDimension(ldims->number, ldims->origin, tmpDims);
435 ldims= ldims->next;
436 }
437 casts|= EvenConform(ldims, rdims);
438
439 } else {
440 /* right array is higher rank */
441 casts= 8;
442 while (n++) {
443 if (rdims->number>1) casts|= 2; /* must broadcast left operand */
444 tmpDims= NewDimension(rdims->number, rdims->origin, tmpDims);
445 rdims= rdims->next;
446 }
447 casts|= EvenConform(ldims, rdims);
448 }
449
450 /* tmpDims is reversed, switch it back (already did tmpDims!=0) */
451 prev= 0;
452 for (;;) {
453 next= tmpDims->next;
454 tmpDims->next= prev;
455 if (!next) break;
456 prev= tmpDims;
457 tmpDims= next;
458 }
459
460 return casts;
461 }
462
EvenConform(Dimension * ldims,Dimension * rdims)463 static int EvenConform(Dimension *ldims, Dimension *rdims)
464 {
465 long lnum, rnum;
466 int casts= 0;
467 while (ldims) {
468 lnum= ldims->number;
469 ldims= ldims->next;
470 rnum= rdims->number;
471 rdims= rdims->next;
472 if (lnum!=rnum) {
473 if (lnum==1) {
474 casts|= 2; /* must broadcast left operand */
475 lnum= rnum;
476 } else if (rnum==1) {
477 casts|= 1; /* must broadcast right operand */
478 } else {
479 casts|= 4; /* not conformable */
480 lnum= -lnum-rnum; /* error marker */
481 }
482 }
483 tmpDims= NewDimension(lnum, 1L, tmpDims);
484 }
485 return casts;
486 }
487
BdCast(Operand * op,Dimension * ddims)488 static void BdCast(Operand *op, Dimension *ddims)
489 {
490 StructDef *base= op->type.base;
491 Array *dst= PushDataBlock(NewArray(base, ddims));
492 Broadcast(dst->value.c, ddims, op->value, op->type.dims, base);
493 PopTo(op->owner);
494 op->references= 0;
495 op->type.dims= ddims;
496 op->type.number= dst->type.number;
497 op->value= dst->value.c;
498 }
499
BinaryConform(Operand * l,Operand * r)500 int BinaryConform(Operand *l, Operand *r)
501 {
502 int casts= Conform(l->type.dims, r->type.dims);
503 if (casts&4) return 4;
504 if (casts&2) BdCast(l, tmpDims);
505 else if ((casts&16) && !l->references) casts|= 2;
506 if (casts&1) BdCast(r, tmpDims);
507 else if ((casts&8) && !r->references) casts|= 1;
508 return casts & 7;
509 }
510
RightConform(Dimension * ldims,Operand * r)511 int RightConform(Dimension *ldims, Operand *r)
512 {
513 int casts= Conform(ldims, r->type.dims);
514 if (casts&6) return 4;
515 else if (casts&1) BdCast(r, tmpDims);
516 return 0;
517 }
518
519 /*--------------------------------------------------------------------------*/
520
521 extern VMaction DropTop;
CalledAsSubroutine(void)522 int CalledAsSubroutine(void)
523 {
524 return pc->Action==&DropTop;
525 }
526
527 Operand *
yarg_op(int iarg,Operand * op)528 yarg_op(int iarg, Operand *op)
529 {
530 if (iarg>=0) {
531 Symbol *s = sp - iarg;
532 if (s->ops) s->ops->FormOperand(s, op);
533 else op->ops=0, op=0;
534 } else {
535 op = 0;
536 }
537 return op;
538 }
539
YGetInteger(Symbol * s)540 long YGetInteger(Symbol *s)
541 {
542 Operand op;
543 if (!s->ops) YError("unexpected keyword argument");
544 s->ops->FormOperand(s, &op);
545 if (op.ops->typeID<=T_LONG && !op.type.dims) {
546 op.ops->ToLong(&op);
547 } else {
548 YError("expecting scalar integer argument");
549 }
550 return *(long *)op.value;
551 }
552
553 long
yarg_sl(int iarg)554 yarg_sl(int iarg)
555 {
556 return (iarg>=0)? YGetInteger(sp-iarg) : 0;
557 }
558
YGetReal(Symbol * s)559 double YGetReal(Symbol *s)
560 {
561 Operand op;
562 if (!s->ops) YError("unexpected keyword argument");
563 s->ops->FormOperand(s, &op);
564 if (op.ops->typeID<=T_DOUBLE && !op.type.dims) {
565 op.ops->ToDouble(&op);
566 } else {
567 YError("expecting scalar real argument");
568 }
569 return *(double *)op.value;
570 }
571
572 double
yarg_sd(int iarg)573 yarg_sd(int iarg)
574 {
575 return (iarg>=0)? YGetReal(sp-iarg) : 0;
576 }
577
YGetString(Symbol * s)578 char *YGetString(Symbol *s)
579 {
580 Operand op;
581 if (!s->ops) YError("unexpected keyword argument");
582 s->ops->FormOperand(s, &op);
583 if (op.ops->typeID!=T_STRING || op.type.dims)
584 YError("expecting scalar string argument");
585 return *(char **)op.value;
586 }
587
588 char *
yarg_sq(int iarg)589 yarg_sq(int iarg)
590 {
591 return (iarg>=0)? YGetString(sp-iarg) : 0;
592 }
593
YNotNil(Symbol * s)594 int YNotNil(Symbol *s)
595 {
596 if (!s) return 0; /* for use with YGetKeywords */
597 if (s->ops==&referenceSym) ReplaceRef(s);
598 return !(s->ops==&dataBlockSym && s->value.db==&nilDB);
599 }
600
YGetKeywords(Symbol * stack,int nArgs,char ** keyNames,Symbol ** symbols)601 Symbol *YGetKeywords(Symbol *stack, int nArgs, char **keyNames,
602 Symbol **symbols)
603 {
604 int i;
605 char *globName;
606 Symbol *s0= 0;
607 for (i=0 ; keyNames[i] ; i++) symbols[i]= 0;
608 for ( ; nArgs>0 ; stack++, nArgs--) {
609 if (stack->ops) {
610 if (!s0) s0= stack;
611 continue;
612 }
613 globName= globalTable.names[stack->index];
614 for (i=0 ; keyNames[i] ; i++)
615 if (strcmp(globName, keyNames[i])==0) break;
616 if (!keyNames[i])
617 YError("unrecognized keyword in builtin function call");
618 symbols[i]= ++stack;
619 nArgs--;
620 }
621 return s0? s0 : stack+1;
622 }
623
624 int
yarg_keys(int iarg,char ** knames,Symbol ** ksymbols)625 yarg_keys(int iarg, char **knames, Symbol **ksymbols)
626 {
627 char *key;
628 int i;
629 while (iarg > 0) {
630 if (sp[-iarg].ops) break;
631 key = globalTable.names[sp[-(iarg--)].index];
632 for (i=0 ; knames[i] ; i++) {
633 if (ksymbols[i]) continue;
634 if (strcmp(key, knames[i]) == 0) break;
635 }
636 if (!knames[i])
637 YError("unrecognized or duplicate keyword");
638 ksymbols[i] = sp - (iarg--);
639 }
640 return iarg;
641 }
642
YGetFile(Symbol * stack)643 IOStream *YGetFile(Symbol *stack)
644 {
645 IOStream *file;
646 Operand op;
647 op.ops= 0;
648 if (stack->ops) stack->ops->FormOperand(stack, &op);
649 if (op.ops!=&streamOps)
650 YError("expecting binary file as function argument");
651 file= op.value;
652 return file;
653 }
654
655 IOStream *
yarg_file(int iarg)656 yarg_file(int iarg)
657 {
658 return (iarg>=0)? YGetFile(sp-iarg) : 0;
659 }
660
661 /*--------------------------------------------------------------------------*/
662
663 /* Retrieve array arguments for foreign code wrappers,
664 applying type conversion (modifies s) if necessary.
665 -- Just cast YGetInteger, YGetReal for scalar arguments, and
666 use YGetString for scalar strings. */
667
YGet_C(Symbol * s,int nilOK,Dimension ** dims)668 char *YGet_C(Symbol *s, int nilOK, Dimension **dims)
669 {
670 Operand op;
671 if (!s->ops) YError("unexpected keyword argument");
672 s->ops->FormOperand(s, &op);
673 if (nilOK && op.ops==&voidOps) { if (dims) *dims= 0; return 0;}
674 op.ops->ToChar(&op);
675 if (dims) *dims= op.type.dims;
676 return op.value;
677 }
678
679 char *
yarg_c(int iarg,Dimension ** dims)680 yarg_c(int iarg, Dimension **dims)
681 {
682 return (iarg>=0)? YGet_C(sp-iarg, 0, dims) : 0;
683 }
684
YGet_S(Symbol * s,int nilOK,Dimension ** dims)685 short *YGet_S(Symbol *s, int nilOK, Dimension **dims)
686 {
687 Operand op;
688 if (!s->ops) YError("unexpected keyword argument");
689 s->ops->FormOperand(s, &op);
690 if (nilOK && op.ops==&voidOps) { if (dims) *dims= 0; return 0;}
691 op.ops->ToShort(&op);
692 if (dims) *dims= op.type.dims;
693 return op.value;
694 }
695
696 short *
yarg_s(int iarg,Dimension ** dims)697 yarg_s(int iarg, Dimension **dims)
698 {
699 return (iarg>=0)? YGet_S(sp-iarg, 0, dims) : 0;
700 }
701
YGet_I(Symbol * s,int nilOK,Dimension ** dims)702 int *YGet_I(Symbol *s, int nilOK, Dimension **dims)
703 {
704 Operand op;
705 if (!s->ops) YError("unexpected keyword argument");
706 if (s->ops==&referenceSym && globTab[s->index].ops==&intScalar) {
707 if (dims) *dims= 0;
708 return &globTab[s->index].value.i;
709 }
710 s->ops->FormOperand(s, &op);
711 if (nilOK && op.ops==&voidOps) { if (dims) *dims= 0; return 0;}
712 op.ops->ToInt(&op);
713 if (dims) *dims= op.type.dims;
714 return op.value;
715 }
716
717 int *
yarg_i(int iarg,Dimension ** dims)718 yarg_i(int iarg, Dimension **dims)
719 {
720 return (iarg>=0)? YGet_I(sp-iarg, 0, dims) : 0;
721 }
722
YGet_L(Symbol * s,int nilOK,Dimension ** dims)723 long *YGet_L(Symbol *s, int nilOK, Dimension **dims)
724 {
725 Operand op;
726 if (!s->ops) YError("unexpected keyword argument");
727 if (s->ops==&referenceSym && globTab[s->index].ops==&longScalar) {
728 if (dims) *dims= 0;
729 return &globTab[s->index].value.l;
730 }
731 s->ops->FormOperand(s, &op);
732 if (nilOK && op.ops==&voidOps) { if (dims) *dims= 0; return 0;}
733 op.ops->ToLong(&op);
734 if (dims) *dims= op.type.dims;
735 return op.value;
736 }
737
738 long *
yarg_l(int iarg,Dimension ** dims)739 yarg_l(int iarg, Dimension **dims)
740 {
741 return (iarg>=0)? YGet_L(sp-iarg, 0, dims) : 0;
742 }
743
YGet_F(Symbol * s,int nilOK,Dimension ** dims)744 float *YGet_F(Symbol *s, int nilOK, Dimension **dims)
745 {
746 Operand op;
747 if (!s->ops) YError("unexpected keyword argument");
748 s->ops->FormOperand(s, &op);
749 if (nilOK && op.ops==&voidOps) { if (dims) *dims= 0; return 0;}
750 op.ops->ToFloat(&op);
751 if (dims) *dims= op.type.dims;
752 return op.value;
753 }
754
755 float *
yarg_f(int iarg,Dimension ** dims)756 yarg_f(int iarg, Dimension **dims)
757 {
758 return (iarg>=0)? YGet_F(sp-iarg, 0, dims) : 0;
759 }
760
YGet_D(Symbol * s,int nilOK,Dimension ** dims)761 double *YGet_D(Symbol *s, int nilOK, Dimension **dims)
762 {
763 Operand op;
764 if (!s->ops) YError("unexpected keyword argument");
765 if (s->ops==&referenceSym && globTab[s->index].ops==&doubleScalar) {
766 if (dims) *dims= 0;
767 return &globTab[s->index].value.d;
768 }
769 s->ops->FormOperand(s, &op);
770 if (nilOK && op.ops==&voidOps) { if (dims) *dims= 0; return 0;}
771 op.ops->ToDouble(&op);
772 if (dims) *dims= op.type.dims;
773 return op.value;
774 }
775
776 double *
yarg_d(int iarg,Dimension ** dims)777 yarg_d(int iarg, Dimension **dims)
778 {
779 return (iarg>=0)? YGet_D(sp-iarg, 0, dims) : 0;
780 }
781
YGet_Z(Symbol * s,int nilOK,Dimension ** dims)782 double *YGet_Z(Symbol *s, int nilOK, Dimension **dims)
783 {
784 Operand op;
785 if (!s->ops) YError("unexpected keyword argument");
786 s->ops->FormOperand(s, &op);
787 if (nilOK && op.ops==&voidOps) { if (dims) *dims= 0; return 0;}
788 op.ops->ToComplex(&op);
789 if (dims) *dims= op.type.dims;
790 return op.value;
791 }
792
793 double *
yarg_z(int iarg,Dimension ** dims)794 yarg_z(int iarg, Dimension **dims)
795 {
796 return (iarg>=0)? YGet_Z(sp-iarg, 0, dims) : 0;
797 }
798
YGet_Q(Symbol * s,int nilOK,Dimension ** dims)799 char **YGet_Q(Symbol *s, int nilOK, Dimension **dims)
800 {
801 Operand op;
802 if (!s->ops) YError("unexpected keyword argument");
803 s->ops->FormOperand(s, &op);
804 if (nilOK && op.ops==&voidOps) { if (dims) *dims= 0; return 0;}
805 if (op.ops->typeID!=T_STRING) YError("expecting string argument");
806 if (dims) *dims= op.type.dims;
807 return op.value;
808 }
809
810 char **
yarg_q(int iarg,Dimension ** dims)811 yarg_q(int iarg, Dimension **dims)
812 {
813 return (iarg>=0)? YGet_Q(sp-iarg, 0, dims) : 0;
814 }
815
YGet_P(Symbol * s,int nilOK,Dimension ** dims)816 void **YGet_P(Symbol *s, int nilOK, Dimension **dims)
817 {
818 Operand op;
819 if (!s->ops) YError("unexpected keyword argument");
820 s->ops->FormOperand(s, &op);
821 if (nilOK && op.ops==&voidOps) { if (dims) *dims= 0; return 0;}
822 if (op.ops->typeID!=T_POINTER) YError("expecting pointer argument");
823 if (dims) *dims= op.type.dims;
824 return op.value;
825 }
826
827 void **
yarg_p(int iarg,Dimension ** dims)828 yarg_p(int iarg, Dimension **dims)
829 {
830 return (iarg>=0)? YGet_P(sp-iarg, 0, dims) : 0;
831 }
832
YGet_dims(const Dimension * dims,long * dlist,int maxDims)833 int YGet_dims(const Dimension *dims, long *dlist, int maxDims)
834 {
835 int i, n= CountDims(dims);
836 for (i=1 ; i<=n ; i++) {
837 if (n-i < maxDims) dlist[n-i]= dims->number;
838 dims= dims->next;
839 }
840 return n;
841 }
842
YGet_Ref(Symbol * s)843 long YGet_Ref(Symbol *s)
844 {
845 if (s->ops!=&referenceSym)
846 YError("expecting simple variable reference as argument");
847 return s->index;
848 }
849
YPut_Result(Symbol * s,long index)850 void YPut_Result(Symbol *s, long index)
851 {
852 Symbol *sout= &globTab[index];
853 if (sout->ops==&dataBlockSym) {
854 sout->ops= &intScalar;
855 Unref(sout->value.db);
856 }
857 if (s->ops==&dataBlockSym) sout->value.db= Ref(s->value.db);
858 else sout->value= s->value;
859 sout->ops= s->ops;
860 }
861
862 /*--------------------------------------------------------------------------*/
863
ExtraNilRefs(void)864 static long ExtraNilRefs(void)
865 {
866 long i, expectNil= 0;
867 Symbol *s;
868 for (i=0 ; i<globalTable.nItems ; i++)
869 if (globTab[i].value.db==&nilDB && globTab[i].ops==&dataBlockSym)
870 expectNil++;
871 for (s=spBottom ; s<=sp ; s++)
872 if (s->value.db==&nilDB && s->ops==&dataBlockSym) expectNil++;
873 return nilDB.references - expectNil;
874 }
875
Y_yorick_stats(int nArgs)876 void Y_yorick_stats(int nArgs)
877 {
878 Array *result;
879 Dimension *dims= tmpDims;
880 tmpDims= 0;
881 FreeDimension(dims);
882 tmpDims= NewDimension(14L, 1L, (Dimension *)0);
883 result= PushDataBlock(NewArray(&longStruct, tmpDims));
884 result->value.l[0]= globalTable.nItems;
885 result->value.l[1]= yStackSize;
886 result->value.l[2]= p_nallocs-p_nfrees;
887 result->value.l[3]= p_asmall;
888 result->value.l[4]= ExtraNilRefs();
889 result->value.l[5]= charStruct.references;
890 result->value.l[6]= shortStruct.references;
891 result->value.l[7]= intStruct.references;
892 result->value.l[8]= longStruct.references;
893 result->value.l[9]= floatStruct.references;
894 result->value.l[10]= doubleStruct.references;
895 result->value.l[11]= complexStruct.references;
896 result->value.l[12]= stringStruct.references;
897 result->value.l[13]= pointerStruct.references;
898 }
899
Y_symbol_def(int nArgs)900 void Y_symbol_def(int nArgs)
901 {
902 long index;
903 Symbol *spp;
904 if (nArgs!=1) YError("symbol_def takes exactly one argument");
905 if (!HashFind(&globalTable, YGetString(sp), 0L))
906 YError("symbol_def name not in global symbol table");
907 index= hashIndex;
908 Drop(2);
909 spp= sp+1;
910 spp->ops= &referenceSym;
911 spp->index= index;
912 sp= spp;
913 ReplaceRef(sp);
914 }
915
Y_symbol_set(int nArgs)916 void Y_symbol_set(int nArgs)
917 {
918 Symbol *glob, *spp= sp-1;
919 if (nArgs!=2 ||
920 !spp->ops) YError("symbol_set takes exactly two arguments");
921 glob= &globTab[Globalize(YGetString(spp), 0L)];
922 ReplaceRef(sp);
923 /* following copied from Define function in ops3.c */
924 if (glob->ops==&dataBlockSym) {
925 DataBlock *db= glob->value.db;
926 if (db->ops==&lvalueOps) {
927 /* copied from ops3.c:DoAssign */
928 LValue *lvalue = (LValue *)db;
929 Operations *ops= lvalue->type.base->dataOps;
930 Operand rhs;
931 sp->ops->FormOperand(sp, &rhs);
932 if (rhs.ops->isArray && RightConform(lvalue->type.dims, &rhs))
933 YError("rhs not conformable with lhs in assign =");
934 ops->Assign((Operand *)lvalue, &rhs);
935 return;
936 } else {
937 glob->ops= &intScalar;
938 Unref(db);
939 }
940 }
941 if (sp->ops==&dataBlockSym) {
942 Array *array= (Array *)sp->value.db;
943 if (array->references && array->ops->isArray) {
944 /* copy non-temporary arrays to avoid unexpected aliasing */
945 Array *result= NewArray(array->type.base, array->type.dims);
946 glob->value.db= (DataBlock *)result;
947 array->type.base->Copy(array->type.base, result->value.c,
948 array->value.c, array->type.number);
949 } else {
950 if (array->ops==&lvalueOps) FetchLValue(array, sp);
951 glob->value.db= Ref(sp->value.db);
952 }
953 } else {
954 glob->value= sp->value;
955 }
956 glob->ops= sp->ops;
957 }
958
Y_symbol_exists(int argc)959 void Y_symbol_exists(int argc)
960 {
961 if (argc != 1) YError("symbol_exists takes exactly one argument");
962 PushIntValue(HashFind(&globalTable, YGetString(sp), 0L));
963 }
964
965 #define GET_ARRAY 1
966 #define GET_STRUCT 2
967 #define GET_RANGE 4
968 #define GET_VOID 8
969 #define GET_FUNCTION 16
970 #define GET_BUILTIN 32
971 #define GET_STRUCTDEF 64
972 #define GET_STREAM 128
973 #define GET_OPAQUE 256
974 #define GET_LIST 512
975 #define GET_AUTOLOAD 1024
976
Y_symbol_names(int argc)977 void Y_symbol_names(int argc)
978 {
979 extern Operations listOps;
980 long i, nitems, number;
981 char **ret;
982 int match[T_OPAQUE+1];
983 int type, flags, pass;
984 int omit_array, omit_list, omit_autoload, omit_opaque;
985 Dimension *dims = tmpDims;
986
987 tmpDims = (Dimension *)0;
988 if (dims != (Dimension *)0) FreeDimension(dims);
989 if (argc != 1) YError("symbol_list takes exactly one argument");
990 if (YNotNil(sp)) {
991 flags = YGetInteger(sp);
992 } else {
993 flags = (GET_ARRAY | GET_STRUCT | GET_RANGE | GET_FUNCTION | GET_BUILTIN |
994 GET_STRUCTDEF | GET_STREAM | GET_OPAQUE);
995 }
996 nitems = globalTable.nItems;
997 if (nitems <= 0) {
998 /* No symbols defined. */
999 PushDataBlock(RefNC(&nilDB));
1000 return;
1001 }
1002 if (flags == -1) {
1003 /* Return names of all symbols ever defined. */
1004 tmpDims = NewDimension(nitems, 1L, (Dimension *)0);
1005 ret = ((Array *)PushDataBlock(NewArray(&stringStruct, tmpDims)))->value.q;
1006 for (i = 0; i < nitems; ++i) {
1007 ret[i] = p_strcpy(globalTable.names[i]);
1008 }
1009 return;
1010 }
1011 omit_array = ((flags & GET_ARRAY) == 0);
1012 omit_list = ((flags & GET_LIST) == 0);
1013 omit_autoload = ((flags & GET_AUTOLOAD) == 0);
1014 omit_opaque = ((flags & GET_OPAQUE) == 0);
1015 if ((flags & (GET_LIST | GET_AUTOLOAD)) != 0) {
1016 flags |= GET_OPAQUE;
1017 }
1018 for (i = 0; i <= T_OPAQUE; ++i) {
1019 match[i] = 0;
1020 }
1021 match[T_CHAR] = ((flags & GET_ARRAY) != 0);
1022 match[T_SHORT] = ((flags & GET_ARRAY) != 0);
1023 match[T_INT] = ((flags & GET_ARRAY) != 0);
1024 match[T_LONG] = ((flags & GET_ARRAY) != 0);
1025 match[T_FLOAT] = ((flags & GET_ARRAY) != 0);
1026 match[T_DOUBLE] = ((flags & GET_ARRAY) != 0);
1027 match[T_COMPLEX] = ((flags & GET_ARRAY) != 0);
1028 match[T_STRING] = ((flags & GET_ARRAY) != 0);
1029 match[T_POINTER] = ((flags & GET_ARRAY) != 0);
1030 match[T_STRUCT] = ((flags & GET_STRUCT) != 0);
1031 match[T_RANGE] = ((flags & GET_RANGE) != 0);
1032 #ifdef GET_LVALUE
1033 match[T_LVALUE] = ((flags & GET_LVALUE) != 0);
1034 #endif
1035 match[T_VOID] = ((flags & GET_VOID) != 0);
1036 match[T_FUNCTION] = ((flags & GET_FUNCTION) != 0);
1037 match[T_BUILTIN] = ((flags & GET_BUILTIN) != 0);
1038 match[T_STRUCTDEF] = ((flags & GET_STRUCTDEF) != 0);
1039 match[T_STREAM] = ((flags & GET_STREAM) != 0);
1040 match[T_OPAQUE] = ((flags & GET_OPAQUE) != 0);
1041
1042 /* Counter number of matching symbols. */
1043 ret = NULL; /* avoids compiler warning */
1044 number = 0;
1045 for (pass = 0; pass <= 1; ++pass) {
1046 if (pass) {
1047 if (number <= 0) {
1048 /* No matching symbols found. */
1049 PushDataBlock(RefNC(&nilDB));
1050 return;
1051 }
1052 tmpDims = NewDimension(number, 1L, (Dimension *)0);
1053 ret = ((Array *)PushDataBlock(NewArray(&stringStruct, tmpDims)))->value.q;
1054 }
1055 for (i=0 ; i<nitems ; ++i) {
1056 OpTable *sym_ops = globTab[i].ops;
1057 if (sym_ops == &dataBlockSym) {
1058 Operations *ops = globTab[i].value.db->ops;
1059 type = ops->typeID;
1060 if ((unsigned int)type > T_OPAQUE || ! match[type]) {
1061 continue;
1062 }
1063 if (type == T_OPAQUE) {
1064 if (ops == &listOps) {
1065 if (omit_list) {
1066 continue;
1067 }
1068 } else if (ops == &auto_ops) {
1069 if (omit_autoload) {
1070 continue;
1071 }
1072 } else {
1073 if (omit_opaque) {
1074 continue;
1075 }
1076 }
1077 }
1078 } else if (sym_ops == &longScalar ||
1079 sym_ops == &intScalar ||
1080 sym_ops == &doubleScalar) {
1081 if (omit_array) {
1082 continue;
1083 }
1084 }
1085 if (pass) {
1086 *ret++ = p_strcpy(globalTable.names[i]);
1087 } else {
1088 ++number;
1089 }
1090 }
1091 }
1092 }
1093
1094 #undef GET_ARRAY
1095 #undef GET_STRUCT
1096 #undef GET_RANGE
1097 #undef GET_VOID
1098 #undef GET_FUNCTION
1099 #undef GET_BUILTIN
1100 #undef GET_STRUCTDEF
1101 #undef GET_STREAM
1102 #undef GET_OPAQUE
1103 #undef GET_LIST
1104 #undef GET_AUTOLOAD
1105
1106 /*--------------------------------------------------------------------------*/
1107