sym.l (84033B)
1 # 02mar13abu 2 # (c) Software Lab. Alexander Burger 3 4 ### Compare long names ### 5 (code 'cmpLongAX_F 0) 6 push X # Keep X 7 do 8 cmp (A DIG) (X DIG) # Equal? 9 if ne # No 10 pop X 11 ret 12 end 13 ld A (A BIG) 14 ld X (X BIG) 15 big A # A on last digit? 16 if z # Yes 17 big X # X also on last digit? 18 if nz # No 19 setc # A is smaller 20 pop X 21 ret 22 end 23 cmp A X # Equal? 24 pop X 25 ret 26 end 27 cnt X # A not on last digit. X on last digit? 28 until nz # Yes 29 clrc # A is greater 30 pop X 31 ret 32 33 ### Is symbol interned? ### 34 # E symbol 35 # X name 36 # Y tree 37 (code 'isInternEXY_F 0) 38 cnt X # Short name? 39 if nz # Yes 40 ld Y (Y) # Y on first tree 41 do 42 atom Y # Empty? 43 jnz ret # Return NO 44 ld A ((Y) TAIL) # Next symbol 45 call nameA_A # Get name 46 cmp A X # Equal? 47 while ne # No 48 ld Y (Y CDR) 49 ldc Y (Y CDR) # Symbol is smaller 50 ldnc Y (Y) # Symbol is greater 51 loop 52 cmp E (Y) # Same Symbol? 53 ret # Return YES or NO 54 end 55 # Long name 56 ld Y (Y CDR) # Y on second tree 57 do 58 atom Y # Empty? 59 jnz ret # Return NO 60 ld A ((Y) TAIL) # Next symbol 61 call nameA_A # Get name 62 call cmpLongAX_F # Equal? 63 while ne # No 64 ld Y (Y CDR) 65 ldc Y (Y CDR) # Symbol is smaller 66 ldnc Y (Y) # Symbol is greater 67 loop 68 cmp E (Y) # Same Symbol? 69 ret # Return YES or NO 70 71 ### Intern a symbol/name ### 72 # E symbol 73 # X name 74 # Y tree 75 (code 'internEXY_FE 0) 76 cnt X # Short name? 77 if nz # Yes 78 ld C (Y) # C on first tree 79 atom C # Empty? 80 if nz # Yes 81 null E # New symbol? 82 if z 83 call consSymX_E # Yes 84 end 85 call consE_X # Cons into a new node 86 ld (X) E 87 ld (X CDR) Nil 88 ld (Y) X # Store in first tree 89 setc # Return new symbol 90 ret 91 end 92 do 93 ld A ((C) TAIL) # Next symbol 94 call nameA_A # Get name 95 cmp A X # Equal? 96 if eq # Yes 97 ld E (C) # Found symbol 98 ret 99 end 100 if lt # Symbol is smaller 101 atom (C CDR) # Already has link? 102 if nz # No 103 null E # New symbol? 104 if z 105 call consSymX_E # Yes 106 end 107 call consE_A # Cons into a new node 108 ld (A) E 109 ld (A CDR) Nil 110 call consA_X # Cons into a new link 111 ld (X) Nil 112 ld (X CDR) A 113 ld (C CDR) X 114 setc # Return new symbol 115 ret 116 end 117 ld C (C CDR) 118 atom (C CDR) # CDR of link? 119 ldz C (C CDR) # Yes: Get CDR of link in C 120 if nz # No 121 null E # New symbol? 122 if z 123 call consSymX_E # Yes 124 end 125 call consE_A # Cons into a new node 126 ld (A) E 127 ld (A CDR) Nil 128 ld (C CDR) A # Store in CDR of link 129 setc # Return new symbol 130 ret 131 end 132 else # Symbol is greater 133 atom (C CDR) # Already has link? 134 if nz # No 135 null E # New symbol? 136 if z 137 call consSymX_E # Yes 138 end 139 call consE_A # Cons into a new node 140 ld (A) E 141 ld (A CDR) Nil 142 call consA_X # Cons into a new link 143 ld (X) A 144 ld (X CDR) Nil 145 ld (C CDR) X 146 setc # Return new symbol 147 ret 148 end 149 ld C (C CDR) 150 atom (C) # CAR of link? 151 ldz C (C) # Yes: Get CAR of link in C 152 if nz # No 153 null E # New symbol? 154 if z 155 call consSymX_E # Yes 156 end 157 call consE_A # Cons into a new node 158 ld (A) E 159 ld (A CDR) Nil 160 ld (C) A # Store in CAR of link 161 setc # Return new symbol 162 ret 163 end 164 end 165 loop 166 end 167 # Long name 168 ld C (Y CDR) # C on second tree 169 atom C # Empty? 170 if nz # Yes 171 null E # New symbol? 172 if z 173 call consSymX_E # Yes 174 end 175 call consE_X # Cons into a new node 176 ld (X) E 177 ld (X CDR) Nil 178 ld (Y CDR) X # Store in second tree 179 setc # Return new symbol 180 ret 181 end 182 do 183 ld A ((C) TAIL) # Next symbol 184 call nameA_A # Get name 185 call cmpLongAX_F # Equal? 186 if eq # Yes 187 ld E (C) # Found symbol 188 ret 189 end 190 if lt # Symbol is smaller 191 atom (C CDR) # Already has link? 192 if nz # No 193 null E # New symbol? 194 if z 195 call consSymX_E # Yes 196 end 197 call consE_A # Cons into a new node 198 ld (A) E 199 ld (A CDR) Nil 200 call consA_X # Cons into a new link 201 ld (X) Nil 202 ld (X CDR) A 203 ld (C CDR) X 204 setc # Return new symbol 205 ret 206 end 207 ld C (C CDR) 208 atom (C CDR) # CDR of link? 209 ldz C (C CDR) # Yes: Get CDR of link in C 210 if nz # No 211 null E # New symbol? 212 if z 213 call consSymX_E # Yes 214 end 215 call consE_A # Cons into a new node 216 ld (A) E 217 ld (A CDR) Nil 218 ld (C CDR) A # Store in CDR of link 219 setc # Return new symbol 220 ret 221 end 222 else # Symbol is greater 223 atom (C CDR) # Already has link? 224 if nz # No 225 null E # New symbol? 226 if z 227 call consSymX_E # Yes 228 end 229 call consE_A # Cons into a new node 230 ld (A) E 231 ld (A CDR) Nil 232 call consA_X # Cons into a new link 233 ld (X) A 234 ld (X CDR) Nil 235 ld (C CDR) X 236 setc # Return new symbol 237 ret 238 end 239 ld C (C CDR) 240 atom (C) # CAR of link? 241 ldz C (C) # Yes: Get CAR of link in C 242 if nz # No 243 null E # New symbol? 244 if z 245 call consSymX_E # Yes 246 end 247 call consE_A # Cons into a new node 248 ld (A) E 249 ld (A CDR) Nil 250 ld (C) A # Store in CAR of link 251 setc # Return new symbol 252 ret 253 end 254 end 255 loop 256 257 (code 'findSymX_E 0) # Y 258 ld E 0 # No symbol yet 259 ld Y ((EnvIntern)) 260 call internEXY_FE # New internal symbol? 261 jnc Ret # No 262 ld (E) Nil # Init to 'NIL' 263 ret 264 265 # X name 266 (code 'externX_E 0) # C 267 ld C 3 # Reserve three cells 268 call needC 269 push X # <S> Save name 270 ld A 6364136223846793005 # Randomize 271 mul X 272 ld E A # Key in E 273 ld X Extern # X on external symbol tree root node 274 do 275 ld A ((X) TAIL) # Next symbol 276 call nameA_A # Get name 277 and A (hex "3FFFFFFFFFFFFFF7") # Mask status and extern bits 278 mul 6364136223846793005 # Randomize 279 cmp A E # Equal to key? 280 if eq # Yes 281 add S I # Drop name 282 ld E (X) # Found symbol 283 ret 284 end 285 if lt # Symbol is smaller 286 atom (X CDR) # Already has link? 287 if nz # No 288 call cons_E # New symbol 289 pop (E) # Retrieve name 290 or (E) SYM # Set 'extern' tag 291 or E SYM # Make symbol 292 ld (E) Nil # Init to 'NIL' 293 call consE_A # Cons into a new node 294 ld (A) E 295 ld (A CDR) Nil 296 call consA_C # Cons into a new link 297 ld (C) Nil 298 ld (C CDR) A 299 ld (X CDR) C 300 ret 301 end 302 ld X (X CDR) 303 atom (X CDR) # CDR of link? 304 ldz X (X CDR) # Yes: Get CDR of link in X 305 if nz # No 306 call cons_E # New symbol 307 pop (E) # Retrieve name 308 or (E) SYM # Set 'extern' tag 309 or E SYM # Make symbol 310 ld (E) Nil # Init to 'NIL' 311 call consE_A # Cons into a new node 312 ld (A) E 313 ld (A CDR) Nil 314 ld (X CDR) A # Store in CDR of link 315 ret 316 end 317 else # Symbol is greater 318 atom (X CDR) # Already has link? 319 if nz # No 320 call cons_E # New symbol 321 pop (E) # Retrieve name 322 or (E) SYM # Set 'extern' tag 323 or E SYM # Make symbol 324 ld (E) Nil # Init to 'NIL' 325 call consE_A # Cons into a new node 326 ld (A) E 327 ld (A CDR) Nil 328 call consA_C # Cons into a new link 329 ld (C) A 330 ld (C CDR) Nil 331 ld (X CDR) C 332 ret 333 end 334 ld X (X CDR) 335 atom (X) # CAR of link? 336 ldz X (X) # Yes: Get CAR of link in X 337 if nz # No 338 call cons_E # New symbol 339 pop (E) # Retrieve name 340 or (E) SYM # Set 'extern' tag 341 or E SYM # Make symbol 342 ld (E) Nil # Init to 'NIL' 343 call consE_A # Cons into a new node 344 ld (A) E 345 ld (A CDR) Nil 346 ld (X) A # Store in CAR of link 347 ret 348 end 349 end 350 loop 351 352 ### Unintern a symbol ### 353 # E symbol 354 # X name 355 # Y tree 356 (code 'uninternEXY 0) 357 cmp X ZERO # Name? 358 jeq ret # No 359 cnt X # Short name? 360 if nz # Yes 361 do # Y on first tree 362 ld C (Y) # Next node 363 atom C # Empty? 364 jnz ret # Yes 365 ld A ((C) TAIL) # Next symbol 366 call nameA_A # Get name 367 cmp A X # Equal? 368 if eq # Yes 369 cmp E (C) # Correct symbol? 370 jne Ret # No 371 ld A (C CDR) # Get subtrees 372 atom (A) # Left branch? 373 if nz # No 374 ld (Y) (A CDR) # Use right branch 375 ret 376 end 377 atom (A CDR) # Right branch? 378 if nz # No 379 ld (Y) (A) # Use left branch 380 ret 381 end 382 ld A (A CDR) # A on right branch 383 ld Y (A CDR) # Y on sub-branches 384 atom (Y) # Left? 385 if nz # No 386 ld (C) (A) # Insert right sub-branch 387 ld ((C CDR) CDR) (Y CDR) 388 ret 389 end 390 ld Y (Y) # Left sub-branch 391 do 392 ld X (Y CDR) # More left branches? 393 atom (X) 394 while z # Yes 395 ld A Y # Go down left 396 ld Y (X) 397 loop 398 ld (C) (Y) # Insert left sub-branch 399 ld ((A CDR)) (X CDR) 400 ret 401 end 402 ld C (C CDR) 403 if lt # Symbol is smaller 404 atom C # Link? 405 jnz ret # No 406 lea Y (C CDR) # Go right 407 else # Symbol is greater 408 atom C # Link? 409 jnz ret # No 410 ld Y C # Go left 411 end 412 loop 413 end 414 # Long name 415 lea Y (Y CDR) 416 do # Y on second tree 417 ld C (Y) # Get next node 418 atom C # Empty? 419 jnz ret # Yes 420 ld A ((C) TAIL) # Next symbol 421 call nameA_A # Get name 422 call cmpLongAX_F # Equal? 423 if eq # Yes 424 cmp E (C) # Correct symbol? 425 jne Ret # No 426 ld A (C CDR) # Get subtrees 427 atom (A) # Left branch? 428 if nz # No 429 ld (Y) (A CDR) # Use right branch 430 ret 431 end 432 atom (A CDR) # Right branch? 433 if nz # No 434 ld (Y) (A) # Use left branch 435 ret 436 end 437 ld A (A CDR) # A on right branch 438 ld Y (A CDR) # Y on sub-branches 439 atom (Y) # Left? 440 if nz # No 441 ld (C) (A) # Insert right sub-branch 442 ld ((C CDR) CDR) (Y CDR) 443 ret 444 end 445 ld Y (Y) # Left sub-branch 446 do 447 ld X (Y CDR) # More left branches? 448 atom (X) 449 while nz # Yes 450 ld A Y # Go down left 451 ld Y (X) 452 loop 453 ld (C) (Y) # Insert left sub-branch 454 ld ((A CDR)) (X CDR) 455 ret 456 end 457 ld C (C CDR) 458 if lt # Symbol is smaller 459 atom C # Link? 460 jnz ret # No 461 lea Y (C CDR) # Go right 462 else # Symbol is greater 463 atom C # Link? 464 jnz ret # No 465 ld Y C # Go left 466 end 467 loop 468 469 (code 'nameA_A 0) 470 off A SYM # Clear 'extern' tag 471 do 472 num A # Find name 473 jnz ret 474 ld A (A CDR) # Skip property 475 loop 476 477 (code 'nameE_E 0) 478 off E SYM # Clear 'extern' tag 479 do 480 num E # Find name 481 jnz ret 482 ld E (E CDR) # Skip property 483 loop 484 485 (code 'nameX_X 0) 486 off X SYM # Clear 'extern' tag 487 do 488 num X # Find name 489 jnz ret 490 ld X (X CDR) # Skip property 491 loop 492 493 (code 'nameY_Y 0) 494 off Y SYM # Clear 'extern' tag 495 do 496 num Y # Find name 497 jnz ret 498 ld Y (Y CDR) # Skip property 499 loop 500 501 # (name 'sym ['sym2]) -> sym 502 (code 'doName 2) 503 push X 504 push Y 505 ld X E 506 ld Y (E CDR) # Y on args 507 ld E (Y) # Eval 'sym' 508 eval 509 num E # Need symbol 510 jnz symErrEX 511 sym E 512 jz symErrEX 513 ld Y (Y CDR) # Second arg? 514 atom Y 515 if nz # No 516 cmp E Nil # NIL? 517 if ne # No 518 ld X (E TAIL) 519 sym X # External symbol? 520 if z # No 521 call nameX_X # Get name 522 call consSymX_E # Make new transient symbol 523 else 524 call nameX_X # Get name 525 call packExtNmX_E # Pack it 526 end 527 end 528 else 529 cmp E Nil # NIL? 530 jeq renErrEX # Yes 531 sym (E TAIL) # External symbol? 532 jnz renErrEX # Yes 533 push X # Save expression 534 push Y 535 ld X (E TAIL) 536 call nameX_X # Get name 537 ld Y ((EnvIntern)) # Internal symbol? 538 call isInternEXY_F 539 pop Y 540 pop X 541 jz renErrEX # Yes 542 link 543 push E # <L I> First (transient) symbol 544 link 545 ld E (Y) 546 eval # Eval second arg 547 num E # Need symbol 548 jnz symErrEX 549 sym E 550 jz symErrEX 551 ld X (E TAIL) 552 call nameX_X # Get name 553 push X # Save new name 554 ld E (L I) # Get first symbol 555 ld X (E TAIL) 556 call nameX_X # Get name 557 ld Y Transient 558 call uninternEXY # Unintern 559 lea Y (E TAIL) 560 do 561 num (Y) # Find name 562 while z 563 lea Y ((Y) CDR) 564 loop 565 pop (Y) # Store name of second 566 drop 567 end 568 pop Y 569 pop X 570 ret 571 572 # Make single-char symbol 573 (code 'mkCharA_A 0) 574 cmp A (hex "80") # ASCII? 575 if ge # No 576 cmp A (hex "800") # Double-byte? 577 if lt # Yes 578 ld (Buf) B # 110xxxxx 10xxxxxx 579 shr A 6 # Upper five bits 580 and B (hex "1F") 581 or B (hex "C0") 582 xchg B (Buf) # Save first byte 583 and A (hex "3F") # Lower 6 bits 584 or B (hex "80") 585 shl A 8 # into second byte 586 ld B (Buf) # Get first byte 587 else 588 cmp A TOP # Special "top" character? 589 if eq # Yes 590 ld B (hex "FF") # Above legal UTF-8 591 zxt 592 else 593 push C 594 ld C A # 1110xxxx 10xxxxxx 10xxxxxx 595 shr A 12 # Hightest four bits 596 and B (hex "0F") 597 or B (hex "E0") 598 ld (Buf) B # Save first byte 599 ld A C 600 shr A 6 # Middle six bits 601 and A (hex "3F") 602 or B (hex "80") 603 shl A 8 # into second byte 604 xchg A C 605 and A (hex "3F") # Lowest 6 bits 606 or B (hex "80") # Add third byte 607 shl A 16 # into third byte 608 or A C # Combine with second byte 609 ld B (Buf) # and first byte 610 pop C 611 end 612 end 613 end 614 shl A 4 # Make short name 615 or A CNT 616 push A # Save character 617 call cons_A # New cell 618 pop (A) # Set name 619 or A SYM # Make symbol 620 ld (A) A # Set value to itself 621 ret 622 623 (code 'mkStrE_E 0) 624 null E # NULL pointer? 625 jz retNil 626 nul (E) # Empty string? 627 jz retNil 628 push C 629 push X 630 link 631 push ZERO # <L I> Name 632 ld C 4 # Build name 633 ld X S 634 link 635 do 636 ld B (E) 637 call byteSymBCX_CX # Pack byte 638 inc E # Next byte 639 nul (E) # Any? 640 until z 641 call cons_E # Cons symbol 642 ld (E) (L I) # Set name 643 or E SYM # Make symbol 644 ld (E) E # Set value to itself 645 drop 646 pop X 647 pop C 648 ret 649 650 (code 'mkStrEZ_A 0) 651 push X 652 link 653 push ZERO # <L I> Name 654 ld C 4 # Build name 655 ld X S 656 link 657 do 658 ld B (E) 659 call byteSymBCX_CX # Pack byte 660 cmp E Z # Reached Z? 661 while ne # No 662 inc E # Next byte 663 nul (E) # Any? 664 until z 665 call cons_A # Cons symbol 666 ld (A) (L I) # Set name 667 or A SYM # Make symbol 668 ld (A) A # Set value to itself 669 drop 670 pop X 671 ret 672 673 (code 'firstByteA_B 0) 674 sym A # External symbol? 675 if z # No 676 call nameA_A # Get name 677 cnt A # Short? 678 if nz # Yes 679 shr A 4 # Normalize 680 else 681 ld A (A DIG) # Get first digit 682 end 683 ret 684 end 685 ld A 0 686 ret 687 688 (code 'firstCharE_A 0) 689 ld A 0 690 cmp E Nil # NIL? 691 if ne # No 692 push X 693 ld X (E TAIL) 694 sym X # External symbol? 695 if z # No 696 call nameX_X # Get name 697 ld C 0 698 call symCharCX_FACX # Get first character 699 end 700 pop X 701 end 702 ret 703 704 (code 'isBlankE_F 0) 705 num E # Symbol? 706 jnz ret # No 707 sym E 708 jz retnz # No 709 cmp E Nil # NIL? 710 jeq ret # Yes 711 sym (E TAIL) # External symbol? 712 jnz ret # Yes 713 push X 714 ld X (E TAIL) 715 call nameX_X # Get name 716 ld C 0 717 do 718 call symByteCX_FACX # Next byte 719 while nz 720 cmp B 32 # Larger than blank? 721 break gt # Yes 722 loop 723 pop X 724 ret 725 726 # (sp? 'any) -> flg 727 (code 'doSpQ 2) 728 ld E ((E CDR)) # Get arg 729 eval # Eval it 730 call isBlankE_F # Blank? 731 ld E TSym # Yes 732 ldnz E Nil 733 ret 734 735 # (pat? 'any) -> sym | NIL 736 (code 'doPatQ 2) 737 ld E ((E CDR)) # Get arg 738 eval # Eval it 739 num E # Number? 740 jnz retNil # Yes 741 sym E # Symbol? 742 jz retNil # No 743 ld A (E TAIL) 744 call firstByteA_B # starting with "@"? 745 cmp B (char "@") 746 ldnz E Nil # No 747 ret 748 749 # (fun? 'any) -> any 750 (code 'doFunQ 2) 751 ld E ((E CDR)) # Get arg 752 eval # Eval it 753 call funqE_FE # Function definition? 754 ldnz E Nil # No 755 ret 756 757 # (getd 'any) -> fun | NIL 758 (code 'doGetd 2) 759 ld E ((E CDR)) # E on arg 760 eval # Eval it 761 num E # No number? 762 if z # Yes 763 sym E # Symbol? 764 if nz # Yes 765 push E 766 ld E (E) # Get value 767 call funqE_FE # Function definition? 768 pop E 769 if eq # Yes 770 ld E (E) # Return value 771 ret 772 end 773 cmp (E) Nil # Value NIL? 774 if eq # Yes 775 ld C E 776 call sharedLibC_FA # Dynamically loaded? 777 if nz # Yes 778 ld E A # Return function pointer 779 ret 780 end 781 end 782 end 783 end 784 ld E Nil 785 ret 786 787 # (all ['NIL | 'T | '0 | '(NIL . flg) | '(T . flg) | '(0)]) -> lst 788 (code 'doAll 2) 789 push X 790 ld E ((E CDR)) # Eval arg 791 eval 792 atom E # Direct tree? 793 if z # Yes 794 cmp (E) Nil # Internal trees? 795 if eq # Yes 796 cmp (E CDR) Nil # Short names? 797 ldz E (((EnvIntern))) # Yes 798 ldnz E (((EnvIntern)) I) 799 else 800 cmp (E) TSym # Transient trees? 801 ldnz E Extern # No: External symbols 802 if eq # Yes 803 cmp (E CDR) Nil # Short names? 804 ldz E (Transient) # Yes 805 ldnz E (Transient I) 806 end 807 end 808 else 809 cmp E Nil # Nil? 810 if eq # Yes 811 ld X (((EnvIntern)) I) # Internal symbols 812 call consTreeXE_E 813 ld X (((EnvIntern))) 814 else 815 cmp E TSym # T? 816 if eq # Yes 817 ld E Nil 818 ld X (Transient I) # Transient symbols 819 call consTreeXE_E 820 ld X (Transient) 821 else 822 ld E Nil 823 ld X Extern # External symbols 824 end 825 end 826 call consTreeXE_E 827 end 828 pop X 829 ret 830 831 # Build sorted list from tree 832 (code 'consTreeXE_E 0) 833 atom X # Tree empty? 834 jnz ret # Yes 835 link 836 push X # <L II> Tree 837 push Nil # <L I> TOS 838 link 839 do 840 do 841 ld A (X CDR) # Get subtrees 842 atom (A CDR) # Right subtree? 843 while z # Yes 844 ld C X # Go right 845 ld X (A CDR) # Invert tree 846 ld (A CDR) (L I) # TOS 847 ld (L I) C 848 loop 849 ld (L II) X # Save tree 850 do 851 call consE_A # Cons value 852 ld (A) (X) 853 ld (A CDR) E 854 ld E A # into E 855 ld A (X CDR) # Left subtree? 856 atom (A) 857 if z # Yes 858 ld C X # Go left 859 ld X (A) # Invert tree 860 ld (A) (L I) # TOS 861 or C SYM # First visit 862 ld (L I) C 863 ld (L II) X # Save tree 864 break T 865 end 866 do 867 ld A (L I) # TOS 868 cmp A Nil # Empty? 869 jeq 90 # Done 870 sym A # Second visit? 871 if z # Yes 872 ld C (A CDR) # Nodes 873 ld (L I) (C CDR) # TOS on up link 874 ld (C CDR) X 875 ld X A 876 ld (L II) X # Save tree 877 break T 878 end 879 off A SYM # Set second visit 880 ld C (A CDR) # Nodes 881 ld (L I) (C) 882 ld (C) X 883 ld X A 884 ld (L II) X # Save tree 885 loop 886 loop 887 loop 888 90 drop # Return E 889 ret 890 891 # Build balanced copy of a namespace 892 (code 'balanceXY) # ACE 893 ld E Nil # Build list 894 call consTreeXE_E 895 link 896 push E # <L I> Save list 897 link 898 ld A E # Get list in A 899 ld C 0 # Calculate length 900 do 901 atom A # More cells? 902 while z # Yes 903 inc C # Increment length 904 ld A (A CDR) # Next cell 905 loop 906 call balanceCEY 907 drop 908 ret 909 910 (code 'balanceCEY 0) 911 do 912 null C # Length zero? 913 jz ret # Yes 914 push C # <S II> Save length 915 push E # <S I> and list 916 inc C # (length + 1) / 2 917 shr C 1 918 push C # <S> Rest length 919 do 920 dec C # nth 921 while nsz 922 ld E (E CDR) 923 loop 924 push (E CDR) # Save rest 925 ld E (E) # Next symbol 926 ld X (E TAIL) # Get name 927 call nameX_X 928 call internEXY_FE # Insert 929 pop E # Retrieve rest 930 ld C (S II) # Get length 931 sub C (S) # minus rest length 932 call balanceCEY # Recurse 933 pop C # Retrieve rest length 934 dec C # Decrement 935 pop E # Retrieve list 936 add S I # Drop length 937 loop # Tail recurse 938 939 # (symbols) -> sym 940 # (symbols 'sym1) -> sym2 941 # (symbols 'sym1 'sym ..) -> sym2 942 (code 'doSymbols 2) 943 push X 944 push Y 945 push Z 946 ld X E 947 ld Z (E CDR) # Z on args 948 atom Z # Any? 949 if nz # No 950 ld E (EnvIntern) # Return current symbol namespace 951 else 952 ld E (Z) # Eval first 953 eval 954 num E # Need symbol 955 jnz symErrEX 956 sym E 957 jz symErrEX 958 ld Z (Z CDR) # Second arg 959 atom Z # Any? 960 if nz # No 961 atom (E) # Value must be a pair 962 jnz symNsErrEX 963 else 964 call checkVarEX 965 link 966 push E # <L III> Save new symbol namespace 967 push Nil # <L II> Space for value 968 push Nil # <L I> and source 969 link 970 call cons_Y # Create namespace cell 971 ld (Y) Nil # Initialize 972 ld (Y CDR) Nil 973 ld (L II) Y # New value 974 do 975 ld E (Z) 976 eval # Eval next source symbol namespace 977 ld (L I) E # Save source 978 num E # Need symbol 979 jnz symErrEX 980 sym E 981 jz symErrEX 982 ld C (E) # Get source value 983 atom C # Must be a pair 984 jnz symNsErrEX 985 push X 986 ld X (C) # Source short names 987 call balanceXY # Balanced copy of short names 988 ld X (((L I)) CDR) # Source long names 989 call balanceXY # Balanced copy of long names 990 pop X 991 ld Z (Z CDR) # Next arg 992 atom Z # Any? 993 until nz # No 994 ld C (L II) # Get value 995 ld E (L III) # And new symbol namespace 996 call redefineCE # Redefine 997 drop 998 end 999 xchg (EnvIntern) E # Set new symbol namespace, return old 1000 end 1001 pop Z 1002 pop Y 1003 pop X 1004 ret 1005 1006 # (intern 'sym) -> sym 1007 (code 'doIntern 2) 1008 push X 1009 ld X E 1010 ld E ((E CDR)) # E on arg 1011 eval # Eval it 1012 num E # Need symbol 1013 jnz symErrEX 1014 sym E 1015 jz symErrEX 1016 ld X (E TAIL) 1017 call nameX_X # Get name 1018 cmp X ZERO # Any? 1019 if ne # Yes 1020 push Y 1021 ld Y ((EnvIntern)) # Insert internal 1022 call internEXY_FE 1023 pop Y 1024 pop X 1025 ret 1026 end 1027 ld E Nil 1028 pop X 1029 ret 1030 1031 # (extern 'sym) -> sym | NIL 1032 (code 'doExtern 2) 1033 push X 1034 push Y 1035 ld X E 1036 ld E ((E CDR)) # E on arg 1037 eval # Eval it 1038 num E # Need symbol 1039 jnz symErrEX 1040 sym E 1041 jz symErrEX 1042 ld X (E TAIL) 1043 call nameX_X # Get name 1044 cmp X ZERO # Any? 1045 if ne # Yes 1046 ld C 0 # Character index 1047 call symCharCX_FACX # First char 1048 cmp B (char "{") # Open brace? 1049 if eq # Yes 1050 call symCharCX_FACX # Skip it 1051 end 1052 ld E 0 # Init file number 1053 do 1054 cmp B (char "@") # File done? 1055 while ge # No 1056 cmp B (char "O") # In A-O range? 1057 jgt 90 # Yes 1058 sub B (char "@") 1059 shl E 4 # Add to file number 1060 add E A 1061 call symCharCX_FACX # Next char? 1062 jz 90 # No 1063 loop 1064 cmp B (char "0") # Octal digit? 1065 jlt 90 1066 cmp B (char "7") 1067 jgt 90 # No 1068 sub B (char "0") 1069 zxt 1070 ld Y A # Init object ID 1071 do 1072 call symCharCX_FACX # Next char? 1073 while nz # Yes 1074 cmp B (char "}") # Closing brace? 1075 while ne # No 1076 cmp B (char "0") # Octal digit? 1077 jlt 90 1078 cmp B (char "7") 1079 jgt 90 # No 1080 sub B (char "0") 1081 shl Y 3 # Add to object ID 1082 add Y A 1083 loop 1084 ld C Y # Object ID 1085 call extNmCE_X # Build external symbol name 1086 call externX_E # New external symbol 1087 call isLifeE_F # Alive? 1088 ldnz E Nil # No 1089 pop Y 1090 pop X 1091 ret 1092 end 1093 90 ld E Nil 1094 pop Y 1095 pop X 1096 ret 1097 1098 # (==== ['sym ..]) -> NIL 1099 (code 'doHide 2) 1100 ld A Nil # Clear transient index trees 1101 ld (Transient) A 1102 ld (Transient I) A 1103 push X 1104 push Y 1105 push Z 1106 ld X E 1107 ld Z (E CDR) # Args 1108 do 1109 atom Z # More? 1110 while z # Yes 1111 ld E (Z) # Eval next 1112 eval 1113 num E # Need symbol 1114 jnz symErrEX 1115 sym E 1116 jz symErrEX 1117 push X 1118 ld X (E TAIL) 1119 call nameX_X # Get name 1120 ld Y Transient # Insert transient 1121 call internEXY_FE 1122 pop X 1123 ld Z (Z CDR) # Z on rest 1124 loop 1125 pop Z 1126 pop Y 1127 pop X 1128 ret 1129 1130 # (box? 'any) -> sym | NIL 1131 (code 'doBoxQ 2) 1132 ld E ((E CDR)) # Get arg 1133 eval # Eval it 1134 num E # Number? 1135 jnz retNil # Yes 1136 sym E # Symbol? 1137 jz retNil # No 1138 ld A (E TAIL) 1139 call nameA_A # Get name 1140 cmp A ZERO # Any? 1141 jne retNil 1142 ret 1143 1144 # (str? 'any) -> sym | NIL 1145 (code 'doStrQ 2) 1146 ld E ((E CDR)) # Get arg 1147 eval # Eval it 1148 num E # Number? 1149 jnz retNil # Yes 1150 sym E # Symbol? 1151 jz retNil # No 1152 sym (E TAIL) # External symbol? 1153 jnz retNil # Yes 1154 push X 1155 push Y 1156 ld X (E TAIL) # Get name 1157 call nameX_X 1158 ld Y ((EnvIntern)) # Internal symbol? 1159 call isInternEXY_F 1160 ldz E Nil # Return NIL 1161 pop Y 1162 pop X 1163 ret 1164 1165 # (ext? 'any) -> sym | NIL 1166 (code 'doExtQ 2) 1167 ld E ((E CDR)) # Get arg 1168 eval # Eval it 1169 num E # Number? 1170 jnz retNil # Yes 1171 sym E # Symbol? 1172 jz retNil # No 1173 ld A (E TAIL) 1174 sym A # External symbol? 1175 jz retNil # No 1176 call isLifeE_F # Alive? 1177 ldnz E Nil # No 1178 ret 1179 1180 # (touch 'sym) -> sym 1181 (code 'doTouch 2) 1182 ld E ((E CDR)) # Get arg 1183 eval # Eval it 1184 num E # Need symbol 1185 jnz symErrEX 1186 sym E 1187 jz symErrEX 1188 sym (E TAIL) # External symbol? 1189 if nz # Yes 1190 call dbTouchEX # Touch it 1191 end 1192 ret 1193 1194 # (zap 'sym) -> sym 1195 (code 'doZap 2) 1196 push X 1197 ld X E 1198 ld E ((E CDR)) # E on arg 1199 eval # Eval it 1200 num E # Need symbol 1201 jnz symErrEX 1202 sym E 1203 jz symErrEX 1204 ld A (E TAIL) 1205 sym A # External symbol? 1206 if nz # Yes 1207 call dbZapE # Mark as "deleted" 1208 else 1209 cmp (EnvIntern) pico # Inside 'pico'? 1210 if eq # Yes 1211 cmp E Nil # Between 'NIL' and '*Bye'? 1212 if ge 1213 cmp E Bye 1214 jle protErrEX # Yes 1215 end 1216 end 1217 push Y 1218 ld X (E TAIL) 1219 call nameX_X # Get name 1220 ld Y ((EnvIntern)) 1221 call uninternEXY # Unintern symbol 1222 pop Y 1223 end 1224 pop X 1225 ret 1226 1227 # (chop 'any) -> lst 1228 (code 'doChop 2) 1229 ld E ((E CDR)) # Get arg 1230 eval # Eval it 1231 atom E # Atomic? 1232 if nz # Yes 1233 cmp E Nil # NIL? 1234 if ne # No 1235 push X 1236 call xSymE_E # Extract symbol 1237 ld X (E TAIL) 1238 call nameX_X # Get name 1239 sym (E TAIL) # External symbol? 1240 if z # No 1241 ld C 0 1242 call symCharCX_FACX # First char? 1243 if nz # Yes 1244 push Y 1245 link 1246 push X # Save name 1247 link 1248 call mkCharA_A # Make single character 1249 call consA_Y # Cons it 1250 ld (Y) A 1251 ld (Y CDR) Nil # with NIL 1252 tuck Y # <L I> Result 1253 link 1254 do 1255 call symCharCX_FACX # Next char 1256 while nz 1257 call mkCharA_A # Make char 1258 call consA_E # Cons it 1259 ld (E) A 1260 ld (E CDR) Nil 1261 ld (Y CDR) E # Append to result 1262 ld Y E 1263 loop 1264 ld E (L I) # Get result 1265 drop 1266 pop Y 1267 else 1268 ld E Nil # Else return NIL 1269 end 1270 else # External symbol 1271 call chopExtNmX_E 1272 end 1273 pop X 1274 end 1275 end 1276 ret 1277 1278 # (pack 'any ..) -> sym 1279 (code 'doPack 2) 1280 push X 1281 push Y 1282 push Z 1283 ld Y (E CDR) # Y on args 1284 ld E (Y) # Eval first 1285 eval 1286 link 1287 push E # <L III> 'any' 1288 push ZERO # <L II> Safe 1289 push ZERO # <L I> Result 1290 ld C 4 # Build name 1291 ld X S 1292 link 1293 do 1294 call packECX_CX 1295 ld Y (Y CDR) # More args? 1296 atom Y 1297 while z # Yes 1298 ld Z C # Save C 1299 ld E (Y) # Eval next arg 1300 eval 1301 ld (L III) E # Save 1302 ld C Z 1303 loop 1304 ld X (L I) # Get result 1305 call consSymX_E # Make transient symbol 1306 drop 1307 pop Z 1308 pop Y 1309 pop X 1310 ret 1311 1312 (code 'packECX_CX 0) 1313 atom E # Atomic? 1314 if z # No 1315 do # List 1316 push (E CDR) # Save rest 1317 ld E (E) # Recurse on CAR 1318 cmp S (StkLimit) # Stack check 1319 jlt stkErr 1320 call packECX_CX 1321 pop E # Done? 1322 atom E 1323 until nz # Yes 1324 end 1325 cmp E Nil # NIL? 1326 jeq ret # Yes 1327 num E # Number? 1328 if z # No 1329 sym (E TAIL) # External symbol? 1330 if nz # Yes 1331 ld B (char "{") 1332 call byteSymBCX_CX # Pack "{" 1333 push C # Save status 1334 push X 1335 ld X (E TAIL) # Get name 1336 call nameX_X 1337 call packExtNmX_E # Pack name 1338 ld (L II) E # Save 1339 pop X # Restore status 1340 pop C 1341 call 10 # Pack external symbol 1342 ld B (char "}") 1343 jmp byteSymBCX_CX # Pack "}" 1344 end 1345 else 1346 ld A 0 # Scale 1347 call fmtNum0AE_E # Convert to symbol 1348 ld (L II) E # Save 1349 end 1350 10 push C # Save status 1351 push X 1352 ld X (E TAIL) 1353 call nameX_X # Get name 1354 ld C 0 1355 do 1356 call symByteCX_FACX # Next char 1357 while nz 1358 xchg C (S I) # Swap status 1359 xchg X (S) 1360 call byteSymBCX_CX # Pack byte 1361 xchg X (S) # Swap status 1362 xchg C (S I) 1363 loop 1364 pop X # Restore status 1365 pop C 1366 ret 1367 1368 # (glue 'any 'lst) -> sym 1369 (code 'doGlue 2) 1370 push X 1371 push Y 1372 ld X (E CDR) # Args 1373 ld E (X) # Eval first 1374 eval 1375 link 1376 push E # <L IV> 'any' 1377 ld X (X CDR) # X on rest 1378 ld E (X) # Eval second 1379 eval+ 1380 push E # <L III> 'lst' 1381 push ZERO # <L II> Number safe 1382 push ZERO # <L I> Result 1383 ld C 4 # Build name 1384 ld X S 1385 link 1386 atom E # Any items? 1387 if z # Yes 1388 ld Y E # 'lst' 1389 do 1390 ld E (Y) # Get next item 1391 call packECX_CX # Pack it 1392 ld Y (Y CDR) # More? 1393 atom Y 1394 while z # Yes 1395 ld E (L IV) # Get 'any' 1396 call packECX_CX # Pack it 1397 loop 1398 ld X (L I) # Get result 1399 call consSymX_E # Make transient symbol 1400 end 1401 drop 1402 pop Y 1403 pop X 1404 ret 1405 1406 # (text 'any1 'any ..) -> sym 1407 (code 'doText 2) 1408 push X 1409 push Y 1410 ld X (E CDR) # Args 1411 call evSymX_E # Eval first 1412 cmp E Nil # NIL? 1413 if ne # No 1414 ld E (E TAIL) 1415 call nameE_E # Get name 1416 link 1417 push E # <(L) -I> Name of 'any1' 1418 do 1419 ld X (X CDR) # Next arg 1420 atom X # Any? 1421 while z # Yes 1422 ld E (X) # Eval next arg 1423 eval+ 1424 push E # and save it 1425 loop 1426 push ZERO # <L II> Number safe 1427 push ZERO # <L I> Result 1428 ld X S 1429 link 1430 push 4 # <S I> Build name 1431 push X # <S> Pack status 1432 ld X ((L) -I) # Get name of 'any1' 1433 ld C 0 # Index 1434 do 1435 call symByteCX_FACX # Next char? 1436 while nz 1437 cmp B (char "@") # Pattern? 1438 if ne # No 1439 10 xchg C (S I) # Swap status 1440 xchg X (S) 1441 call byteSymBCX_CX # Pack byte 1442 xchg X (S) # Swap status 1443 xchg C (S I) 1444 continue T 1445 end 1446 call symByteCX_FACX # Next char after "@"? 1447 while nz 1448 cmp B (char "@") # "@@"? 1449 jeq 10 # Yes 1450 sub B (char "0") # >= "1"? 1451 if gt # Yes 1452 cmp B 8 # > 8? 1453 if gt 1454 sub B 7 # Adjust for letter 1455 end 1456 shl A 3 # Vector index 1457 lea E ((L) -I) # Point above first 'any' arg 1458 sub E A # Get arg address 1459 lea A (L II) # Address of number save 1460 cmp E A # Arg address too low? 1461 if gt # No 1462 ld E (E) 1463 xchg C (S I) # Swap status 1464 xchg X (S) 1465 call packECX_CX # Pack it 1466 xchg X (S) # Swap status 1467 xchg C (S I) 1468 end 1469 end 1470 loop 1471 ld X (L I) # Get result 1472 call consSymX_E # Make transient symbol 1473 drop 1474 end 1475 pop Y 1476 pop X 1477 ret 1478 1479 (code 'preCEXY_F 0) 1480 do 1481 call symByteCX_FACX # First string done? 1482 jz ret # Yes 1483 ld (Buf) B # Keep 1484 xchg C E # Second string 1485 xchg X Y 1486 call symByteCX_FACX # Next byte? 1487 jz retnz # No 1488 cmp (Buf) B # Equal? 1489 jne ret # No 1490 xchg C E # First string 1491 xchg X Y 1492 loop 1493 1494 (code 'subStrAE_F 0) 1495 cmp A Nil # NIL? 1496 jeq ret # Yes 1497 ld A (A TAIL) # First symbol 1498 call nameA_A # Get name 1499 cmp A ZERO # None? 1500 jeq ret # Yes 1501 ld E (E TAIL) # Second symbol 1502 call nameE_E # Get name 1503 cmp E ZERO # Any? 1504 jeq retnz # No 1505 push X 1506 push Y 1507 push Z 1508 push A # <S I> First name 1509 ld Z E # Second name 1510 push 0 # <S> Second index 1511 do 1512 ld X (S I) # First name 1513 ld C 0 # First index 1514 ld Y Z # Second name 1515 ld E (S) # Second index 1516 call preCEXY_F # Prefix? 1517 while ne # No 1518 ld A (S) 1519 shr A 8 # New round in second index? 1520 if z # Yes 1521 cmp Z ZERO # Second done? 1522 if eq # Yes 1523 clrz # 'nz' 1524 break T 1525 end 1526 cnt Z # Short? 1527 if nz # Yes 1528 ld A Z # Get short 1529 shr A 4 # Normalize 1530 ld Z ZERO # Clear for next round 1531 else 1532 ld A (Z DIG) # Get next digit 1533 ld Z (Z BIG) 1534 end 1535 end 1536 ld (S) A 1537 loop 1538 lea S (S II) # Drop locals 1539 pop Z 1540 pop Y 1541 pop X 1542 ret # 'z' or 'nz' 1543 1544 # (pre? 'any1 'any2) -> any2 | NIL 1545 (code 'doPreQ 2) 1546 push X 1547 push Y 1548 push Z 1549 ld X (E CDR) # X on args 1550 call evSymX_E # Eval first 1551 link 1552 push E # <L I> 'any1' 1553 link 1554 ld X (X CDR) # Next arg 1555 call evSymX_E # Eval second 1556 ld X (L I) # 'any1' 1557 cmp X Nil # NIL? 1558 if ne # No 1559 ld Z E # Keep second in Z 1560 ld X (X TAIL) # 'any1' 1561 call nameX_X # First name 1562 ld C 0 1563 ld E (E TAIL) # 'any2' 1564 call nameE_E # Second name 1565 ld Y E 1566 ld E 0 1567 call preCEXY_F # Prefix? 1568 ld E Nil 1569 ldz E Z # Yes 1570 end 1571 drop 1572 pop Z 1573 pop Y 1574 pop X 1575 ret 1576 1577 # (sub? 'any1 'any2) -> any2 | NIL 1578 (code 'doSubQ 2) 1579 push X 1580 ld X (E CDR) # X on args 1581 call evSymX_E # Eval first 1582 link 1583 push E # <L I> 'any1' 1584 link 1585 ld X (X CDR) # Next arg 1586 call evSymX_E # Eval second 1587 ld A (L I) # 'any1' 1588 ld X E # Keep second in X 1589 call subStrAE_F # Substring? 1590 ld E Nil 1591 ldz E X # Yes 1592 drop 1593 pop X 1594 ret 1595 1596 # (val 'var) -> any 1597 (code 'doVal 2) 1598 push X 1599 ld X E 1600 ld E ((E CDR)) # E on arg 1601 eval # Eval it 1602 num E # Need variable 1603 jnz varErrEX 1604 sym E # Symbol? 1605 if nz # Yes 1606 sym (E TAIL) # External symbol? 1607 if nz # Yes 1608 call dbFetchEX # Fetch it 1609 end 1610 end 1611 ld E (E) # Return value 1612 pop X 1613 ret 1614 1615 # (set 'var 'any ..) -> any 1616 (code 'doSet 2) 1617 push X 1618 push Y 1619 ld X E 1620 ld Y (E CDR) # Y on args 1621 link 1622 push ZERO # <L I> Safe 1623 link 1624 do 1625 ld E (Y) # Eval next 1626 eval 1627 call needVarEX # Need variable 1628 sym E # Symbol? 1629 if nz # Yes 1630 sym (E TAIL) # External symbol? 1631 if nz # Yes 1632 call dbTouchEX # Touch it 1633 end 1634 end 1635 ld (L I) E # Save it 1636 ld Y (Y CDR) # Next arg 1637 ld E (Y) 1638 eval # Eval 'any' 1639 ld ((L I)) E # Set value 1640 ld Y (Y CDR) # Next arg 1641 atom Y # Any? 1642 until nz # No 1643 drop 1644 pop Y 1645 pop X 1646 ret 1647 1648 # (setq var 'any ..) -> any 1649 (code 'doSetq 2) 1650 push X 1651 push Y 1652 push Z 1653 ld X E 1654 ld Y (E CDR) # Y on args 1655 do 1656 ld E (Y) # Next var 1657 call needVarEX # Need variable 1658 ld Z E # Keep in Z 1659 ld Y (Y CDR) # Eval next arg 1660 ld E (Y) 1661 eval 1662 ld (Z) E # Store value 1663 ld Y (Y CDR) # More args? 1664 atom Y 1665 until nz # No 1666 pop Z 1667 pop Y 1668 pop X 1669 ret 1670 1671 # (xchg 'var 'var ..) -> any 1672 (code 'doXchg 2) 1673 push X 1674 push Y 1675 ld X E 1676 ld Y (E CDR) # Y on args 1677 link 1678 push ZERO # <L I> Safe 1679 link 1680 do 1681 ld E (Y) # Eval next 1682 eval 1683 call needVarEX # Need variable 1684 sym E # Symbol? 1685 if nz # Yes 1686 sym (E TAIL) # External symbol? 1687 if nz # Yes 1688 call dbTouchEX # Touch it 1689 end 1690 end 1691 ld (L I) E # Save it 1692 ld Y (Y CDR) # Next arg 1693 ld E (Y) 1694 eval # Eval next arg 1695 call needVarEX # Need variable 1696 sym E # Symbol? 1697 if nz # Yes 1698 sym (E TAIL) # External symbol? 1699 if nz # Yes 1700 call dbTouchEX # Touch it 1701 end 1702 end 1703 ld C (L I) # Get first 'var' 1704 ld A (C) # Get value 1705 ld (C) (E) # Set new 1706 ld (E) A 1707 ld Y (Y CDR) # Next arg 1708 atom Y # Any? 1709 until nz # No 1710 ld E A # Return last 1711 drop 1712 pop Y 1713 pop X 1714 ret 1715 1716 # (on var ..) -> T 1717 (code 'doOn 2) 1718 push X 1719 ld X (E CDR) 1720 do 1721 ld E (X) # Get next arg 1722 call needVarEX # Need variable 1723 ld (E) TSym # Set to 'T' 1724 ld X (X CDR) # More? 1725 atom X 1726 until nz # No 1727 ld E TSym 1728 pop X 1729 ret 1730 1731 # (off var ..) -> NIL 1732 (code 'doOff 2) 1733 push X 1734 ld X (E CDR) 1735 do 1736 ld E (X) # Get next arg 1737 call needVarEX # Need variable 1738 ld (E) Nil # Set to 'NIL' 1739 ld X (X CDR) # More? 1740 atom X 1741 until nz # No 1742 ld E Nil 1743 pop X 1744 ret 1745 1746 # (onOff var ..) -> flg 1747 (code 'doOnOff 2) 1748 push X 1749 ld X (E CDR) 1750 do 1751 ld E (X) # Get next arg 1752 call needVarEX # Need variable 1753 cmp (E) Nil # Value NIL? 1754 ld A TSym # Negate 1755 ldnz A Nil 1756 ld (E) A # Set new value 1757 ld X (X CDR) # More? 1758 atom X 1759 until nz # No 1760 ld E A # Return last 1761 pop X 1762 ret 1763 1764 # (zero var ..) -> 0 1765 (code 'doZero 2) 1766 push X 1767 ld X (E CDR) 1768 do 1769 ld E (X) # Get next arg 1770 call needVarEX # Need variable 1771 ld (E) ZERO # Set to '0' 1772 ld X (X CDR) # More? 1773 atom X 1774 until nz # No 1775 ld E ZERO 1776 pop X 1777 ret 1778 1779 # (one var ..) -> 1 1780 (code 'doOne 2) 1781 push X 1782 ld X (E CDR) 1783 do 1784 ld E (X) # Get next arg 1785 call needVarEX # Need variable 1786 ld (E) ONE # Set to '1' 1787 ld X (X CDR) # More? 1788 atom X 1789 until nz # No 1790 ld E ONE 1791 pop X 1792 ret 1793 1794 # (default sym 'any ..) -> any 1795 (code 'doDefault 2) 1796 push X 1797 push Y 1798 push Z 1799 ld X E 1800 ld Y (E CDR) # Y on args 1801 do 1802 ld E (Y) # Next var 1803 ld Y (Y CDR) 1804 call needVarEX # Need variable 1805 ld Z E # Keep in Z 1806 cmp (Z) Nil # Value 'NIL'? 1807 if eq # Yes 1808 ld E (Y) # Eval next arg 1809 eval 1810 ld (Z) E # Store value 1811 end 1812 ld Y (Y CDR) # More args? 1813 atom Y 1814 until nz # No 1815 ld E (Z) # Return value 1816 pop Z 1817 pop Y 1818 pop X 1819 ret 1820 1821 # (push 'var 'any ..) -> any 1822 (code 'doPush 2) 1823 push X 1824 push Y 1825 ld X E 1826 ld Y (E CDR) # Y on args 1827 ld E (Y) # Eval first 1828 eval 1829 call needVarEX # Need variable 1830 sym E # Symbol? 1831 if nz # Yes 1832 sym (E TAIL) # External symbol? 1833 if nz # Yes 1834 call dbTouchEX # Touch it 1835 end 1836 end 1837 link 1838 push E # <L I> 'var' 1839 link 1840 ld Y (Y CDR) # Second arg 1841 do 1842 ld E (Y) 1843 eval # Eval next arg 1844 call consE_A # Cons into value 1845 ld (A) E 1846 ld C (L I) # 'var' 1847 ld (A CDR) (C) 1848 ld (C) A 1849 ld Y (Y CDR) # Next arg 1850 atom Y # Any? 1851 until nz # No 1852 drop 1853 pop Y 1854 pop X 1855 ret 1856 1857 # (push1 'var 'any ..) -> any 1858 (code 'doPush1 2) 1859 push X 1860 push Y 1861 push Z 1862 ld X E 1863 ld Y (E CDR) # Y on args 1864 ld E (Y) # Eval first 1865 eval 1866 call needVarEX # Need variable 1867 sym E # Symbol? 1868 if nz # Yes 1869 sym (E TAIL) # External symbol? 1870 if nz # Yes 1871 call dbTouchEX # Touch it 1872 end 1873 end 1874 link 1875 push E # <L I> 'var' 1876 link 1877 ld Y (Y CDR) # Second arg 1878 do 1879 ld E (Y) 1880 eval # Eval next arg 1881 ld C ((L I)) # Value of 'var' 1882 do # 'member' 1883 atom C # List? 1884 while z # Yes 1885 ld A (C) 1886 ld Z E # Preserve E 1887 call equalAE_F # Member? 1888 ld E Z 1889 jeq 10 # Yes 1890 ld C (C CDR) 1891 loop 1892 call consE_A # Cons into value 1893 ld (A) E 1894 ld C (L I) # 'var' 1895 ld (A CDR) (C) 1896 ld (C) A 1897 10 ld Y (Y CDR) # Next arg 1898 atom Y # Any? 1899 until nz # No 1900 drop 1901 pop Z 1902 pop Y 1903 pop X 1904 ret 1905 1906 # (pop 'var) -> any 1907 (code 'doPop 2) 1908 push X 1909 ld X E 1910 ld E ((E CDR)) # E on arg 1911 eval # Eval it 1912 call needVarEX # Need variable 1913 sym E # Symbol? 1914 if nz # Yes 1915 sym (E TAIL) # External symbol? 1916 if nz # Yes 1917 call dbTouchEX # Touch it 1918 end 1919 end 1920 ld A E # 'var' in A 1921 ld E (A) # Get value 1922 atom E # List? 1923 if z # Yes 1924 ld (A) (E CDR) # Set to CDR 1925 ld E (E) # Return CAR 1926 end 1927 pop X 1928 ret 1929 1930 # (cut 'cnt 'var) -> lst 1931 (code 'doCut 2) 1932 push X 1933 push Y 1934 ld X E 1935 ld Y (E CDR) # Y on args 1936 call evCntXY_FE # Eval 'cnt' 1937 if nsz # Yes 1938 ld Y ((Y CDR)) # Second arg 1939 xchg E Y # 'cnt' in Y 1940 eval # Eval 'var' 1941 call needVarEX # Need variable 1942 sym E # Symbol? 1943 if nz # Yes 1944 sym (E TAIL) # External symbol? 1945 if nz # Yes 1946 call dbTouchEX # Touch it 1947 end 1948 end 1949 atom (E) # List value? 1950 ldnz E (E) 1951 if z # Yes 1952 call consE_X # Cons first cell 1953 ld C (E) # Get value 1954 ld (X) (C) # CAR 1955 ld (X CDR) Nil 1956 link 1957 push E # <L II> 'var' 1958 push X # <L I> 'lst' 1959 link 1960 do 1961 ld C (C CDR) # More elements? 1962 atom C 1963 while z # Yes 1964 dec Y # Count? 1965 while nz # Yes 1966 call cons_A # Copy next cell 1967 ld (A) (C) 1968 ld (A CDR) Nil 1969 ld (X CDR) A # Append to result 1970 ld X (X CDR) 1971 loop 1972 ld ((L II)) C # Set new value 1973 ld E (L I) # Get result 1974 drop 1975 end 1976 pop Y 1977 pop X 1978 ret 1979 end 1980 ld E Nil 1981 pop Y 1982 pop X 1983 ret 1984 1985 # (del 'any 'var) -> lst 1986 (code 'doDel 2) 1987 push X 1988 push Y 1989 push Z 1990 ld X E 1991 ld Y (E CDR) # Y on args 1992 ld E (Y) # Eval first 1993 eval 1994 link 1995 push E # <L II/III> 'any' 1996 ld Y (Y CDR) 1997 ld E (Y) # Eval second 1998 eval+ 1999 push E # <L I/II> 'var' 2000 link 2001 call needVarEX # Need variable 2002 sym E # Symbol? 2003 if nz # Yes 2004 sym (E TAIL) # External symbol? 2005 if nz # Yes 2006 call dbTouchEX # Touch it 2007 end 2008 end 2009 ld E ((L I)) # Get value of 'var' 2010 atom E # List? 2011 if z # Yes 2012 ld Y E # Keep value in Y 2013 ld E (Y) # First element 2014 ld A (L II) # 'any' 2015 call equalAE_F # Equal? 2016 if eq # Yes 2017 ld E (Y CDR) # Get value's CDR 2018 ld ((L I)) E # Set 'var' 2019 else 2020 call cons_Z # Copy first cell 2021 ld (Z) (Y) 2022 ld (Z CDR) Nil 2023 tuck Z # <L I> Save it 2024 link 2025 do 2026 ld Y (Y CDR) # More cells? 2027 atom Y 2028 while z # Yes 2029 ld E (Y) # Next element 2030 ld A (L III) # 'any' 2031 call equalAE_F # Equal? 2032 if eq # Yes 2033 ld (Z CDR) (Y CDR) # Skip found element 2034 ld E (L I) # Result 2035 ld ((L II)) E # Set 'var' 2036 jmp 90 2037 end 2038 call cons_A # Copy next cell 2039 ld (A) (Y) 2040 ld (A CDR) Nil 2041 ld (Z CDR) A # Append to result 2042 ld Z (Z CDR) 2043 loop 2044 ld E ((L II)) # Not found: Return old value of 'var' 2045 end 2046 end 2047 90 drop 2048 pop Z 2049 pop Y 2050 pop X 2051 ret 2052 2053 # (queue 'var 'any) -> any 2054 (code 'doQueue 2) 2055 push X 2056 push Y 2057 ld X E 2058 ld Y (E CDR) # Y on args 2059 ld E (Y) # Eval first 2060 eval 2061 call needVarEX # Need variable 2062 sym E # Symbol? 2063 if nz # Yes 2064 sym (E TAIL) # External symbol? 2065 if nz # Yes 2066 call dbTouchEX # Touch it 2067 end 2068 end 2069 link 2070 push E # <L I> 'var' 2071 link 2072 ld Y (Y CDR) # Next arg 2073 ld E (Y) 2074 eval # Eval next arg 2075 call consE_C # Build cell 2076 ld (C) E 2077 ld (C CDR) Nil 2078 ld X (L I) # Get 'var' 2079 ld Y (X) # Value 2080 atom Y # Atomic? 2081 if nz # Yes 2082 ld (X) C # Store first cell 2083 else 2084 do 2085 atom (Y CDR) # Find last cell 2086 while z 2087 ld Y (Y CDR) 2088 loop 2089 ld (Y CDR) C 2090 end 2091 drop 2092 pop Y 2093 pop X 2094 ret 2095 2096 # (fifo 'var ['any ..]) -> any 2097 (code 'doFifo 2) 2098 push X 2099 push Y 2100 ld X E 2101 ld Y (E CDR) # Y on args 2102 ld E (Y) # Eval first 2103 eval 2104 call needVarEX # Need variable 2105 sym E # Symbol? 2106 if nz # Yes 2107 sym (E TAIL) # External symbol? 2108 if nz # Yes 2109 call dbTouchEX # Touch it 2110 end 2111 end 2112 link 2113 push E # <L I> 'var' 2114 link 2115 ld Y (Y CDR) # More args? 2116 atom Y 2117 if z # Yes 2118 ld E (Y) # Eval 'any' 2119 eval 2120 call consE_A # Cons into new cell 2121 ld (A) E 2122 ld C (L I) # Get 'var' 2123 ld X (C) # Value in X 2124 atom X # List? 2125 if z # Yes 2126 ld (A CDR) (X CDR) # Concat to value 2127 ld (X CDR) A 2128 else 2129 ld (A CDR) A # Circular cell 2130 ld (C) X # Set new value 2131 end 2132 ld X A 2133 do 2134 ld Y (Y CDR) # More args? 2135 atom Y 2136 while z # Yes 2137 ld E (Y) # Eval next 'any' 2138 eval 2139 call consE_A # Cons into new cell 2140 ld (A) E 2141 ld (A CDR) (X CDR) # Concat to value 2142 ld (X CDR) A 2143 ld X A 2144 loop 2145 ld ((L I)) X # Set new value 2146 else 2147 ld C (L I) # Get 'var' 2148 ld X (C) # Value in X 2149 atom X # Any? 2150 if nz # No 2151 ld E Nil 2152 else 2153 cmp X (X CDR) # Single cell? 2154 if eq # Yes 2155 ld E (X) # Return CAR 2156 ld (C) Nil # Clear value 2157 else 2158 ld E ((X CDR)) # Return CADR 2159 ld (X CDR) ((X CDR) CDR) # Cut cell 2160 end 2161 end 2162 end 2163 drop 2164 pop Y 2165 pop X 2166 ret 2167 2168 # (idx 'var 'any 'flg) -> lst 2169 # (idx 'var 'any) -> lst 2170 # (idx 'var) -> lst 2171 (code 'doIdx 2) 2172 push X 2173 ld X E 2174 ld E ((E CDR)) # Eval first arg 2175 eval 2176 call needVarEX # Need variable 2177 ld X ((X CDR) CDR) # Second arg? 2178 atom X 2179 if nz # No 2180 ld X (E) # Get tree 2181 ld E Nil # Cons a list 2182 call consTreeXE_E 2183 else 2184 push Y 2185 link 2186 push E # <L II> 'var' 2187 ld E (X) 2188 eval+ # Eval second arg 2189 push E # <L I> 'any' 2190 link # Save it 2191 ld Y E # Keep in Y 2192 ld X (X CDR) # Third arg? 2193 atom X 2194 if nz # No 2195 ld X (L II) # Get 'var' 2196 call idxGetXY_E # Find 2197 else 2198 ld E (X) # Eval last arg 2199 eval 2200 ld X (L II) # Get 'var' 2201 cmp E Nil # Delete? 2202 if ne # No 2203 call idxPutXY_E # Insert 2204 else 2205 call idxDelXY_E # Delete 2206 end 2207 end 2208 drop 2209 pop Y 2210 end 2211 pop X 2212 ret 2213 2214 (code 'idxGetXY_E 0) 2215 ld X (X) # Get value of 'var' 2216 do 2217 atom X # More nodes? 2218 ld E Nil 2219 while z # Yes 2220 ld A Y # Get key 2221 ld E (X) # Compare with node value 2222 call compareAE_F # Found? 2223 ld E X 2224 while ne # No 2225 ld X (X CDR) 2226 ldc X (X) # Smaller 2227 ldnc X (X CDR) # Greater 2228 loop 2229 ret 2230 2231 (code 'idxPutXY_E 0) 2232 atom (X) # First insert? 2233 if nz # Yes 2234 call cons_A # Cons new node 2235 ld (A) Y # 'any' 2236 ld (A CDR) Nil 2237 ld (X) A # Set 'var' 2238 ld E Nil # return NIL 2239 else 2240 ld X (X) # Get value of 'var' 2241 do 2242 ld A Y # Get key 2243 ld E (X) # Compare with node value 2244 call compareAE_F # Equal? 2245 ld E X 2246 while ne # No 2247 ld A (X CDR) 2248 if ge # Greater 2249 atom A # Already has link? 2250 if nz # No 2251 call cons_A # Cons into a new node 2252 ld (A) Y # key 2253 ld (A CDR) Nil 2254 call consA_C # Cons a new link 2255 ld (C) Nil 2256 ld (C CDR) A 2257 ld (X CDR) C 2258 ld E Nil # Return NIL 2259 break T 2260 end 2261 ld X A 2262 atom (X CDR) # CDR of link? 2263 ldz X (X CDR) # Yes: Get CDR of link in X 2264 if nz # No 2265 call cons_A # Else cons into a new node 2266 ld (A) Y # key 2267 ld (A CDR) Nil 2268 ld (X CDR) A # Store in CDR of link 2269 ld E Nil # Return NIL 2270 break T 2271 end 2272 else # Smaller 2273 atom A # Already has link? 2274 if nz # No 2275 call cons_A # Cons into a new node 2276 ld (A) Y # key 2277 ld (A CDR) Nil 2278 call consA_C # Cons a new link 2279 ld (C) A 2280 ld (C CDR) Nil 2281 ld (X CDR) C 2282 ld E Nil # Return NIL 2283 break T 2284 end 2285 ld X A 2286 atom (X) # CAR of link? 2287 ldz X (X) # Yes: Get CAR of link in X 2288 if nz # No 2289 call cons_A # Else cons into a new node 2290 ld (A) Y # key 2291 ld (A CDR) Nil 2292 ld (X) A # Store in CAR of link 2293 ld E Nil # Return NIL 2294 break T 2295 end 2296 end 2297 loop 2298 end 2299 ret 2300 2301 (code 'idxDelXY_E 0) 2302 do 2303 atom (X) # Next node? 2304 ld E Nil 2305 while z # Yes 2306 ld A Y # Get key 2307 ld E ((X)) # Compare with node value 2308 call compareAE_F # Equal? 2309 if eq # Yes 2310 ld C (X) # Found subtree 2311 ld E C # Preset return value 2312 ld A (C CDR) # Get subtrees 2313 atom (A) # Left branch? 2314 if nz # No 2315 ld (X) (A CDR) # Use right branch 2316 ret 2317 end 2318 atom (A CDR) # Right branch? 2319 if nz # No 2320 ld (X) (A) # Use left branch 2321 ret 2322 end 2323 ld A (A CDR) # A on right branch 2324 ld X (A CDR) # X on sub-branches 2325 atom (X) # Left? 2326 if nz # No 2327 ld (C) (A) # Insert right sub-branch 2328 ld ((C CDR) CDR) (X CDR) 2329 ret 2330 end 2331 push E # Save return value 2332 ld X (X) # Left sub-branch 2333 do 2334 ld E (X CDR) # More left branches? 2335 atom (E) 2336 while z # Yes 2337 ld A X # Go down left 2338 ld X (E) 2339 loop 2340 ld (C) (X) # Insert left sub-branch 2341 ld ((A CDR)) (E CDR) 2342 pop E 2343 ret 2344 end 2345 ld E Nil 2346 ld X ((X) CDR) 2347 if ge # Node value is greater 2348 atom X # Link? 2349 break nz # No 2350 lea X (X CDR) # Go right 2351 else # Node value is smaller 2352 atom X # Link? 2353 break nz # No 2354 end 2355 loop 2356 ret 2357 2358 # (lup 'lst 'any) -> lst 2359 # (lup 'lst 'any 'any2) -> lst 2360 (code 'doLup 2) 2361 push X 2362 ld X (E CDR) # Args 2363 ld E (X) # Eval first 2364 eval 2365 atom E # List? 2366 if z # Yes 2367 link 2368 push E # <L V> 'lst' 2369 ld X (X CDR) # Eval second 2370 ld E (X) 2371 eval+ # 'any' 2372 ld X (X CDR) # Next arg? 2373 atom X 2374 if nz # No 2375 pop X # Get 'lst' in X 2376 pop L # Discard partial stack frame 2377 push Y 2378 ld Y E # Get 'any' in Y 2379 do 2380 ld E (X) # CAR of 'lst' 2381 cmp E TSym # Is it T? 2382 if eq # Yes 2383 ld X ((X CDR)) # Go to CADR 2384 else 2385 atom E # Atomic? 2386 if nz # Yes 2387 ld X ((X CDR) CDR) # Go to CDDR 2388 else 2389 ld A Y # Key 'any' 2390 ld E (E) # CAAR of 'lst' 2391 call compareAE_F # Equal? 2392 if eq # Yes 2393 ld E (X) # Return CAR of 'lst' 2394 pop Y 2395 pop X 2396 ret 2397 end 2398 ld X (X CDR) 2399 ldc X (X) # Smaller 2400 ldnc X (X CDR) # Greater 2401 end 2402 end 2403 atom X # Reached leaf? 2404 until nz # Yes 2405 ld E Nil # Return NIL 2406 pop Y 2407 else 2408 push E # <L IV> "from" key 2409 ld E (X) # Eval next 2410 eval+ 2411 push E # <L III> "to" key 2412 push Nil # <L II> TOS 2413 push Nil # <L I> Result 2414 link 2415 ld X (L V) # Get 'lst' in X 2416 do 2417 do 2418 ld A (X CDR) 2419 atom (A CDR) # Right subtree? 2420 while z # Yes 2421 ld E (X) # CAR of 'lst' 2422 cmp E TSym # Is it T? 2423 while ne # No 2424 atom E # Atomic? 2425 jnz 10 # Yes 2426 ld A (L III) # "to" key 2427 ld E (E) # CAAR of 'lst' 2428 call compareAE_F # Greater or equal? 2429 while ge # Yes 2430 10 ld C X # Go right 2431 ld A (X CDR) 2432 ld X (A CDR) # Invert tree 2433 ld (A CDR) (L II) # TOS 2434 ld (L II) C 2435 loop 2436 ld (L V) X # Save tree 2437 do 2438 ld E (X) # CAR of 'lst' 2439 atom E # Atomic? 2440 if z # No 2441 ld A (L IV) # "from" key 2442 ld E (E) # CAAR of 'lst' 2443 call compareAE_F # Less or equal? 2444 if le # Yes 2445 ld A (L III) # "to" key 2446 ld E ((X)) # CAAR of 'lst' 2447 call compareAE_F # Greater or equal? 2448 if ge # Yes 2449 call cons_A # Cons value 2450 ld (A) (X) 2451 ld (A CDR) (L I) # Into result 2452 ld (L I) A 2453 end 2454 ld A (X CDR) # Left subtree? 2455 atom (A) 2456 if z # Yes 2457 ld C X # Go left 2458 ld X (A) # Invert tree 2459 ld (A) (L II) # TOS 2460 or C SYM # First visit 2461 ld (L II) C 2462 ld (L V) X # Save tree 2463 break T 2464 end 2465 end 2466 end 2467 do 2468 ld A (L II) # TOS 2469 cmp A Nil # Empty? 2470 if eq # Yes 2471 ld E (L I) # Return result 2472 drop 2473 pop X 2474 ret 2475 end 2476 sym A # Second visit? 2477 if z # Yes 2478 ld C (A CDR) # Nodes 2479 ld (L II) (C CDR) # TOS on up link 2480 ld (C CDR) X 2481 ld X A 2482 ld (L V) X # Save tree 2483 break T 2484 end 2485 off A SYM # Set second visit 2486 ld C (A CDR) # Nodes 2487 ld (L II) (C) 2488 ld (C) X 2489 ld X A 2490 ld (L V) X # Save tree 2491 loop 2492 loop 2493 loop 2494 end 2495 end 2496 pop X 2497 ret 2498 2499 ### Property access ### 2500 (code 'putACE 0) 2501 push X 2502 ld X (A TAIL) # Properties 2503 num X # Any? 2504 if z # Yes 2505 off X SYM # Clear 'extern' tag 2506 atom (X) # First property atomic? 2507 if nz # Yes 2508 cmp C (X) # Found flag? 2509 if eq # Yes 2510 cmp E Nil # Value NIL? 2511 if eq # Yes 2512 10 ld X (X CDR) # Remove property 2513 sym (A TAIL) # Extern? 2514 if nz # Yes 2515 or X SYM # Set 'extern' tag 2516 end 2517 ld (A TAIL) X 2518 20 pop X 2519 ret 2520 end 2521 cmp E TSym # Value T? 2522 jeq 20 # No change 2523 push C 2524 call consE_C # New property cell 2525 ld (C) E 2526 pop (C CDR) 2527 ld (X) C 2528 pop X 2529 ret 2530 end 2531 else 2532 cmp C ((X) CDR) # Found property? 2533 if eq # Yes 2534 cmp E Nil # Value NIL? 2535 jeq 10 # Yes 2536 cmp E TSym # Value T? 2537 if ne # No 2538 ld ((X)) E # Set new value 2539 else 2540 ld (X) C # Change to flag 2541 end 2542 pop X 2543 ret 2544 end 2545 end 2546 push Y 2547 do 2548 ld Y (X CDR) # Next property 2549 atom Y # Any? 2550 while z # Yes 2551 atom (Y) # Atomic? 2552 if nz # Yes 2553 cmp C (Y) # Found flag? 2554 if eq # Yes 2555 cmp E Nil # Value NIL? 2556 if eq # Yes 2557 ld (X CDR) (Y CDR) # Remove cell 2558 else 2559 cmp E TSym # Value T? 2560 if ne # No 2561 push C 2562 call consE_C # New property cell 2563 ld (C) E 2564 pop (C CDR) 2565 ld (Y) C # Store 2566 end 2567 ld (X CDR) (Y CDR) # Unlink cell 2568 ld X (A TAIL) # Get tail 2569 sym X # Extern? 2570 if z # No 2571 ld (Y CDR) X # Insert cell in front 2572 else 2573 off X SYM # Clear 'extern' tag 2574 ld (Y CDR) X # Insert cell in front 2575 or Y SYM # Set 'extern' tag 2576 end 2577 ld (A TAIL) Y 2578 pop Y 2579 pop X 2580 ret 2581 end 2582 end 2583 else 2584 cmp C ((Y) CDR) # Found property? 2585 if eq # Yes 2586 cmp E Nil # Value NIL? 2587 if eq # Yes 2588 ld (X CDR) (Y CDR) # Remove cell 2589 else 2590 cmp E TSym # Value T? 2591 if ne # No 2592 ld ((Y)) E # Set new value 2593 else 2594 ld (Y) C # Change to flag 2595 end 2596 ld (X CDR) (Y CDR) # Unlink cell 2597 ld X (A TAIL) # Get tail 2598 sym X # Extern? 2599 if z # No 2600 ld (Y CDR) X # Insert cell in front 2601 else 2602 off X SYM # Clear 'extern' tag 2603 ld (Y CDR) X # Insert cell in front 2604 or Y SYM # Set 'extern' tag 2605 end 2606 ld (A TAIL) Y 2607 pop Y 2608 pop X 2609 ret 2610 end 2611 end 2612 end 2613 ld X Y 2614 loop 2615 pop Y 2616 ld X (A TAIL) # Get properties again 2617 end 2618 cmp E Nil # Value Non-NIL? 2619 if ne # Yes 2620 cmp E TSym # Flag? 2621 if ne # No 2622 push C 2623 call consE_C # New property cell 2624 ld (C) E 2625 pop (C CDR) 2626 end 2627 push C 2628 call consC_C # New first property 2629 pop (C) 2630 sym X # Extern? 2631 if z # No 2632 ld (C CDR) X 2633 else 2634 off X SYM # Clear 'extern' tag 2635 ld (C CDR) X 2636 or C SYM # Set 'extern' tag 2637 end 2638 ld (A TAIL) C # Set new tail 2639 end 2640 pop X 2641 ret 2642 2643 (code 'getnECX_E 0) 2644 num E # Need symbol or pair 2645 jnz argErrEX 2646 atom E # List? 2647 if z # Yes 2648 num C # Numeric key? 2649 if nz # Yes 2650 shr C 4 # Positive? 2651 if nc # Yes 2652 jz retNil # Return NIL if zero 2653 do 2654 dec C # nth 2655 jz retE_E 2656 ld E (E CDR) 2657 loop 2658 end 2659 # Key is negative 2660 do 2661 ld E (E CDR) 2662 dec C # nth 2663 until z 2664 ret 2665 end 2666 do # asoq 2667 atom (E) # CAR atomic? 2668 if z # No 2669 cmp C ((E)) # Found? 2670 break eq # Yes 2671 end 2672 ld E (E CDR) # Next 2673 atom E # Done? 2674 jnz retNil # Return NIL 2675 loop 2676 ld E ((E) CDR) # Return CDAR 2677 ret 2678 end 2679 # E is symbolic 2680 sym (E TAIL) # External symbol? 2681 if nz # Yes 2682 call dbFetchEX # Fetch it 2683 end 2684 (code 'getEC_E 0) 2685 cmp C ZERO # Key is zero? 2686 jeq retE_E # Get value 2687 ld A (E TAIL) # Get tail 2688 num A # No properties? 2689 jnz retNil # Return NIL 2690 off A SYM # Clear 'extern' tag 2691 atom (A) # First property atomic? 2692 if nz # Yes 2693 cmp C (A) # Found flag? 2694 jeq retT # Return T 2695 else 2696 cmp C ((A) CDR) # Found property? 2697 if eq # Yes 2698 ld E ((A)) # Return value 2699 ret 2700 end 2701 end 2702 push X 2703 do 2704 ld X (A CDR) # Next property 2705 atom X # Any? 2706 while z # Yes 2707 atom (X) # Atomic? 2708 if nz # Yes 2709 cmp C (X) # Found flag? 2710 if eq # Yes 2711 ld (A CDR) (X CDR) # Unlink cell 2712 ld A (E TAIL) # Get tail 2713 sym A # Extern? 2714 if z # No 2715 ld (X CDR) A # Insert cell in front 2716 else 2717 off A SYM # Clear 'extern' tag 2718 ld (X CDR) A # Insert cell in front 2719 or X SYM # Set 'extern' tag 2720 end 2721 ld (E TAIL) X 2722 ld E TSym # Return T 2723 pop X 2724 ret 2725 end 2726 else 2727 cmp C ((X) CDR) # Found property? 2728 if eq # Yes 2729 ld (A CDR) (X CDR) # Unlink cell 2730 ld A (E TAIL) # Get tail 2731 sym A # Extern? 2732 if z # No 2733 ld (X CDR) A # Insert cell in front 2734 ld (E TAIL) X 2735 ld E ((X)) # Return value 2736 else 2737 off A SYM # Clear 'extern' tag 2738 ld (X CDR) A # Insert cell in front 2739 ld A ((X)) # Return value 2740 or X SYM # Set 'extern' tag 2741 ld (E TAIL) X 2742 ld E A 2743 end 2744 pop X 2745 ret 2746 end 2747 end 2748 ld A X 2749 loop 2750 ld E Nil # Return NIL 2751 pop X 2752 ret 2753 2754 (code 'propEC_E 0) 2755 push X 2756 ld A (E TAIL) # Get tail 2757 num A # Properties? 2758 if z # Yes 2759 off A SYM # Clear 'extern' tag 2760 atom (A) # First property atomic? 2761 if nz # Yes 2762 cmp C (A) # Found flag? 2763 if eq # Yes 2764 ld E C # Return key 2765 pop X 2766 ret 2767 end 2768 else 2769 cmp C ((A) CDR) # Found property? 2770 if eq # Yes 2771 ld E (A) # Return property 2772 pop X 2773 ret 2774 end 2775 end 2776 do 2777 ld X (A CDR) # Next property 2778 atom X # Any? 2779 while z # Yes 2780 atom (X) # Atomic? 2781 if nz # Yes 2782 cmp C (X) # Found flag? 2783 if eq # Yes 2784 ld (A CDR) (X CDR) # Unlink cell 2785 ld A (E TAIL) # Get tail 2786 sym A # Extern? 2787 if z # No 2788 ld (X CDR) A # Insert cell in front 2789 else 2790 off A SYM # Clear 'extern' tag 2791 ld (X CDR) A # Insert cell in front 2792 or X SYM # Set 'extern' tag 2793 end 2794 ld (E TAIL) X 2795 ld E C # Return key 2796 pop X 2797 ret 2798 end 2799 else 2800 cmp C ((X) CDR) # Found property? 2801 if eq # Yes 2802 ld (A CDR) (X CDR) # Unlink cell 2803 ld A (E TAIL) # Get tail 2804 sym A # Extern? 2805 if z # No 2806 ld (X CDR) A # Insert cell in front 2807 ld (E TAIL) X 2808 ld E (X) # Return property 2809 else 2810 off A SYM # Clear 'extern' tag 2811 ld (X CDR) A # Insert cell in front 2812 ld A (X) # Return property 2813 or X SYM # Set 'extern' tag 2814 ld (E TAIL) X 2815 ld E A 2816 end 2817 pop X 2818 ret 2819 end 2820 end 2821 ld A X 2822 loop 2823 end 2824 call cons_A # New property cell 2825 ld (A) Nil # (NIL . key) 2826 ld (A CDR) C 2827 call consA_C # New first property 2828 ld (C) A 2829 ld X (E TAIL) # Get tail 2830 sym X # Extern? 2831 if z # No 2832 ld (C CDR) X 2833 else 2834 off X SYM # Clear 'extern' tag 2835 ld (C CDR) X 2836 or C SYM # Set 'extern' tag 2837 end 2838 ld (E TAIL) C # Set new tail 2839 ld E A # Return first (new) cell 2840 pop X 2841 ret 2842 2843 # (put 'sym1|lst ['sym2|cnt ..] 'sym|0 'any) -> any 2844 (code 'doPut 2) 2845 push X 2846 push Y 2847 ld X E 2848 ld Y (E CDR) # Y on args 2849 ld E (Y) # Eval first 2850 eval 2851 link 2852 push E # <L II> 'sym1|lst' item 2853 ld Y (Y CDR) 2854 ld E (Y) # Eval second 2855 eval+ 2856 push E # <L I> 'sym2|cnt' key 2857 link 2858 do 2859 ld Y (Y CDR) # Args 2860 atom (Y CDR) # More than one? 2861 while z # Yes 2862 ld C E # Key 2863 ld E (L II) # Current item 2864 call getnECX_E 2865 ld (L II) E # Store item 2866 ld E (Y) 2867 eval # Eval next arg 2868 ld (L I) E # Save it 2869 loop 2870 ld E (L II) # Get item 2871 num E # Need symbol 2872 jnz symErrEX 2873 sym E 2874 jz symErrEX 2875 ld E (Y) # Eval 'any' 2876 eval 2877 ld A (L II) # Get symbol 2878 ld C (L I) # Get key 2879 sym (A TAIL) # External symbol? 2880 if nz # Yes 2881 cmp C Nil # Volatile property? 2882 if ne # No 2883 push E # Save 'any' 2884 ld E A # Get symbol 2885 call dbTouchEX # Touch it 2886 ld A E 2887 pop E 2888 end 2889 end 2890 cmp C ZERO # Key is zero? 2891 if eq # Yes 2892 call checkVarAX # Check variable 2893 ld (A) E # Set value 2894 else 2895 call putACE # Put value or propery 2896 end 2897 drop 2898 pop Y 2899 pop X 2900 ret 2901 2902 # (get 'sym1|lst ['sym2|cnt ..]) -> any 2903 (code 'doGet 2) 2904 push X 2905 push Y 2906 ld X E 2907 ld Y (E CDR) # Y on args 2908 ld E (Y) # Eval first 2909 eval 2910 ld Y (Y CDR) # Next arg? 2911 atom Y 2912 if z # Yes 2913 link 2914 push E # <L I> 'sym|lst' item 2915 link 2916 do 2917 ld E (Y) 2918 eval # Eval next arg 2919 ld C E # Key 2920 ld E (L I) # Current item 2921 call getnECX_E 2922 ld Y (Y CDR) # More args? 2923 atom Y 2924 while z # Yes 2925 ld (L I) E # Save item 2926 loop 2927 drop 2928 end 2929 pop Y 2930 pop X 2931 ret 2932 2933 # (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> var 2934 (code 'doProp 2) 2935 push X 2936 push Y 2937 ld X E 2938 ld Y (E CDR) # Y on args 2939 ld E (Y) # Eval first 2940 eval 2941 link 2942 push E # <L II> 'sym|lst' item 2943 ld Y (Y CDR) # Next arg 2944 ld E (Y) 2945 eval+ # Eval next arg 2946 push E # <L I> 'sym2|cnt' key 2947 link 2948 do 2949 ld Y (Y CDR) # More args? 2950 atom Y 2951 while z # Yes 2952 ld C E # Key 2953 ld E (L II) # Current item 2954 call getnECX_E 2955 ld (L II) E # Store item 2956 ld E (Y) 2957 eval # Eval next arg 2958 ld (L I) E # Save it 2959 loop 2960 ld E (L II) # Get item 2961 num E # Need symbol 2962 jnz symErrEX 2963 sym E 2964 jz symErrEX 2965 cmp E Nil # Can't be NIL 2966 jeq protErrEX 2967 sym (E TAIL) # External symbol? 2968 if nz # Yes 2969 call dbTouchEX # Touch it 2970 end 2971 ld C (L I) # Get key 2972 call propEC_E 2973 drop 2974 pop Y 2975 pop X 2976 ret 2977 2978 # (; 'sym1|lst [sym2|cnt ..]) -> any 2979 (code 'doSemicol 2) 2980 push X 2981 push Y 2982 ld X E 2983 ld Y (E CDR) # Y on args 2984 ld E (Y) # Eval first 2985 eval 2986 ld Y (Y CDR) # Next arg? 2987 atom Y 2988 if z # Yes 2989 link 2990 push E # <L I> 'sym|lst' item 2991 link 2992 do 2993 ld C (Y) # Key 2994 ld E (L I) # Current item 2995 call getnECX_E 2996 ld Y (Y CDR) # More args? 2997 atom Y 2998 while z # Yes 2999 ld (L I) E # Save item 3000 loop 3001 drop 3002 end 3003 pop Y 3004 pop X 3005 ret 3006 3007 # (=: sym|0 [sym1|cnt .. sym2|0] 'any) -> any 3008 (code 'doSetCol 2) 3009 push X 3010 push Y 3011 ld X E 3012 ld Y (E CDR) # Y on args 3013 ld E (This) # Get value of This 3014 sym (E TAIL) # External symbol? 3015 if nz # Yes 3016 call dbFetchEX # Fetch it 3017 end 3018 ld C (Y) # sym1|cnt 3019 ld Y (Y CDR) # Args 3020 atom (Y CDR) # More than one? 3021 if z # Yes 3022 call getEC_E 3023 do 3024 ld C (Y) # sym2|cnt 3025 ld Y (Y CDR) # Args 3026 atom (Y CDR) # More than one? 3027 while z # Yes 3028 call getnECX_E 3029 loop 3030 end 3031 num E # Need symbol 3032 jnz symErrEX 3033 sym E 3034 jz symErrEX 3035 sym (E TAIL) # External symbol? 3036 if nz # Yes 3037 cmp C Nil # Volatile property? 3038 if ne # No 3039 call dbTouchEX # Touch it 3040 end 3041 end 3042 push C # Save key 3043 push E # Save symbol 3044 ld E (Y) # Eval 'any' 3045 eval 3046 pop A # Retrieve symbol 3047 pop C # and key 3048 cmp C ZERO # Key is zero? 3049 if eq # Yes 3050 call checkVarAX # Check variable 3051 ld (A) E # Set value 3052 else 3053 call putACE # Put value or propery 3054 end 3055 pop Y 3056 pop X 3057 ret 3058 3059 # (: sym|0 [sym1|cnt ..]) -> any 3060 (code 'doCol 2) 3061 push X 3062 push Y 3063 ld X E 3064 ld Y (E CDR) # Y on args 3065 ld E (This) # Get value of This 3066 sym (E TAIL) # External symbol? 3067 if nz # Yes 3068 call dbFetchEX # Fetch it 3069 end 3070 ld C (Y) # Next key 3071 call getEC_E 3072 do 3073 ld Y (Y CDR) # More args? 3074 atom Y 3075 while z # Yes 3076 ld C (Y) # Next key 3077 call getnECX_E 3078 loop 3079 pop Y 3080 pop X 3081 ret 3082 3083 # (:: sym|0 [sym1|cnt .. sym2]) -> var 3084 (code 'doPropCol 2) 3085 push X 3086 push Y 3087 ld X E 3088 ld Y (E CDR) # Y on args 3089 ld E (This) # Get value of This 3090 sym (E TAIL) # External symbol? 3091 if nz # Yes 3092 call dbFetchEX # Fetch it 3093 end 3094 ld C (Y) # Next key 3095 atom (Y CDR) # More than one arg? 3096 if z # Yes 3097 call getEC_E 3098 do 3099 ld Y (Y CDR) 3100 ld C (Y) # Next key 3101 atom (Y CDR) # More than one arg? 3102 while z # Yes 3103 call getnECX_E 3104 loop 3105 end 3106 num E # Need symbol 3107 jnz symErrEX 3108 sym E 3109 jz symErrEX 3110 cmp E Nil # Can't be NIL 3111 jeq protErrEX 3112 sym (E TAIL) # External symbol? 3113 if nz # Yes 3114 call dbTouchEX # Touch it 3115 end 3116 call propEC_E 3117 pop Y 3118 pop X 3119 ret 3120 3121 # (putl 'sym1|lst1 ['sym2|cnt ..] 'lst) -> lst 3122 (code 'doPutl 2) 3123 push X 3124 push Y 3125 ld X E 3126 ld Y (E CDR) # Y on args 3127 ld E (Y) # Eval first 3128 eval 3129 link 3130 push E # <L II> 'sym|lst' item 3131 ld Y (Y CDR) # Next arg 3132 ld E (Y) 3133 eval+ # Eval next arg 3134 push E # <L I> 'sym2|cnt' key 3135 link 3136 do 3137 ld Y (Y CDR) # More args? 3138 atom Y 3139 while z # Yes 3140 ld C E # Key 3141 ld E (L II) # Current item 3142 call getnECX_E 3143 ld (L II) E # Store item 3144 ld E (Y) 3145 eval # Eval next arg 3146 ld (L I) E # Save it 3147 loop 3148 ld E (L II) # Get item 3149 num E # Need symbol 3150 jnz symErrEX 3151 sym E 3152 jz symErrEX 3153 cmp E Nil # Can't be NIL 3154 jeq protErrEX 3155 sym (E TAIL) # External symbol? 3156 if nz # Yes 3157 call dbTouchEX # Touch it 3158 end 3159 ld X (E TAIL) # Skip old properties 3160 off X SYM # Clear 'extern' tag 3161 do 3162 num X # More properties? 3163 while z # Yes 3164 ld X (X CDR) 3165 loop 3166 ld Y (L I) # New property list 3167 do 3168 atom Y # Any? 3169 while z # Yes 3170 ld C (Y) 3171 atom C # Flag? 3172 if nz # Yes 3173 ld A X 3174 call consA_X # New property cell 3175 ld (X) C 3176 ld (X CDR) A 3177 else 3178 cmp (C) Nil # Value Nil? 3179 if ne # No 3180 cmp (C) TSym # Flag? 3181 if eq # Yes 3182 ld C (C CDR) # Get key 3183 end 3184 ld A X 3185 call consA_X # New property cell 3186 ld (X) C 3187 ld (X CDR) A 3188 end 3189 end 3190 ld Y (Y CDR) 3191 loop 3192 sym (E TAIL) # Extern? 3193 if nz # Yes 3194 or X SYM # Set 'extern' tag 3195 end 3196 ld (E TAIL) X 3197 ld E (L I) # Return new property list 3198 drop 3199 pop Y 3200 pop X 3201 ret 3202 3203 # (getl 'sym1|lst1 ['sym2|cnt ..]) -> lst 3204 (code 'doGetl 2) 3205 push X 3206 push Y 3207 ld X E 3208 ld Y (E CDR) # Y on args 3209 ld E (Y) # Eval first 3210 eval 3211 link 3212 push E # <L I> 'sym|lst' item 3213 link 3214 do 3215 ld Y (Y CDR) # More args? 3216 atom Y 3217 while z 3218 ld E (Y) 3219 eval # Eval next arg 3220 ld C E # Key 3221 ld E (L I) # Current item 3222 call getnECX_E 3223 ld (L I) E # Save item 3224 loop 3225 num E # Need symbol 3226 jnz symErrEX 3227 sym E 3228 jz symErrEX 3229 sym (E TAIL) # External symbol? 3230 if nz # Yes 3231 call dbFetchEX # Fetch it 3232 end 3233 ld X (E TAIL) # Get tail 3234 num X # No properties? 3235 if nz # Yes 3236 ld E Nil 3237 else 3238 off X SYM # Clear 'extern' tag 3239 call cons_C # Copy first cell 3240 ld (C) (X) 3241 ld (C CDR) Nil 3242 tuck C # Save it 3243 link 3244 do 3245 ld X (X CDR) # More properties? 3246 atom X 3247 while z # Yes 3248 call cons_A # Copy next cell 3249 ld (A) (X) 3250 ld (A CDR) Nil 3251 ld (C CDR) A # Append 3252 ld C A 3253 loop 3254 ld E (L I) # Get result 3255 end 3256 drop 3257 pop Y 3258 pop X 3259 ret 3260 3261 # (wipe 'sym|lst) -> sym 3262 (code 'doWipe 2) 3263 ld E ((E CDR)) # Get arg 3264 eval # Eval it 3265 cmp E Nil # NIL? 3266 if ne # No 3267 atom E # List? 3268 if nz # No 3269 call wipeE # Wipe it 3270 else 3271 push E # Save 3272 ld C E # Get list 3273 do 3274 ld E (C) # Next symbol 3275 call wipeE # Wipe it 3276 ld C (C CDR) 3277 atom C # More? 3278 until nz # No 3279 pop E 3280 end 3281 end 3282 ret 3283 3284 (code 'wipeE 0) 3285 ld A (E TAIL) # Get tail 3286 sym A # Extern? 3287 if z # No 3288 call nameA_A # Get name 3289 ld (E) Nil # Clear value 3290 ld (E TAIL) A # And properties 3291 ret 3292 end 3293 call nameA_A # Get name 3294 shl A 1 # Dirty? 3295 if nc # No 3296 shl A 1 # Loaded? 3297 if c # Yes 3298 ror A 2 # Set "not loaded" 3299 ld (E) Nil # Clear value 3300 or A SYM # Set 'extern' tag 3301 ld (E TAIL) A 3302 end 3303 end 3304 ret 3305 3306 # (meta 'obj|typ 'sym ['sym2|cnt ..]) -> any 3307 (code 'doMeta 2) 3308 push X 3309 push Y 3310 ld X E 3311 ld Y (E CDR) # Y on args 3312 ld E (Y) # Eval first 3313 eval 3314 link 3315 push E # <L I> 'obj|typ' 3316 link 3317 num E # Need symbol or pair 3318 jnz argErrEX 3319 sym E # Symbol? 3320 if nz # Yes 3321 sym (E TAIL) # External symbol? 3322 if nz # Yes 3323 call dbFetchEX # Fetch it 3324 end 3325 ld (L I) (E) # Get value 3326 end 3327 ld Y (Y CDR) # Next arg 3328 ld E (Y) 3329 eval # Eval next arg 3330 ld C E # Key 3331 ld X (L I) # 'obj|typ' 3332 call metaCX_E # Fetch 3333 do 3334 ld Y (Y CDR) # More args? 3335 atom Y 3336 while z # Yes 3337 ld (L I) E # Save item 3338 ld E (Y) 3339 eval # Eval next arg 3340 ld C E # Key 3341 ld E (L I) # Current item 3342 call getnECX_E 3343 loop 3344 drop 3345 pop Y 3346 pop X 3347 ret 3348 3349 (code 'metaCX_E 0) 3350 do 3351 atom X # List? 3352 jnz retNil # No 3353 ld E (X) # Next item 3354 num E # Symbol? 3355 if z 3356 sym E 3357 if nz # Yes 3358 call getEC_E # Propery 3359 cmp E Nil # found? 3360 jne Ret # No 3361 push X 3362 ld X ((X)) # Try in superclass(es) 3363 cmp S (StkLimit) # Stack check 3364 jlt stkErr 3365 call metaCX_E 3366 pop X 3367 cmp E Nil # found? 3368 jne Ret # No 3369 end 3370 end 3371 ld X (X CDR) 3372 loop 3373 3374 ### Case mappings from the GNU Kaffe Project ### 3375 (code 'caseDataA_AC 0) 3376 ld C A # Keep character in C 3377 shr A 4 # Make index 3378 off A 1 3379 ld2 (A CaseBlocks) # Get blocks entry 3380 add A C # Add character 3381 and A (hex "FFFF") # Limit to 16 bits 3382 shl A 1 # Adjust index 3383 ld2 (A CaseData) # Get case data 3384 ret 3385 3386 # (low? 'any) -> sym | NIL 3387 (code 'doLowQ 2) 3388 ld E ((E CDR)) # Get arg 3389 eval # Eval it 3390 num E # Number? 3391 jnz retNil # Yes 3392 sym E # Symbol? 3393 jz retNil # No 3394 call firstCharE_A # Get first character 3395 call caseDataA_AC # Get case info 3396 and B (hex "1F") # Character type 3397 cmp B CHAR_LOWERCASE # Lower case? 3398 ldnz E Nil # No 3399 ret 3400 3401 # (upp? 'any) -> sym | NIL 3402 (code 'doUppQ 2) 3403 ld E ((E CDR)) # Get arg 3404 eval # Eval it 3405 num E # Number? 3406 jnz retNil # Yes 3407 sym E # Symbol? 3408 jz retNil # No 3409 call firstCharE_A # Get first character 3410 call caseDataA_AC # Get case info 3411 and B (hex "1F") # Character type 3412 cmp B CHAR_UPPERCASE # Lower case? 3413 ldnz E Nil # No 3414 ret 3415 3416 # (lowc 'any) -> any 3417 (code 'doLowc 2) 3418 push X 3419 ld E ((E CDR)) # Get arg 3420 eval # Eval it 3421 num E # Number? 3422 if z # No 3423 sym E # Symbol? 3424 if nz # Yes 3425 cmp E Nil # NIL? 3426 if ne # No 3427 sym (E TAIL) # External symbol? 3428 if z # No 3429 ld E (E TAIL) 3430 call nameE_E # Get name 3431 link 3432 push E # <L II> Name 3433 push ZERO # <L I> Result 3434 ld X S 3435 link 3436 push 4 # <S I> Build name 3437 push X # <S> Pack status 3438 ld X (L II) # Get name 3439 ld C 0 # Index 3440 do 3441 call symCharCX_FACX # Next char? 3442 while nz 3443 ld E C # Save C 3444 call caseDataA_AC # Get case info 3445 and A (hex "FFFF") 3446 shr A 6 # Make index 3447 off A 1 3448 ld2 (A CaseLower) # Get lower case entry 3449 add A C # plus character 3450 and A (hex "FFFF") 3451 ld C (S I) # Swap status 3452 xchg X (S) 3453 call charSymACX_CX # Pack char 3454 xchg X (S) # Swap status 3455 ld (S I) C 3456 ld C E # Restore C 3457 loop 3458 ld X (L I) # Get result 3459 call consSymX_E # Make transient symbol 3460 drop 3461 end 3462 end 3463 end 3464 end 3465 pop X 3466 ret 3467 3468 # (uppc 'any) -> any 3469 (code 'doUppc 2) 3470 push X 3471 ld E ((E CDR)) # Get arg 3472 eval # Eval it 3473 num E # Number? 3474 if z # No 3475 sym E # Symbol? 3476 if nz # Yes 3477 cmp E Nil # NIL? 3478 if ne # No 3479 sym (E TAIL) # External symbol? 3480 if z # No 3481 ld E (E TAIL) 3482 call nameE_E # Get name 3483 link 3484 push E # <L II> Name 3485 push ZERO # <L I> Result 3486 ld X S 3487 link 3488 push 4 # <S I> Build name 3489 push X # <S> Pack status 3490 ld X (L II) # Get name 3491 ld C 0 # Index 3492 do 3493 call symCharCX_FACX # Next char? 3494 while nz 3495 ld E C # Save C 3496 call caseDataA_AC # Get case info 3497 and A (hex "FFFF") 3498 shr A 6 # Make index 3499 off A 1 3500 ld2 (A CaseUpper) # Get upper case entry 3501 add A C # plus character 3502 and A (hex "FFFF") 3503 ld C (S I) # Swap status 3504 xchg X (S) 3505 call charSymACX_CX # Pack char 3506 xchg X (S) # Swap status 3507 ld (S I) C 3508 ld C E # Restore C 3509 loop 3510 ld X (L I) # Get result 3511 call consSymX_E # Make transient symbol 3512 drop 3513 end 3514 end 3515 end 3516 end 3517 pop X 3518 ret 3519 3520 # (fold 'any ['cnt]) -> sym 3521 (code 'doFold 2) 3522 push X 3523 push Y 3524 ld X E 3525 ld Y (E CDR) # Y on args 3526 ld E (Y) # Eval first 3527 eval 3528 num E # Number? 3529 if z # No 3530 sym E # Symbol? 3531 if nz # Yes 3532 cmp E Nil # NIL? 3533 if ne 3534 sym (E TAIL) # External symbol? 3535 if z # No 3536 ld E (E TAIL) 3537 call nameE_E # Get name 3538 link 3539 push E # <L II> Name 3540 push ZERO # <L I> Result 3541 link 3542 ld Y (Y CDR) # Next arg? 3543 atom Y 3544 if nz # No 3545 push 0 # <S II> Default 'cnt' zero 3546 else 3547 call evCntXY_FE # Eval 'cnt' 3548 push E # <S II> 'cnt' 3549 end 3550 push 4 # <S I> Build name 3551 lea X (L I) 3552 push X # <S> Pack status 3553 ld X (L II) # Get name 3554 ld C 0 # Index 3555 do 3556 call symCharCX_FACX # Next char? 3557 while nz 3558 ld E C # Save C 3559 call isLetterOrDigitA_F # Letter or digit? 3560 if nz # Yes 3561 call caseDataA_AC # Get case info 3562 and A (hex "FFFF") 3563 shr A 6 # Make index 3564 off A 1 3565 ld2 (A CaseLower) # Get lower case entry 3566 add A C # plus character 3567 and A (hex "FFFF") 3568 ld C (S I) # Swap status 3569 xchg X (S) 3570 call charSymACX_CX # Pack char 3571 xchg X (S) # Swap status 3572 ld (S I) C 3573 dec (S II) # Decrement 'cnt' 3574 break z 3575 end 3576 ld C E # Restore C 3577 loop 3578 ld X (L I) # Get result 3579 call consSymX_E # Make transient symbol 3580 drop 3581 end 3582 end 3583 end 3584 end 3585 pop Y 3586 pop X 3587 ret 3588 3589 (code 'isLetterOrDigitA_F 0) # C 3590 push A 3591 call caseDataA_AC # Get case info 3592 and B (hex "1F") # Character type 3593 ld C 1 3594 zxt 3595 shl C A 3596 test C (| CHAR_DIGIT CHAR_LETTER) 3597 pop A 3598 ret 3599 3600 # vi:et:ts=3:sw=3