1 /****************************************************************/
2 /* file storage.c
3
4 ARIBAS interpreter for Arithmetic
5 Copyright (C) 1996-2002 O.Forster
6
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
11
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20
21 Address of the author
22
23 Otto Forster
24 Math. Institut der LMU
25 Theresienstr. 39
26 D-80333 Muenchen, Germany
27
28 Email forster@mathematik.uni-muenchen.de
29 */
30 /****************************************************************/
31
32 /*
33 ** storage.c
34 ** storage of symbols
35 **
36 ** date of last change
37 ** 1995-04-08: fixed bug with hugefloat
38 ** 1997-04-13: newreflsym(), neworg (newintsym)
39 ** 2000-12-28: removed some debugging code
40 ** 2002-04-19: mkgf2n, mk0gf2n
41 ** 2004-11-29: changed mkcopy, mkcopy0
42 */
43
44 #include "common.h"
45
46 PUBLIC void inistore _((void));
47
48 PUBLIC truc *nextsymptr _((int i));
49 PUBLIC truc symbobj _((truc *ptr));
50 PUBLIC int lookupsym _((char *name, truc *pobj));
51 PUBLIC truc mksym _((char *name, int *sflgptr));
52 PUBLIC truc scratch _((char *name));
53 PUBLIC truc newselfsym _((char *name, int flg));
54 PUBLIC truc newreflsym _((char *name, int flg));
55 PUBLIC truc newintsym _((char *name, int flg, wtruc bind));
56 PUBLIC int tokenvalue _((truc op));
57 PUBLIC truc newsym _((char *name, int flg, truc bind));
58 PUBLIC truc newsymsig _((char *name, int flg, wtruc bind, int sig));
59 PUBLIC truc new0symsig _((char *name, int flg, wtruc bind, int sig));
60 PUBLIC truc mkcopy _((truc *x));
61 PUBLIC truc mkcopy0 _((truc *x));
62 PUBLIC truc mkarrcopy _((truc *x));
63 PUBLIC truc mkinum _((long n));
64 PUBLIC truc mkarr2 _((unsigned w0, unsigned w1));
65 PUBLIC truc mklocsym _((int flg, unsigned u));
66 PUBLIC truc mkfixnum _((unsigned n));
67 PUBLIC truc mksfixnum _((int n));
68 PUBLIC truc mkint _((int sign, word2 *arr, int len));
69 PUBLIC truc mkgf2n _((word2 *arr, int len));
70 PUBLIC truc mk0gf2n _((word2 *arr, int len));
71 PUBLIC truc mkfloat _((int prec, numdata *nptr));
72 PUBLIC truc fltzero _((int prec));
73 PUBLIC truc mk0float _((numdata *nptr));
74 PUBLIC truc mkchar _((int ch));
75 PUBLIC truc mkbstr _((byte *arr, unsigned len));
76 PUBLIC truc mkstr _((char *str));
77 PUBLIC truc mkstr0 _((unsigned len));
78 PUBLIC truc mkbstr0 _((unsigned len));
79 PUBLIC truc mknullstr _((void));
80 PUBLIC truc mknullbstr _((void));
81 PUBLIC truc mkvect0 _((unsigned len));
82 PUBLIC truc mkrecord _((int flg, truc *ptr, unsigned len));
83 PUBLIC truc mkstack _((void));
84 PUBLIC truc mkstream _((FILE *file, int mode));
85 PUBLIC truc mk0stream _((FILE *file, int mode));
86 PUBLIC truc mk0fun _((truc op));
87 PUBLIC truc mkpair _((int flg, truc sym1, truc sym2));
88 PUBLIC truc mkunode _((truc op));
89 PUBLIC truc mkbnode _((truc op));
90 PUBLIC truc mkspecnode _((truc fun, truc *argptr, int k));
91 PUBLIC truc mkfunode _((truc fun, int n));
92 PUBLIC truc mkfundef _((int argc, int argoptc, int varc));
93 PUBLIC truc mkntuple _((int flg, truc *arr, int n));
94 PUBLIC truc mkcompnode _((int flg, int n));
95
96 /*----------------------------------------------------------------*/
97 PRIVATE int hash _((char *name));
98 PRIVATE truc *mksymaux _((int flg, char *name, int mode));
99 PRIVATE truc *findsym _((char *name, int mode));
100 PRIVATE truc mkstraux _((int flg, char *str, unsigned len, int mode));
101 PRIVATE truc mkstraux0 _((int flg, unsigned len, int mode));
102 PRIVATE void streamaux _((FILE *file, int mode, struct stream *ptr));
103
104
105 PRIVATE truc scratchsym;
106
107 /*----------------------------------------------------------------*/
inistore()108 PUBLIC void inistore()
109 {
110 scratchsym = newselfsym("",sINTERNAL);
111 }
112 /*----------------------------------------------------------------*/
hash(name)113 PRIVATE int hash(name)
114 char *name;
115 {
116 register unsigned long h = 0;
117 register int ch;
118 int i = 10;
119
120 while((ch = *name++)) {
121 h += ch;
122 if(--i >= 0) h <<= 3;
123 }
124 return(h % hashtabSize);
125 }
126 /* -----------------------------------------------------------*/
mksymaux(flg,name,mode)127 PRIVATE truc *mksymaux(flg,name,mode)
128 int flg;
129 char *name;
130 int mode; /* mode != 0: allocate new space for name */
131 {
132 truc *ptr;
133 char *str;
134 size_t wo;
135
136 wo = new0(SIZEOFSYMBOL);
137 ptr = Symbol + wo;
138
139 *FLAGPTR(ptr) = flg;
140 *SEGPTR(ptr) = 0;
141 *OFFSPTR(ptr) = (word2)wo;
142
143 if(mode) {
144 str = stringalloc(strlen(name) + 1);
145 ((struct symbol *)ptr)->name = str;
146 strcopy(str,name);
147 }
148 else
149 ((struct symbol *)ptr)->name = name;
150
151 ((struct symbol *)ptr)->bind.t = zero; /* zur Sicherheit */
152 ((struct symbol *)ptr)->cc.xx = 0;
153
154 return(ptr);
155 }
156 /*-------------------------------------------------------------------*/
157 /*
158 ** Zum Durchlaufen der Symboltabelle.
159 ** Anfang mit Argument 0
160 ** used during garbage collection
161 */
nextsymptr(i)162 PUBLIC truc *nextsymptr(i)
163 int i;
164 {
165 static truc *ptr = NULL;
166 static int index = -1;
167 truc *ptr1;
168
169 if(i == 0) {
170 ptr = NULL;
171 index = -1;
172 }
173 while(ptr == NULL) {
174 if(++index >= hashtabSize) {
175 index = -1;
176 return(NULL);
177 }
178 ptr = Symtab[index];
179 }
180 ptr1 = ptr;
181 ptr = ((struct symbol *)ptr)->link;
182 return(ptr1);
183 }
184 /*-------------------------------------------------------------------*/
185 /*
186 ** constructs symbol truc associated to symbol at place ptr
187 */
symbobj(ptr)188 PUBLIC truc symbobj(ptr)
189 truc *ptr;
190 {
191 variant v;
192
193 v.xx = *ptr;
194 v.pp.b0 = fSYMBOL;
195 return(v.xx);
196 }
197 /*-------------------------------------------------------------------*/
198 /*
199 ** find resp. make a symbol object
200 */
findsym(name,mode)201 PRIVATE truc *findsym(name,mode)
202 char *name;
203 int mode; /* mode == 0: use string space of name */
204 {
205 trucptr *pptr;
206 truc *ptr, *ptr1;
207 int cmp;
208
209 pptr = Symtab + hash(name);
210 while((ptr = *pptr) != NULL) {
211 cmp = strcmp(name,((struct symbol *)ptr)->name);
212 if(cmp == 0) /* found */
213 return(ptr);
214 if(cmp < 0) /* not present */
215 break;
216 pptr = (trucptr *)&(((struct symbol *)ptr)->link);
217 }
218 *pptr = ptr1 = mksymaux(sUNBOUND,name,mode); /* insert */
219 ((struct symbol *)ptr1)->link = ptr;
220 return(ptr1);
221 }
222 /*---------------------------------------------------------------------*/
lookupsym(name,pobj)223 PUBLIC int lookupsym(name,pobj)
224 char *name;
225 truc *pobj;
226 {
227 truc *ptr;
228 int cmp, sflg;
229
230 ptr = Symtab[hash(name)];
231 while(ptr != NULL) {
232 cmp = strcmp(name,((struct symbol *)ptr)->name);
233 if(cmp == 0) { /* found */
234 sflg = *FLAGPTR(ptr);
235 *pobj = symbobj(ptr);
236 return(sflg);
237 }
238 if(cmp < 0) /* not present */
239 break;
240 ptr = ((struct symbol *)ptr)->link;
241 }
242 return(aERROR); /* not found */
243 }
244 /*---------------------------------------------------------------------*/
mksym(name,sflgptr)245 PUBLIC truc mksym(name,sflgptr)
246 char *name;
247 int *sflgptr;
248 {
249 variant v;
250
251 v.xx = *findsym(name,1);
252 *sflgptr = v.pp.b0;
253 v.pp.b0 = fSYMBOL;
254
255 return(v.xx);
256 }
257 /*---------------------------------------------------------------------*/
258 /*
259 ** make a temporary symbol with given name
260 */
scratch(name)261 PUBLIC truc scratch(name)
262 char *name;
263 {
264 SYMname(scratchsym) = name;
265 return(scratchsym);
266 }
267 /*----------------------------------------------------------------------*/
268 /*
269 ** make internal symbol, not in hash table,
270 ** bound to itself
271 */
newselfsym(name,flg)272 PUBLIC truc newselfsym(name,flg)
273 char *name;
274 int flg;
275 {
276 truc obj;
277
278 obj = newintsym(name,flg,(wtruc)0);
279 SYMbind(obj) = obj;
280
281 return(obj);
282 }
283 /*----------------------------------------------------------------------*/
284 /*
285 ** make internal symbol, not in hash table,
286 ** with given name, flag, binding
287 */
newintsym(name,flg,bind)288 PUBLIC truc newintsym(name,flg,bind)
289 char *name;
290 int flg;
291 wtruc bind;
292 {
293 truc *ptr;
294 variant v;
295 size_t wo;
296
297 wo = new0(SIZEOFINTSYMBOL);
298 ptr = Symbol + wo;
299
300 *FLAGPTR(ptr) = flg;
301 *SEGPTR(ptr) = 0;
302 *OFFSPTR(ptr) = (word2)wo;
303
304 ((struct intsymbol *)ptr)->name = name;
305 ((struct intsymbol *)ptr)->bind.w = bind;
306
307 v.xx = *ptr;
308 v.pp.b0 = fSYMBOL;
309
310 return(v.xx);
311 }
312 /*----------------------------------------------------------------------*/
313 /*
314 ** make internal symbol, not in hash table,
315 ** with given name, flag, binding and signature
316 */
new0symsig(name,flg,bind,sig)317 PUBLIC truc new0symsig(name,flg,bind,sig)
318 char *name;
319 int flg;
320 wtruc bind;
321 int sig;
322 {
323 truc *ptr;
324 variant v;
325
326 ptr = mksymaux(flg,name,0);
327 v.xx = *ptr;
328 v.pp.b0 = fSYMBOL;
329 ((struct symbol *)ptr)-> bind.w = bind;
330 ((struct symbol *)ptr)->cc.yy.ww = sig;
331
332 return(v.xx);
333 }
334 /*---------------------------------------------------------------------*/
335 /*
336 ** returns token associated to symbols representing infix operators
337 */
tokenvalue(op)338 PUBLIC int tokenvalue(op)
339 truc op;
340 {
341 variant v;
342
343 v.xx = SYMcc(op);
344 return(v.pp.ww);
345 }
346 /*---------------------------------------------------------------------*/
347 /*
348 ** make a new symbol object (in hash table)
349 ** with given name, flag and binding
350 */
newsym(name,flg,bind)351 PUBLIC truc newsym(name,flg,bind)
352 char *name;
353 int flg;
354 truc bind;
355 {
356 variant v;
357 truc *ptr;
358
359 ptr = findsym(name,0);
360 *FLAGPTR(ptr) = flg;
361 ((struct symbol *)ptr)->bind.t = bind;
362 v.xx = *ptr;
363 v.pp.b0 = fSYMBOL;
364
365 return(v.xx);
366 }
367 /*---------------------------------------------------------------------*/
368 /*
369 ** make a new symbol object (in hash table)
370 ** with given name and flag, bound to itself
371 */
newreflsym(name,flg)372 PUBLIC truc newreflsym(name,flg)
373 char *name;
374 int flg;
375 {
376 variant v;
377 truc *ptr;
378
379 ptr = findsym(name,0);
380 *FLAGPTR(ptr) = flg;
381 v.xx = *ptr;
382 v.pp.b0 = fSYMBOL;
383 ((struct symbol *)ptr)->bind.t = v.xx;
384
385 return(v.xx);
386 }
387 /*---------------------------------------------------------------------*/
388 /*
389 ** make a new symbol object with given name, flag, binding and signature
390 */
newsymsig(name,flg,bind,sig)391 PUBLIC truc newsymsig(name,flg,bind,sig)
392 char *name;
393 int flg;
394 wtruc bind;
395 int sig;
396 {
397 variant v;
398 truc *ptr;
399
400 ptr = findsym(name,0);
401 *FLAGPTR(ptr) = flg;
402 ((struct symbol *)ptr)->bind.w = bind;
403 ((struct symbol *)ptr)->cc.yy.ww = sig;
404 v.xx = *ptr;
405 v.pp.b0 = fSYMBOL;
406
407 return(v.xx);
408 }
409 /*--------------------------------------------------------*/
410 /*
411 ** Stellt Kopie eines Objekts *x her (top-level)
412 ** Es wird vorausgesetzt, dass x bei gc geschuetzt ist
413 */
mkcopy0(x)414 PUBLIC truc mkcopy0(x)
415 truc *x;
416 {
417 truc *ptr;
418 truc obj;
419 unsigned int len;
420 int flg = *FLAGPTR(x);
421
422 if((flg & FIXMASK) || (!*SEGPTR(x)))
423 return(*x);
424 len = obj4size(flg,TAddress(x));
425 obj = newobj(flg,len,&ptr);
426 cpy4arr(TAddress(x),len,ptr);
427 return(obj);
428 }
429 /*--------------------------------------------------------*/
430 /*
431 ** Stellt Kopie eines Objekts *x her (top-level)
432 ** Es wird vorausgesetzt, dass x bei gc geschuetzt ist
433 */
mkcopy(x)434 PUBLIC truc mkcopy(x)
435 truc *x;
436 {
437 truc *ptr;
438 truc obj;
439 unsigned int len;
440 int flg = *FLAGPTR(x);
441
442 if((flg & FIXMASK))
443 return(*x);
444 len = obj4size(flg,TAddress(x));
445 obj = newobj(flg,len,&ptr);
446 cpy4arr(TAddress(x),len,ptr);
447 return(obj);
448 }
449 /*--------------------------------------------------------*/
450 /*
451 ** Stellt Kopie eines Objekts *x her (Array beliebigen Ranges oder record)
452 ** Es wird vorausgesetzt, dass x bei gc geschuetzt ist
453 */
mkarrcopy(x)454 PUBLIC truc mkarrcopy(x)
455 truc *x;
456 {
457 truc *ptr;
458 truc obj;
459 unsigned int i, len;
460 int flg = *FLAGPTR(x);
461
462 if(flg & FIXMASK)
463 return(*x);
464 len = obj4size(flg,TAddress(x));
465 obj = newobj(flg,len,&ptr);
466 cpy4arr(TAddress(x),len,ptr);
467 if(flg < fRECORD || flg > fVECTOR || len < 2)
468 return(obj);
469 /* now recursively copy components of vector or record */
470 WORKpush(obj);
471 ARGpush(zero);
472 ptr++;
473 for(i=1; i<len; i++) {
474 flg = *FLAGPTR(ptr);
475 if(flg >= fRECORD && flg <= fVECTLIKE1) {
476 *argStkPtr = *ptr;
477 obj = mkarrcopy(argStkPtr);
478 ptr = TAddress(workStkPtr)+i;
479 *ptr++ = obj;
480 }
481 else
482 ptr++;
483 }
484 ARGpop();
485 return(WORKretr());
486 }
487 /*--------------------------------------------------------*/
488 /*
489 ** make an intobj from long
490 */
mkinum(n)491 PUBLIC truc mkinum(n)
492 long n;
493 {
494 struct bigcell *ptr;
495 truc obj;
496 variant v;
497 int sign;
498
499 sign = (n < 0 ? MINUSBYTE : 0);
500 if(sign)
501 n = -n;
502 if(n < 0x10000) {
503 v.pp.b0 = fFIXNUM;
504 v.pp.b1 = sign;
505 v.pp.ww = n;
506 return(v.xx);
507 }
508 else {
509 obj = newobj(fBIGNUM,SIZEOFBIG(2),(trucptr *)&ptr);
510 ptr->flag = fBIGNUM;
511 ptr->signum = sign;
512 ptr->len = 2;
513 ptr->digi0 = n & 0xFFFF;
514 ptr->digi1 = n >> 16;
515 return(obj);
516 }
517 }
518 /*--------------------------------------------------------------*/
mkarr2(w0,w1)519 PUBLIC truc mkarr2(w0,w1)
520 unsigned w0, w1;
521 {
522 variant v;
523
524 v.yy.w0 = w0;
525 v.yy.ww = w1;
526 return(v.xx);
527 }
528 /*--------------------------------------------------------------*/
mklocsym(flg,u)529 PUBLIC truc mklocsym(flg,u)
530 int flg;
531 unsigned u;
532 {
533 variant v;
534
535 v.pp.b0 = flg;
536 v.pp.b1 = 0;
537 v.pp.ww = u;
538 return(v.xx);
539 }
540 /*--------------------------------------------------------------*/
541 /*
542 ** stellt aus der Zahl n >= 0 ein fixnum her
543 */
mkfixnum(n)544 PUBLIC truc mkfixnum(n)
545 unsigned n;
546 {
547 variant v;
548
549 v.pp.b0 = fFIXNUM;
550 v.pp.b1 = 0;
551 v.pp.ww = n;
552 return(v.xx);
553 }
554 /*--------------------------------------------------------------*/
555 /*
556 ** stellt aus der Zahl n ein fixnum her;
557 ** Vorzeichen von n wird beruecksichtigt
558 */
mksfixnum(n)559 PUBLIC truc mksfixnum(n)
560 int n;
561 {
562 variant v;
563
564 v.pp.b0 = fFIXNUM;
565 if(n < 0) {
566 v.pp.b1 = MINUSBYTE;
567 n = -n;
568 }
569 else
570 v.pp.b1 = 0;
571 v.pp.ww = n;
572 return(v.xx);
573 }
574 /*--------------------------------------------------------------*/
575 /*
576 ** make intobj from big-array
577 */
mkint(sign,arr,len)578 PUBLIC truc mkint(sign,arr,len)
579 int sign;
580 word2 *arr;
581 int len;
582 {
583 struct bigcell *big;
584 variant v;
585 truc obj;
586
587 if(len <= 1) {
588 v.pp.b0 = fFIXNUM;
589 if(!len) {
590 v.pp.b1 = 0;
591 v.pp.ww = 0;
592 }
593 else {
594 v.pp.b1 = sign;
595 v.pp.ww = *arr;
596 }
597 return(v.xx);
598 }
599 /* else if(len >= 2) */
600 obj = newobj(fBIGNUM,SIZEOFBIG(len),(trucptr *)&big);
601 big->flag = fBIGNUM;
602 big->signum = sign;
603 big->len = len;
604 cpyarr(arr,len,&(big->digi0));
605 return(obj);
606 }
607 /*--------------------------------------------------------------*/
608 /*
609 ** make gf2nint from (arr,len)
610 */
mkgf2n(arr,len)611 PUBLIC truc mkgf2n(arr,len)
612 word2 *arr;
613 int len;
614 {
615 struct bigcell *big;
616 truc obj;
617
618 if(len <= 1) {
619 if (!len)
620 return gf2nzero;
621 else if (arr[0] == 1)
622 return gf2none;
623 /* else fall through */
624 }
625 obj = newobj(fGF2NINT,SIZEOFBIG(len),(trucptr *)&big);
626 big->flag = fGF2NINT;
627 big->signum = 0;
628 big->len = len;
629 cpyarr(arr,len,&(big->digi0));
630 return(obj);
631 }
632 /*--------------------------------------------------------------*/
633 /*
634 ** make gf2nint which is not moved during garbage collection
635 */
mk0gf2n(arr,len)636 PUBLIC truc mk0gf2n(arr,len)
637 word2 *arr;
638 int len;
639 {
640 struct bigcell *big;
641 truc obj;
642
643 obj = new0obj(fGF2NINT,SIZEOFBIG(len),(trucptr *)&big);
644
645 big->flag = fGF2NINT;
646 big->signum = 0;
647 big->len = len;
648 cpyarr(arr,len,&(big->digi0));
649
650 return(obj);
651 }
652 /*--------------------------------------------------------------*/
mkfloat(prec,nptr)653 PUBLIC truc mkfloat(prec,nptr)
654 int prec; /* must be one of FltPrec[k] */
655 numdata *nptr;
656 {
657 struct floatcell *fl;
658 truc obj;
659 long ex;
660 unsigned hugelow;
661 int hugeflg = 0;
662 int n, flg, pcode;
663
664 n = normfloat(prec,nptr);
665 if(n == 0)
666 return(fltzero(prec));
667 ex = nptr->expo;
668 pcode = fltpreccode(prec);
669 flg = fFLTOBJ + (pcode<<1);
670 if(ex >= 0x8000 || -ex > 0x8000) {
671 hugeflg = 1;
672 flg |= HUGEFLTBIT;
673 hugelow = ex & 0x7F;
674 ex >>= 7;
675 }
676 obj = newobj(flg,SIZEOFFLOAT(prec),(trucptr *)&fl);
677 fl->flag = flg;
678 fl->signum = (nptr->sign ? FSIGNBIT : 0);
679 if(hugeflg)
680 fl->signum |= hugelow;
681 fl->expo = ex;
682 cpyarr(nptr->digits,prec,&(fl->digi0));
683 return(obj);
684 }
685 /*--------------------------------------------------------------*/
fltzero(prec)686 PUBLIC truc fltzero(prec)
687 int prec; /* must be one of FltPrec[k] */
688 {
689 variant v;
690 int pcode;
691
692 pcode = fltpreccode(prec);
693 v.pp.b0 = fFLTOBJ + (pcode<<1) + FLTZEROBIT;
694 v.pp.b1 = 0;
695 v.pp.ww = 0;
696 return(v.xx);
697 }
698 /*--------------------------------------------------------------*/
699 /*
700 ** make a float which is not moved during garbage collection
701 */
mk0float(nptr)702 PUBLIC truc mk0float(nptr)
703 numdata *nptr;
704 /* nptr wird als normalisiert und nicht huge vorausgesetzt */
705 {
706 struct floatcell *fl;
707 truc obj;
708 int prec, flg, pcode;
709
710 prec = nptr->len;
711 pcode = fltpreccode(prec);
712 flg = fFLTOBJ + (pcode<<1);
713 obj = new0obj(flg,SIZEOFFLOAT(prec),(trucptr *)&fl);
714 fl->flag = flg;
715 fl->signum = (nptr->sign ? FSIGNBIT : 0);
716 fl->expo = nptr->expo;
717
718 cpyarr(nptr->digits,prec,&(fl->digi0));
719 return(obj);
720 }
721 /*--------------------------------------------------------------*/
722 /*
723 ** make a character object
724 */
mkchar(n)725 PUBLIC truc mkchar(n)
726 int n;
727 {
728 variant v;
729
730 v.pp.b0 = fCHARACTER;
731 v.pp.b1 = 0;
732 v.pp.ww = (n & 0x00FF);
733 return(v.xx);
734 }
735 /*--------------------------------------------------------------*/
736 /*
737 ** make a byte_string object for byte array (arr,len)
738 */
mkbstr(arr,len)739 PUBLIC truc mkbstr(arr,len)
740 byte *arr;
741 unsigned int len;
742 {
743 return(mkstraux(fBYTESTRING,(char *)arr,len,1));
744 }
745 /*--------------------------------------------------------------*/
746 /*
747 ** make a string object for string str
748 */
mkstr(str)749 PUBLIC truc mkstr(str)
750 char *str;
751 {
752 unsigned len = strlen(str);
753
754 return(mkstraux(fSTRING,str,len,1));
755 }
756 /*---------------------------------------------------------*/
757 /*
758 ** make a string object for unknown string of length len
759 */
mkstr0(len)760 PUBLIC truc mkstr0(len)
761 unsigned len;
762 {
763 return(mkstraux0(fSTRING,len,1));
764 }
765 /*---------------------------------------------------------*/
766 /*
767 ** make a bytestring object for unknown string of length len
768 */
mkbstr0(len)769 PUBLIC truc mkbstr0(len)
770 unsigned len;
771 {
772 return(mkstraux0(fBYTESTRING,len,1));
773 }
774 /*---------------------------------------------------------*/
775 /*
776 ** make a nullstring, not moved during gc
777 */
mknullstr()778 PUBLIC truc mknullstr()
779 {
780 return(mkstraux0(fSTRING,0,0));
781 }
782 /*---------------------------------------------------------*/
783 /*
784 ** make a nullbytestring, not moved during gc
785 */
mknullbstr()786 PUBLIC truc mknullbstr()
787 {
788 return(mkstraux0(fBYTESTRING,0,0));
789 }
790 /*---------------------------------------------------------*/
mkstraux(flg,str,len,mode)791 PRIVATE truc mkstraux(flg,str,len,mode)
792 int flg; /* fSTRING or fBYTESTRING */
793 char *str;
794 unsigned len;
795 int mode; /* mode = 0: string not moved during gc */
796 {
797 unsigned k;
798 struct strcell *ptr;
799 truc obj;
800 char *cpt;
801
802 if(mode)
803 obj = newobj(flg,SIZEOFSTRING(len),(trucptr *)&ptr);
804 else
805 obj = new0obj(flg,SIZEOFSTRING(len),(trucptr *)&ptr);
806
807 ptr->flag = fSTRING;
808 ptr->flg2 = 0;
809 ptr->len = len;
810 cpt = (char *)&(ptr->ch0);
811 for(k=0; k<len; k++)
812 *cpt++ = *str++;
813 *cpt = 0;
814 return(obj);
815 }
816 /*---------------------------------------------------------*/
mkstraux0(flg,len,mode)817 PRIVATE truc mkstraux0(flg,len,mode)
818 int flg; /* fSTRING or fBYTESTRING */
819 unsigned len;
820 int mode; /* mode = 0: string not moved during gc */
821 {
822 unsigned k;
823 struct strcell *ptr;
824 truc obj;
825 char *cpt;
826
827 if(mode)
828 obj = newobj(flg,SIZEOFSTRING(len),(trucptr *)&ptr);
829 else
830 obj = new0obj(flg,SIZEOFSTRING(len),(trucptr *)&ptr);
831
832 ptr->flag = fSTRING;
833 ptr->flg2 = 0;
834 ptr->len = len;
835 cpt = (char *)&(ptr->ch0);
836 for(k=0; k<=len; k++)
837 *cpt++ = 0;
838 return(obj);
839 }
840 /*---------------------------------------------------------*/
841 /*
842 ** make a vector object for vector of length len
843 ** initialized with zeroes
844 */
mkvect0(len)845 PUBLIC truc mkvect0(len)
846 unsigned int len;
847 {
848 struct vector *ptr;
849 truc *vec;
850 truc obj;
851 unsigned int k;
852
853 k = SIZEOFVECTOR(len); /* k is positive */
854 obj = newobj(fVECTOR,k,(trucptr *)&ptr);
855
856 ptr->flag = fVECTOR;
857 ptr->flg2 = 0;
858 ptr->len = len;
859 vec = (truc *)&(ptr->ele0);
860 while(--k)
861 *vec++ = zero;
862 return(obj);
863 }
864 /*-------------------------------------------------------------*/
mkrecord(flg,ptr,len)865 PUBLIC truc mkrecord(flg,ptr,len)
866 int flg; /* fRECORD or fPOINTER */
867 truc *ptr;
868 unsigned len;
869 {
870 struct record *rptr;
871 truc obj;
872 unsigned k;
873
874 k = SIZEOFRECORD(len);
875 obj = newobj(flg,k,(trucptr *)&rptr);
876 rptr->flag = flg;
877 rptr->flg2 = 0;
878 rptr->len = len;
879 cpy4arr(ptr,len+1,(truc *)&(rptr->recdef));
880 return(obj);
881 }
882 /*-------------------------------------------------------------*/
mkstack()883 PUBLIC truc mkstack()
884 {
885 struct stack *ptr;
886 truc obj;
887
888 obj = newobj(fSTACK,SIZEOFSTACK,(trucptr *)&ptr);
889 ptr->flag = fSTACK;
890 ptr->line = 0;
891 ptr->pageno = 0;
892 ptr->type = zero;
893 ptr->page = nullsym;
894 return(obj);
895 }
896 /*-------------------------------------------------------------*/
mkstream(file,mode)897 PUBLIC truc mkstream(file,mode)
898 FILE *file;
899 int mode;
900 {
901 struct stream *ptr;
902 truc strm = newobj(fSTREAM,SIZEOFSTREAM,(trucptr *)&ptr);
903
904 streamaux(file,mode,ptr);
905 return(strm);
906 }
907 /* ---------------------------------------------------------- */
streamaux(file,mode,ptr)908 PRIVATE void streamaux(file,mode,ptr)
909 FILE *file;
910 int mode;
911 struct stream *ptr;
912 {
913 ptr->flag = fSTREAM;
914 ptr->mode = mode;
915 ptr->pos = 0;
916 ptr->lineno = 1;
917 ptr->ch = EOL;
918 ptr->tok = EOLTOK;
919 ptr->file = file;
920 }
921 /* ---------------------------------------------------------- */
922 /*
923 ** make a stream which is not moved during garbage collection
924 */
mk0stream(file,mode)925 PUBLIC truc mk0stream(file,mode)
926 FILE *file;
927 int mode;
928 {
929 struct stream *ptr;
930 truc strm = new0obj(fSTREAM,SIZEOFSTREAM,(trucptr *)&ptr);
931
932 streamaux(file,mode,ptr);
933 return(strm);
934 }
935 /*--------------------------------------------------------------*/
936 /*
937 ** make function object without arguments
938 */
mk0fun(op)939 PUBLIC truc mk0fun(op)
940 truc op;
941 {
942 variant v;
943 int sflg;
944
945 sflg = Symflag(op);
946 if(sflg == sFBINARY || sflg == sSBINARY) {
947 v.xx = op;
948 v.pp.b0 = fSPECIAL0;
949 return(v.xx);
950 }
951 else
952 return(mkfunode(op,0));
953 }
954 /*--------------------------------------------------------------*/
mkpair(flg,sym1,sym2)955 PUBLIC truc mkpair(flg,sym1,sym2)
956 int flg;
957 truc sym1, sym2;
958 {
959 struct opnode *node;
960 truc obj;
961
962 obj = newobj(flg,SIZEOFOPNODE(1),(trucptr *)&node);
963 node->op = sym1;
964 node->arg0 = sym2;
965 return(obj);
966 }
967 /*--------------------------------------------------------------*/
968 /*
969 ** make unary opnode with arg from ParseStack
970 */
mkunode(op)971 PUBLIC truc mkunode(op)
972 truc op;
973 {
974 struct opnode *node;
975 truc obj;
976 int flg, sflg;
977
978 sflg = Symflag(op);
979 if(sflg == sSBINARY)
980 flg = fSPECIAL1;
981 else if(sflg == sFBINARY)
982 flg = fBUILTIN1;
983 else
984 return(mkfunode(op,1));
985
986 obj = newobj(flg,SIZEOFOPNODE(1),(trucptr *)&node);
987 node->op = op;
988 node->arg0 = *argStkPtr;
989 return(obj);
990 }
991 /*--------------------------------------------------------------*/
992 /*
993 ** make binary opnode with arg0 and arg1 from ParseStack
994 */
mkbnode(op)995 PUBLIC truc mkbnode(op)
996 truc op;
997 {
998 struct opnode *node;
999 truc obj;
1000 int flg, sflg;
1001
1002 sflg = Symflag(op);
1003
1004 if(sflg == sSBINARY)
1005 flg = fSPECIAL2;
1006 else if(sflg == sFBINARY)
1007 flg = fBUILTIN2;
1008 else
1009 return(mkfunode(op,2));
1010
1011 obj = newobj(flg,SIZEOFOPNODE(2),(trucptr *)&node);
1012 node->op = op;
1013 node->arg0 = argStkPtr[-1];
1014 node->arg1 = argStkPtr[0];
1015 return(obj);
1016 }
1017 /*--------------------------------------------------------------*/
mkspecnode(fun,argptr,k)1018 PUBLIC truc mkspecnode(fun,argptr,k)
1019 truc fun;
1020 truc *argptr;
1021 int k; /* k == 1 or k == 2 */
1022 {
1023 struct opnode *node;
1024 int flg;
1025 truc obj;
1026
1027 flg = (k == 1 ? fSPECIAL1 : fSPECIAL2);
1028 obj = newobj(flg,SIZEOFOPNODE(k),(trucptr *)&node);
1029 node->op = fun;
1030 node->arg0 = argptr[0];
1031 if(k == 2)
1032 node->arg1 = argptr[1];
1033 return(obj);
1034 }
1035 /*--------------------------------------------------------------*/
mkfunode(fun,n)1036 PUBLIC truc mkfunode(fun,n)
1037 truc fun;
1038 int n;
1039 {
1040 struct funode *node;
1041 truc obj;
1042 truc *ptr;
1043 int flg, sflg;
1044
1045 sflg = Symflag(fun);
1046 if(sflg == sFBINARY) {
1047 flg = fBUILTINn;
1048 }
1049 else if(sflg == sSBINARY) {
1050 flg = fSPECIALn;
1051 }
1052 else
1053 flg = fFUNCALL;
1054
1055 obj = newobj(flg,SIZEOFFUNODE(n),(trucptr *)&node);
1056 node->op = fun;
1057 node->argno = mkfixnum(n);
1058 ptr = (truc *)&(node->arg1);
1059 while(--n >= 0) {
1060 *ptr++ = argStkPtr[-n];
1061 }
1062 return(obj);
1063 }
1064 /*--------------------------------------------------------------*/
mkfundef(argc,argoptc,varc)1065 PUBLIC truc mkfundef(argc,argoptc,varc)
1066 int argc, argoptc, varc;
1067 {
1068 struct fundef *node;
1069 truc obj;
1070
1071 obj = newobj(fFUNDEF,SIZEOFFUNDEF,(trucptr *)&node);
1072
1073 node->flag = fFUNDEF;
1074 node->flg2 = argoptc;
1075 node->argc = argc;
1076 node->varno = mkfixnum(varc);
1077 node->body = argStkPtr[0];
1078 node->parms = argStkPtr[-2];
1079 node->vars = argStkPtr[-1];
1080
1081 return(obj);
1082 }
1083 /*--------------------------------------------------------------*/
1084 /*
1085 ** make node with n expressions from array arr
1086 */
mkntuple(flg,arr,n)1087 PUBLIC truc mkntuple(flg,arr,n)
1088 int flg, n;
1089 truc *arr;
1090 {
1091 truc *node;
1092 truc obj;
1093 variant v;
1094
1095 obj = newobj(flg,SIZEOFTUPLE(n),&node);
1096
1097 v.pp.b0 = flg;
1098 v.pp.b1 = 0;
1099 v.pp.ww = n;
1100 *node++ = v.xx;
1101 cpy4arr(arr,n,node);
1102 return(obj);
1103 }
1104 /*--------------------------------------------------------------*/
1105 /*
1106 ** make node with n statements from ParseStack in reverse order
1107 */
mkcompnode(flg,n)1108 PUBLIC truc mkcompnode(flg,n)
1109 int flg, n;
1110 {
1111 truc *node;
1112 truc obj;
1113 variant v;
1114 int i;
1115
1116 obj = newobj(flg,SIZEOFCOMP(n),&node);
1117
1118 v.pp.b0 = flg;
1119 v.pp.b1 = 0;
1120 v.pp.ww = n;
1121 *node++ = v.xx;
1122 for(i=0; i<n; i++)
1123 *node++ = argStkPtr[-i];
1124 return(obj);
1125 }
1126 /*********************************************************************/
1127