| 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 | } |