![[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] / 43BSD / ucb / lisp / franz|
Return to lam8.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: lam8.c,v 1.16 85/03/24 11:04:31 sklower Exp $";
4: #endif
5:
6: /* -[Thu Sep 29 22:24:10 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: Lrplcx()
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(P(port));
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:
832: /*
833: * (character-index 'string 'char)
834: * return the index of char in the string.
835: * return nil if not present
836: * char can be a fixnum (representing a character)
837: * a symbol or string (in which case the first char is used)
838: *
839: */
840:
841: #if os_unix_ts
842: #define index strchr
843: #endif
844: lispval
845: Lcharindex()
846: {
847: register char *string;
848: register char ch;
849: char *str2;
850:
851: chkarg(2,"character-index");
852:
853:
854: string = (char *)verify(lbot[0].val,"character-index: non symbol or string arg ");
855: if(TYPE(lbot[1].val) == INT)
856: ch = (char) lbot[1].val->i;
857: else {
858: str2 = (char *) verify(lbot[1].val,"character-index: bad first argument ");
859: ch = *str2; /* grab the first character */
860: }
861:
862: if((str2 = (char *) index(string,ch)) == 0) return(nil); /* not there */
863: /* return 1-based index of character */
864: return(inewint(str2-string+1));
865: }
866:
867:
868: lispval Ipurcopy();
869:
870:
871: lispval
872: Lpurcopy()
873: {
874: chkarg(1,"purcopy");
875: return(Ipurcopy(lbot[0].val));
876: }
877:
878: lispval
879: Ipurcopy(handy)
880: lispval handy;
881: {
882: extern int *beginsweep;
883: register lispval retv, curv, lv;
884: int i,size;
885:
886: switch(TYPE(handy)) {
887:
888: case DTPR:
889: retv = curv = pnewdot();
890: lv = handy;
891: while(TRUE)
892: {
893: curv->d.car = Ipurcopy(lv->d.car);
894: if(TYPE(lv = lv->d.cdr) == DTPR)
895: {
896: curv->d.cdr = pnewdot();
897: curv = curv->d.cdr;
898: }
899: else {
900: curv->d.cdr = Ipurcopy(lv);
901: break;
902: }
903: }
904: return(retv);
905:
906: case SDOT:
907: retv = curv = pnewsdot();
908: lv = handy;
909: while(TRUE)
910: {
911: curv->s.I = lv->s.I;
912: if(lv->s.CDR == (lispval) 0) break;
913: lv = lv->s.CDR;
914: curv->s.CDR = pnewdot();
915: curv = curv->s.CDR;
916: }
917: curv->s.CDR = 0;
918: return(retv);
919:
920: case INT:
921: if((int *)handy < beginsweep) return(handy);
922: retv = pnewint();
923: retv->i = handy->i;
924: return(retv);
925:
926: case DOUB:
927: retv = pnewdb();
928: retv->r = handy->r;
929: return(retv);
930:
931: case HUNK2:
932: i = 0;
933: goto hunkit;
934:
935: case HUNK4:
936: i = 1;
937: goto hunkit;
938:
939: case HUNK8:
940: i = 2;
941: goto hunkit;
942:
943: case HUNK16:
944: i = 3;
945: goto hunkit;
946:
947: case HUNK32:
948: i = 4;
949: goto hunkit;
950:
951: case HUNK64:
952: i = 5;
953: goto hunkit;
954:
955: case HUNK128:
956: i = 6;
957:
958: hunkit:
959: retv = pnewhunk(i);
960: size = 2 << i ; /* number of elements to copy over */
961: for( i = 0; i < size ; i++)
962: {
963: retv->h.hunk[i] = Ipurcopy(handy->h.hunk[i]);
964: }
965: return(retv);
966:
967:
968:
969: case STRNG:
970: #ifdef GCSTRINGS
971: { extern char purepage[];
972:
973: if(purepage[((int)handy)>>9]==0)
974: return((lispval)pinewstr((char *)handy));}
975:
976: #endif
977: case ATOM:
978: case BCD:
979: case PORT:
980: return(handy); /* We don't want to purcopy these, yet
981: * it won't hurt if we don't mark them
982: * since they either aren't swept or
983: * will be marked in a special way
984: */
985: case ARRAY:
986: error("purcopy: can't purcopy array structures",FALSE);
987:
988: default:
989: error(" bad type to purcopy ",FALSE);
990: /* NOTREACHED */
991: }
992: }
993:
994: /*
995: * Lpurep returns t if the given arg is in pure space
996: */
997: lispval
998: Lpurep()
999: {
1000: lispval Ipurep();
1001:
1002: chkarg(1,"purep");
1003: return(Ipurep(lbot->val));
1004: }
1005:
1006:
1007:
1008: /* vector functions */
1009: lispval newvec(), nveci(), Inewvector();
1010:
1011: /* vector creation and initialization functions */
1012: lispval
1013: Lnvec()
1014: {
1015: return(Inewvector(3));
1016: }
1017:
1018: lispval
1019: Lnvecb()
1020: {
1021: return(Inewvector(0));
1022: }
1023:
1024: lispval
1025: Lnvecw()
1026: {
1027: return(Inewvector(1));
1028: }
1029:
1030: lispval
1031: Lnvecl()
1032: {
1033: return(Inewvector(2));
1034: }
1035:
1036: /*
1037: * (new-vector 'x_size ['g_fill] ['g_prop])
1038: * class = 0: byte \
1039: * = 1: word > immediate
1040: * = 2: long /
1041: * = 3: long
1042: */
1043: lispval
1044: Inewvector(class)
1045: {
1046: register int i;
1047: register lispval handy;
1048: register lispval *handy2;
1049: char *chandy;
1050: short *whandy;
1051: long *lhandy;
1052: lispval sizearg, fillarg, proparg;
1053: int size, vsize;
1054:
1055: fillarg = proparg = nil;
1056:
1057: switch(np-lbot) {
1058: case 3: proparg = lbot[2].val;
1059: case 2: fillarg = lbot[1].val;
1060: case 1: sizearg = lbot[0].val;
1061: break;
1062: default: argerr("new-vector");
1063: }
1064:
1065: while((TYPE(sizearg) != INT) || sizearg->i < 0)
1066: sizearg = errorh1(Vermisc,"new-vector: bad size for vector ",nil,
1067: TRUE,0,sizearg);
1068: size = sizearg->i;
1069: switch(class)
1070: {
1071: case 0: vsize = size * sizeof(char);
1072: break;
1073: case 1: vsize = size * sizeof(short);
1074: break;
1075: default: vsize = size * sizeof(long);
1076: break;
1077: }
1078:
1079: if(class != 3) handy = nveci(vsize);
1080: else handy = newvec(vsize);
1081:
1082: switch(class)
1083: {
1084: case 0: chandy = (char *)handy;
1085: for(i = 0 ; i < size ; i++) *chandy++ = (char) (fillarg->i);
1086: break;
1087:
1088: case 1: whandy = (short *)handy;
1089: for(i = 0 ; i < size ; i++) *whandy++ = (short) (fillarg->i);
1090: break;
1091:
1092: case 2: lhandy = (long *)handy;
1093: for(i = 0 ; i < size ; i++) *lhandy++ = (fillarg->i);
1094: break;
1095:
1096: case 3: handy2 = (lispval *)handy;
1097: for(i = 0 ; i < size ; i++) *handy2++ = fillarg;
1098: break;
1099: }
1100: handy->v.vector[-1] = proparg;
1101: return(handy);
1102: }
1103:
1104: lispval
1105: Lvectorp()
1106: {
1107: chkarg(1,"vectorp");
1108: if(TYPE(lbot->val) == VECTOR) return(tatom);
1109: else return(nil);
1110: }
1111:
1112: lispval
1113: Lpvp()
1114: {
1115: chkarg(1,"vectorip");
1116: if(TYPE(lbot->val) == VECTORI) return(tatom);
1117: else return(nil);
1118: }
1119:
1120: /*
1121: * int:vref vector[i] index class
1122: * class = 0: byte immed, 1: word immed, 2: long immed, 3: long
1123: *
1124: * also do C style dereferencing of pointers. This is a temporary
1125: * hack until we decide if we can live without it:
1126: * class = 4: char, 5: short, 6: long, 7: float, 8: double
1127: */
1128: lispval
1129: LIvref()
1130: {
1131: register lispval vect;
1132: register int index;
1133: int class;
1134: double value;
1135:
1136: chkarg(3,"int:vref");
1137: vect = lbot[0].val;
1138: index = lbot[1].val->i;
1139: class = lbot[2].val->i;
1140: switch(class)
1141: {
1142: case 0: return(inewint(vect->vb.vectorb[index]));
1143: case 1: return(inewint(vect->vw.vectorw[index]));
1144: case 2: return(inewint(vect->vl.vectorl[index]));
1145: case 3: return(vect->v.vector[index]);
1146: case 4: return(inewint(*(char *)(vect->i+index)));
1147: case 5: return(inewint(*(short *)(vect->i+index)));
1148: case 6: return(inewint(*(long *)(vect->i+index)));
1149: case 7: value = *(float *) (vect->i+index);
1150: vect = newdoub();
1151: vect->r = value;
1152: return(vect);
1153: case 8: value = *(double *) (vect->i+index);
1154: vect = newdoub();
1155: vect->r = value;
1156: return(vect);
1157: }
1158: error("int:vref: impossible class detected",FALSE);
1159: /* NOTREACHED */
1160: }
1161:
1162: /*
1163: * int:vset vector[i] index value class
1164: * class = 0: byte immed, 1: word immed, 2: long immed, 3: long
1165: */
1166: lispval
1167: LIvset()
1168: {
1169: register lispval vect,value;
1170: register int index;
1171: int class;
1172:
1173: chkarg(4,"int:vset");
1174: vect = lbot[0].val;
1175: index = lbot[1].val->i;
1176: value = lbot[2].val;
1177: class = lbot[3].val->i;
1178: switch(class)
1179: {
1180: case 0: vect->vb.vectorb[index] = (char)value->i;
1181: break;
1182: case 1: vect->vw.vectorw[index] = (short)value->i;
1183: break;
1184: case 2: vect->vl.vectorl[index] = value->i;
1185: break;
1186: case 3: vect->v.vector[index] = value;
1187: break;
1188: case 4: *(char *) (vect->i+index) = value->i;
1189: break;
1190: case 5: *(short *) (vect->i+index) = value->i;
1191: break;
1192: case 6: *(long *) (vect->i+index) = value->i;
1193: break;
1194: case 7: *(float *) (vect->i+index) = value->r;
1195: break;
1196: case 8: *(double *) (vect->i+index) = value->r;
1197: break;
1198: default:
1199: error("int:vref: impossible class detected",FALSE);
1200: }
1201: return(value);
1202: }
1203:
1204: /*
1205: * LIvsize == (int:vsize 'vector 'x_shift)
1206: * return the vsize field of the vector shifted right by x_shift
1207: */
1208: lispval
1209: LIvsize()
1210: {
1211: int typ;
1212:
1213: chkarg(2,"int:vsize");
1214: return(inewint((lbot[0].val->vl.vectorl[VSizeOff]) >> lbot[1].val->i));
1215: }
1216:
1217: lispval
1218: Lvprop()
1219: {
1220: int typ;
1221: chkarg(1,"vprop");
1222:
1223: if(((typ = TYPE(lbot->val)) != VECTOR) && (typ != VECTORI))
1224: errorh1(Vermisc,"vprop: non vector argument: ", nil, FALSE,0,
1225: lbot->val);
1226: return(lbot[0].val->v.vector[VPropOff]);
1227: }
1228:
1229:
1230: lispval
1231: Lvsp()
1232: {
1233: int typ;
1234: lispval vector, property;
1235: chkarg(2,"vsetprop");
1236:
1237: vector = lbot->val;
1238: property = lbot[1].val;
1239: typ = TYPE(vector);
1240:
1241: if(typ != VECTOR && typ !=VECTORI)
1242: errorh1(Vermisc,"vsetprop: non vector argument: ",
1243: nil,FALSE,0,vector);
1244: vector->v.vector[VPropOff] = property;
1245: return(property);
1246: }
1247:
1248:
1249: /* vecequal
1250: * check if the two vector arguments are 'equal'
1251: * this is called by equal which has already checked that
1252: * the arguments are vector
1253: */
1254: vecequal(v,w)
1255: lispval v,w;
1256: {
1257: int i;
1258: lispval vv, ww, ret;
1259: int vsize = (int) v->v.vector[VSizeOff];
1260: int wsize = (int) w->v.vector[VSizeOff];
1261: struct argent *oldlbot = lbot;
1262: lispval Lequal();
1263:
1264: if(vsize != wsize) return(FALSE);
1265:
1266: vsize /= sizeof(int); /* determine number of entries */
1267:
1268: for(i = 0 ; i < vsize ; i++)
1269: {
1270: vv = v->v.vector[i];
1271: ww = w->v.vector[i];
1272: /* avoid calling equal if they are eq */
1273: if(vv != ww)
1274: {
1275: lbot = np;
1276: protect(vv);
1277: protect(ww);
1278: ret = Lequal();
1279: np = lbot;
1280: lbot = oldlbot;
1281: if(ret == nil) return(FALSE);
1282: }
1283: }
1284: return(TRUE);
1285: }
1286:
1287: /* veciequal
1288: * check if the two vectori arguments are 'equal'
1289: * this is called by equal which has already checked that
1290: * the arguments are vector
1291: * Note: this would run faster if we did as many 'longword'
1292: * comparisons as possible and then did byte comparisons.
1293: * or if we used pointers instead of indexing.
1294: */
1295: veciequal(v,w)
1296: lispval v,w;
1297: {
1298: char vv, ww;
1299: int i;
1300: int vsize = (int) v->v.vector[VSizeOff];
1301: int wsize = (int) w->v.vector[VSizeOff];
1302:
1303: if(vsize != wsize) return(FALSE);
1304:
1305:
1306: for(i = 0 ; i < vsize ; i++)
1307: {
1308: if(v->vb.vectorb[i] != w->vb.vectorb[i]) return(FALSE);
1309: }
1310: return(TRUE);
1311: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.