![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fex4.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / lisp|
Return to fex4.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / lisp |
1.1 ! root 1: #include "global.h" ! 2: #include "lfuncs.h" ! 3: #include "chkrtab.h" ! 4: #include <signal.h> ! 5: ! 6: lispval ! 7: Nsyscall() { ! 8: register lispval aptr, temp; ! 9: register int acount = 0; ! 10: int args[50]; ! 11: snpand(3); ! 12: ! 13: aptr = lbot->val; ! 14: temp = eval(aptr->car); ! 15: if (TYPE(temp) != INT) ! 16: return(error("syscall", FALSE)); ! 17: args[acount++] = temp->i; ! 18: aptr = aptr->cdr; ! 19: while( aptr != nil && acount < 49) { ! 20: temp = eval(aptr->car); ! 21: switch(TYPE(temp)) { ! 22: ! 23: case ATOM: ! 24: args[acount++] = (int)temp->a.pname; ! 25: break; ! 26: ! 27: case INT: ! 28: args[acount++] = (int)temp->i; ! 29: break; ! 30: ! 31: default: ! 32: return(error("syscall", FALSE)); ! 33: } ! 34: aptr = aptr->cdr; ! 35: } ! 36: ! 37: if (acount==0) chkarg(2); /* produce arg count message */ ! 38: temp = newint(); ! 39: temp->i = vsyscall(args); ! 40: return(temp); ! 41: } ! 42: ! 43: /* eval-when: this has the form (eval-when <list> <form1> <form2> ...) ! 44: where the list may contain any combination of `eval', `load', `compile'. ! 45: The interpreter (us) looks for the atom `eval', if it is present ! 46: we treat the rest of the forms as a progn. ! 47: */ ! 48: ! 49: lispval ! 50: Nevwhen() ! 51: { ! 52: register lispval handy; ! 53: snpand(1); ! 54: ! 55: for(handy=(lbot->val)->car ; handy != nil ; handy = handy->cdr) ! 56: if (handy->car == (lispval) Veval) { lbot=np ; ! 57: protect(((lbot-1)->val)->cdr); ! 58: return(Nprogn()); } ; ! 59: ! 60: ! 61: return(nil); /* eval not seen */ ! 62: } ! 63: ! 64: ! 65: /* Status functions. ! 66: * These operate on the statuslist stlist which has the form: ! 67: * ( status_elem_1 status_elem_2 status_elem_3 ...) ! 68: * where each status element has the form: ! 69: * ( name readcode setcode . readvalue) ! 70: * where ! 71: * name - name of the status feature (the first arg to the status ! 72: * function). ! 73: * readcode - fixnum which tells status how to read the value of ! 74: * this status name. The codes are #defined. ! 75: * setcode - fixnum which tells sstatus how to set the value of ! 76: * this status name ! 77: * readvalue - the value of the status feature is usually stored ! 78: * here. ! 79: * ! 80: * Readcodes: ! 81: * ! 82: * ST_READ - if no second arg, return readvalue. ! 83: * if the second arg is given, we return t if it is eq to ! 84: * the readvalue. ! 85: * ST_FEATR - used in (status feature xxx) where we test for xxx being ! 86: * in the status features list ! 87: * ST_SYNT - used in (status syntax c) where we return c's syntax code ! 88: * ST_INTB - read stattab entry ! 89: * ST_NFETR - used in (status nofeature xxx) where we test for xxx not ! 90: * being in the status features list ! 91: * ST_DMPR - read the dumpmode ! 92: * ! 93: * Setcodes: ! 94: * ST_NO - if not allowed to set this status through sstatus. ! 95: * ST_SET - if the second arg is made the readvalue. ! 96: * ST_FEATW - for (sstatus feature xxx), we add xxx to the ! 97: * (status features) list. ! 98: * ST_TOLC - if non nil, map upper case chars in atoms to lc. ! 99: * ST_CORE - if non nil, have bus errors and segmentation violations ! 100: * dump core, if nil have them produce a bad-mem err msg ! 101: * ST_INTB - set stattab table entry ! 102: * ST_NFETW - use in (sstatus nofeature xxx) where we wish to remove xxx ! 103: * from the status feature list. ! 104: * ST_DMPW - set the dumpmode ! 105: */ ! 106: ! 107: ! 108: lispval ! 109: Nstatus() ! 110: { ! 111: register lispval handy,curitm,valarg; ! 112: int indx; ! 113: int typ; ! 114: extern char *ctable; ! 115: extern int dmpmode; ! 116: lispval Istsrch(); ! 117: ! 118: if(lbot->val == nil) return(nil); ! 119: handy = lbot->val; /* arg list */ ! 120: ! 121: while(TYPE(handy) != DTPR) handy = error("status: bad arg list",TRUE); ! 122: ! 123: curitm = Istsrch(handy->car); /* look for feature */ ! 124: ! 125: if( curitm == nil ) return(nil); /* non existant */ ! 126: ! 127: if( handy->cdr == nil ) valarg = (lispval) CNIL; ! 128: else valarg = handy->cdr->car; ! 129: ! 130: /* now do the processing with curitm pointing to the requested ! 131: item in the status list ! 132: */ ! 133: ! 134: switch( typ = curitm->cdr->car->i ) { /* look at readcode */ ! 135: ! 136: ! 137: case ST_READ: ! 138: curitm = Istsrch(handy->car); /* look for name */ ! 139: if(curitm == nil) return(nil); ! 140: if( valarg != (lispval) CNIL) ! 141: error("status: Second arg not allowed.",FALSE); ! 142: else return(curitm->cdr->cdr->cdr); ! 143: ! 144: case ST_NFETR: /* look for feature present */ ! 145: case ST_FEATR: /* look for feature */ ! 146: curitm = Istsrch(matom("features")); ! 147: if( valarg == (lispval) CNIL) ! 148: error("status: need second arg",FALSE); ! 149: ! 150: for( handy = curitm->cdr->cdr->cdr; ! 151: handy != nil; ! 152: handy = handy->cdr) ! 153: if(handy->car == valarg) ! 154: return(typ == ST_FEATR ? tatom : nil); ! 155: ! 156: return(typ == ST_FEATR ? nil : tatom); ! 157: ! 158: case ST_SYNT: /* want characcter syntax */ ! 159: handy = Vreadtable->clb; ! 160: chkrtab(handy); ! 161: if( valarg == (lispval) CNIL) ! 162: error("status: need second arg",FALSE); ! 163: ! 164: while (TYPE(valarg) != ATOM) ! 165: valarg = error("status: second arg must be atom",TRUE); ! 166: ! 167: indx = valarg->pname[0]; /* get first char */ ! 168: ! 169: if(valarg->pname[1] != '\0') ! 170: error("status: only one character atom allowed",FALSE); ! 171: ! 172: (handy = newint())->i = ctable[indx] & 0377; ! 173: return(handy); ! 174: ! 175: case ST_RINTB: ! 176: return(stattab[curitm->cdr->cdr->cdr->i]); ! 177: ! 178: case ST_DMPR: ! 179: return(inewint(dmpmode)); ! 180: ! 181: } ! 182: } ! 183: lispval ! 184: Nsstatus() ! 185: { ! 186: register lispval handy; ! 187: lispval Isstatus(); ! 188: ! 189: handy = lbot->val; ! 190: ! 191: while( TYPE(handy) != DTPR || TYPE(handy->cdr) != DTPR) ! 192: handy = error("sstatus: Bad args",TRUE); ! 193: ! 194: return(Isstatus(handy->car,handy->cdr->car)); ! 195: } ! 196: ! 197: /* Isstatus - internal routine to do a set status. */ ! 198: lispval ! 199: Isstatus(curnam,curval) ! 200: lispval curnam,curval; ! 201: { ! 202: register lispval curitm,head; ! 203: lispval Istsrch(),Iaddstat(); ! 204: int badmemr(); ! 205: extern int uctolc, dmpmode; ! 206: ! 207: curitm = Istsrch(curnam); ! 208: /* if doesnt exist, make one up */ ! 209: ! 210: if(curitm == nil) curitm = Iaddstat(curnam,ST_READ,ST_SET,nil); ! 211: ! 212: switch (curitm->cdr->cdr->car->i) { ! 213: ! 214: case ST_NO: error("sstatus: cannot set this status",FALSE); ! 215: ! 216: case ST_SET: goto setit; ! 217: ! 218: case ST_FEATW: curitm = Istsrch(matom("features")); ! 219: (curnam = newdot())->car = curval; ! 220: curnam->cdr = curitm->cdr->cdr->cdr; /* old val */ ! 221: curitm->cdr->cdr->cdr = curnam; ! 222: return(curval); ! 223: ! 224: case ST_NFETW: /* remove from features list */ ! 225: curitm = Istsrch(matom("features"))->cdr->cdr; ! 226: for(head = curitm->cdr; head != nil; head = head->cdr) ! 227: { ! 228: if(head->car == curval) curitm->cdr = head->cdr; ! 229: else curitm = head; ! 230: } ! 231: return(nil); ! 232: ! 233: ! 234: case ST_TOLC: if(curval == nil) uctolc = FALSE; ! 235: else uctolc = TRUE; ! 236: goto setit; ! 237: ! 238: case ST_CORE: if(curval == nil) ! 239: { ! 240: signal(SIGBUS,badmemr); /* catch bus errors */ ! 241: signal(SIGSEGV,badmemr); /* and segmentation viols */ ! 242: } ! 243: else { ! 244: signal(SIGBUS,SIG_DFL); /* let them core dump */ ! 245: signal(SIGSEGV,SIG_DFL); ! 246: } ! 247: goto setit; ! 248: ! 249: case ST_INTB: ! 250: stattab[curitm->cdr->cdr->cdr->i] = curval; ! 251: return(curval); ! 252: ! 253: case ST_DMPW: ! 254: if(TYPE(curval) != INT || ! 255: (curval->i != 413 && ! 256: curval->i != 410)) errorh(Vermisc,"sstatus: bad dump mode:", ! 257: nil,FALSE,0,curval); ! 258: dmpmode= curval->i; ! 259: return(curval); ! 260: } ! 261: ! 262: setit: /* store value in status list */ ! 263: curitm->cdr->cdr->cdr = curval; ! 264: return(curval); ! 265: ! 266: ! 267: } ! 268: ! 269: /* Istsrch - utility routine to search the status list for the ! 270: name given as an argument. If such an entry is not found, ! 271: we return nil ! 272: */ ! 273: ! 274: lispval Istsrch(nam) ! 275: lispval nam; ! 276: { ! 277: register lispval handy; ! 278: ! 279: for(handy = stlist ; handy != nil ; handy = handy->cdr) ! 280: if(handy->car->car == nam) return(handy->car); ! 281: ! 282: return(nil); ! 283: } ! 284: ! 285: /* Iaddstat - add a status entry to the status list */ ! 286: /* return new entry in status list */ ! 287: ! 288: lispval ! 289: Iaddstat(name,readcode,setcode,valu) ! 290: lispval name,valu; ! 291: int readcode,setcode; ! 292: { ! 293: register lispval handy,handy2; ! 294: snpand(2); ! 295: ! 296: ! 297: protect(handy=newdot()); /* build status list here */ ! 298: ! 299: (handy2 = newdot())->car = name; ! 300: ! 301: handy->car = handy2; ! 302: ! 303: ((handy2->cdr = newdot())->car = newint())->i = readcode; ! 304: ! 305: handy2 = handy2->cdr; ! 306: ! 307: ((handy2->cdr = newdot())->car = newint())->i = setcode; ! 308: ! 309: handy2->cdr->cdr = valu; ! 310: ! 311: /* link this one in */ ! 312: ! 313: handy->cdr = stlist; ! 314: stlist = handy; ! 315: ! 316: return(handy->car); /* return new item in stlist */ ! 317: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.