projects / unix-history / blame
| Commit | Line | Data |
|---|---|---|
| 4619ba6b JF |
1 | #include "global.h" |
| 2 | ||
| 3 | lispval | |
| 4 | Lfork() { | |
| 5 | register lispval temp; | |
| 6 | int pid; | |
| 7 | ||
| 8 | chkarg(0); | |
| 9 | if ((pid=fork())) { | |
| 10 | temp = newint(); | |
| 11 | temp->i = pid; | |
| 12 | return(temp); | |
| 13 | } else | |
| 14 | return(nil); | |
| 15 | } | |
| 16 | ||
| 17 | lispval | |
| 18 | Lwait() | |
| 19 | { | |
| 20 | register lispval ret, temp; | |
| 21 | int status = -1, pid; | |
| 22 | snpand(2); | |
| 23 | ||
| 24 | ||
| 25 | chkarg(0); | |
| 26 | pid = wait(&status); | |
| 27 | ret = newdot(); | |
| 28 | protect(ret); | |
| 29 | temp = newint(); | |
| 30 | temp->i = pid; | |
| 31 | ret->car = temp; | |
| 32 | temp = newint(); | |
| 33 | temp->i = status; | |
| 34 | ret->cdr = temp; | |
| 35 | return(ret); | |
| 36 | } | |
| 37 | ||
| 38 | lispval | |
| 39 | Lpipe() | |
| 40 | { | |
| 41 | register lispval ret, temp; | |
| 42 | int pipes[2]; | |
| 43 | ||
| 44 | chkarg(0); | |
| 45 | pipes[0] = -1; | |
| 46 | pipes[1] = -1; | |
| 47 | pipe(pipes); | |
| 48 | ret = newdot(); | |
| 49 | protect(ret); | |
| 50 | temp = newint(); | |
| 51 | temp->i = pipes[0]; | |
| 52 | ret->car = temp; | |
| 53 | temp = newint(); | |
| 54 | temp->i = pipes[1]; | |
| 55 | ret->cdr = temp; | |
| 56 | return(ret); | |
| 57 | } | |
| 58 | ||
| 59 | lispval | |
| 60 | Lfdopen() | |
| 61 | { | |
| 62 | register lispval fd, type; | |
| 63 | FILE *ptr; | |
| 64 | ||
| 65 | chkarg(2); | |
| 66 | type = (np-1)->val; | |
| 67 | fd = lbot->val; | |
| 68 | if( TYPE(fd)!=INT ) | |
| 69 | return(nil); | |
| 70 | if ( (ptr=fdopen((int)fd->i, (char *)type->a.pname))==NULL) | |
| 71 | return(nil); | |
| 72 | return(P(ptr)); | |
| 73 | } | |
| 74 | ||
| 75 | lispval | |
| 76 | Lexece() | |
| 77 | { | |
| 78 | lispval fname, arglist, envlist, temp; | |
| 79 | char *args[100], *envs[100], estrs[1024]; | |
| 80 | char *p, *cp, **sp; | |
| 81 | snpand(0); | |
| 82 | ||
| 83 | chkarg(3); | |
| 84 | envlist = (--np)->val; | |
| 85 | arglist = (--np)->val; | |
| 86 | fname = (--np)->val; | |
| 87 | if (TYPE(fname)!=ATOM) | |
| 88 | return(nil); | |
| 89 | if (TYPE(arglist)!=DTPR && arglist!=nil) | |
| 90 | return(nil); | |
| 91 | for (sp=args; arglist!=nil; arglist=arglist->d.cdr) { | |
| 92 | temp = arglist->d.car; | |
| 93 | if (TYPE(temp)!=ATOM) | |
| 94 | return(nil); | |
| 95 | *sp++ = temp->a.pname; | |
| 96 | } | |
| 97 | *sp = 0; | |
| 98 | if (TYPE(envlist)!=DTPR && envlist!=nil) | |
| 99 | return(nil); | |
| 100 | for (sp=envs,cp=estrs; envlist!=nil; envlist=envlist->d.cdr) { | |
| 101 | temp = envlist->d.car; | |
| 102 | if (TYPE(temp)!=DTPR || TYPE(temp->d.car)!=ATOM | |
| 103 | || TYPE(temp->d.cdr)!=ATOM) | |
| 104 | return(nil); | |
| 105 | *sp++ = cp; | |
| 106 | for (p=temp->d.car->a.pname; (*cp++ = *p++);) ; | |
| 107 | *(cp-1) = '='; | |
| 108 | for (p=temp->d.cdr->a.pname; (*cp++ = *p++);) ; | |
| 109 | } | |
| 110 | *sp = 0; | |
| 111 | execve(fname->a.pname, args, envs); | |
| 112 | return(nil); | |
| 113 | } | |
| 114 | ||
| 115 | lispval | |
| 116 | Lgensym() | |
| 117 | { | |
| 118 | lispval arg; | |
| 119 | char leader; | |
| 120 | static int counter = 0; | |
| 121 | ||
| 122 | chkarg(1); | |
| 123 | arg = lbot->val; | |
| 124 | leader = 'g'; | |
| 125 | if (arg != nil && TYPE(arg)==ATOM) | |
| 126 | leader = arg->a.pname[0]; | |
| 127 | sprintf(strbuf, "%c%05d", leader, counter++); | |
| 128 | atmlen = 7; | |
| 129 | return((lispval)newatom()); | |
| 130 | } | |
| 131 | extern struct types { | |
| 132 | char *next_free; | |
| 133 | int space_left, | |
| 134 | space, | |
| 135 | type, | |
| 136 | type_len; /* note type_len is in units of int */ | |
| 137 | lispval *items, | |
| 138 | *pages, | |
| 139 | *type_name; | |
| 140 | struct heads | |
| 141 | *first; | |
| 142 | } atom_str ; | |
| 143 | ||
| 144 | lispval | |
| 145 | Lremprop() | |
| 146 | { | |
| 147 | register struct argent *argp; | |
| 148 | register lispval pptr, ind, opptr; | |
| 149 | register struct argent *lbot, *np; | |
| 150 | lispval atm; | |
| 151 | int disemp = FALSE; | |
| 152 | ||
| 153 | chkarg(2); | |
| 154 | argp = lbot; | |
| 155 | ind = argp[1].val; | |
| 156 | atm = argp->val; | |
| 157 | switch (TYPE(atm)) { | |
| 158 | case DTPR: | |
| 159 | pptr = atm->cdr; | |
| 160 | disemp = TRUE; | |
| 161 | break; | |
| 162 | case ATOM: | |
| 163 | if((lispval)atm==nil) | |
| 164 | pptr = nilplist; | |
| 165 | else | |
| 166 | pptr = atm->plist; | |
| 167 | break; | |
| 168 | default: | |
| 169 | errorh(Vermisc, "remprop: Illegal first argument :", | |
| 170 | nil, FALSE, 0, atm); | |
| 171 | } | |
| 172 | opptr = nil; | |
| 173 | if (pptr==nil) | |
| 174 | return(nil); | |
| 175 | while(TRUE) { | |
| 176 | if (TYPE(pptr->cdr)!=DTPR) | |
| 177 | errorh(Vermisc, "remprop: Bad property list", | |
| 178 | nil, FALSE, 0,atm); | |
| 179 | if (pptr->car == ind) { | |
| 180 | if( opptr != nil) | |
| 181 | opptr->cdr = pptr->cdr->cdr; | |
| 182 | else if(disemp) | |
| 183 | atm->cdr = pptr->cdr->cdr; | |
| 184 | else if(atm==nil) | |
| 185 | nilplist = pptr->cdr->cdr; | |
| 186 | else | |
| 187 | atm->plist = pptr->cdr->cdr; | |
| 188 | return(pptr->cdr); | |
| 189 | } | |
| 190 | if ((pptr->cdr)->cdr == nil) return(nil); | |
| 191 | opptr = pptr->cdr; | |
| 192 | pptr = (pptr->cdr)->cdr; | |
| 193 | } | |
| 194 | } | |
| 195 | ||
| 196 | lispval | |
| 197 | Lbcdad() | |
| 198 | { | |
| 199 | lispval ret, temp; | |
| 200 | ||
| 201 | chkarg(1); | |
| 202 | temp = lbot->val; | |
| 203 | if (TYPE(temp)!=ATOM) | |
| 204 | error("ONLY ATOMS HAVE FUNCTION BINDINGS", FALSE); | |
| 205 | temp = temp->fnbnd; | |
| 206 | if (TYPE(temp)!=BCD) | |
| 207 | return(nil); | |
| 208 | ret = newint(); | |
| 209 | ret->i = (int)temp; | |
| 210 | return(ret); | |
| 211 | } | |
| 212 | ||
| 213 | lispval | |
| 214 | Lstringp() | |
| 215 | { | |
| 216 | chkarg(1); | |
| 217 | if (TYPE(lbot->val)==STRNG) | |
| 218 | return(tatom); | |
| 219 | return(nil); | |
| 220 | } | |
| 221 | ||
| 222 | lispval | |
| 223 | Lsymbolp() | |
| 224 | { | |
| 225 | chkarg(1); | |
| 226 | if (TYPE(lbot->val)==ATOM) | |
| 227 | return(tatom); | |
| 228 | return(nil); | |
| 229 | } | |
| 230 | ||
| 231 | lispval | |
| 232 | Lrematom() | |
| 233 | { | |
| 234 | register lispval temp; | |
| 235 | ||
| 236 | chkarg(1); | |
| 237 | temp = lbot->val; | |
| 238 | if (TYPE(temp)!=ATOM) | |
| 239 | return(nil); | |
| 240 | temp->a.fnbnd = nil; | |
| 241 | temp->a.pname = (char *)CNIL; | |
| 242 | temp->a.plist = nil; | |
| 243 | (atom_items->i)--; | |
| 244 | (atom_str.space_left)++; | |
| 245 | temp->a.clb=(lispval)atom_str.next_free; | |
| 246 | atom_str.next_free=(char *) temp; | |
| 247 | return(tatom); | |
| 248 | } | |
| 249 | ||
| 250 | #define QUTMASK 0200 | |
| 251 | #define VNUM 0000 | |
| 252 | ||
| 253 | lispval | |
| 254 | Lprname() | |
| 255 | { | |
| 256 | lispval a, ret; | |
| 257 | register lispval work, prev; | |
| 258 | char *front, *temp; int clean; | |
| 259 | char ctemp[100]; | |
| 260 | extern char *ctable; | |
| 261 | snpand(2); | |
| 262 | ||
| 263 | chkarg(1); | |
| 264 | a = lbot->val; | |
| 265 | switch (TYPE(a)) { | |
| 266 | case INT: | |
| 267 | sprintf(ctemp,"%d",a->i); | |
| 268 | break; | |
| 269 | ||
| 270 | case DOUB: | |
| 271 | sprintf(ctemp,"%f",a->r); | |
| 272 | break; | |
| 273 | ||
| 274 | case ATOM: | |
| 275 | temp = front = a->pname; | |
| 276 | clean = *temp; | |
| 277 | if (*temp == '-') temp++; | |
| 278 | clean = clean && (ctable[*temp] != VNUM); | |
| 279 | while (clean && *temp) | |
| 280 | clean = (!(ctable[*temp++] & QUTMASK)); | |
| 281 | if (clean) | |
| 282 | strcpyn(ctemp, front, 99); | |
| 283 | else | |
| 284 | sprintf(ctemp,"\"%s\"",front); | |
| 285 | break; | |
| 286 | ||
| 287 | default: | |
| 288 | error("prname does not support this type", FALSE); | |
| 289 | } | |
| 290 | temp = ctemp; | |
| 291 | protect(ret = prev = newdot()); | |
| 292 | while (*temp) { | |
| 293 | prev->cdr = work = newdot(); | |
| 294 | strbuf[0] = *temp++; | |
| 295 | strbuf[1] = 0; | |
| 296 | work->car = getatom(); | |
| 297 | work->cdr = nil; | |
| 298 | prev = work; | |
| 299 | } | |
| 300 | return(ret->cdr); | |
| 301 | } | |
| 302 | Lexit() | |
| 303 | { | |
| 304 | register lispval handy; | |
| 305 | if(np-lbot==0) exit(0); | |
| 306 | handy = lbot->val; | |
| 307 | if(TYPE(handy)==INT) | |
| 308 | exit(handy->i); | |
| 309 | exit(-1); | |
| 310 | } | |
| 311 | lispval | |
| 312 | Iimplode(unintern) | |
| 313 | { | |
| 314 | register lispval handy, work; | |
| 315 | register char *cp = strbuf; | |
| 316 | extern int atmlen; /* used by newatom and getatom */ | |
| 317 | ||
| 318 | chkarg(1); | |
| 319 | for(handy = lbot->val; handy!=nil; handy = handy->cdr) | |
| 320 | { | |
| 321 | work = handy->car; | |
| 322 | if(cp >= endstrb) | |
| 323 | errorh(Vermisc,"maknam/impode argument exceeds buffer",nil,FALSE,43,lbot->val); | |
| 324 | again: | |
| 325 | switch(TYPE(work)) | |
| 326 | { | |
| 327 | case ATOM: | |
| 328 | *cp++ = work->pname[0]; | |
| 329 | break; | |
| 330 | case SDOT: | |
| 331 | case INT: | |
| 332 | *cp++ = work->i; | |
| 333 | break; | |
| 334 | case STRNG: | |
| 335 | *cp++ = * (char *) work; | |
| 336 | break; | |
| 337 | default: | |
| 338 | work = errorh(Vermisc,"implode/maknam: Illegal type for this arg:",nil,FALSE,44,work); | |
| 339 | goto again; | |
| 340 | } | |
| 341 | } | |
| 342 | *cp = 0; | |
| 343 | if(unintern) return((lispval)newatom()); | |
| 344 | else return((lispval) getatom()); | |
| 345 | } | |
| 346 | ||
| 347 | lispval | |
| 348 | Lmaknam() | |
| 349 | { | |
| 350 | return(Iimplode(TRUE)); /* unintern result */ | |
| 351 | } | |
| 352 | ||
| 353 | lispval | |
| 354 | Limplode() | |
| 355 | { | |
| 356 | return(Iimplode(FALSE)); /* intern result */ | |
| 357 | } |