![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lam8.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz|
Return to lam8.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: lam8.c,v 1.9 83/09/12 14:16:52 sklower Exp $";
4: #endif
5:
6: /* -[Fri Aug 12 07:54:00 1983 by jkf]-
7: * lam8.c $Locker: $
8: * lambda functions
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13: #include "global.h"
14: #include <sys/types.h>
15: #include <sys/stat.h>
16: #include "frame.h"
17:
18: /* various functions from the c math library */
19: double sin(),cos(),asin(),acos(),atan2(),sqrt(), log(), exp();
20: extern int current;
21:
22: lispval Imath(func)
23: double (*func)();
24: {
25: register lispval handy;
26: register double res;
27: chkarg(1,"Math functions");
28:
29: switch(TYPE(handy=lbot->val)) {
30: case INT: res = func((double)handy->i);
31: break;
32:
33: case DOUB: res = func(handy->r);
34: break;
35:
36: default: error("Non fixnum or flonum to math function",FALSE);
37: }
38: handy = newdoub();
39: handy->r = res;
40: return(handy);
41: }
42: lispval Lsin()
43: {
44: return(Imath(sin));
45: }
46:
47: lispval Lcos()
48: {
49: return(Imath(cos));
50: }
51:
52: lispval Lasin()
53: {
54: return(Imath(asin));
55: }
56:
57: lispval Lacos()
58: {
59: return(Imath(acos));
60: }
61:
62: lispval Lsqrt()
63: {
64: return(Imath(sqrt));
65: }
66: lispval Lexp()
67: {
68: return(Imath(exp));
69: }
70:
71: lispval Llog()
72: {
73: return(Imath(log));
74: }
75:
76: /* although we call this atan, it is really atan2 to the c-world,
77: that is, it takes two args
78: */
79: lispval Latan()
80: {
81: register lispval arg;
82: register double arg1v;
83: register double res;
84: chkarg(2,"arctan");
85:
86: switch(TYPE(arg=lbot->val)) {
87:
88: case INT: arg1v = (double) arg->i;
89: break;
90:
91: case DOUB: arg1v = arg->r;
92: break;
93:
94: default: error("Non fixnum or flonum arg to atan2",FALSE);
95: }
96:
97: switch(TYPE(arg = (lbot+1)->val)) {
98:
99: case INT: res = atan2(arg1v,(double) arg->i);
100: break;
101:
102: case DOUB: res = atan2(arg1v, arg->r);
103: break;
104:
105: default: error("Non fixnum or flonum to atan2",FALSE);
106: }
107: arg = newdoub();
108: arg->r = res;
109: return(arg);
110: }
111:
112: /* (random) returns a fixnum in the range -2**30 to 2**30 -1
113: (random fixnum) returns a fixnum in the range 0 to fixnum-1
114: */
115: lispval
116: Lrandom()
117: {
118: register int curval;
119: float pow();
120:
121: curval = rand(); /* get numb from 0 to 2**31-1 */
122:
123: if(np==lbot) return(inewint(curval-(int)pow((double)2,(double)30)));
124:
125: if((TYPE(lbot->val) != INT)
126: || (lbot->val->i <= 0)) errorh1(Vermisc,"random: non fixnum arg:",
127: nil, FALSE, 0, lbot->val);
128:
129: return(inewint(curval % lbot->val->i ));
130:
131: }
132: lispval
133: Lmakunb()
134: {
135: register lispval work;
136:
137: chkarg(1,"makunbound");
138: work = lbot->val;
139: if(work==nil || (TYPE(work)!=ATOM))
140: return(work);
141: work->a.clb = CNIL;
142: return(work);
143: }
144:
145: lispval
146: Lfseek()
147: {
148:
149: FILE *f;
150: long offset, whence;
151: lispval retp;
152:
153: chkarg(3,"fseek"); /* Make sure there are three arguments*/
154:
155: f = lbot->val->p; /* Get first argument into f */
156: if (TYPE(lbot->val)!=PORT) /* Check type of first */
157: error("fseek: First argument must be a port.",FALSE);
158:
159: offset = lbot[1].val->i; /* Get second argument */
160: if (TYPE(lbot[1].val)!=INT)
161: error("fseek: Second argument must be an integer.",FALSE);
162:
163: whence = lbot[2].val->i; /* Get last arg */
164: if (TYPE(lbot[2].val)!=INT)
165: error("fseek: Third argument must be an integer.",FALSE);
166:
167: if (fseek(f, offset, (int)whence) == -1)
168: error("fseek: Illegal parameters.",FALSE);
169:
170: retp = inewint(ftell(f));
171:
172: return((lispval) retp);
173: }
174:
175: /* function hashtabstat : return list of number of members in each bucket */
176: lispval Lhashst()
177: {
178: register lispval handy,cur;
179: register struct atom *pnt;
180: int i,cnt;
181: extern int hashtop;
182: Savestack(3);
183:
184: handy = newdot();
185: protect(handy);
186: cur = handy;
187: for(i = 0; i < hashtop; i++)
188: {
189: pnt = hasht[i];
190: for(cnt = 0; pnt != (struct atom *) CNIL ; pnt=pnt->hshlnk , cnt++);
191: cur->d.cdr = newdot();
192: cur = cur->d.cdr;
193: cur->d.car = inewint(cnt);
194: }
195: cur->d.cdr = nil;
196: Restorestack();
197: return(handy->d.cdr);
198: }
199:
200:
201: /* Lctcherr
202: this routine should only be called by the unwind protect simulation
203: lisp code
204: It is called after an unwind-protect frame has been entered and
205: evalated and we want to get on with the error or throw
206: We only handle the case where there are 0 to 2 extra arguments to the
207: error call.
208: */
209: lispval
210: Lctcherr()
211: {
212: register lispval handy;
213: lispval type,messg,valret,contuab,uniqid,datum1,datum2;
214:
215: chkarg(1,"I-throw-err");
216:
217: handy = lbot->val;
218:
219: if(TYPE(handy->d.car) == INT)
220: { /* continuing a non error (throw,reset, etc) */
221: Inonlocalgo((int)handy->d.car->i,
222: handy->d.cdr->d.car,
223: handy->d.cdr->d.cdr->d.car);
224: /* NOT REACHED */
225: }
226:
227: if(handy->d.car != nil)
228: {
229: errorh1(Vermisc,"I-do-throw: first element not fixnum or nil",
230: nil,FALSE,0,handy);
231: }
232:
233: /* decode the arg list */
234: handy = handy->d.cdr;
235: type = handy->d.car;
236: handy = handy->d.cdr;
237: messg = handy->d.car;
238: handy = handy->d.cdr;
239: valret = handy->d.car;
240: handy = handy->d.cdr;
241: contuab = handy->d.car;
242: handy = handy->d.cdr;
243: uniqid = handy->d.car;
244: handy = handy->d.cdr;
245:
246: /* if not extra args */
247: if(handy == nil)
248: {
249: errorh(type,messg->a.pname,valret,(int)contuab->i,(int)uniqid->i);
250: }
251: datum1 = handy->d.car;
252: handy = handy->d.cdr;
253:
254: /* if one extra arg */
255: if(handy == nil)
256: {
257: errorh1(type,messg->a.pname,valret,(int)contuab->i,(int)uniqid->i,datum1);
258: }
259:
260: /* if two or more extra args, just use first 2 */
261: datum2 = handy->d.car;
262: errorh2(type,messg->a.pname,valret,(int)contuab->i,(int)uniqid->i,datum1,datum2);
263: }
264:
265: /*
266: * (*makhunk '<fixnum>)
267: * <fixnum>
268: * Create a hunk of size 2 . <fixnum> must be between 0 and 6.
269: *
270: */
271:
272: lispval
273: LMakhunk()
274: {
275: register int hsize, hcntr;
276: register lispval result;
277:
278: chkarg(1,"Makehunk");
279: if (TYPE(lbot->val)==INT)
280: {
281: hsize = lbot->val->i; /* size of hunk (0-6) */
282: if ((hsize >= 0) && (hsize <= 6))
283: {
284: result = newhunk(hsize);
285: hsize = 2 << hsize; /* size of hunk (2-128) */
286: for (hcntr = 0; hcntr < hsize; hcntr++)
287: result->h.hunk[hcntr] = hunkfree;
288: }
289: else
290: error("*makhunk: Illegal hunk size", FALSE);
291: return(result);
292: }
293: else
294: error("*makhunk: First arg must be an fixnum",FALSE);
295: /* NOTREACHED */
296: }
297:
298: /*
299: * (cxr '<fixnum> '<hunk>)
300: * Returns the <fixnum>'th element of <hunk>
301: *
302: */
303: lispval
304: Lcxr()
305: {
306: register lispval temp;
307:
308: chkarg(2,"cxr");
309: if (TYPE(lbot->val)!=INT)
310: error("cxr: First arg must be a fixnum", FALSE);
311: else
312: {
313: if (! HUNKP(lbot[1].val))
314: error("cxr: Second arg must be a hunk", FALSE);
315: else
316: if ( (lbot->val->i >= 0) &&
317: (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) )
318: {
319: temp = lbot[1].val->h.hunk[lbot->val->i];
320: if (temp != hunkfree)
321: return(temp);
322: else
323: error("cxr: Arg outside of hunk range",
324: FALSE);
325: }
326: else
327: error("cxr: Arg outside of hunk range", FALSE);
328: }
329: /* NOTREACHED */
330: }
331:
332: /*
333: * (rplacx '<fixnum> '<hunk> '<expr>)
334: * Replaces the <fixnum>'th element of <hunk> with <expr>.
335: *
336: */
337: lispval
338: Lrplacx()
339: {
340: lispval *handy;
341: chkarg(3,"rplacx");
342: if (TYPE(lbot->val)!=INT)
343: error("rplacx: First arg must be a fixnum", FALSE);
344: else
345: {
346: if (! HUNKP(lbot[1].val))
347: error("rplacx: Second arg must be a hunk", FALSE);
348: else
349: {
350: if ( (lbot->val->i >= 0) &&
351: (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) )
352: {
353: if (*(handy = &(lbot[1].val->h.hunk[lbot->val->i]))
354: != hunkfree)
355: *handy = lbot[2].val;
356: else
357: error("rplacx: Arg outside hunk range", FALSE);
358: }
359: else
360: error("rplacx: Arg outside hunk range", FALSE);
361: }
362: }
363: return(lbot[1].val);
364: }
365:
366: /*
367: * (*rplacx '<fixnum> '<hunk> '<expr>)
368: * Replaces the <fixnum>'th element of <hunk> with <expr>. This is the
369: * same as (rplacx ...) except with this function you can replace EMPTY's.
370: *
371: */
372: lispval
373: Lstarrpx()
374: {
375: chkarg(3,"*rplacx");
376: if (TYPE(lbot->val)!=INT)
377: error("*rplacx: First arg must be a fixnum", FALSE);
378: else
379: {
380: if (! HUNKP(lbot[1].val))
381: error("*rplacx: Second arg must be a hunk", FALSE);
382: else
383: {
384: if ( (lbot->val->i >= 0) &&
385: (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) )
386: lbot[1].val->h.hunk[lbot->val->i] = lbot[2].val;
387: else
388: error("*rplacx: Arg outside hunk range", FALSE);
389: }
390: }
391: return(lbot[1].val);
392: }
393:
394: /*
395: * (hunksize '<hunk>)
396: * Returns the size of <hunk>
397: *
398: */
399: lispval
400: Lhunksize()
401: {
402: register int size,i;
403:
404: chkarg(1,"hunksize");
405: if (HUNKP(lbot->val))
406: {
407: size = 2 << HUNKSIZE(lbot->val);
408: for (i = size-1; i >= 0; i--)
409: {
410: if (lbot->val->h.hunk[i] != hunkfree)
411: {
412: size = i + 1;
413: break;
414: }
415: }
416: return( inewint(size) );
417: }
418: else
419: error("hunksize: First argument must me a hunk", FALSE);
420: /* NOTREACHED */
421: }
422:
423: /*
424: * (hunk-to-list 'hunk) returns a list of the hunk elements
425: */
426: lispval
427: Lhtol()
428: {
429: register lispval handy,retval,last;
430: register int i;
431: int size;
432: Savestack(4);
433:
434: chkarg(1,"hunk-to-list");
435: handy = lbot->val;
436: if(!(HUNKP(handy)))
437: errorh1(Vermisc,"hunk-to-list: non hunk argument: ", nil,0,FALSE,
438: handy);
439: size = 2 << HUNKSIZE(handy);
440: retval = nil;
441: for(i=0 ; i < size ; i++)
442: {
443: if(handy->h.hunk[i] != hunkfree)
444: {
445: if(retval==nil)
446: {
447: protect(retval=newdot());
448: last = retval;
449: }
450: else {
451: last = (last->d.cdr = newdot());
452: }
453: last->d.car = handy->h.hunk[i];
454: }
455: else break;
456: }
457: Restorestack();
458: return(retval);
459: }
460:
461: /*
462: * (fileopen filename mode)
463: * open a file for read, write, or append the arguments can be either
464: * strings or atoms.
465: */
466: lispval
467: Lfileopen()
468: {
469: FILE *port;
470: register lispval name;
471: register lispval mode;
472: register char *namech;
473: register char *modech;
474:
475: chkarg(2,"fileopen");
476: name = lbot->val;
477: mode = lbot[1].val;
478:
479: namech = (char *) verify(name,"fileopen:args must be atoms or strings");
480: modech = (char *) verify(mode,"fileopen:args must be atoms or strings");
481:
482: while (modech[0] != 'r' && modech[0] != 'w' && modech[0] != 'a')
483: {
484: mode = errorh(Vermisc,"Modes are only r, w, a.",nil,TRUE,31);
485: modech = (char *) verify(mode,"fileopen:args must be atoms or strings");
486: }
487:
488: while ((port = fopen(namech, modech)) == NULL)
489: {
490: name = errorh1(Vermisc,"Unable to open file.",nil,TRUE,31,name);
491: namech = (char *) verify(name,"fileopen:args must be atoms or strings");
492: }
493: /* xports is a FILE *, cc complains about adding pointers */
494:
495: ioname[PN(port)] = (lispval) inewstr(namech); /* remember name */
496: return( (lispval) (xports + (port - _iob)));
497: }
498:
499: /*
500: * (*invmod '<number> '<modulus>)
501: * This function returns the inverse of <number>
502: * mod <modulus> in balanced representation
503: * It is used in vaxima as a speed enhancement.
504: */
505:
506: static lispval
507: Ibalmod(invmodp)
508: {
509: register long mod_div_2, number, modulus;
510:
511: chkarg(2,"*mod");
512: if ((TYPE(lbot->val) == INT) && (TYPE(lbot[1].val) == INT))
513: {
514: modulus = lbot[1].val->i;
515: if(invmodp) number = invmod(lbot->val->i , modulus);
516: else number = lbot->val->i % modulus;
517: mod_div_2 = modulus / 2;
518: if (number < 0)
519: {
520: if (number < (-mod_div_2))
521: number += modulus;
522: }
523: else
524: {
525: if (number > mod_div_2)
526: number -= modulus;
527: }
528: return( inewint(number) );
529: }
530: else
531: error("*mod: Arguments must be fixnums", FALSE);
532: /* NOTREACHED */
533: }
534:
535: invmod (n,modulus)
536: long n , modulus;
537:
538: {
539: long a1,a2,a3,y1,y2,y3,q;
540:
541: a1 = modulus;
542: a2 = n;
543: y1 = 0;
544: y2= 1;
545: goto step3;
546: step2:
547: q = a1 /a2; /*truncated quotient */
548: a3= mmuladd(modulus-a2,q,a1,modulus);
549: y3= mmuladd(modulus-y2,q,y1,modulus);
550: a1 = a2;
551: a2= a3;
552: y1=y2;
553: y2=y3;
554: step3:
555: if (a2==0) error("invmod: inverse of zero divisor",TRUE);
556: else if (a2 != 1) goto step2;
557: else return (y2);
558: /* NOTREACHED */
559: }
560:
561: lispval
562: Lstarinvmod()
563: {
564: return(Ibalmod(TRUE));
565: }
566:
567: /*
568: * (*mod '<number> '<modulus>)
569: * This function returns <number> mod <modulus> (for balanced modulus).
570: * It is used in vaxima as a speed enhancement.
571: */
572: lispval
573: LstarMod()
574: {
575: return(Ibalmod(FALSE));
576: }
577:
578: lispval
579: Llsh()
580: {
581: register struct argent *mylbot = lbot;
582: int val,shift;
583:
584: chkarg(2,"lsh");
585: if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT))
586: errorh2(Vermisc,
587: "Non ints to lsh",
588: nil,FALSE,0,mylbot->val,mylbot[1].val);
589: val = mylbot[0].val->i;
590: shift = mylbot[1].val->i;
591: if(shift < -32 || shift > 32)
592: return(inewint(0));
593: if (shift < 0)
594: val = val >> -shift;
595: else
596: val = val << shift;
597: if((val < 0) && (shift < 0))
598: { /* special case: the vax doesn't have a logical shift
599: instruction, so we must zero out the ones which
600: will propogate from the sign position
601: */
602: return(inewint ( val & ~(0x80000000 << (shift+1))));
603: }
604: else return( inewint(val));
605: }
606:
607: /* very temporary function to test the validity of the bind stack */
608:
609: bndchk()
610: {
611: register struct nament *npt;
612: register lispval in2;
613:
614: in2 = inewint(200);
615: for(npt=orgbnp; npt < bnp; npt++)
616: { if((int) npt->atm < (int) in2) abort();
617: }
618: }
619:
620: /*
621: * formatted printer for lisp data
622: * use: (cprintf formatstring datum [port])
623: */
624: lispval
625: Lcprintf()
626: {
627: FILE *p;
628: char *fstrng;
629: lispval v;
630: if(np-lbot == 2) protect(nil); /* write to standard output port */
631: chkarg(3,"cprintf");
632:
633: fstrng = (char *)verify(lbot->val,"cprintf: first arg not string or symbol");
634:
635: p = okport(lbot[2].val,okport(Vpoport->a.clb,poport));
636:
637: switch(TYPE(v=lbot[1].val)) {
638:
639: case INT: fprintf(p,fstrng,v->i);
640: break;
641:
642: case DOUB: fprintf(p,fstrng,v->r);
643: break;
644:
645: case ATOM: fprintf(p,fstrng,v->a.pname);
646: break;
647:
648: case STRNG:fprintf(p,fstrng,v);
649: break;
650:
651: default: error("cprintf: Illegal second argument",FALSE);
652: };
653:
654: return(lbot[1].val);
655: }
656:
657:
658: /*
659: * C style sprintf: (sprintf "format" {<arg-list>})
660: *
661: * This function stacks the arguments onto the C stack in reverse
662: * order and then calls sprintf with one argument...This is what the
663: * C compiler does, so it works just fine. The return value is the
664: * string that is the result of the sprintf.
665: */
666: lispval
667: Lsprintf()
668: {
669: register struct argent *argp;
670: register int j;
671: char sbuf[600], *sprintf(); /* better way? */
672: Keepxs();
673:
674: if (np-lbot == 0) {
675: argerr("sprintf");
676: }
677: if (TYPE(lbot->val)==STRNG || TYPE(lbot->val)==INT) {
678: for (argp = np-1; argp >= lbot; argp--) {
679: switch(TYPE(argp->val)) {
680: case ATOM:
681: stack((long)argp->val->a.pname);
682: break;
683:
684: case DOUB:
685: #ifndef SPISFP
686: stack(argp->val->r);
687: #else
688: {double rr = argp->val->r;
689: stack(((long *)&rr)[1]);
690: stack(((long *)&rr)[0]);}
691: #endif
692: break;
693:
694: case INT:
695: stack(argp->val->i);
696: break;
697:
698: case STRNG:
699: stack((long)argp->val);
700: break;
701:
702: default:
703: error("sprintf: Bad data type to sprintf",
704: FALSE);
705: }
706: }
707: sprintf(sbuf);
708: for (j = 0; j < np-lbot; j++)
709: unstack();
710: } else
711: error("sprintf: First arg must be an atom or string", FALSE);
712: Freexs();
713: return ((lispval) inewstr(sbuf));
714: }
715:
716: lispval
717: Lprobef()
718: {
719: char *name;
720: chkarg(1,"probef");
721:
722: name = (char *)verify(lbot->val,"probef: not symbol or string arg ");
723:
724: if(access(name,0) == 0) return(tatom);
725: else return(nil);
726: }
727:
728: lispval
729: Lsubstring()
730: { register char *name;
731: register lispval index,length;
732: int restofstring = FALSE;
733: int len,ind,reallen;
734:
735: switch (np-lbot)
736: {
737: case 2: restofstring = TRUE;
738: break;
739:
740: case 3: break;
741:
742: default: chkarg(3,"substring");
743: }
744:
745: name = (char *)verify(lbot[0].val,"substring: not symbol or string arg ");
746:
747: while (TYPE(index = lbot[1].val) != INT)
748: { lbot[1].val = errorh1(Vermisc,"substring: non integer index ",nil,
749: TRUE,0,index);
750: }
751:
752: len = strlen(name);
753: ind = index->i;
754:
755: if(ind < 0) ind = len+1 + ind;
756:
757: if(ind < 1 || ind > len) return(nil); /*index out of bounds*/
758: if(restofstring) return((lispval)inewstr(name+ind-1));
759:
760: while (TYPE(length = lbot[2].val) != INT)
761: { lbot[2].val = errorh1(Vermisc,"substring: not integer length ",nil,
762: TRUE,0,length);
763: }
764:
765: if((reallen = length->i ) < 0 || (reallen + ind) > len)
766: return((lispval)inewstr(name+ind-1));
767:
768: strncpy(strbuf,name+ind-1,reallen);
769: strbuf[reallen] = '\0';
770: return((lispval)newstr(0));
771: }
772:
773: /*
774: * This is substringn
775: */
776: lispval
777: Lsstrn()
778: {
779: register char *name;
780: register int len,ind,reallen;
781: lispval index,length;
782: int restofstring = FALSE;
783: Savestack(4);
784:
785: if((np-lbot) == 2) restofstring = TRUE;
786: else { chkarg(3,"substringn");}
787:
788: name = (char *) verify(lbot[0].val,"substringn: non symbol or string arg ");
789:
790: while (TYPE(index = lbot[1].val) != INT)
791: { lbot[1].val = errorh1(Vermisc,"substringn: non integer index ",nil,
792: TRUE,0,index);
793: }
794:
795: if(!restofstring)
796: {
797: while (TYPE(length = lbot[2].val) != INT)
798: { lbot[2].val = errorh1(Vermisc,"substringn: not integer length ",
799: nil, TRUE,0,length);
800: }
801: reallen = length->i;
802: }
803: else reallen = -1;
804:
805: len = strlen(name);
806: ind = index->i;
807: if(ind < 0) ind = len + 1 + ind;
808: if( ind < 1 || ind > len) return(nil);
809:
810: if(reallen == 0)
811: return((lispval)inewint(*(name + ind - 1)));
812: else {
813: char *pnt = name + ind - 1;
814: char *last = name + len -1;
815: lispval cur,start;
816:
817: protect(cur = start = newdot());
818: cur->d.car = inewint(*pnt);
819: while(++pnt <= last && --reallen != 0)
820: {
821: cur->d.cdr = newdot();
822: cur = cur->d.cdr;
823: cur->d.car = inewint(*pnt);
824: }
825: Restorestack();
826: return(start);
827: }
828:
829: }
830:
831: lispval Ipurcopy();
832:
833:
834: lispval
835: Lpurcopy()
836: {
837: chkarg(1,"purcopy");
838: return(Ipurcopy(lbot[0].val));
839: }
840:
841: lispval
842: Ipurcopy(handy)
843: lispval handy;
844: {
845: extern int *beginsweep;
846: register lispval retv, curv, lv;
847: int i,size;
848:
849: switch(TYPE(handy)) {
850:
851: case DTPR:
852: retv = curv = pnewdot();
853: lv = handy;
854: while(TRUE)
855: {
856: curv->d.car = Ipurcopy(lv->d.car);
857: if(TYPE(lv = lv->d.cdr) == DTPR)
858: {
859: curv->d.cdr = pnewdot();
860: curv = curv->d.cdr;
861: }
862: else {
863: curv->d.cdr = Ipurcopy(lv);
864: break;
865: }
866: }
867: return(retv);
868:
869: case SDOT:
870: retv = curv = pnewsdot();
871: lv = handy;
872: while(TRUE)
873: {
874: curv->s.I = lv->s.I;
875: if(lv->s.CDR == (lispval) 0) break;
876: lv = lv->s.CDR;
877: curv->s.CDR = pnewdot();
878: curv = curv->s.CDR;
879: }
880: curv->s.CDR = 0;
881: return(retv);
882:
883: case INT:
884: if((int *)handy < beginsweep) return(handy);
885: retv = pnewint();
886: retv->i = handy->i;
887: return(retv);
888:
889: case DOUB:
890: retv = pnewdoub();
891: retv->r = handy->r;
892: return(retv);
893:
894: case HUNK2:
895: i = 0;
896: goto hunkit;
897:
898: case HUNK4:
899: i = 1;
900: goto hunkit;
901:
902: case HUNK8:
903: i = 2;
904: goto hunkit;
905:
906: case HUNK16:
907: i = 3;
908: goto hunkit;
909:
910: case HUNK32:
911: i = 4;
912: goto hunkit;
913:
914: case HUNK64:
915: i = 5;
916: goto hunkit;
917:
918: case HUNK128:
919: i = 6;
920:
921: hunkit:
922: retv = pnewhunk(i);
923: size = 2 << i ; /* number of elements to copy over */
924: for( i = 0; i < size ; i++)
925: {
926: retv->h.hunk[i] = Ipurcopy(handy->h.hunk[i]);
927: }
928: return(retv);
929:
930:
931:
932: case STRNG:
933: #ifdef GCSTRINGS
934: { extern char purepage[];
935:
936: if(purepage[((int)handy)>>9]==0)
937: return((lispval)pinewstr((char *)handy));}
938:
939: #endif
940: case ATOM:
941: case BCD:
942: case PORT:
943: return(handy); /* We don't want to purcopy these, yet
944: * it won't hurt if we don't mark them
945: * since they either aren't swept or
946: * will be marked in a special way
947: */
948: case ARRAY:
949: error("purcopy: can't purcopy array structures",FALSE);
950:
951: default:
952: error(" bad type to purcopy ",FALSE);
953: /* NOTREACHED */
954: }
955: }
956:
957: /*
958: * Lpurep returns t if the given arg is in pure space
959: */
960: lispval
961: Lpurep()
962: {
963: lispval Ipurep();
964:
965: chkarg(1,"purep");
966: return(Ipurep(lbot->val));
967: }
968:
969:
970:
971: /* vector functions */
972: lispval newvec(), nveci(), Inewvector();
973:
974: /* vector creation and initialization functions */
975: lispval
976: Lnvec()
977: {
978: return(Inewvector(3));
979: }
980:
981: lispval
982: Lnvecb()
983: {
984: return(Inewvector(0));
985: }
986:
987: lispval
988: Lnvecw()
989: {
990: return(Inewvector(1));
991: }
992:
993: lispval
994: Lnvecl()
995: {
996: return(Inewvector(2));
997: }
998:
999: /*
1000: * (new-vector 'x_size ['g_fill] ['g_prop])
1001: * class = 0: byte \
1002: * = 1: word > immediate
1003: * = 2: long /
1004: * = 3: long
1005: */
1006: lispval
1007: Inewvector(class)
1008: {
1009: register int i;
1010: register lispval handy;
1011: register lispval *handy2;
1012: char *chandy;
1013: short *whandy;
1014: long *lhandy;
1015: lispval sizearg, fillarg, proparg;
1016: int size, vsize;
1017:
1018: fillarg = proparg = nil;
1019:
1020: switch(np-lbot) {
1021: case 3: proparg = lbot[2].val;
1022: case 2: fillarg = lbot[1].val;
1023: case 1: sizearg = lbot[0].val;
1024: break;
1025: default: argerr("new-vector");
1026: }
1027:
1028: while((TYPE(sizearg) != INT) || sizearg->i < 0)
1029: sizearg = errorh1(Vermisc,"new-vector: bad size for vector ",nil,
1030: TRUE,0,sizearg);
1031: size = sizearg->i;
1032: switch(class)
1033: {
1034: case 0: vsize = size * sizeof(char);
1035: break;
1036: case 1: vsize = size * sizeof(short);
1037: break;
1038: default: vsize = size * sizeof(long);
1039: break;
1040: }
1041:
1042: if(class != 3) handy = nveci(vsize);
1043: else handy = newvec(vsize);
1044:
1045: switch(class)
1046: {
1047: case 0: chandy = (char *)handy;
1048: for(i = 0 ; i < size ; i++) *chandy++ = (char) (fillarg->i);
1049: break;
1050:
1051: case 1: whandy = (short *)handy;
1052: for(i = 0 ; i < size ; i++) *whandy++ = (short) (fillarg->i);
1053: break;
1054:
1055: case 2: lhandy = (long *)handy;
1056: for(i = 0 ; i < size ; i++) *lhandy++ = (fillarg->i);
1057: break;
1058:
1059: case 3: handy2 = (lispval *)handy;
1060: for(i = 0 ; i < size ; i++) *handy2++ = fillarg;
1061: break;
1062: }
1063: handy->v.vector[-1] = proparg;
1064: return(handy);
1065: }
1066:
1067: lispval
1068: Lvectorp()
1069: {
1070: chkarg(1,"vectorp");
1071: if(TYPE(lbot->val) == VECTOR) return(tatom);
1072: else return(nil);
1073: }
1074:
1075: lispval
1076: Lpvp()
1077: {
1078: chkarg(1,"vectorip");
1079: if(TYPE(lbot->val) == VECTORI) return(tatom);
1080: else return(nil);
1081: }
1082:
1083: /*
1084: * int:vref vector[i] index class
1085: * class = 0: byte immed, 1: word immed, 2: long immed, 3: long
1086: */
1087: lispval
1088: LIvref()
1089: {
1090: register lispval vect;
1091: register int index;
1092: int class;
1093:
1094: chkarg(3,"int:vref");
1095: vect = lbot[0].val;
1096: index = lbot[1].val->i;
1097: class = lbot[2].val->i;
1098: switch(class)
1099: {
1100: case 0: return(inewint(vect->vb.vectorb[index]));
1101: case 1: return(inewint(vect->vw.vectorw[index]));
1102: case 2: return(inewint(vect->vl.vectorl[index]));
1103: case 3: return(vect->v.vector[index]);
1104: }
1105: error("int:vref: impossible class detected",FALSE);
1106: /* NOTREACHED */
1107: }
1108:
1109: /*
1110: * int:vset vector[i] index value class
1111: * class = 0: byte immed, 1: word immed, 2: long immed, 3: long
1112: */
1113: lispval
1114: LIvset()
1115: {
1116: register lispval vect,value;
1117: register int index;
1118: int class;
1119:
1120: chkarg(4,"int:vset");
1121: vect = lbot[0].val;
1122: index = lbot[1].val->i;
1123: value = lbot[2].val;
1124: class = lbot[3].val->i;
1125: switch(class)
1126: {
1127: case 0: vect->vb.vectorb[index] = (char)value->i;
1128: break;
1129: case 1: vect->vw.vectorw[index] = (short)value->i;
1130: break;
1131: case 2: vect->vl.vectorl[index] = value->i;
1132: break;
1133: case 3: vect->v.vector[index] = value;
1134: break;
1135: }
1136: return(value);
1137: }
1138:
1139: /*
1140: * LIvsize == (int:vsize 'vector 'x_shift)
1141: * return the vsize field of the vector shifted right by x_shift
1142: */
1143: lispval
1144: LIvsize()
1145: {
1146: int typ;
1147:
1148: chkarg(2,"int:vsize");
1149: return(inewint((lbot[0].val->vl.vectorl[VSizeOff]) >> lbot[1].val->i));
1150: }
1151:
1152: lispval
1153: Lvprop()
1154: {
1155: int typ;
1156: chkarg(1,"vprop");
1157:
1158: if(((typ = TYPE(lbot->val)) != VECTOR) && (typ != VECTORI))
1159: errorh1(Vermisc,"vprop: non vector argument: ", nil, FALSE,0,
1160: lbot->val);
1161: return(lbot[0].val->v.vector[VPropOff]);
1162: }
1163:
1164:
1165: lispval
1166: Lvsp()
1167: {
1168: int typ;
1169: lispval vector, property;
1170: chkarg(2,"vsetprop");
1171:
1172: vector = lbot->val;
1173: property = lbot[1].val;
1174: typ = TYPE(vector);
1175:
1176: if(typ != VECTOR && typ !=VECTORI)
1177: errorh1(Vermisc,"vsetprop: non vector argument: ",
1178: nil,FALSE,0,vector);
1179: vector->v.vector[VPropOff] = property;
1180: return(property);
1181: }
1182:
1183:
1184: /* vecequal
1185: * check if the two vector arguments are 'equal'
1186: * this is called by equal which has already checked that
1187: * the arguments are vector
1188: */
1189: vecequal(v,w)
1190: lispval v,w;
1191: {
1192: int i;
1193: lispval vv, ww, ret;
1194: int vsize = (int) v->v.vector[VSizeOff];
1195: int wsize = (int) w->v.vector[VSizeOff];
1196: struct argent *oldlbot = lbot;
1197: lispval Lequal();
1198:
1199: if(vsize != wsize) return(FALSE);
1200:
1201: vsize /= sizeof(int); /* determine number of entries */
1202:
1203: for(i = 0 ; i < vsize ; i++)
1204: {
1205: vv = v->v.vector[i];
1206: ww = w->v.vector[i];
1207: /* avoid calling equal if they are eq */
1208: if(vv != ww)
1209: {
1210: lbot = np;
1211: protect(vv);
1212: protect(ww);
1213: ret = Lequal();
1214: np = lbot;
1215: lbot = oldlbot;
1216: if(ret == nil) return(FALSE);
1217: }
1218: }
1219: return(TRUE);
1220: }
1221:
1222: /* veciequal
1223: * check if the two vectori arguments are 'equal'
1224: * this is called by equal which has already checked that
1225: * the arguments are vector
1226: * Note: this would run faster if we did as many 'longword'
1227: * comparisons as possible and then did byte comparisons.
1228: * or if we used pointers instead of indexing.
1229: */
1230: veciequal(v,w)
1231: lispval v,w;
1232: {
1233: char vv, ww;
1234: int i;
1235: int vsize = (int) v->v.vector[VSizeOff];
1236: int wsize = (int) w->v.vector[VSizeOff];
1237:
1238: if(vsize != wsize) return(FALSE);
1239:
1240:
1241: for(i = 0 ; i < vsize ; i++)
1242: {
1243: if(v->vb.vectorb[i] != w->vb.vectorb[i]) return(FALSE);
1244: }
1245: return(TRUE);
1246: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.