| 1 | #include "global.h" |
| 2 | FILE * |
| 3 | mkstFI(base,count,flag) |
| 4 | char *base; |
| 5 | char flag; |
| 6 | { |
| 7 | register FILE *p = stderr; |
| 8 | |
| 9 | /* find free file descriptor */ |
| 10 | for(;p->_flag&(_IOREAD|_IOWRT);p++) |
| 11 | if(p >= _iob + _NFILE) |
| 12 | error("Too many open files to do readlist",FALSE); |
| 13 | p->_flag = _IOSTRG | flag; |
| 14 | p->_cnt = count; |
| 15 | p->_base = base; |
| 16 | p->_ptr = base; |
| 17 | p->_file = -1; |
| 18 | return(p); |
| 19 | } |
| 20 | lispval |
| 21 | Lreadli() |
| 22 | { |
| 23 | register lispval work, handy; |
| 24 | register FILE *p; |
| 25 | register char *string; |
| 26 | register struct argent *lbot, *np; |
| 27 | struct argent *olbot; |
| 28 | FILE *opiport = piport; |
| 29 | lispval Lread(); |
| 30 | int count; |
| 31 | |
| 32 | chkarg(1); |
| 33 | if(lbot->val==nil) { /*effectively, return(matom(""));*/ |
| 34 | strbuf[0] = 0; |
| 35 | return(getatom()); |
| 36 | } |
| 37 | count = 1; |
| 38 | |
| 39 | /* compute length of list */ |
| 40 | for(work = lbot->val; TYPE(work)==DTPR; work=work->cdr) |
| 41 | count++; |
| 42 | string = (char *) alloca(count); |
| 43 | p = mkstFI(string, count - 1, _IOREAD); |
| 44 | for(work = lbot->val; TYPE(work)==DTPR; work=work->cdr) { |
| 45 | handy = work->car; |
| 46 | switch(TYPE(handy)) { |
| 47 | case SDOT: |
| 48 | case INT: |
| 49 | *string++=handy->i; |
| 50 | break; |
| 51 | case ATOM: |
| 52 | *string++ = *(handy->pname); |
| 53 | break; |
| 54 | default: |
| 55 | error("Non atom or int to readlist",FALSE); |
| 56 | } |
| 57 | } |
| 58 | *string = 0; |
| 59 | olbot = lbot; |
| 60 | lbot = np; |
| 61 | protect(P(p)); |
| 62 | work = Lread(); |
| 63 | lbot = olbot; |
| 64 | frstFI(p); |
| 65 | return(work); |
| 66 | } |
| 67 | frstFI(p) |
| 68 | register FILE *p; |
| 69 | { |
| 70 | p->_flag=0; |
| 71 | p->_base=0; |
| 72 | p->_cnt = 0; |
| 73 | p->_ptr = 0; |
| 74 | p->_file = 0; |
| 75 | } |
| 76 | lispval |
| 77 | Lgetenv() |
| 78 | { |
| 79 | register struct argent *mylbot=lbot; |
| 80 | snpand(1); |
| 81 | if((TYPE(mylbot->val))!=ATOM) |
| 82 | error("argument to getenv must be atom",FALSE); |
| 83 | |
| 84 | strcpy(strbuf,getenv(mylbot->val->pname)); |
| 85 | return(getatom()); |
| 86 | } |
| 87 | lispval |
| 88 | Lboundp() |
| 89 | { |
| 90 | register struct argent *mynp=lbot; |
| 91 | register lispval result, handy; |
| 92 | snpand(3); |
| 93 | |
| 94 | if((TYPE(mynp->val))!=ATOM) |
| 95 | error("argument to boundp must be atom",FALSE); |
| 96 | if( (handy = mynp->val)->clb==CNIL) |
| 97 | result = nil; |
| 98 | else |
| 99 | (result = newdot())->cdr = handy->clb; |
| 100 | return(result); |
| 101 | } |
| 102 | lispval |
| 103 | Lplist() |
| 104 | { |
| 105 | register lispval atm; |
| 106 | snpand(0); |
| 107 | /* get property list of an atom or disembodied property list */ |
| 108 | |
| 109 | chkarg(1); |
| 110 | atm = lbot->val; |
| 111 | switch(TYPE(atm)) { |
| 112 | case ATOM: |
| 113 | case DTPR: |
| 114 | break; |
| 115 | default: |
| 116 | error("Only Atoms and disembodied property lists allowed for plist",FALSE); |
| 117 | } |
| 118 | if(atm==nil) return(nilplist); |
| 119 | return(atm->plist); |
| 120 | } |
| 121 | lispval |
| 122 | Lsetpli() |
| 123 | { /* set the property list of the given atom to the given list */ |
| 124 | register lispval atm, vall; |
| 125 | register lispval dum1, dum2; |
| 126 | register struct argent *lbot, *np; |
| 127 | snpand(2); |
| 128 | |
| 129 | chkarg(2); |
| 130 | atm = lbot->val; |
| 131 | if (TYPE(atm) != ATOM) error("First argument must be an atom",FALSE); |
| 132 | vall = (np-1)->val; |
| 133 | if (TYPE(vall)!= DTPR && vall !=nil) |
| 134 | error("Second argument must be a list",FALSE); |
| 135 | if (atm==nil) |
| 136 | nilplist = vall; |
| 137 | else |
| 138 | atm->plist = vall; |
| 139 | return(vall); |
| 140 | } |
| 141 | |
| 142 | lispval |
| 143 | Lsignal() |
| 144 | { |
| 145 | register struct argent *mylbot = lbot; |
| 146 | extern lispval sigacts[16]; |
| 147 | int i; register lispval handy, old; |
| 148 | chkarg(2); |
| 149 | |
| 150 | handy = mylbot[AD].val; |
| 151 | if(TYPE(handy)!=INT) |
| 152 | error("First arg to signal must be an int",FALSE); |
| 153 | i = handy->i & 15; |
| 154 | handy = mylbot[AD+1].val; |
| 155 | if(TYPE(handy)!=ATOM) |
| 156 | error("Second arg to signal must be an atom",FALSE); |
| 157 | old = sigacts[i]; |
| 158 | if(old==0) old = nil; |
| 159 | if(handy==nil) |
| 160 | sigacts[i]=((lispval) 0); |
| 161 | else |
| 162 | sigacts[i]=handy; |
| 163 | return(old); |
| 164 | } |
| 165 | lispval |
| 166 | Lassq() |
| 167 | { |
| 168 | register lispval work, handy, dum1, dum2; |
| 169 | register struct argent *lbot, *np; |
| 170 | snpand(2); |
| 171 | |
| 172 | chkarg(2); |
| 173 | for(work = lbot[AD+1].val; |
| 174 | work->car->car!=lbot->val&& work!=nil; |
| 175 | work = work->cdr); |
| 176 | return(work->car); |
| 177 | } |
| 178 | lispval |
| 179 | Lkilcopy() |
| 180 | { |
| 181 | if(fork()==0) { |
| 182 | asm(".byte 0"); |
| 183 | } |
| 184 | } |
| 185 | lispval |
| 186 | Larg() |
| 187 | { |
| 188 | register lispval handy; register offset, count; |
| 189 | snpand(3); |
| 190 | |
| 191 | handy = lexpr_atom->clb; |
| 192 | if(handy==CNIL || TYPE(handy)!=DTPR) |
| 193 | error("Arg: not in context of Lexpr.",FALSE); |
| 194 | count = ((long *)handy->cdr) - (long *)handy->car; |
| 195 | if(np==lbot || lbot->val==nil) |
| 196 | return(inewint(count)); |
| 197 | if(TYPE(lbot->val)!=INT || (offset = lbot->val->i - 1) > count || offset < 0 ) |
| 198 | error("Out of bonds: arg to \"Arg\"",FALSE); |
| 199 | return( ((struct argent *)handy->car)[offset].val); |
| 200 | } |
| 201 | lispval |
| 202 | Lptime(){ |
| 203 | extern int GCtime; |
| 204 | int lgctime = GCtime; |
| 205 | static struct tbuf { |
| 206 | long mytime; |
| 207 | long allelse[3]; |
| 208 | } current; |
| 209 | register lispval result, handy; |
| 210 | |
| 211 | snpand(2); |
| 212 | times(¤t); |
| 213 | result = newdot(); |
| 214 | handy = result; |
| 215 | protect(result); |
| 216 | result->cdr = newdot(); |
| 217 | result->car = inewint(current.mytime); |
| 218 | handy = result->cdr; |
| 219 | handy->car = inewint(lgctime); |
| 220 | handy->cdr = nil; |
| 221 | if(GCtime==0) |
| 222 | GCtime = 1; |
| 223 | return(result); |
| 224 | } |
| 225 | |
| 226 | /* (err [value] [flag]) |
| 227 | where if value is present, it is the value to throw to the errset. |
| 228 | flag if present must evaluate to nil, as we always evaluate value |
| 229 | before unwinding stack |
| 230 | */ |
| 231 | |
| 232 | lispval Lerr() |
| 233 | { |
| 234 | register lispval handy; |
| 235 | lispval errorh(); |
| 236 | char *mesg = "call to err"; /* default message */ |
| 237 | |
| 238 | chkarg(1); |
| 239 | |
| 240 | if ((np >= lbot + 2) && ((lbot+1)->val != nil)) |
| 241 | error("Second arg to err must be nil",FALSE); |
| 242 | if ((lbot->val != nil) && (TYPE(lbot->val) == ATOM)) |
| 243 | mesg = lbot->val->pname; /* new message if atom */ |
| 244 | |
| 245 | return(errorh(Vererr,mesg,lbot->val,nil)); |
| 246 | } |
| 247 | lispval |
| 248 | Ltyi() |
| 249 | { |
| 250 | register FILE *port; |
| 251 | register char val; |
| 252 | |
| 253 | chkarg(1); |
| 254 | port = okport(lbot->val,okport(Vpiport->clb,stdin)); |
| 255 | |
| 256 | |
| 257 | fflush(stdout); /* flush any pending output characters */ |
| 258 | val = getc(port); |
| 259 | return(inewint(val)); |
| 260 | } |
| 261 | lispval |
| 262 | Ltyipeek() |
| 263 | { |
| 264 | register FILE *port; |
| 265 | register char val; |
| 266 | |
| 267 | chkarg(1); |
| 268 | port = okport(lbot->val,okport(Vpiport->clb,stdin)); |
| 269 | |
| 270 | fflush(stdout); /* flush any pending output characters */ |
| 271 | val = getc(port); |
| 272 | ungetc(val,port); |
| 273 | return(inewint(val)); |
| 274 | } |
| 275 | lispval |
| 276 | Ltyo() |
| 277 | { |
| 278 | register FILE *port; |
| 279 | register lispval handy, where; |
| 280 | register char val; |
| 281 | register struct argent *lbot, *np; |
| 282 | |
| 283 | chkarg(2); |
| 284 | handy = lbot->val; |
| 285 | if(TYPE(handy)!=INT) |
| 286 | error("Tyo demands number for 1st arg",FALSE); |
| 287 | val = handy->i; |
| 288 | |
| 289 | where = lbot[1].val; |
| 290 | port = (FILE *) okport(where,okport(Vpoport->clb,stdout)); |
| 291 | putc(val,port); |
| 292 | return(handy); |
| 293 | } |
| 294 | lispval |
| 295 | Imkrtab(current) |
| 296 | { |
| 297 | extern struct rtab { |
| 298 | char ctable[132]; |
| 299 | } initread; |
| 300 | register lispval handy; extern lispval lastrtab; |
| 301 | static int cycle = 0; |
| 302 | static char *nextfree; |
| 303 | if((cycle++)%3==0) { |
| 304 | nextfree = (char *) csegment(int_name,128); |
| 305 | } |
| 306 | handy = newarray(); |
| 307 | handy->data = nextfree; |
| 308 | if(current == 0) |
| 309 | *(struct rtab *)nextfree = initread; |
| 310 | else |
| 311 | *(struct rtab *)nextfree = *(struct rtab *)ctable; |
| 312 | handy->delta = inewint(4); |
| 313 | handy->length = inewint(sizeof(struct rtab)/sizeof(int)); |
| 314 | handy->accfun = handy->aux = nil; |
| 315 | nextfree += sizeof(struct rtab); |
| 316 | return(handy); |
| 317 | } |
| 318 | |
| 319 | /* makereadtable - arg : t or nil |
| 320 | returns a readtable, t means return a copy of the initial readtable |
| 321 | |
| 322 | nil means return a copy of the current readtable |
| 323 | */ |
| 324 | lispval |
| 325 | Lmakertbl() |
| 326 | { |
| 327 | if(lbot==np) error("makereadtable: wrong number of args",FALSE); |
| 328 | |
| 329 | if(TYPE(lbot->val) != ATOM) |
| 330 | error("makereadtable: arg must be atom",FALSE); |
| 331 | |
| 332 | if(lbot->val == nil) return(Imkrtab(1)); |
| 333 | else return(Imkrtab(0)); |
| 334 | } |
| 335 | lispval |
| 336 | Lcpy1() |
| 337 | { |
| 338 | register lispval handy = lbot->val, result = handy; |
| 339 | |
| 340 | top: |
| 341 | switch(TYPE(handy)) |
| 342 | { |
| 343 | case INT: |
| 344 | result = inewint(handy->i); |
| 345 | break; |
| 346 | case VALUE: |
| 347 | (result = newval())->l = handy->l; |
| 348 | break; |
| 349 | case DOUB: |
| 350 | (result = newdoub())->r = handy->r; |
| 351 | break; |
| 352 | default: |
| 353 | lbot->val = |
| 354 | errorh(Vermisc,"Bad arg to cpy1",nil,TRUE,67,handy); |
| 355 | goto top; |
| 356 | } |
| 357 | return(result); |
| 358 | } |