sym.c (35448B)
1 /* 01apr08abu 2 * (c) Software Lab. Alexander Burger 3 */ 4 5 #include "pico.h" 6 7 static byte Ascii6[] = { 8 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 10 2, 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 4, 6, 11 27, 29, 31, 33, 35, 37, 39, 41, 43, 45, 47, 49, 8, 51, 10, 53, 12 55, 57, 59, 61, 63, 65, 67, 69, 71, 73, 75, 77, 79, 81, 83, 85, 13 87, 89, 91, 93, 95, 97, 99, 101, 103, 105, 107, 109, 111, 113, 115, 117, 14 119, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, 32, 34, 36, 38, 40, 15 42, 44, 46, 48, 50, 52, 54, 56, 58, 60, 62, 121, 123, 125, 127, 0 16 }; 17 18 static byte Ascii7[] = { 19 0, 33, 32, 34, 46, 35, 47, 36, 60, 37, 62, 38, 97, 39, 98, 40, 20 99, 41, 100, 42, 101, 43, 102, 44, 103, 45, 104, 48, 105, 49, 106, 50, 21 107, 51, 108, 52, 109, 53, 110, 54, 111, 55, 112, 56, 113, 57, 114, 58, 22 115, 59, 116, 61, 117, 63, 118, 64, 119, 65, 120, 66, 121, 67, 122, 68, 23 0, 69, 0, 70, 0, 71, 0, 72, 0, 73, 0, 74, 0, 75, 0, 76, 24 0, 77, 0, 78, 0, 79, 0, 80, 0, 81, 0, 82, 0, 83, 0, 84, 25 0, 85, 0, 86, 0, 87, 0, 88, 0, 89, 0, 90, 0, 91, 0, 92, 26 0, 93, 0, 94, 0, 95, 0, 96, 0, 123, 0, 124, 0, 125, 0, 126 27 }; 28 29 30 int firstByte(any s) { 31 int c; 32 33 if (isNil(s)) 34 return 0; 35 c = (int)(isTxt(s = name(s))? (word)s >> 1 : (word)tail(s)); 36 return Ascii7[c & (c & 1? 127 : 63)]; 37 } 38 39 int secondByte(any s) { 40 int c; 41 42 if (isNil(s)) 43 return 0; 44 c = (int)(isTxt(s = name(s))? (word)s >> 1 : (word)tail(s)); 45 c >>= c & 1? 7 : 6; 46 return Ascii7[c & (c & 1? 127 : 63)]; 47 } 48 49 int getByte1(int *i, word *p, any *q) { 50 int c; 51 52 if (isTxt(*q)) 53 *i = BITS-1, *p = (word)*q >> 1, *q = NULL; 54 else 55 *i = BITS, *p = (word)tail(*q), *q = val(*q); 56 if (*p & 1) 57 c = Ascii7[*p & 127], *p >>= 7, *i -= 7; 58 else 59 c = Ascii7[*p & 63], *p >>= 6, *i -= 6; 60 return c; 61 } 62 63 int getByte(int *i, word *p, any *q) { 64 int c; 65 66 if (*i == 0) { 67 if (!*q) 68 return 0; 69 if (isNum(*q)) 70 *i = BITS-2, *p = (word)*q >> 2, *q = NULL; 71 else 72 *i = BITS, *p = (word)tail(*q), *q = val(*q); 73 } 74 if (*p & 1) { 75 c = *p & 127, *p >>= 7; 76 if (*i >= 7) 77 *i -= 7; 78 else if (isNum(*q)) { 79 *p = (word)*q >> 2, *q = NULL; 80 c |= *p << *i; 81 *p >>= 7 - *i; 82 *i += BITS-9; 83 } 84 else { 85 *p = (word)tail(*q), *q = val(*q); 86 c |= *p << *i; 87 *p >>= 7 - *i; 88 *i += BITS-7; 89 } 90 c &= 127; 91 } 92 else { 93 c = *p & 63, *p >>= 6; 94 if (*i >= 6) 95 *i -= 6; 96 else if (!*q) 97 return 0; 98 else if (isNum(*q)) { 99 *p = (word)*q >> 2, *q = NULL; 100 c |= *p << *i; 101 *p >>= 6 - *i; 102 *i += BITS-8; 103 } 104 else { 105 *p = (word)tail(*q), *q = val(*q); 106 c |= *p << *i; 107 *p >>= 6 - *i; 108 *i += BITS-6; 109 } 110 c &= 63; 111 } 112 return Ascii7[c]; 113 } 114 115 any mkTxt(int c) {return txt(Ascii6[c & 127]);} 116 117 any mkChar(int c) { 118 return consSym(NULL, Ascii6[c & 127]); 119 } 120 121 any mkChar2(int c, int d) { 122 c = Ascii6[c & 127]; 123 d = Ascii6[d & 127]; 124 return consSym(NULL, d << (c & 1? 7 : 6) | c); 125 } 126 127 void putByte0(int *i, word *p, any *q) { 128 *i = 0, *p = 0, *q = NULL; 129 } 130 131 void putByte1(int c, int *i, word *p, any *q) { 132 *i = (*p = Ascii6[c & 127]) & 1? 7 : 6; 133 *q = NULL; 134 } 135 136 void putByte(int c, int *i, word *p, any *q, cell *cp) { 137 int d = (c = Ascii6[c & 127]) & 1? 7 : 6; 138 139 if (*i != BITS) 140 *p |= (word)c << *i; 141 if (*i + d > BITS) { 142 if (*q) 143 *q = val(*q) = consName(*p, Zero); 144 else { 145 Push(*cp, consSym(NULL,0)); 146 tail(data(*cp)) = *q = consName(*p, Zero); 147 } 148 *p = c >> BITS - *i; 149 *i -= BITS; 150 } 151 *i += d; 152 } 153 154 any popSym(int i, word n, any q, cell *cp) { 155 if (q) { 156 val(q) = i <= (BITS-2)? box(n) : consName(n, Zero); 157 return Pop(*cp); 158 } 159 if (i > BITS-1) { 160 Push(*cp, consSym(NULL,0)); 161 tail(data(*cp)) = consName(n, Zero); 162 return Pop(*cp); 163 } 164 return consSym(NULL,n); 165 } 166 167 int symBytes(any x) { 168 int cnt = 0; 169 word w; 170 171 if (isNil(x)) 172 return 0; 173 x = name(x); 174 if (isTxt(x)) { 175 w = (word)x >> 1; 176 while (w) 177 ++cnt, w >>= w & 1? 7 : 6; 178 } 179 else { 180 do { 181 w = (word)tail(x); 182 do 183 ++cnt; 184 while (w >>= w & 1? 7 : 6); 185 } while (!isNum(x = val(x))); 186 w = (word)x >> 2; 187 while (w) 188 ++cnt, w >>= w & 1? 7 : 6; 189 } 190 return cnt; 191 } 192 193 any isIntern(any nm, any tree[2]) { 194 any x, y, z; 195 long n; 196 197 if (isTxt(nm)) { 198 for (x = tree[0]; isCell(x);) { 199 if ((n = (word)nm - (word)name(car(x))) == 0) 200 return car(x); 201 x = n<0? cadr(x) : cddr(x); 202 } 203 } 204 else { 205 for (x = tree[1]; isCell(x);) { 206 y = nm, z = name(car(x)); 207 for (;;) { 208 if ((n = (word)tail(y) - (word)tail(z)) != 0) { 209 x = n<0? cadr(x) : cddr(x); 210 break; 211 } 212 y = val(y), z = val(z); 213 if (isNum(y)) { 214 if (y == z) 215 return car(x); 216 x = isNum(z) && y>z? cddr(x) : cadr(x); 217 break; 218 } 219 if (isNum(z)) { 220 x = cddr(x); 221 break; 222 } 223 } 224 } 225 } 226 return NULL; 227 } 228 229 any intern(any sym, any tree[2]) { 230 any nm, x, y, z; 231 long n; 232 233 if ((nm = name(sym)) == txt(0)) 234 return sym; 235 if (isTxt(nm)) { 236 if (!isCell(x = tree[0])) { 237 tree[0] = cons(sym, Nil); 238 return sym; 239 } 240 for (;;) { 241 if ((n = (word)nm - (word)name(car(x))) == 0) 242 return car(x); 243 if (!isCell(cdr(x))) { 244 cdr(x) = n<0? cons(cons(sym,Nil), Nil) : cons(Nil, cons(sym,Nil)); 245 return sym; 246 } 247 if (n < 0) { 248 if (isCell(cadr(x))) 249 x = cadr(x); 250 else { 251 cadr(x) = cons(sym, Nil); 252 return sym; 253 } 254 } 255 else { 256 if (isCell(cddr(x))) 257 x = cddr(x); 258 else { 259 cddr(x) = cons(sym, Nil); 260 return sym; 261 } 262 } 263 } 264 } 265 else { 266 if (!isCell(x = tree[1])) { 267 tree[1] = cons(sym, Nil); 268 return sym; 269 } 270 for (;;) { 271 y = nm, z = name(car(x)); 272 while ((n = (word)tail(y) - (word)tail(z)) == 0) { 273 y = val(y), z = val(z); 274 if (isNum(y)) { 275 if (y == z) 276 return car(x); 277 n = isNum(z)? y-z : -1; 278 break; 279 } 280 if (isNum(z)) { 281 n = +1; 282 break; 283 } 284 } 285 if (!isCell(cdr(x))) { 286 cdr(x) = n<0? cons(cons(sym,Nil), Nil) : cons(Nil, cons(sym,Nil)); 287 return sym; 288 } 289 if (n < 0) { 290 if (isCell(cadr(x))) 291 x = cadr(x); 292 else { 293 cadr(x) = cons(sym, Nil); 294 return sym; 295 } 296 } 297 else { 298 if (isCell(cddr(x))) 299 x = cddr(x); 300 else { 301 cddr(x) = cons(sym, Nil); 302 return sym; 303 } 304 } 305 } 306 } 307 } 308 309 void unintern(any sym, any tree[2]) { 310 any nm, x, y, z, *p; 311 long n; 312 313 if ((nm = name(sym)) == txt(0)) 314 return; 315 if (isTxt(nm)) { 316 if (!isCell(x = tree[0])) 317 return; 318 p = &tree[0]; 319 for (;;) { 320 if ((n = (word)nm - (word)name(car(x))) == 0) { 321 if (!isCell(cadr(x))) 322 *p = cddr(x); 323 else if (!isCell(y = cddr(x))) 324 *p = cadr(x); 325 else if (!isCell(z = cadr(y))) 326 car(x) = car(y), cddr(x) = cddr(y); 327 else { 328 while (isCell(cadr(z))) 329 z = cadr(y = z); 330 car(x) = car(z), cadr(y) = cddr(z); 331 } 332 return; 333 } 334 if (!isCell(cdr(x))) 335 return; 336 if (n < 0) { 337 if (!isCell(cadr(x))) 338 return; 339 x = *(p = &cadr(x)); 340 } 341 else { 342 if (!isCell(cddr(x))) 343 return; 344 x = *(p = &cddr(x)); 345 } 346 } 347 } 348 else { 349 if (!isCell(x = tree[1])) 350 return; 351 p = &tree[1]; 352 for (;;) { 353 y = nm, z = name(car(x)); 354 while ((n = (word)tail(y) - (word)tail(z)) == 0) { 355 y = val(y), z = val(z); 356 if (isNum(y)) { 357 if (y == z) { 358 if (!isCell(cadr(x))) 359 *p = cddr(x); 360 else if (!isCell(y = cddr(x))) 361 *p = cadr(x); 362 else if (!isCell(z = cadr(y))) 363 car(x) = car(y), cddr(x) = cddr(y); 364 else { 365 while (isCell(cadr(z))) 366 z = cadr(y = z); 367 car(x) = car(z), cadr(y) = cddr(z); 368 } 369 return; 370 } 371 n = isNum(z)? y-z : -1; 372 break; 373 } 374 if (isNum(z)) { 375 n = +1; 376 break; 377 } 378 } 379 if (!isCell(cdr(x))) 380 return; 381 if (n < 0) { 382 if (!isCell(cadr(x))) 383 return; 384 x = *(p = &cadr(x)); 385 } 386 else { 387 if (!isCell(cddr(x))) 388 return; 389 x = *(p = &cddr(x)); 390 } 391 } 392 } 393 } 394 395 /* Get symbol name */ 396 any name(any s) { 397 for (s = tail(s); isCell(s); s = car(s)); 398 return s; 399 } 400 401 // (name 'sym ['sym2]) -> sym 402 any doName(any ex) { 403 any x, y, *p; 404 cell c1; 405 406 x = cdr(ex), data(c1) = EVAL(car(x)); 407 NeedSymb(ex,data(c1)); 408 y = isNil(data(c1))? txt(0) : name(data(c1)); 409 if (!isCell(x = cdr(x))) { 410 if (y == txt(0)) 411 return Nil; 412 Save(c1); 413 tail(x = consSym(NULL,0)) = y; 414 drop(c1); 415 return x; 416 } 417 if (isNil(data(c1)) || data(c1) == isIntern(y, Intern)) 418 err(ex, data(c1), "Can't rename"); 419 Save(c1); 420 x = EVAL(car(x)); 421 NeedSymb(ex,x); 422 for (p = &tail(data(c1)); isCell(*p); p = &car(*p)); 423 *p = name(x); 424 return Pop(c1); 425 } 426 427 /* Make name */ 428 any mkSym(byte *s) { 429 int i; 430 word w; 431 cell c1, *p; 432 433 putByte1(*s++, &i, &w, &p); 434 while (*s) 435 putByte(*s++, &i, &w, &p, &c1); 436 return popSym(i, w, p, &c1); 437 } 438 439 /* Make string */ 440 any mkStr(char *s) {return s && *s? mkSym((byte*)s) : Nil;} 441 442 bool isBlank(any x) { 443 int i, c; 444 word w; 445 446 if (!isSymb(x)) 447 return NO; 448 if (isNil(x)) 449 return YES; 450 x = name(x); 451 for (c = getByte1(&i, &w, &x); c; c = getByte(&i, &w, &x)) 452 if (c > ' ') 453 return NO; 454 return YES; 455 } 456 457 // (sp? 'any) -> flg 458 any doSpQ(any x) { 459 x = cdr(x); 460 return isBlank(EVAL(car(x)))? T : Nil; 461 } 462 463 // (pat? 'any) -> sym | NIL 464 any doPatQ(any x) { 465 x = cdr(x); 466 return isSymb(x = EVAL(car(x))) && firstByte(x) == '@'? x : Nil; 467 } 468 469 // (fun? 'any) -> any 470 any doFunQ(any x) { 471 any y; 472 473 x = cdr(x); 474 if (isNum(x = EVAL(car(x)))) 475 return x; 476 if (isSym(x)) 477 return Nil; 478 for (y = cdr(x); isCell(y) && y != x; y = cdr(y)) { 479 if (isCell(car(y))) { 480 if (isCell(cdr(y)) && isNum(caar(y))) 481 return Nil; 482 if (isNil(caar(y)) || caar(y) == T) 483 return Nil; 484 } 485 else if (!isNil(cdr(y))) 486 return Nil; 487 } 488 if (!isNil(y)) 489 return Nil; 490 if (isNil(x = car(x))) 491 return T; 492 for (y = x; isCell(y);) 493 if (isNum(car(y)) || isCell(car(y)) || isNil(car(y)) || car(y)==T || x==(y=cdr(y))) 494 return Nil; 495 return isNum(y) || y==T? Nil : x; 496 } 497 498 // (all ['T]) -> lst 499 static void all(any x, cell *p) { 500 if (isCell(cddr(x))) 501 all(cddr(x), p); 502 data(*p) = cons(car(x), data(*p)); 503 if (isCell(cadr(x))) 504 all(cadr(x), p); 505 } 506 507 any doAll(any x) { 508 any *p; 509 cell c1; 510 511 x = cdr(x); 512 p = isNil(EVAL(car(x)))? Intern : Transient; 513 Push(c1, Nil); 514 if (isCell(p[1])) 515 all(p[1], &c1); 516 if (isCell(p[0])) 517 all(p[0], &c1); 518 return Pop(c1); 519 } 520 521 // (intern 'sym) -> sym 522 any doIntern(any ex) { 523 any x; 524 525 x = cdr(ex), x = EVAL(car(x)); 526 NeedSymb(ex,x); 527 return intern(x, Intern); 528 } 529 530 // (==== ['sym ..]) -> NIL 531 any doHide(any ex) { 532 any x, y; 533 534 Transient[0] = Transient[1] = Nil; 535 for (x = cdr(ex); isCell(x); x = cdr(x)) { 536 y = EVAL(car(x)); 537 NeedSymb(ex,y); 538 intern(y, Transient); 539 } 540 return Nil; 541 } 542 543 // (box? 'any) -> sym | NIL 544 any doBoxQ(any x) { 545 x = cdr(x); 546 return isSymb(x = EVAL(car(x))) && name(x) == txt(0)? x : Nil; 547 } 548 549 // (str? 'any) -> sym | NIL 550 any doStrQ(any x) { 551 any y; 552 553 x = cdr(x); 554 return isSymb(x = EVAL(car(x))) && 555 (y = name(x)) != txt(0) && 556 x != isIntern(y, Intern)? x : Nil; 557 } 558 559 // (zap 'sym) -> sym 560 any doZap(any ex) { 561 any x; 562 563 x = cdr(ex), x = EVAL(car(x)); 564 NeedSymb(ex,x); 565 if (x >= Nil && x <= Bye) 566 protError(ex,x); 567 unintern(x, Intern); 568 return x; 569 } 570 571 // (chop 'any) -> lst 572 any doChop(any x) { 573 any y; 574 int i, c; 575 word w; 576 cell c1, c2; 577 578 if (isCell(x = EVAL(cadr(x))) || isNil(x)) 579 return x; 580 x = name(data(c1) = xSym(x)); 581 if (!(c = getByte1(&i, &w, &x))) 582 return Nil; 583 Save(c1); 584 Push(c2, y = cons(mkChar(c), Nil)); 585 while (c = getByte(&i, &w, &x)) 586 y = cdr(y) = cons(mkChar(c), Nil); 587 drop(c1); 588 return data(c2); 589 } 590 591 void pack(any x, int *i, word *p, any *q, cell *cp) { 592 int c, j; 593 word w; 594 595 if (isCell(x)) 596 do 597 pack(car(x), i, p, q, cp); 598 while (isCell(x = cdr(x))); 599 if (isNum(x)) { 600 char buf[BITS/2], *b = buf; 601 602 bufNum(buf, unBox(x)); 603 do 604 putByte(*b++, i, p, q, cp); 605 while (*b); 606 } 607 else if (!isNil(x)) 608 for (x = name(x), c = getByte1(&j, &w, &x); c; c = getByte(&j, &w, &x)) 609 putByte(c, i, p, q, cp); 610 } 611 612 // (pack 'any ..) -> sym 613 any doPack(any x) { 614 int i; 615 word w; 616 any y; 617 cell c1, c2; 618 619 x = cdr(x), Push(c1, EVAL(car(x))); 620 putByte0(&i, &w, &y); 621 pack(data(c1), &i, &w, &y, &c2); 622 while (isCell(x = cdr(x))) 623 pack(data(c1) = EVAL(car(x)), &i, &w, &y, &c2); 624 y = popSym(i, w, y, &c2); 625 drop(c1); 626 return i? y : Nil; 627 } 628 629 // (glue 'any 'lst) -> sym 630 any doGlue(any x) { 631 int i; 632 word w; 633 any y; 634 cell c1, c2, c3; 635 636 x = cdr(x), Push(c1, EVAL(car(x))); 637 x = cdr(x), Push(c2, x = EVAL(car(x))); 638 if (!isCell(x)) { 639 drop(c1); 640 return x; 641 } 642 putByte0(&i, &w, &y); 643 pack(car(x), &i, &w, &y, &c3); 644 while (isCell(x = cdr(x))) { 645 pack(data(c1), &i, &w, &y, &c3); 646 pack(car(x), &i, &w, &y, &c3); 647 } 648 y = popSym(i, w, y, &c3); 649 drop(c1); 650 return i? y : Nil; 651 } 652 653 // (text 'sym 'any ..) -> sym 654 any doText(any x) { 655 int c, n, i1, i2; 656 word w1, w2; 657 any nm1, nm2; 658 cell c1, c2; 659 660 nm1 = name(data(c1) = evSym(x = cdr(x))); 661 if (!(c = getByte1(&i1, &w1, &nm1))) 662 return Nil; 663 Save(c1); 664 { 665 cell arg[length(x = cdr(x))]; 666 667 for (n = 0; isCell(x); ++n, x = cdr(x)) 668 Push(arg[n], EVAL(car(x))); 669 670 putByte0(&i2, &w2, &nm2); 671 do { 672 if (c != '@') 673 putByte(c, &i2, &w2, &nm2, &c2); 674 else if (!(c = getByte(&i1, &w1, &nm1))) 675 break; 676 else if (c == '@') 677 putByte('@', &i2, &w2, &nm2, &c2); 678 else if (c >= '1') { 679 if ((c -= '1') > 8) 680 c -= 7; 681 if (n > c) 682 pack(data(arg[c]), &i2, &w2, &nm2, &c2); 683 } 684 } while (c = getByte(&i1, &w1, &nm1)); 685 nm2 = popSym(i2, w2, nm2, &c2); 686 drop(c1); 687 return nm2; 688 } 689 } 690 691 // (pre? 'sym1 'sym2) -> flg 692 any doPreQ(any ex) { 693 int c, i1, i2; 694 word w1, w2; 695 any x, y; 696 cell c1; 697 698 x = cdr(ex); 699 if (isNil(y = EVAL(car(x)))) 700 return T; 701 NeedSymb(ex,y); 702 Push(c1, y); 703 x = cdr(x), x = EVAL(car(x)); 704 drop(c1); 705 if (isNil(x)) 706 return Nil; 707 NeedSymb(ex,x); 708 y = name(y); 709 if (!(c = getByte1(&i1, &w1, &y))) 710 return T; 711 x = name(x); 712 if (c != getByte1(&i2, &w2, &x)) 713 return Nil; 714 for (;;) { 715 if (!(c = getByte(&i1, &w1, &y))) 716 return T; 717 if (c != getByte(&i2, &w2, &x)) 718 return Nil; 719 } 720 } 721 722 // (val 'var) -> any 723 any doVal(any ex) { 724 any x; 725 726 x = cdr(ex), x = EVAL(car(x)); 727 NeedVar(ex,x); 728 return val(x); 729 } 730 731 // (set 'var 'any ..) -> any 732 any doSet(any ex) { 733 any x; 734 cell c1; 735 736 x = cdr(ex); 737 do { 738 Push(c1, EVAL(car(x))), x = cdr(x); 739 NeedVar(ex,data(c1)); 740 CheckVar(ex,data(c1)); 741 val(data(c1)) = EVAL(car(x)), x = cdr(x); 742 drop(c1); 743 } while (isCell(x)); 744 return val(data(c1)); 745 } 746 747 // (setq var 'any ..) -> any 748 any doSetq(any ex) { 749 any x, y; 750 751 x = cdr(ex); 752 do { 753 y = car(x), x = cdr(x); 754 NeedVar(ex,y); 755 CheckVar(ex,y); 756 val(y) = EVAL(car(x)); 757 } while (isCell(x = cdr(x))); 758 return val(y); 759 } 760 761 // (xchg 'var 'var ..) -> any 762 any doXchg(any ex) { 763 any x, y, z; 764 cell c1; 765 766 x = cdr(ex); 767 do { 768 Push(c1, EVAL(car(x))), x = cdr(x); 769 NeedVar(ex,data(c1)); 770 CheckVar(ex,data(c1)); 771 y = EVAL(car(x)), x = cdr(x); 772 NeedVar(ex,y); 773 CheckVar(ex,y); 774 z = val(data(c1)), val(data(c1)) = val(y), val(y) = z; 775 drop(c1); 776 } while (isCell(x)); 777 return z; 778 } 779 780 // (on sym ..) -> T 781 any doOn(any ex) { 782 any x = cdr(ex); 783 do { 784 NeedSymb(ex,car(x)); 785 val(car(x)) = T; 786 } while (isCell(x = cdr(x))); 787 return T; 788 } 789 790 // (off sym ..) -> NIL 791 any doOff(any ex) { 792 any x = cdr(ex); 793 do { 794 NeedSymb(ex,car(x)); 795 val(car(x)) = Nil; 796 } while (isCell(x = cdr(x))); 797 return Nil; 798 } 799 800 // (onOff sym ..) -> flg 801 any doOnOff(any ex) { 802 any x = cdr(ex); 803 any y; 804 805 do { 806 NeedSymb(ex,car(x)); 807 y = val(car(x)) = isNil(val(car(x)))? T : Nil; 808 } while (isCell(x = cdr(x))); 809 return y; 810 } 811 812 // (zero sym ..) -> 0 813 any doZero(any ex) { 814 any x = cdr(ex); 815 do { 816 NeedSymb(ex,car(x)); 817 val(car(x)) = Zero; 818 } while (isCell(x = cdr(x))); 819 return Zero; 820 } 821 822 // (one sym ..) -> 1 823 any doOne(any ex) { 824 any x = cdr(ex); 825 do { 826 NeedSymb(ex,car(x)); 827 val(car(x)) = One; 828 } while (isCell(x = cdr(x))); 829 return One; 830 } 831 832 // (default sym 'any ..) -> any 833 any doDefault(any ex) { 834 any x, y; 835 836 x = cdr(ex); 837 do { 838 y = car(x), x = cdr(x); 839 NeedSymb(ex,y); 840 if (isNil(val(y))) 841 val(y) = EVAL(car(x)); 842 } while (isCell(x = cdr(x))); 843 return val(y); 844 } 845 846 // (push 'var 'any ..) -> any 847 any doPush(any ex) { 848 any x, y; 849 cell c1; 850 851 x = cdr(ex), Push(c1, EVAL(car(x))); 852 NeedVar(ex,data(c1)); 853 CheckVar(ex,data(c1)); 854 x = cdr(x); 855 val(data(c1)) = cons(y = EVAL(car(x)), val(data(c1))); 856 while (isCell(x = cdr(x))) 857 val(data(c1)) = cons(y = EVAL(car(x)), val(data(c1))); 858 drop(c1); 859 return y; 860 } 861 862 // (push1 'var 'any ..) -> any 863 any doPush1(any ex) { 864 any x, y; 865 cell c1; 866 867 x = cdr(ex), Push(c1, EVAL(car(x))); 868 NeedVar(ex,data(c1)); 869 CheckVar(ex,data(c1)); 870 x = cdr(x); 871 if (!member(y = EVAL(car(x)), val(data(c1)))) 872 val(data(c1)) = cons(y, val(data(c1))); 873 while (isCell(x = cdr(x))) 874 if (!member(y = EVAL(car(x)), val(data(c1)))) 875 val(data(c1)) = cons(y, val(data(c1))); 876 drop(c1); 877 return y; 878 } 879 880 // (pop 'var) -> any 881 any doPop(any ex) { 882 any x, y; 883 884 x = cdr(ex), x = EVAL(car(x)); 885 NeedVar(ex,x); 886 CheckVar(ex,x); 887 if (!isCell(y = val(x))) 888 return y; 889 val(x) = cdr(y); 890 return car(y); 891 } 892 893 // (cut 'num 'var) -> lst 894 any doCut(any ex) { 895 long n; 896 any x, y; 897 cell c1, c2; 898 899 if ((n = evNum(ex, x = cdr(ex))) <= 0) 900 return Nil; 901 x = cdr(x), Push(c1, EVAL(car(x))); 902 NeedVar(ex,data(c1)); 903 CheckVar(ex,data(c1)); 904 if (isCell(val(data(c1)))) { 905 Push(c2, y = cons(car(val(data(c1))), Nil)); 906 while (isCell(val(data(c1)) = cdr(val(data(c1)))) && --n) 907 y = cdr(y) = cons(car(val(data(c1))), Nil); 908 drop(c1); 909 return data(c2); 910 } 911 return val(Pop(c1)); 912 } 913 914 // (del 'any 'var) -> lst 915 any doDel(any ex) { 916 any x, y; 917 cell c1, c2, c3; 918 919 x = cdr(ex), Push(c1, EVAL(car(x))); 920 x = cdr(x), Push(c2, EVAL(car(x))); 921 NeedVar(ex,data(c2)); 922 CheckVar(ex,data(c2)); 923 if (isCell(x = val(data(c2)))) { 924 if (equal(data(c1), car(x))) { 925 drop(c1); 926 return val(data(c2)) = cdr(x); 927 } 928 Push(c3, y = cons(car(x), Nil)); 929 while (isCell(x = cdr(x))) { 930 if (equal(data(c1), car(x))) { 931 cdr(y) = cdr(x); 932 drop(c1); 933 return val(data(c2)) = data(c3); 934 } 935 y = cdr(y) = cons(car(x), Nil); 936 } 937 } 938 drop(c1); 939 return val(data(c2)); 940 } 941 942 // (queue 'var 'any) -> any 943 any doQueue(any ex) { 944 any x, y; 945 cell c1; 946 947 x = cdr(ex), Push(c1, EVAL(car(x))); 948 NeedVar(ex,data(c1)); 949 CheckVar(ex,data(c1)); 950 x = cdr(x), x = EVAL(car(x)); 951 if (!isCell(y = val(data(c1)))) 952 val(data(c1)) = cons(x,Nil); 953 else { 954 while (isCell(cdr(y))) 955 y = cdr(y); 956 cdr(y) = cons(x,Nil); 957 } 958 drop(c1); 959 return x; 960 } 961 962 // (fifo 'var ['any ..]) -> any 963 any doFifo(any ex) { 964 any x, y, z; 965 cell c1; 966 967 x = cdr(ex), Push(c1, EVAL(car(x))); 968 NeedVar(ex,data(c1)); 969 CheckVar(ex,data(c1)); 970 if (isCell(x = cdr(x))) { 971 y = EVAL(car(x)); 972 if (isCell(z = val(data(c1)))) 973 val(data(c1)) = z = cdr(z) = cons(y,cdr(z)); 974 else 975 cdr(z) = z = val(data(c1)) = cons(y,Nil); 976 while (isCell(x = cdr(x))) 977 val(data(c1)) = z = cdr(z) = cons(y = EVAL(car(x)), cdr(z)); 978 } 979 else if (!isCell(z = val(data(c1)))) 980 y = Nil; 981 else { 982 if (z == cdr(z)) { 983 y = car(z); 984 val(data(c1)) = Nil; 985 } 986 else { 987 y = cadr(z); 988 cdr(z) = cddr(z); 989 } 990 } 991 drop(c1); 992 return y; 993 } 994 995 static void idx(any x, cell *p) { 996 if (isCell(cddr(x))) 997 idx(cddr(x), p); 998 data(*p) = cons(car(x), data(*p)); 999 if (isCell(cadr(x))) 1000 idx(cadr(x), p); 1001 } 1002 1003 // (idx 'var 'any 'flg) -> lst 1004 // (idx 'var 'any) -> lst 1005 // (idx 'var) -> lst 1006 any doIdx(any ex) { 1007 any x, y, z, *p; 1008 int flg, n; 1009 cell c1, c2; 1010 1011 x = cdr(ex), Push(c1, EVAL(car(x))); 1012 NeedVar(ex,data(c1)); 1013 CheckVar(ex,data(c1)); 1014 if (!isCell(x = cdr(x))) { 1015 Push(c2, Nil); 1016 if (isCell(val(data(c1)))) 1017 idx(val(data(c1)), &c2); 1018 drop(c1); 1019 return data(c2); 1020 } 1021 Push(c2, EVAL(car(x))); 1022 flg = !isCell(cdr(x))? 0 : isNil(EVAL(cadr(x)))? -1 : +1; 1023 if (!isCell(x = val(data(c1)))) { 1024 if (flg > 0) 1025 val(data(c1)) = cons(data(c2),Nil); 1026 drop(c1); 1027 return Nil; 1028 } 1029 p = (any*)data(c1); 1030 for (;;) { 1031 if ((n = compare(data(c2), car(x))) == 0) { 1032 if (flg < 0) { 1033 if (!isCell(cadr(x))) 1034 *p = cddr(x); 1035 else if (!isCell(y = cddr(x))) 1036 *p = cadr(x); 1037 else if (!isCell(z = cadr(y))) 1038 car(x) = car(y), cddr(x) = cddr(y); 1039 else { 1040 while (isCell(cadr(z))) 1041 z = cadr(y = z); 1042 car(x) = car(z), cadr(y) = cddr(z); 1043 } 1044 } 1045 drop(c1); 1046 return x; 1047 } 1048 if (!isCell(cdr(x))) { 1049 if (flg > 0) 1050 cdr(x) = n < 0? 1051 cons(cons(data(c2),Nil), Nil) : cons(Nil, cons(data(c2),Nil)); 1052 drop(c1); 1053 return Nil; 1054 } 1055 if (n < 0) { 1056 if (!isCell(cadr(x))) { 1057 if (flg > 0) 1058 cadr(x) = cons(data(c2),Nil); 1059 drop(c1); 1060 return Nil; 1061 } 1062 x = *(p = &cadr(x)); 1063 } 1064 else { 1065 if (!isCell(cddr(x))) { 1066 if (flg > 0) 1067 cddr(x) = cons(data(c2),Nil); 1068 drop(c1); 1069 return Nil; 1070 } 1071 x = *(p = &cddr(x)); 1072 } 1073 } 1074 } 1075 1076 static any From, To; 1077 static cell LupCell; 1078 1079 static void lup(any x) { 1080 if (isCell(x)) { 1081 if (car(x) == T) 1082 lup(cadr(x)); 1083 else if (!isCell(car(x))) 1084 lup(cddr(x)); 1085 else if (compare(To, caar(x)) >= 0) { 1086 lup(cddr(x)); 1087 if (compare(From, caar(x)) <= 0) { 1088 data(LupCell) = cons(car(x), data(LupCell)); 1089 lup(cadr(x)); 1090 } 1091 } 1092 else if (compare(From, caar(x)) <= 0) 1093 lup(cadr(x)); 1094 } 1095 } 1096 1097 // (lup 'lst 'any) -> lst 1098 // (lup 'lst 'any 'any2) -> lst 1099 any doLup(any x) { 1100 int n; 1101 cell c1, c2; 1102 1103 x = cdr(x), Push(c1, EVAL(car(x))); 1104 x = cdr(x), Push(c2, EVAL(car(x))); 1105 x = cdr(x); 1106 if (!isNil(To = EVAL(car(x)))) { 1107 From = data(c2); 1108 Push(LupCell, Nil); 1109 lup(data(c1)); 1110 drop(c1); 1111 return data(LupCell); 1112 } 1113 while (isCell(data(c1))) { 1114 if (car(data(c1)) == T) 1115 data(c1) = cadr(data(c1)); 1116 else if (!isCell(car(data(c1)))) 1117 data(c1) = cddr(data(c1)); 1118 else if (n = compare(data(c2), caar(data(c1)))) 1119 data(c1) = n < 0? cadr(data(c1)) : cddr(data(c1)); 1120 else { 1121 drop(c1); 1122 return car(data(c1)); 1123 } 1124 } 1125 drop(c1); 1126 return Nil; 1127 } 1128 1129 any put(any x, any key, any val) { 1130 any y, z; 1131 1132 if (isCell(y = tail(x))) { 1133 if (isCell(cdr(y))) { 1134 if (key == cddr(y)) { 1135 if (isNil(val)) 1136 tail(x) = car(y); 1137 else if (val == T) 1138 cdr(y) = key; 1139 else 1140 cadr(y) = val; 1141 return val; 1142 } 1143 } 1144 else if (key == cdr(y)) { 1145 if (isNil(val)) 1146 tail(x) = car(y); 1147 else if (val != T) 1148 cdr(y) = cons(val,key); 1149 return val; 1150 } 1151 while (isCell(z = car(y))) { 1152 if (isCell(cdr(z))) { 1153 if (key == cddr(z)) { 1154 if (isNil(val)) 1155 car(y) = car(z); 1156 else { 1157 if (val == T) 1158 cdr(z) = key; 1159 else 1160 cadr(z) = val; 1161 car(y) = car(z), car(z) = tail(x), tail(x) = z; 1162 } 1163 return val; 1164 } 1165 } 1166 else if (key == cdr(z)) { 1167 if (isNil(val)) 1168 car(y) = car(z); 1169 else { 1170 if (val != T) 1171 cdr(z) = cons(val,key); 1172 car(y) = car(z), car(z) = tail(x), tail(x) = z; 1173 } 1174 return val; 1175 } 1176 y = z; 1177 } 1178 } 1179 if (!isNil(val)) { 1180 y = cons(Nil, val==T? key : cons(val,key)); 1181 car(y) = tail(x); 1182 tail(x) = y; 1183 } 1184 return val; 1185 } 1186 1187 any get(any x, any key) { 1188 any y, z; 1189 1190 if (!isCell(y = tail(x))) 1191 return Nil; 1192 if (!isCell(cdr(y))) { 1193 if (key == cdr(y)) 1194 return T; 1195 } 1196 else if (key == cddr(y)) 1197 return cadr(y); 1198 while (isCell(z = car(y))) { 1199 if (!isCell(cdr(z))) { 1200 if (key == cdr(z)) { 1201 car(y) = car(z), car(z) = tail(x), tail(x) = z; 1202 return T; 1203 } 1204 } 1205 else if (key == cddr(z)) { 1206 car(y) = car(z), car(z) = tail(x), tail(x) = z; 1207 return cadr(z); 1208 } 1209 y = z; 1210 } 1211 return Nil; 1212 } 1213 1214 any prop(any x, any key) { 1215 any y, z; 1216 1217 if (!isCell(y = tail(x))) 1218 return Nil; 1219 if (!isCell(cdr(y))) { 1220 if (key == cdr(y)) 1221 return key; 1222 } 1223 else if (key == cddr(y)) 1224 return cdr(y); 1225 while (isCell(z = car(y))) { 1226 if (!isCell(cdr(z))) { 1227 if (key == cdr(z)) { 1228 car(y) = car(z), car(z) = tail(x), tail(x) = z; 1229 return key; 1230 } 1231 } 1232 else if (key == cddr(z)) { 1233 car(y) = car(z), car(z) = tail(x), tail(x) = z; 1234 return cdr(z); 1235 } 1236 y = z; 1237 } 1238 return Nil; 1239 } 1240 1241 // (put 'sym1|lst ['sym2|num ..] 'sym|num 'any) -> any 1242 any doPut(any ex) { 1243 any x; 1244 cell c1, c2; 1245 1246 x = cdr(ex), Push(c1, EVAL(car(x))); 1247 x = cdr(x), Push(c2, EVAL(car(x))); 1248 while (isCell(cdr(x = cdr(x)))) { 1249 if (isCell(data(c1))) 1250 data(c1) = getn(data(c2), data(c1)); 1251 else { 1252 NeedSymb(ex,data(c1)); 1253 data(c1) = data(c2)==Zero? val(data(c1)) : get(data(c1), data(c2)); 1254 } 1255 data(c2) = EVAL(car(x)); 1256 } 1257 NeedSymb(ex,data(c1)); 1258 x = put(data(c1), data(c2), EVAL(car(x))); 1259 drop(c1); 1260 return x; 1261 } 1262 1263 // (get 'sym1|lst ['sym2|num ..]) -> any 1264 any doGet(any ex) { 1265 any x, y; 1266 cell c1; 1267 1268 x = cdr(ex), data(c1) = EVAL(car(x)); 1269 if (!isCell(x = cdr(x))) 1270 return data(c1); 1271 Save(c1); 1272 do { 1273 y = EVAL(car(x)); 1274 if (isCell(data(c1))) 1275 data(c1) = getn(y, data(c1)); 1276 else { 1277 NeedSymb(ex,data(c1)); 1278 data(c1) = y==Zero? val(data(c1)) : get(data(c1), y); 1279 } 1280 } while (isCell(x = cdr(x))); 1281 return Pop(c1); 1282 } 1283 1284 // (prop 'sym1|lst ['sym2|num ..] 'sym) -> lst|sym 1285 any doProp(any ex) { 1286 any x, y; 1287 cell c1; 1288 1289 x = cdr(ex), Push(c1, EVAL(car(x))); 1290 x = cdr(x), y = EVAL(car(x)); 1291 while (isCell(x = cdr(x))) { 1292 if (isCell(data(c1))) 1293 data(c1) = getn(y, data(c1)); 1294 else { 1295 NeedSymb(ex,data(c1)); 1296 data(c1) = y==Zero? val(data(c1)) : get(data(c1), y); 1297 } 1298 y = EVAL(car(x)); 1299 } 1300 NeedSymb(ex,data(c1)); 1301 return prop(Pop(c1), y); 1302 } 1303 1304 // (; 'sym1|lst [sym2|num ..]) -> any 1305 any doSemicol(any ex) { 1306 any x, y; 1307 1308 x = cdr(ex), y = EVAL(car(x)); 1309 while (isCell(x = cdr(x))) { 1310 if (isCell(y)) 1311 y = getn(car(x), y); 1312 else { 1313 NeedSymb(ex,y); 1314 y = car(x)==Zero? val(y) : get(y, car(x)); 1315 } 1316 } 1317 return y; 1318 } 1319 1320 // (=: sym|0 [sym1|num .. sym2] 'any) -> any 1321 any doSetCol(any ex) { 1322 any x, y, z; 1323 1324 x = cdr(ex); 1325 y = val(This); 1326 if (z = car(x), isCell(cdr(x = cdr(x)))) { 1327 y = z==Zero? val(y) : get(y,z); 1328 while (z = car(x), isCell(cdr(x = cdr(x)))) { 1329 if (isCell(y)) 1330 y = getn(z,y); 1331 else { 1332 NeedSymb(ex,y); 1333 y = z==Zero? val(y) : get(y,z); 1334 } 1335 } 1336 } 1337 NeedSymb(ex,y); 1338 x = put(y, z, EVAL(car(x))); 1339 return x; 1340 } 1341 1342 // (: sym|0 [sym1|num ..]) -> any 1343 any doCol(any ex) { 1344 any x, y; 1345 1346 x = cdr(ex), y = val(This); 1347 y = car(x)==Zero? val(y) : get(y, car(x)); 1348 while (isCell(x = cdr(x))) { 1349 if (isCell(y)) 1350 y = getn(car(x), y); 1351 else { 1352 NeedSymb(ex,y); 1353 y = car(x)==Zero? val(y) : get(y,car(x)); 1354 } 1355 } 1356 return y; 1357 } 1358 1359 // (:: sym|0 [sym1|num .. sym2]) -> lst|sym 1360 any doPropCol(any ex) { 1361 any x, y; 1362 1363 x = cdr(ex), y = val(This); 1364 if (!isCell(cdr(x))) 1365 return prop(y, car(x)); 1366 y = car(x)==Zero? val(y) : get(y, car(x)); 1367 while (isCell(cdr(x = cdr(x)))) { 1368 if (isCell(y)) 1369 y = getn(car(x), y); 1370 else { 1371 NeedSymb(ex,y); 1372 y = car(x)==Zero? val(y) : get(y,car(x)); 1373 } 1374 } 1375 return prop(y,car(x)); 1376 } 1377 1378 // (putl 'sym1|lst1 ['sym2|num ..] 'lst) -> lst 1379 any doPutl(any ex) { 1380 any x, y; 1381 cell c1, c2; 1382 1383 x = cdr(ex), Push(c1, EVAL(car(x))); 1384 x = cdr(x), Push(c2, EVAL(car(x))); 1385 while (isCell(x = cdr(x))) { 1386 if (isCell(data(c1))) 1387 data(c1) = getn(data(c2), data(c1)); 1388 else { 1389 NeedSymb(ex,data(c1)); 1390 data(c1) = data(c2)==Zero? val(data(c1)) : get(data(c1), data(c2)); 1391 } 1392 data(c2) = EVAL(car(x)); 1393 } 1394 NeedSymb(ex,data(c1)); 1395 NeedLst(ex,data(c2)); 1396 x = (any)&tail(data(c1)); 1397 while (isCell(car(x))) 1398 car(x) = caar(x); 1399 for (y = data(c2); isCell(y); y = cdr(y)) 1400 if (!isCell(car(y))) 1401 car(x) = cons(car(x),car(y)); 1402 else if (!isNil(caar(y))) 1403 car(x) = cons(car(x), caar(y)==T? cdar(y) : car(y)); 1404 drop(c1); 1405 return data(c2); 1406 } 1407 1408 // (getl 'sym1|lst1 ['sym2|num ..]) -> lst 1409 any doGetl(any ex) { 1410 any x, y; 1411 cell c1, c2; 1412 1413 x = cdr(ex), Push(c1, EVAL(car(x))); 1414 while (isCell(x = cdr(x))) { 1415 y = EVAL(car(x)); 1416 if (isCell(data(c1))) 1417 data(c1) = getn(y, data(c1)); 1418 else { 1419 NeedSymb(ex,data(c1)); 1420 data(c1) = y==Zero? val(data(c1)) : get(data(c1), y); 1421 } 1422 } 1423 NeedSymb(ex,data(c1)); 1424 if (!isCell(x = tail(data(c1)))) 1425 data(c2) = Nil; 1426 else { 1427 Push(c2, y = cons(cdr(x),Nil)); 1428 while (isCell(x = car(x))) 1429 y = cdr(y) = cons(cdr(x),Nil); 1430 } 1431 drop(c1); 1432 return data(c2); 1433 } 1434 1435 static any meta(any x, any y) { 1436 any z; 1437 1438 while (isCell(x)) { 1439 if (isSymb(car(x))) 1440 if (!isNil(z = get(car(x),y)) || !isNil(z = meta(val(car(x)), y))) 1441 return z; 1442 x = cdr(x); 1443 } 1444 return Nil; 1445 } 1446 1447 // (meta 'obj|typ 'sym ['sym2|num ..]) -> any 1448 any doMeta(any ex) { 1449 any x, y; 1450 cell c1; 1451 1452 x = cdr(ex), Push(c1, EVAL(car(x))); 1453 x = cdr(x), y = EVAL(car(x)); 1454 if (isSymb(data(c1))) 1455 data(c1) = val(data(c1)); 1456 data(c1) = meta(data(c1), y); 1457 while (isCell(x = cdr(x))) { 1458 y = EVAL(car(x)); 1459 if (isCell(data(c1))) { 1460 NeedNum(ex,y); 1461 data(c1) = car(nth(unBox(y), data(c1))); 1462 } 1463 else { 1464 NeedSymb(ex,data(c1)); 1465 data(c1) = get(data(c1), y); 1466 } 1467 } 1468 return Pop(c1); 1469 } 1470 1471 #define isLowc(c) ((c) >= 'a' && (c) <= 'z') 1472 #define isUppc(c) ((c) >= 'A' && (c) <= 'Z') 1473 1474 static inline bool isLetterOrDigit(int c) { 1475 return isLowc(c) || isUppc(c) || (c) >= '0' && (c) <= '9'; 1476 } 1477 1478 static int toUpperCase(int c) { 1479 return isLowc(c)? c - 32 : c; 1480 } 1481 1482 static int toLowerCase(int c) { 1483 return isUppc(c)? c + 32 : c; 1484 } 1485 1486 // (low? 'any) -> sym | NIL 1487 any doLowQ(any x) { 1488 x = cdr(x); 1489 return isSymb(x = EVAL(car(x))) && isLowc(firstByte(x))? x : Nil; 1490 } 1491 1492 // (upp? 'any) -> sym | NIL 1493 any doUppQ(any x) { 1494 x = cdr(x); 1495 return isSymb(x = EVAL(car(x))) && isUppc(firstByte(x))? x : Nil; 1496 } 1497 1498 // (lowc 'any) -> any 1499 any doLowc(any x) { 1500 int c, i1, i2; 1501 word w1, w2; 1502 any nm; 1503 cell c1, c2; 1504 1505 x = cdr(x); 1506 if (!isSymb(x = EVAL(car(x))) || isNil(x)) 1507 return x; 1508 x = name(data(c1) = x); 1509 if (!(c = getByte1(&i1, &w1, &x))) 1510 return data(c1); 1511 Save(c1); 1512 putByte1(toLowerCase(c), &i2, &w2, &nm); 1513 while (c = getByte(&i1, &w1, &x)) 1514 putByte(toLowerCase(c), &i2, &w2, &nm, &c2); 1515 nm = popSym(i2, w2, nm, &c2); 1516 drop(c1); 1517 return nm; 1518 } 1519 1520 // (uppc 'any) -> any 1521 any doUppc(any x) { 1522 int c, i1, i2; 1523 word w1, w2; 1524 any nm; 1525 cell c1, c2; 1526 1527 x = cdr(x); 1528 if (!isSymb(x = EVAL(car(x))) || isNil(x)) 1529 return x; 1530 x = name(data(c1) = x); 1531 if (!(c = getByte1(&i1, &w1, &x))) 1532 return data(c1); 1533 Save(c1); 1534 putByte1(toUpperCase(c), &i2, &w2, &nm); 1535 while (c = getByte(&i1, &w1, &x)) 1536 putByte(toUpperCase(c), &i2, &w2, &nm, &c2); 1537 nm = popSym(i2, w2, nm, &c2); 1538 drop(c1); 1539 return nm; 1540 } 1541 1542 // (fold 'any ['num]) -> sym 1543 any doFold(any ex) { 1544 int n, c, i1, i2; 1545 word w1, w2; 1546 any x, nm; 1547 cell c1, c2; 1548 1549 x = cdr(ex); 1550 if (!isSymb(x = EVAL(car(x))) || isNil(x)) 1551 return Nil; 1552 x = name(data(c1) = x); 1553 if (!(c = getByte1(&i1, &w1, &x))) 1554 return Nil; 1555 while (!isLetterOrDigit(c)) 1556 if (!(c = getByte(&i1, &w1, &x))) 1557 return Nil; 1558 Save(c1); 1559 n = isCell(x = cddr(ex))? evNum(ex,x) : 24; 1560 putByte1(toLowerCase(c), &i2, &w2, &nm); 1561 while (c = getByte(&i1, &w1, &x)) 1562 if (isLetterOrDigit(c)) { 1563 if (!--n) 1564 break; 1565 putByte(toLowerCase(c), &i2, &w2, &nm, &c2); 1566 } 1567 nm = popSym(i2, w2, nm, &c2); 1568 drop(c1); 1569 return nm; 1570 }