![[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] / 40BSD / cmd / lisp|
Return to lam8.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 root 1: static char *sccsid = "@(#)lam8.c 34.5 11/7/80";
2:
3: #include "global.h"
4: #include <sys/types.h>
5: #include <pagsiz.h>
6: #include "naout.h"
7:
8: /* various functions from the c math library */
9: double sin(),cos(),asin(),acos(),atan2(),sqrt(), log(), exp();
10: extern int current;
11:
12: lispval Imath(func)
13: double (*func)();
14: {
15: register lispval handy;
16: register double res;
17: chkarg(1,"Math functions");
18:
19: switch(TYPE(handy=lbot->val)) {
20: case INT: res = func((double)handy->i);
21: break;
22:
23: case DOUB: res = func(handy->r);
24: break;
25:
26: default: error("Non fixnum or flonum to math function",FALSE);
27: }
28: handy = newdoub();
29: handy->r = res;
30: return(handy);
31: }
32: lispval Lsin()
33: {
34: return(Imath(sin));
35: }
36:
37: lispval Lcos()
38: {
39: return(Imath(cos));
40: }
41:
42: lispval Lasin()
43: {
44: return(Imath(asin));
45: }
46:
47: lispval Lacos()
48: {
49: return(Imath(acos));
50: }
51:
52: lispval Lsqrt()
53: {
54: return(Imath(sqrt));
55: }
56: lispval Lexp()
57: {
58: return(Imath(exp));
59: }
60:
61: lispval Llog()
62: {
63: return(Imath(log));
64: }
65:
66: /* although we call this atan, it is really atan2 to the c-world,
67: that is, it takes two args
68: */
69: lispval Latan()
70: {
71: register lispval arg;
72: register double arg1v;
73: register double res;
74: chkarg(2,"arctan");
75:
76: switch(TYPE(arg=lbot->val)) {
77:
78: case INT: arg1v = (double) arg->i;
79: break;
80:
81: case DOUB: arg1v = arg->r;
82: break;
83:
84: default: error("Non fixnum or flonum arg to atan2",FALSE);
85: }
86:
87: switch(TYPE(arg = (lbot+1)->val)) {
88:
89: case INT: res = atan2(arg1v,(double) arg->i);
90: break;
91:
92: case DOUB: res = atan2(arg1v, arg->r);
93: break;
94:
95: default: error("Non fixnum or flonum to atan2",FALSE);
96: }
97: arg = newdoub();
98: arg->r = res;
99: return(arg);
100: }
101:
102: /* (random) returns a fixnum in the range -2**30 to 2**30 -1
103: (random fixnum) returns a fixnum in the range 0 to fixnum-1
104: */
105: lispval
106: Lrandom()
107: {
108: register int curval;
109: float pow();
110:
111: curval = rand(); /* get numb from 0 to 2**31-1 */
112:
113: if(np==lbot) return(inewint(curval-(int)pow((double)2,(double)30)));
114:
115: if((TYPE(lbot->val) != INT)
116: || (lbot->val->i <= 0)) errorh(Vermisc,"random: non fixnum arg:",
117: nil, FALSE, 0, lbot->val);
118:
119: return(inewint(curval % lbot->val->i ));
120:
121: }
122: lispval
123: Lmakunb()
124: {
125: register lispval work;
126:
127: chkarg(1,"makunbound");
128: work = lbot->val;
129: if(work==nil || (TYPE(work)!=ATOM))
130: return(work);
131: work->a.clb = CNIL;
132: return(work);
133: }
134: lispval
135: Lpolyev()
136: {
137: register int count;
138: register double *handy, *base;
139: register struct argent *argp, *lbot, *np;
140: lispval result; int type;
141:
142: count = 2 * (((int) np) - (int) lbot);
143: if(count == 0)
144: return(inewint(0));
145: if(count == 8)
146: return(lbot->val);
147: base = handy = (double *) alloca(count);
148: for(argp = lbot; argp < np; argp++) {
149: while((type = TYPE(argp->val))!=DOUB && type!=INT)
150: argp->val = (lispval) errorh(Vermisc,"%%machine-polyev:non-real arg",nil,TRUE,73,lbot,argp->val);
151: if(TYPE(argp->val)==INT) {
152: *handy++ = argp->val->i;
153: } else
154: *handy++ = argp->val->r;
155: }
156: count = count/sizeof(double) - 2;
157: asm("polyd (r9),r11,8(r9)");
158: asm("movd r0,(r9)");
159: result = newdoub();
160: result->r = *base;
161: return(result);
162: }
163: typedef struct doub {
164: unsigned short f1:7,expt:8,sign:1;
165: unsigned short f2,f3p1:14,f3p2:2,f4;
166: } *dp;
167:
168: typedef struct quad2 {
169: unsigned long g4:16,g3p1:14;
170: } *qp2;
171:
172: typedef struct quad1 {
173: unsigned long g3p2:2,g2:16,g1:7,hide:1;
174: } *qp1;
175:
176: static long workbuf[2];
177: static int exponent;
178: static Idebig()
179: {
180: register lispval work;
181: register dp rdp;
182: register qp1 rqp1;
183: register qp2 rqp2;
184: register struct argent *lbot,np;
185: workbuf[1] = workbuf[0] = 0;
186:
187: work = lbot->val; /* Unfold mantissa */
188: rqp2 = (qp2) workbuf + 1;
189: rqp1 = (qp1) workbuf;
190: rdp = (dp) work;
191: rqp2->g4 = rdp->f4;
192: rqp2->g3p1 = rdp->f3p1;
193: rqp1->g3p2 = rdp->f3p2;
194: rqp1->g2 = rdp->f2;
195: rqp1->g1 = rdp->f1;
196: rqp1->hide = 1;
197: if(rdp->sign) {
198: workbuf[0] = (- workbuf[0]);
199: if(workbuf[1] = (- workbuf[1]) & 0xC0000000)
200: workbuf[0]--;
201: }
202: /* calcuate exponent and adjustment */
203: exponent = -129 - 55 + (int) rdp->expt;
204: }
205: lispval
206: Lfdecom()
207: {
208: register lispval result, handy;
209: register dum1,dum2;
210: register struct argent *lbot,*np;
211:
212: chkarg(1,"Decompose-float");
213: while(TYPE(lbot->val)!=DOUB)
214: lbot->val = error("Decompose-float: Non-real argument",TRUE);
215: Idebig();
216: np++->val = result = handy = newdot();
217: handy->d.car = inewint(exponent);
218: handy = handy->d.cdr = newdot();
219: handy = handy->d.car = newsdot();
220: handy->s.I = workbuf[1];
221: handy = handy->s.CDR = newsdot();
222: handy->s.I = workbuf[0];
223: }
224:
225: lispval
226: Lfseek()
227: {
228: register lispval result, handy;
229: register dum1,dum2;
230: register struct argent *lbot,*np;
231:
232: FILE *f;
233: long disk_addr, offset, whence;
234: lispval retp;
235:
236: chkarg(3,"fseek"); /* Make sure there are three arguments*/
237:
238: f = lbot->val->p; /* Get first argument into f */
239: if (TYPE(lbot->val)!=PORT) /* Check type of first */
240: error("fseek: First argument must be a port.",FALSE);
241:
242: offset = lbot[1].val->i; /* Get second argument */
243: if (TYPE(lbot[1].val)!=INT)
244: error("fseek: Second argument must be an integer.",FALSE);
245:
246: whence = lbot[2].val->i; /* Get last arg */
247: if (TYPE(lbot[2].val)!=INT)
248: error("fseek: Third argument must be an integer.",FALSE);
249:
250: if (fseek(f, offset, whence) == -1)
251: error("fseek: Illegal parameters.",FALSE);
252:
253: retp = inewint(ftell(f));
254:
255: return((lispval) retp);
256: }
257:
258: /* function hashtabstat : return list of number of members in each bucket */
259: lispval Lhashst()
260: {
261: register lispval handy,cur;
262: register struct atom *pnt;
263: int i,cnt;
264: extern int hashtop;
265: snpand(3);
266:
267: handy = newdot();
268: protect(handy);
269: cur = handy;
270: for(i = 0; i < hashtop; i++)
271: {
272: pnt = hasht[i];
273: for(cnt = 0; pnt != (struct atom *) CNIL ; pnt=pnt->hshlnk , cnt++);
274: cur->d.cdr = newdot();
275: cur = cur->d.cdr;
276: cur->d.car = inewint(cnt);
277: }
278: cur->d.cdr = nil;
279: return(handy->d.cdr);
280: }
281:
282:
283: /* Lctcherr
284: this routine should only be called by the unwind protect simulation
285: lisp code
286: It is called after an unwind-protect frame has been entered and
287: evalated and we want to get on with the error or throw
288: We only handle the case where there are 0 to 2 extra arguments to the
289: error call.
290: */
291: lispval
292: Lctcherr()
293: {
294: register lispval handy;
295: lispval type,messg,valret,contuab,uniqid,datum1,datum2;
296: snpand(1);
297:
298: if(lbot-np==0) protect(nil);
299: if((handy = lbot->val) == nil) return(nil);
300:
301: if(handy->d.car == tatom)
302: { /* continuaing a throw */
303: Idothrow(handy->d.cdr->d.car, handy->d.cdr->d.cdr->d.car);
304: error("ctcherr: throw label gone!",FALSE);
305: }
306:
307: /* decode the arg list */
308: handy = handy->d.cdr;
309: type = handy->d.car;
310: handy = handy->d.cdr;
311: messg = handy->d.car;
312: handy = handy->d.cdr;
313: valret = handy->d.car;
314: handy = handy->d.cdr;
315: contuab = handy->d.car;
316: handy = handy->d.cdr;
317: uniqid = handy->d.car;
318: handy = handy->d.cdr;
319:
320: /* if not extra args */
321: if(handy == nil)
322: {
323: errorh(type,messg->a.pname,valret,contuab->i,uniqid->i);
324: }
325: datum1 = handy->d.car;
326: handy = handy->d.cdr;
327:
328: /* if one extra arg */
329: if(handy == nil)
330: {
331: errorh(type,messg->a.pname,valret,contuab->i,uniqid->i,datum1);
332: }
333:
334: /* if two or more extra args, just use first 2 */
335: datum2 = handy->d.car;
336: errorh(type,messg->a.pname,valret,contuab->i,uniqid->i,datum1,datum2);
337: }
338:
339: /*
340: * (*makhunk '<fixnum>)
341: * <fixnum>
342: * Create a hunk of size 2 . <fixnum> must be between 0 and 6.
343: *
344: */
345:
346: lispval
347: LMakhunk()
348: {
349: register int hsize, hcntr;
350: register lispval result;
351:
352: chkarg(1,"Makehunk");
353: if (TYPE(lbot->val)==INT)
354: {
355: hsize = lbot->val->i; /* size of hunk (0-6) */
356: if ((hsize >= 0) && (hsize <= 6))
357: {
358: result = newhunk(hsize);
359: hsize = 2 << hsize; /* size of hunk (2-128) */
360: for (hcntr = 0; hcntr < hsize; hcntr++)
361: result->h.hunk[hcntr] = hunkfree;
362: }
363: else
364: error("*makhunk: Illegal hunk size", FALSE);
365: return(result);
366: }
367: else
368: error("*makhunk: First arg must be an fixnum",FALSE);
369: }
370:
371: /*
372: * (cxr '<fixnum> '<hunk>)
373: * Returns the <fixnum>'th element of <hunk>
374: *
375: */
376: lispval
377: Lcxr()
378: {
379: register lispval temp;
380:
381: chkarg(2,"cxr");
382: if (TYPE(lbot->val)!=INT)
383: error("cxr: First arg must be a fixnum", FALSE);
384: else
385: {
386: if (! HUNKP(lbot[1].val))
387: error("cxr: Second arg must be a hunk", FALSE);
388: else
389: if ( (lbot->val->i >= 0) &&
390: (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) )
391: {
392: temp = lbot[1].val->h.hunk[lbot->val->i];
393: if (temp != hunkfree)
394: return(temp);
395: else
396: error("cxr: Arg outside of hunk range",
397: FALSE);
398: }
399: else
400: error("cxr: Arg outside of hunk range", FALSE);
401: }
402: }
403:
404: /*
405: * (rplacx '<fixnum> '<hunk> '<expr>)
406: * Replaces the <fixnum>'th element of <hunk> with <expr>.
407: *
408: */
409: lispval
410: Lrplacx()
411: {
412: lispval *handy;
413: chkarg(3,"rplacx");
414: if (TYPE(lbot->val)!=INT)
415: error("rplacx: First arg must be a fixnum", FALSE);
416: else
417: {
418: if (! HUNKP(lbot[1].val))
419: error("rplacx: Second arg must be a hunk", FALSE);
420: else
421: {
422: if ( (lbot->val->i >= 0) &&
423: (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) )
424: {
425: if (*(handy = &(lbot[1].val->h.hunk[lbot->val->i]))
426: != hunkfree)
427: *handy = lbot[2].val;
428: else
429: error("rplacx: Arg outside hunk range", FALSE);
430: }
431: else
432: error("rplacx: Arg outside hunk range", FALSE);
433: }
434: }
435: return(lbot[1].val);
436: }
437:
438: /*
439: * (*rplacx '<fixnum> '<hunk> '<expr>)
440: * Replaces the <fixnum>'th element of <hunk> with <expr>. This is the
441: * same as (rplacx ...) except with this function you can replace EMPTY's.
442: *
443: */
444: lispval
445: Lstarrpx()
446: {
447: chkarg(3,"*rplacx");
448: if (TYPE(lbot->val)!=INT)
449: error("*rplacx: First arg must be a fixnum", FALSE);
450: else
451: {
452: if (! HUNKP(lbot[1].val))
453: error("*rplacx: Second arg must be a hunk", FALSE);
454: else
455: {
456: if ( (lbot->val->i >= 0) &&
457: (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) )
458: lbot[1].val->h.hunk[lbot->val->i] = lbot[2].val;
459: else
460: error("*rplacx: Arg outside hunk range", FALSE);
461: }
462: }
463: return(lbot[1].val);
464: }
465:
466: /*
467: * (hunksize '<hunk>)
468: * Returns the size of <hunk>
469: *
470: */
471: lispval
472: Lhunksize()
473: {
474: register int size,i;
475:
476: chkarg(1,"hunksize");
477: if (HUNKP(lbot->val))
478: {
479: size = 2 << HUNKSIZE(lbot->val);
480: for (i = size-1; i >= 0; i--)
481: {
482: if (lbot->val->h.hunk[i] != hunkfree)
483: {
484: size = i + 1;
485: break;
486: }
487: }
488: return( inewint(size) );
489: }
490: else
491: error("hunksize: First argument must me a hunk", FALSE);
492: }
493:
494: /*
495: * (fileopen filename mode)
496: * open a file for read, write, or append the arguments can be either
497: * strings or atoms.
498: */
499: lispval
500: Lfileopen()
501: {
502: FILE *port;
503: register lispval name;
504: register lispval mode;
505: register char *namech;
506: register char *modech;
507: register struct argent *lbot, *np;
508: int typ;
509:
510: chkarg(2,"fileopen");
511: name = lbot->val;
512: mode = lbot[1].val;
513:
514: namech = (char *) verify(name,"fileopen:args must be atoms or strings");
515: modech = (char *) verify(mode,"fileopen:args must be atoms or strings");
516:
517: while (modech[0] != 'r' && modech[0] != 'w' && modech[0] != 'a')
518: {
519: mode = errorh(Vermisc,"Modes are only r, w, a.",nil,TRUE,31,(char *) 0);
520: modech = (char *) verify(mode,"fileopen:args must be atoms or strings");
521: }
522:
523: while ((port = fopen(namech, modech)) == NULL)
524: {
525: name = errorh(Vermisc,"Unable to open file.",nil,TRUE,31,name);
526: namech = (char *) verify(name,"fileopen:args must be atoms or strings");
527: }
528: /* xports is a FILE *, cc complains about adding pointers */
529:
530: return( (lispval) (xports + (port - _iob)));
531: }
532:
533: /*
534: * (*mod '<number> '<modulus>)
535: * This function returns <number> mod <modulus> (for balanced modulus).
536: * It is used in vaxima as a speed enhancement.
537: */
538: lispval
539: LstarMod()
540: {
541: register int mod_div_2, number, modulus;
542:
543: chkarg(2,"*mod");
544: if ((TYPE(lbot->val) == INT) && (TYPE(lbot[1].val) == INT))
545: {
546: modulus = lbot[1].val->i;
547: number = lbot->val->i % modulus;
548: mod_div_2 = modulus / 2;
549: if (number < 0)
550: {
551: if (number < (-mod_div_2))
552: number += modulus;
553: }
554: else
555: {
556: if (number > mod_div_2)
557: number -= modulus;
558: }
559: return( inewint(number) );
560: }
561: else
562: error("*mod: Arguments must be fixnums", FALSE);
563: }
564: lispval
565: Llsh()
566: {
567: register struct argent *mylbot = lbot;
568: int val,shift;
569:
570: chkarg(2,"lsh");
571: if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT))
572: errorh(Vermisc,
573: "Non ints to lsh",
574: nil,FALSE,0,mylbot->val,mylbot[1].val);
575: val = mylbot[0].val->i;
576: shift = mylbot[1].val->i;
577: if(shift < -32 || shift > 32)
578: return(inewint(0));
579: val = val << shift; /* do the shift */
580: if((val < 0) && (shift < 0))
581: { /* special case: the vax doesn't have a logical shift
582: instruction, so we must zero out the ones which
583: will propogate from the sign position
584: */
585: return(inewint ( val & ~(0x80000000 << (shift+1))));
586: }
587: else return( inewint(val));
588: }
589:
590: lispval
591: Lrot()
592: {
593: register rot,val; /* these must be the first registers */
594: register struct argent *mylbot = lbot;
595:
596: chkarg(2,"rot");
597: if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT))
598: errorh(Vermisc,
599: "Non ints to rot",
600: nil,FALSE,0,mylbot->val,mylbot[1].val);
601: val = mylbot[0].val->i;
602: rot = mylbot[1].val->i;
603: rot = rot % 32 ; /* bring it down below one byte in size */
604: asm(" rotl r11,r10,r10 "); /* rotate val by rot and put back in val */
605: return( inewint(val));
606: }
607:
608: /*----------------- vms routines to simulate dumplisp -------------------- */
609: #ifdef VMS
610:
611: extern char firstalloc[];
612: extern int lsbrkpnt;
613: extern char zfreespace[];
614: extern int end;
615:
616: #define roundup(a,b) (((a-1)|(b-1))+1)
617: lispval
618: Lsavelsp()
619: {
620: char *filnm;
621: int fp,i,num,start;
622:
623: chkarg(1,"savelisp");
624:
625: filnm = (char *) verify(lbot->val, "savelisp: non atom arg");
626: if((fp=creat(filnm,0666)) < 0)
627: errorh(Vermisc,"savelisp: can't open file",nil,FALSE,0,
628: lbot->val);
629: start = roundup((int)firstalloc,PAGSIZ);
630: num = roundup(((int)lsbrkpnt)-NBPG-start,PAGSIZ);
631: if((num = write(fp,start,num)) <= 0)
632: error("savelisp: write failed ",FALSE);
633: printf(" %x bytes written from %x to %x \n",num,start,start+num-1);
634: close(fp);
635: return(tatom);
636: }
637:
638: lispval
639: Lrestlsp()
640: {
641: char *filnm;
642: int fp,i,num,start;
643: extern int xcycle;
644:
645: chkarg(1,"restorelisp");
646:
647: filnm = (char *) verify(lbot->val,"restorelisp: non atom arg");
648: if((fp=open(filnm,0)) < 0)
649: errorh(Vermisc,"restorelisp: can't open file",nil,FALSE,0,
650: lbot->val);
651:
652: start = roundup((int)firstalloc,PAGSIZ);
653: if((num = vread(fp,start,((int)&end)-start)) <= 0)
654: error("restorelisp: read failed " ,FALSE);
655: printf(" %x bytes read into %x to %x\n",num,start,start+num-1);
656: xcycle = 0; /* indicate no saved pages to xsbrk */
657: close(fp);
658: bnp = orgbnp;
659: lbot = np = orgnp;
660: contval = 0;
661: reset(BRRETB); /* reset */
662: }
663: #endif
664:
665: /*----------------------------------------------------------- */
666:
667:
668: /* getaddress --
669: *
670: * (getaddress '|_entry1| 'fncname1 '|_entry2| 'fncname2 ...)
671: *
672: * binds value of symbol |_entry1| to function defition of atom fncname1, etc.
673: *
674: * returns fnc-binding of fncname1.
675: *
676: */
677:
678: lispval
679: Lgetaddress(){
680: register struct argent *mlbot = lbot;
681: register lispval work;
682: register int numberofargs, i;
683: register struct argent *lbot, *np;
684: char *gstab();
685: char ostabf[128];
686: struct nlist NTABLE[100];
687: lispval dispget();
688:
689: snpand(2);
690:
691: if(np-lbot == 2) protect(nil); /* allow 2 args */
692: numberofargs = (np - lbot)/3;
693: if(numberofargs * 3 != np-lbot)
694: error("getaddress: arguments must come in triples ",FALSE);
695:
696: for ( i=0; i<numberofargs; i++,mlbot += 3) {
697: NTABLE[i].n_value = 0;
698: mlbot[0].val = verify(mlbot[0].val,"Incorrect entry specification for binding");
699: NTABLE[i].n_un.n_name = (char *) mlbot[0].val;
700: while(TYPE(mlbot[1].val) != ATOM)
701: mlbot[1].val = errorh(Vermisc,
702: "Bad associated atom name for binding",
703: nil,TRUE,0,mlbot[1].val);
704: mlbot[2].val = dispget(mlbot[2].val,"getaddress: Incorrect discipline specification ",Vsubrou->a.pname);
705: }
706: NTABLE[(numberofargs)].n_un.n_name = "";
707: strcpyn(ostabf,gstab(),128);
708: if ( nlist(ostabf,NTABLE) == -1 ) {
709: errorh(Vermisc,"Getaddress: Bad file",nil,FALSE,0,inewstr(ostabf));
710: } else
711: for (i=0,mlbot=lbot+1; i<numberofargs; i++,mlbot+=3) {
712: if ( NTABLE[i].n_value == 0 )
713: fprintf(stderr,"Undefined symbol: %s\n",
714: NTABLE[i].n_un.n_name);
715: else {
716: work= newfunct();
717: work->bcd.entry = (lispval (*) ())NTABLE[i].n_value;
718: work->bcd.discipline = mlbot[1].val;
719: mlbot->val->a.fnbnd = work;
720: }
721: };
722: return(lbot[1].val->a.fnbnd);
723: };
724:
725: /* very temporary function to test the validity of the bind stack */
726:
727: bndchk()
728: {
729: register struct nament *npt;
730: register lispval in2;
731:
732: in2 = inewint(200);
733: for(npt=orgbnp; npt < bnp; npt++)
734: { if((int) npt->atm < (int) in2) asm(" halt ");
735: }
736: }
737:
738: /*
739: * formatted printer for lisp data
740: * use: (cprintf formatstring datum [port])
741: */
742: lispval
743: Lcprintf()
744: {
745: FILE *p;
746: char *fstrng;
747: lispval v;
748: if(np-lbot == 2) protect(nil); /* write to standard output port */
749: chkarg(3,"cprintf");
750:
751: fstrng = (char *)verify(lbot->val,"cprintf: first arg not string or symbol");
752:
753: p = okport(lbot[2].val,okport(Vpoport->a.clb,poport));
754:
755: switch(TYPE(v=lbot[1].val)) {
756:
757: case INT: fprintf(p,fstrng,v->i);
758: break;
759:
760: case DOUB: fprintf(p,fstrng,v->r);
761: break;
762:
763: case ATOM: fprintf(p,fstrng,v->a.pname);
764: break;
765:
766: case STRNG:fprintf(p,fstrng,v);
767: break;
768:
769: default: error("cprintf: Illegal second argument",FALSE);
770: };
771:
772: return(lbot[1].val);
773: }
774:
775: lispval
776: Lprobef()
777: {
778: char *name;
779: chkarg(1,"probef");
780:
781: name = (char *)verify(lbot->val,"probef: not symbol or string arg ");
782:
783: if(access(name,0) == 0) return(tatom);
784: else return(nil);
785: }
786:
787: lispval
788: Lsubstring()
789: { register char *name;
790: register lispval index,length;
791: int restofstring = FALSE;
792: int len,ind,reallen;
793: extern char strbuf[];
794:
795: switch (np-lbot)
796: {
797: case 2: restofstring = TRUE;
798: break;
799:
800: case 3: break;
801:
802: default: chkarg(3,"substring");
803: }
804:
805: name = (char *)verify(lbot[0].val,"substring: not symbol or string arg ");
806:
807: while (TYPE(index = lbot[1].val) != INT)
808: { lbot[1].val = errorh(Vermisc,"substring: non integer index ",nil,
809: TRUE,0,index);
810: }
811:
812: len = strlen(name);
813: ind = index->i;
814:
815: if(ind < 0) ind = len+1 + ind;
816:
817: if(ind < 1 || ind > len) return(nil); /*index out of bounds*/
818: if(restofstring) return((lispval)inewstr(name+ind-1));
819:
820: while (TYPE(length = lbot[2].val) != INT)
821: { lbot[2].val = errorh(Vermisc,"substring: not integer length ",nil,
822: TRUE,0,length);
823: }
824:
825: if((reallen = length->i ) < 0 || (reallen + ind) > len)
826: return((lispval)inewstr(name+ind-1));
827:
828: strncpy(strbuf,name+ind-1,reallen);
829: strbuf[reallen] = '\0';
830: return((lispval)newstr());
831: }
832:
833: lispval
834: Lsubstringn()
835: {
836: register char *name;
837: register int len,ind,reallen;
838: lispval index,length;
839: int restofstring = FALSE;
840: snpand(4);
841:
842: if((np-lbot) == 2) restofstring = TRUE;
843: else { chkarg(3,"substringn");}
844:
845: name = (char *) verify(lbot[0].val,"substringn: non symbol or string arg ");
846:
847: while (TYPE(index = lbot[1].val) != INT)
848: { lbot[1].val = errorh(Vermisc,"substringn: non integer index ",nil,
849: TRUE,0,index);
850: }
851:
852: if(!restofstring)
853: {
854: while (TYPE(length = lbot[2].val) != INT)
855: { lbot[2].val = errorh(Vermisc,"substringn: not integer length ",
856: nil, TRUE,0,length);
857: }
858: reallen = length->i;
859: }
860: else reallen = -1;
861:
862: len = strlen(name);
863: ind = index->i;
864: if(ind < 0) ind = len + 1 + ind;
865: if( ind < 1 || ind > len) return(nil);
866:
867: if(reallen == 0)
868: return((lispval)inewint(*(name + ind - 1)));
869: else {
870: char *pnt = name + ind - 1;
871: char *last = name + len -1;
872: lispval cur,start;
873:
874: protect(cur = start = newdot());
875: cur->d.car = inewint(*pnt);
876: while(++pnt <= last && --reallen != 0)
877: {
878: cur->d.cdr = newdot();
879: cur = cur->d.cdr;
880: cur->d.car = inewint(*pnt);
881: }
882: return(start);
883: }
884:
885: }
886:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.