io.l (133267B)
1 # 10jul13abu 2 # (c) Software Lab. Alexander Burger 3 4 # Close file descriptor 5 (code 'closeAX) 6 cc close(A) 7 nul4 # OK? 8 jz Ret # Yes 9 ld E A # Get file descriptor 10 shl E 4 # Make short number 11 or E CNT 12 jmp closeErrEX 13 14 # Lock/unlock file 15 (code 'unLockFileAC) 16 st2 (Flock L_TYPE) # 'l_type' 17 ld (Flock L_START) 0 # Start position ('l_whence' is SEEK_SET) 18 shr A 16 # Get length 19 ld (Flock L_LEN) A # Length 20 cc fcntl(C F_SETLK Flock) # Try to unlock 21 ret 22 23 (code 'wrLockFileC) 24 ld A F_WRLCK # Write lock, length 0 25 jmp lockFileAC 26 (code 'rdLockFileC) 27 ld A F_RDLCK # Read lock, length 0 28 (code 'lockFileAC) 29 st2 (Flock L_TYPE) # 'l_type' 30 ld (Flock L_START) 0 # Start position ('l_whence' is SEEK_SET) 31 shr A 16 # Get length 32 ld (Flock L_LEN) A # Length 33 do 34 cc fcntl(C F_SETLKW Flock) # Try to lock 35 nul4 # OK? 36 jns Ret # Yes 37 call errno_A 38 cmp A EINTR # Interrupted? 39 jne lockErr # No 40 loop 41 42 # Set the close-on-exec flag 43 (code 'closeOnExecAX) 44 cc fcntl(A F_SETFD FD_CLOEXEC) 45 nul4 # OK? 46 jns Ret # Yes 47 ld Y SetFD 48 jmp errnoEXY 49 50 # Set file descriptor to non-blocking / blocking 51 (code 'nonblockingA_A) 52 push C 53 ld C A # Keep fd 54 cc fcntl(C F_GETFL 0) # Get file status flags 55 push A # Save flags 56 or A O_NONBLOCK 57 cc fcntl(C F_SETFL A) # Set file status flags 58 pop A # Return old flags 59 pop C 60 ret 61 62 # Initialize input file 63 (code 'initInFileA_A) # E 64 ld C 0 # No name 65 : initInFileAC_A 66 xchg A C 67 : initInFileCA_A 68 push A # Save 'name' 69 push C # and 'fd' 70 shl C 3 # Vector index 71 cmp C (InFDs) # 'fd' >= 'InFDs'? 72 if ge # Yes 73 push X 74 ld X (InFDs) # Keep old 'InFDs' 75 ld E C # Get vector index 76 add E I # Plus 1 77 ld (InFDs) E # Store new 'InFDs' 78 ld A (InFiles) # Get vector 79 call allocAE_A # Extend vector 80 ld (InFiles) A 81 add X A # X on beg 82 add A E # A on end 83 do 84 ld (X) 0 # Clear new range 85 add X I 86 cmp X A 87 until eq 88 pop X 89 end 90 add C (InFiles) # Get vector 91 ld A (C) # Old inFile (should be NULL!) 92 ld E (+ VII BUFSIZ) # sizeof(inFile) 93 call allocAE_A 94 ld (C) A # New inFile 95 pop (A) # Set 'fd' 96 ld (A I) 0 # Clear 'ix' 97 ld (A II) 0 # Clear 'cnt' 98 ld (A III) 0 # Clear 'next' 99 ld C 1 100 ld (A IV) C # line = 1 101 ld (A V) C # src = 1 102 pop (A VI) # Set filename 103 ret 104 105 # Initialize output file 106 (code 'initOutFileA_A) 107 ld C A 108 push A # Save 'fd' 109 cc isatty(A) 110 push A # Save 'tty' flag 111 shl C 3 # Vector index 112 cmp C (OutFDs) # 'fd' >= 'OutFDs'? 113 if ge # Yes 114 push X 115 ld X (OutFDs) # Keep old 'OutFDs' 116 ld E C # Get vector index 117 add E I # Plus 1 118 ld (OutFDs) E # Store new 'OutFDs' 119 ld A (OutFiles) # Get vector 120 call allocAE_A # Extend vector 121 ld (OutFiles) A 122 add X A # X on beg 123 add A E # A on end 124 do 125 ld (X) 0 # Clear new range 126 add X I 127 cmp X A 128 until eq 129 pop X 130 end 131 add C (OutFiles) # Get vector 132 ld A (C) # Old outFile (should be NULL!) 133 ld E (+ III BUFSIZ) # sizeof(outFile) 134 call allocAE_A 135 ld (C) A # New outFile 136 pop (A II) # Set 'tty' 137 ld (A I) 0 # Clear 'ix' 138 pop (A) # Set 'fd' 139 ret 140 141 # Close input file 142 (code 'closeInFileA 0) 143 shl A 3 # Vector index 144 cmp A (InFDs) # 'fd' < 'InFDs'? 145 if lt # Yes 146 push X 147 add A (InFiles) # Get vector 148 ld X (A) 149 null X # Any? 150 if nz # Yes 151 cmp X (InFile) # Current Infile? 152 if eq # Yes 153 ld (InFile) 0 # Clear it 154 end 155 ld (A) 0 # Clear slot 156 cc free((X VI)) # Free filename 157 cc free(X) # And inFile 158 end 159 pop X 160 end 161 ret 162 163 # Close output file 164 (code 'closeOutFileA 0) 165 shl A 3 # Vector index 166 cmp A (OutFDs) # 'fd' < 'OutFDs'? 167 if lt # Yes 168 push X 169 add A (OutFiles) # Get vector 170 ld X (A) 171 null X # Any? 172 if nz # Yes 173 cmp A (OutFile) # Current Outfile? 174 if eq # Yes 175 ld (OutFile) 0 # Clear it 176 end 177 ld (A) 0 # Clear slot 178 cc free(X) # And outFile 179 end 180 pop X 181 end 182 ret 183 184 # Wait for pipe process if necessary 185 (code 'waitFileC 0) 186 cmp (C II) 1 # 'pid' > 1? 187 if gt # Yes 188 do 189 cc waitpid((C II) 0 0) # Wait for pipe process 190 nul4 # OK? 191 while s # No 192 call errno_A 193 cmp A EINTR # Interrupted? 194 jne closeErrX 195 null (Signal) # Signal? 196 if nz # Yes 197 call sighandler0 198 end 199 loop 200 end 201 ret 202 203 # Interruptible read 204 (code 'slowZ_F) 205 ld (Z I) 0 # Clear 'ix' 206 ld (Z II) 0 # Clear 'cnt' 207 do 208 cc read((Z) &(Z VII) BUFSIZ) # Read into buffer 209 null A # OK? 210 if ns # Yes 211 ld (Z II) A # Set new 'cnt' 212 ret # Return 'ge' 213 end 214 call errno_A 215 cmp A EINTR # Interrupted? 216 if ne # No 217 setz # Return 'z' 218 ret 219 end 220 null (Signal) # Signal? 221 if nz # Yes 222 call sighandler0 223 end 224 loop 225 226 (code 'slowNbC_FA) 227 ld (C I) 0 # Clear 'ix' 228 ld (C II) 0 # Clear 'cnt' 229 do 230 ld A (C) # Set non-blocking 231 call nonblockingA_A 232 push A # Save old file status flags 233 cc read((C) &(C VII) BUFSIZ) # Read into buffer 234 xchg A (S) 235 cc fcntl((C) F_SETFL A) # Restore file status flags 236 pop A # Get 'read' return value 237 null A # OK? 238 if nsz # Yes 239 ld (C II) A # Set new 'cnt' 240 ret # Return 'ge' 241 end 242 if z # Closed 243 dec (C I) # 'ix' = 'cnt' = -1 244 dec (C II) 245 setz # Return 'z' 246 ret 247 end 248 call errno_A 249 cmp A EAGAIN # No data available? 250 if eq # Yes 251 clrz # Return 'lt' 252 setc 253 ret 254 end 255 cmp A EINTR # Interrupted? 256 if ne # No 257 setz # Return 'z' 258 ret 259 end 260 null (Signal) # Signal? 261 if nz # Yes 262 call sighandler0 263 end 264 loop 265 266 (code 'rdBytesCEX_F) 267 do 268 do 269 cc read(C X E) # Read into buffer 270 null A # OK? 271 while sz # No 272 jz Ret # EOF 273 call errno_A 274 cmp A EINTR # Interrupted? 275 jne Retz # No: Return 'z' 276 null (Signal) # Signal? 277 if nz # Yes 278 call sighandler0 279 end 280 loop 281 add X A # Increment buffer pointer 282 sub E A # Decrement count 283 until z 284 null A # 'nsz' 285 ret 286 287 (code 'rdBytesNbCEX_F) 288 do 289 ld A C # Set non-blocking 290 call nonblockingA_A 291 push A # Save old file status flags 292 cc read(C X E) # Read into buffer 293 xchg A (S) 294 cc fcntl(C F_SETFL A) # Restore file status flags 295 pop A # Get 'read' return value 296 null A # OK? 297 if nsz # Yes 298 do 299 sub E A # Decrement count 300 if z # Got all 301 null A # Return 'gt' (A is non-zero) 302 ret 303 end 304 add X A # Increment buffer pointer 305 do 306 cc read(C X E) # Read into buffer 307 null A # OK? 308 while sz # No 309 jz Ret # EOF 310 call errno_A 311 cmp A EINTR # Interrupted? 312 jne Retz # No: Return 'z' 313 null (Signal) # Signal? 314 if nz # Yes 315 call sighandler0 316 end 317 loop 318 loop 319 end 320 jz Ret # EOF 321 call errno_A 322 cmp A EAGAIN # No data available? 323 if eq # Yes 324 clrz # Return 'lt' 325 setc 326 ret 327 end 328 cmp A EINTR # Interrupted? 329 jne Retz # No: Return 'z' 330 null (Signal) # Signal? 331 if nz # Yes 332 call sighandler0 333 end 334 loop 335 336 (code 'wrBytesCEX_F) 337 do 338 cc write(C X E) # Write buffer 339 null A # OK? 340 if ns # Yes 341 sub E A # Decrement count 342 jz Ret # Return 'z' if OK 343 add X A # Increment buffer pointer 344 else 345 call errno_A 346 cmp A EBADF # Bad file number? 347 jeq retnz # Return 'nz' 348 cmp A EPIPE # Broken pipe? 349 jeq retnz # Return 'nz' 350 cmp A ECONNRESET # Connection reset by peer? 351 jeq retnz # Return 'nz' 352 cmp A EINTR # Interrupted? 353 if ne # No 354 cmp C 2 # stderr? 355 jne wrBytesErr # No 356 ld E 2 # Exit error code 357 jmp byeE 358 end 359 null (Signal) # Signal? 360 if nz # Yes 361 call sighandler0 362 end 363 end 364 loop 365 366 (code 'clsChildY 0) 367 cmp (Y) (Talking) # Currently active? 368 if eq # Yes 369 ld (Talking) 0 # Clear 370 end 371 ld (Y) 0 # Clear 'pid' 372 cc close((Y I)) # Close 'hear' 373 cc close((Y II)) # and 'tell' 374 cc free((Y V)) # Free buffer 375 ret 376 377 (code 'wrChildCXY) # E 378 ld E (Y IV) # Get buffer count 379 null E # Any? 380 if z # No 381 do 382 cc write((Y II) X C) # Write buffer to 'tell' pipe 383 null A # OK? 384 if ns # Yes 385 sub C A # Decrement count 386 jz Ret # Done 387 add X A # Increment buffer pointer 388 else 389 call errno_A 390 cmp A EAGAIN # Would block? 391 break eq # Yes 392 cmp A EPIPE # Broken pipe? 393 jeq clsChildY # Close child 394 cmp A ECONNRESET # Connection reset by peer? 395 jeq clsChildY # Close child 396 cmp A EINTR # Interrupted? 397 jne wrChildErr # No 398 end 399 loop 400 end 401 ld A (Y V) # Get buffer 402 add E C # Increment count 403 add E 4 # plus count size 404 call allocAE_A # Extend buffer 405 ld (Y V) A # Store 406 ld E (Y IV) # Get buffer count again 407 add E A # Point to new count 408 ld A C # Store new 409 st4 (E) 410 add E 4 # Point to new data 411 movn (E) (X) C # Copy data 412 add C 4 # Total new size 413 add (Y IV) C # Add to buffer count 414 ret 415 416 (code 'flushA_F 0) 417 null A # Output file? 418 if nz # Yes 419 push E 420 ld E (A I) # Get 'ix' 421 null E # Any? 422 if nz # Yes 423 push C 424 push X 425 ld (A I) 0 # Clear 'ix' 426 ld C (A) # Get 'fd' 427 lea X (A III) # Buffer pointer 428 call wrBytesCEX_F # Write buffer 429 pop X 430 pop C 431 end 432 pop E 433 end 434 ret # Return 'z' if OK 435 436 (code 'flushAll) # C 437 ld C 0 # Iterate output files 438 do 439 cmp C (OutFDs) # 'fd' < 'OutFDs'? 440 while lt 441 ld A C # Get vector index 442 add A (OutFiles) # Get OutFile 443 ld A (A) 444 call flushA_F # Flush it 445 add C I # Increment vector index 446 loop 447 ret 448 449 ### Low level I/O ### 450 (code 'stdinByte_A) 451 push Z 452 ld Z ((InFiles)) # Get stdin 453 null Z # Open? 454 if nz # Yes 455 call getBinaryZ_FB # Get byte 456 if nc 457 zxt 458 pop Z 459 ret 460 end 461 end 462 cc isatty(0) # STDIN 463 nul4 # on a tty? 464 if z # No 465 ld A -1 # Return EOF 466 pop Z 467 ret 468 end 469 ld E 0 # Exit OK 470 jmp byeE 471 472 (code 'getBinaryZ_FB 0) 473 ld A (Z I) # Get 'ix' 474 cmp A (Z II) # Equals 'cnt'? 475 if eq # Yes 476 null A # Closed? 477 js retc # Yes 478 call slowZ_F # Read into buffer 479 jz retc # EOF (c) 480 ld A 0 # 'ix' 481 end 482 inc (Z I) # Increment 'ix' 483 add A Z # Fetch byte (nc) 484 ld B (A VII) # from buffer 485 ret # nc 486 487 # Add next byte to a number 488 (code 'byteNumBCX_CX 0) 489 zxt 490 big X # Big number? 491 if z # No: Direct buffer pointer 492 # xxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxS010 493 # 59 51 43 35 27 19 11 3 494 cmp C 59 # Short digit full? 495 if ne # No 496 shl A C # Shift byte to character position 497 or (X) A # Combine with short number 498 add C 8 # Increment position 499 ret 500 end 501 ld C (X) # Get short number 502 shr C 3 # De-normalize, keep sign bit 503 shl A 56 # Combine byte with digit 504 or C A 505 call boxNum_A # Box number 506 ld (A DIG) C 507 ld (X) A 508 ld X A 509 ld C 0 # Start new digit 510 ret 511 end 512 null C # Last bit of big digit? 513 if z # Yes 514 ld C (X DIG) 515 shr A 1 # Get lowest bit 516 rcr C 1 # into highest bit of big digit 517 ld (X DIG) C 518 rcl A 1 # Get sign bit into A 519 shl A 3 # Normalize with sign 520 or A CNT # Make short number 521 ld (X BIG) A 522 ld C 11 # Set up for second byte 523 ret 524 end 525 cmp C 59 # Short digit full? 526 if ne # No 527 shl A C # Shift byte to character position 528 or (X BIG) A # Combine with name digit 529 add C 8 # Increment position 530 ret 531 end 532 ld C (X BIG) # Get short number 533 shr C 3 # De-normalize, keep sign bit 534 shl A 56 # Combine byte with digit 535 or C A 536 call boxNum_A # Box number 537 ld (A DIG) C 538 ld (X BIG) A 539 ld X A 540 ld C 0 # Start new digit 541 ret 542 543 # Read binary expression 544 (code 'binReadZ_FE) 545 call (GetBinZ_FB) # Tag byte? 546 jc ret # No 547 nul B # NIX? 548 jz retNil # Return NIL 549 zxt 550 test B (hex "FC") # Atomic? 551 if z # No 552 ld E A 553 cmp B BEG # Begin a list? 554 jne retnc # No: Return DOT or END (also in B) 555 call binReadZ_FE # Else read list 556 jc ret 557 push X 558 call consE_X # First cell 559 ld (X) E 560 ld (X CDR) Nil 561 link 562 push X # <L I> Save it 563 link 564 do 565 call binReadZ_FE # Next item 566 jc 10 # EOF 567 cmp E END # Any? 568 while ne # Yes 569 cmp E DOT # Dotted pair? 570 if eq 571 cmp B DOT # Only if B is also DOT (to distinguish from Zero) 572 if eq # Yes 573 call binReadZ_FE # Get CDR 574 if c # EOF 575 10 drop 576 pop X 577 ret # Return 'c' 578 end 579 cmp E END # Circular list? 580 ldz E (L I) # Yes: Get first cell 581 ld (X CDR) E # Store in last cell 582 break T # 'nc' (E > END) 583 end 584 end 585 call consE_C # Append next cell 586 ld (C) E 587 ld (C CDR) Nil 588 ld (X CDR) C 589 ld X C 590 loop 591 ld E (L I) # Return list 592 drop # Return 'nc' 593 pop X 594 ret 595 end 596 push X 597 link 598 push ZERO # <L I> Result 599 ld X S 600 link 601 ld E A # Get tag byte 602 shr E 2 # Count 603 and A 3 # Tag 604 if z # NUMBER 605 ld C 3 # Build signed number 606 cmp E 63 # More than one chunk? 607 if eq # Yes 608 do 609 do 610 call (GetBinZ_FB) # Next byte? 611 jc 90 # No 612 call byteNumBCX_CX 613 dec E # Decrement count 614 until z 615 call (GetBinZ_FB) # Next count? 616 jc 90 # No 617 zxt 618 ld E A 619 cmp B 255 # Another chunk? 620 until ne # No 621 or B B # Empty? 622 jz 20 # Yes 623 end 624 do 625 call (GetBinZ_FB) # Next byte? 626 jc 90 # No 627 call byteNumBCX_CX # (B is zero (not DOT) if Zero) 628 dec E # Decrement count 629 until z 630 20 ld E (L I) # Get result 631 big X # Big number? 632 if nz # Yes 633 ld A (X BIG) # Get last short 634 and A SIGN # Sign bit 635 off (X BIG) SIGN 636 or E A # Set sign bit in result 637 end 638 else # INTERN, TRANSIENT or EXTERN 639 push A # Tag 640 ld C 4 # Build name 641 cmp E 63 # More than one chunk? 642 if eq # Yes 643 do 644 do 645 call (GetBinZ_FB) # Next byte? 646 jc 90 # No 647 call byteSymBCX_CX 648 dec E # Decrement count 649 until z 650 call (GetBinZ_FB) # Next count? 651 jc 90 # No 652 zxt 653 ld E A 654 cmp B 255 # Another chunk? 655 until ne # No 656 or B B # Empty? 657 jz 30 # Yes 658 end 659 do 660 call (GetBinZ_FB) # Next byte? 661 jc 90 # No 662 call byteSymBCX_CX 663 dec E # Decrement count 664 until z 665 30 ld X (L I) # Get name 666 pop A # Get tag 667 cmp A TRANSIENT # Transient? 668 if eq # Yes 669 call consSymX_E # Build symbol 670 else 671 cmp A INTERN # Internal? 672 if eq # Yes 673 push Y 674 call findSymX_E # Find or create it 675 pop Y 676 else # External 677 null (Extn) # External symbol offset? 678 if nz # Yes 679 ld A X # Get file number 680 shr A 24 # Lower 8 bits 681 ld C A # into C 682 and C (hex "FF") 683 shr A 12 # Upper 8 bits 684 and A (hex "FF00") 685 or A C 686 add A (Extn) # Add external symbol offset 687 shl A 24 688 ld C A # Lower result bits 689 shl A 12 690 or A C 691 and A (hex "000FF000FF000000") # Mask file number 692 and X (hex "FFF00FFF00FFFFFF") # Mask object ID 693 or X A # Combine 694 end 695 call externX_E # New external symbol 696 end 697 end 698 end 699 clrc 700 90 drop 701 pop X 702 ret 703 704 # Binary print next byte from a number 705 (code 'prByteCEXY 0) 706 null C # New round? 707 if z # Yes 708 cnt X # Short number? 709 if z # No 710 ld E (X DIG) # Next digit 711 ld X (X BIG) 712 else 713 ld E X # Get short 714 shr E 4 # Normalize 715 end 716 shr Y 1 # Get overflow bit 717 rcl E 1 # Shift into digit 718 rcl Y 1 # Keep new overflow bit 719 ld C 8 # Init count 720 end 721 ld A E # Output next byte 722 call (PutBinBZ) 723 shr E 8 # Shift to next 724 dec C # Decrement count 725 ret 726 727 # Binary print short number 728 (code 'prCntCE 0) 729 ld A E 730 do 731 shr A 8 # More bytes? 732 while nz # Yes 733 add C 4 # Increment count 734 loop 735 ld A C # Output tag byte 736 call (PutBinBZ) 737 shr C 2 # Discard tag bits 738 do 739 ld A E # Next data byte 740 shr E 8 741 call (PutBinBZ) # Output data byte 742 dec C # More? 743 until z # No 744 ret 745 746 # Binary print expression 747 (code 'prTellEZ 0) 748 ld (PutBinBZ) putTellBZ # Set binary print function 749 ld (Extn) 0 # Set external symbol offset to zero 750 call binPrintEZ 751 ret 752 753 (code 'prE) 754 ld (PutBinBZ) putStdoutB # Set binary print function 755 (code 'binPrintEZ) 756 cnt E # Short number? 757 if nz # Yes 758 ld C 4 # Count significant bytes (adjusted to tag) 759 shr E 3 # Normalize 760 jmp prCntCE # Output 'cnt' 761 end 762 big E # Big number? 763 if nz # Yes 764 push X 765 push Y 766 push E # Save signed number 767 off E SIGN # Make positive 768 ld X E # Keep in X 769 ld A 8 # Count 8 significant bytes 770 do 771 ld C (E DIG) # Keep digit 772 ld E (E BIG) # More cells? 773 cnt E 774 while z # Yes 775 add A 8 # Increment count by 8 776 loop 777 shr E 4 # Normalize short 778 shl C 1 # Get most significant bit of last digit 779 addc E E # Any significant bits in short number? 780 if nz # Yes 781 do 782 inc A # Increment count 783 shr E 8 # More bytes? 784 until z # No 785 end 786 pop Y # Get sign 787 shr Y 3 # into lowest bit 788 ld C 0 # Init byte count 789 cmp A 63 # Single chunk? 790 if lt # Yes 791 push A # <S> Count 792 shl A 2 # Adjust to tag byte 793 call (PutBinBZ) # Output tag byte 794 do 795 call prByteCEXY # Output next data byte 796 dec (S) # More? 797 until z # No 798 else 799 sub A 63 # Adjust count 800 push A # <S I> Count 801 ld B (* 4 63) # Output first tag byte 802 call (PutBinBZ) 803 push 63 # <S> and first 63 data bytes 804 do 805 call prByteCEXY # Output next data byte 806 dec (S) # More? 807 until z # No 808 do 809 cmp (S I) 255 # Count greater or equal 255? 810 while ge # Yes 811 ld A 255 # Next chunk 812 ld (S) A # and the next 255 data bytes 813 call (PutBinBZ) # Output count byte 814 do 815 call prByteCEXY # Output next data byte 816 dec (S) # More? 817 until z # No 818 sub (S I) 255 # Decrement counter 819 loop 820 add S I # Drop second count 821 ld A (S) # Retrieve count 822 call (PutBinBZ) # Output last count 823 do 824 sub (S) 1 # More? 825 while ge # Yes 826 call prByteCEXY # Output next data byte 827 loop 828 end 829 add S I # Drop count 830 pop Y 831 pop X 832 ret 833 end 834 sym E # Symbol? 835 if nz # Yes 836 cmp E Nil # NIL? 837 if eq # Yes 838 ld B NIX # Output NIX 839 jmp (PutBinBZ) 840 end 841 sym (E TAIL) # External symbol? 842 if nz # Yes 843 ld E (E TAIL) 844 call nameE_E # Get name 845 null (Extn) # External symbol offset? 846 if nz # Yes 847 ld A E # Get file number 848 shr A 24 # Lower 8 bits 849 ld C A # into C 850 and C (hex "FF") 851 shr A 12 # Upper 8 bits 852 and A (hex "FF00") 853 or A C 854 sub A (Extn) # Subtract external symbol offset 855 shl A 24 856 ld C A # Lower result bits 857 shl A 12 858 or A C 859 and A (hex "000FF000FF000000") # Mask file number 860 and E (hex "FFF00FFF00FFFFFF") # Mask object ID 861 or E A # Combine 862 end 863 shl E 2 # Strip status bits 864 shr E 6 # Normalize 865 ld C (+ 4 EXTERN) # Count significant bytes (adjusted to tag) 866 jmp prCntCE # Output external name 867 end 868 push X 869 push Y 870 ld X (E TAIL) 871 call nameX_X # Get name 872 cmp X ZERO # Any? 873 if eq # No 874 ld B NIX # Output NIX 875 call (PutBinBZ) 876 else 877 ld Y ((EnvIntern)) 878 call isInternEXY_F # Internal symbol? 879 ld C INTERN # Yes 880 ldnz C TRANSIENT # No 881 cnt X # Short name? 882 if nz # Yes 883 add C 4 # Count significant bytes (adjusted to tag) 884 ld E X # Get name 885 shr E 4 # Normalize 886 call prCntCE # Output internal or transient name 887 else # Long name 888 ld E X # Into E 889 ld A 8 # Count significant bytes 890 do 891 ld E (E BIG) # More cells? 892 cnt E 893 while z # Yes 894 add A 8 # Increment count 895 loop 896 shr E 4 # Any significant bits in short name? 897 if nz # Yes 898 do 899 inc A # Increment count 900 shr E 8 # More bytes? 901 until z # No 902 end 903 ld E A # Keep count in E 904 cmp A 63 # Single chunk? 905 if lt # Yes 906 shl A 2 # Adjust to tag byte 907 or A C # Combine with tag 908 call (PutBinBZ) # Output tag byte 909 ld C 0 910 do 911 call symByteCX_FACX # Next data byte 912 call (PutBinBZ) # Output it 913 dec E # More? 914 until z # No 915 else 916 ld B (* 4 63) # Output first tag byte 917 or A C # Combine with tag 918 call (PutBinBZ) 919 sub E 63 # Adjust count 920 push E # <S> Count 921 ld E 63 # and first 63 data bytes 922 ld C 0 923 do 924 call symByteCX_FACX # Next data byte 925 call (PutBinBZ) # Output it 926 dec E # More? 927 until z # No 928 do 929 cmp (S) 255 # Count greater or equal 255? 930 while ge # Yes 931 ld A 255 # Next chunk 932 ld E A # and the next 255 data bytes 933 call (PutBinBZ) # Output count byte 934 do 935 call symByteCX_FACX # Next data byte 936 call (PutBinBZ) # Output it 937 dec E # More? 938 until z # No 939 sub (S) 255 # Decrement counter 940 loop 941 pop E # Retrieve count 942 ld A E 943 call (PutBinBZ) # Output last count 944 do 945 sub E 1 # More? 946 while ge # Yes 947 call symByteCX_FACX # Next data byte 948 call (PutBinBZ) # Output it 949 loop 950 end 951 end 952 end 953 pop Y 954 pop X 955 ret 956 end 957 push X 958 push Y 959 ld B BEG # Begin list 960 call (PutBinBZ) 961 ld X E # Keep list in X 962 call circE_YF # Circular? 963 if nz # No 964 do 965 ld E (X) # Next item 966 call binPrintEZ 967 ld X (X CDR) # NIL-terminated? 968 cmp X Nil 969 while ne # No 970 atom X # Atomic tail? 971 if nz # Yes 972 ld B DOT # Output dotted pair 973 call (PutBinBZ) 974 ld E X # Output atom 975 call binPrintEZ 976 pop Y # Return 977 pop X 978 ret 979 end 980 loop 981 else 982 cmp X Y # Fully circular? 983 if eq # Yes 984 do 985 ld E (X) # Output CAR 986 call binPrintEZ 987 ld X (X CDR) # Done? 988 cmp X Y 989 until eq # Yes 990 ld B DOT # Output dotted pair 991 call (PutBinBZ) 992 else 993 do # Non-circular part 994 ld E (X) # Output CAR 995 call binPrintEZ 996 ld X (X CDR) # Done? 997 cmp X Y 998 until eq # Yes 999 ld B DOT # Output DOT+BEG 1000 call (PutBinBZ) 1001 ld B BEG 1002 call (PutBinBZ) 1003 do # Circular part 1004 ld E (X) # Output CAR 1005 call binPrintEZ 1006 ld X (X CDR) # Done? 1007 cmp X Y 1008 until eq # Yes 1009 ld B DOT # Output DOT+END 1010 call (PutBinBZ) 1011 ld B END 1012 call (PutBinBZ) 1013 end 1014 end 1015 pop Y 1016 pop X 1017 ld B END # End list 1018 jmp (PutBinBZ) 1019 1020 # Family IPC 1021 (code 'putTellBZ 0) 1022 ld (Z) B # Store byte 1023 inc Z # Increment pointer 1024 lea A ((TellBuf) (- PIPE_BUF 1)) # Reached (TellBuf + PIPE_BUF - 1)? 1025 cmp Z A 1026 jeq tellErr # Yes 1027 ret 1028 1029 (code 'tellBegZ_Z 0) 1030 ld (TellBuf) Z # Set global buffer 1031 add Z 4 # 4 bytes space (PID and count) 1032 set (Z) BEG # Begin a list 1033 inc Z 1034 ret 1035 1036 (code 'tellEndAZ) 1037 push X 1038 push Y 1039 set (Z) END # Close list 1040 inc Z 1041 ld X (TellBuf) # Get buffer 1042 st2 (X) # Store PID 1043 push A # <S I> PID 1044 ld E Z # Calculate total size 1045 sub E X 1046 ld A E # Size in A 1047 sub A 4 # without PID and count 1048 st2 (X 2) # Store in buffer count 1049 push A # <S> Size 1050 ld C (Tell) # File descriptor 1051 null C # Any? 1052 if nz # Yes 1053 call wrBytesCEX_F # Write buffer to pipe 1054 if nz # Not successful 1055 cc close(C) # Close 'Tell' 1056 ld (Tell) 0 # Clear 'Tell' 1057 end 1058 end 1059 ld Y (Child) # Iterate children 1060 ld Z (Children) # Count 1061 do 1062 sub Z VI # More? 1063 while ge # Yes 1064 null (Y) # 'pid'? 1065 if nz # Yes 1066 ld A (S I) # Get PID 1067 null A # Any? 1068 jz 10 # Yes 1069 cmp A (Y) # Same as 'pid'? 1070 if eq # Yes 1071 10 ld C (S) # Get size 1072 lea X ((TellBuf) 4) # and data 1073 call wrChildCXY # Write to child 1074 end 1075 end 1076 add Y VI # Increment by sizeof(child) 1077 loop 1078 add S II # Drop size and PID 1079 pop Y 1080 pop X 1081 ret 1082 1083 (code 'unsync 0) # X 1084 ld C (Tell) # File descriptor 1085 null C # Any? 1086 if nz # Yes 1087 push 0 # Send zero 1088 ld X S # Get buffer 1089 ld E 4 # Size (PID and count) 1090 call wrBytesCEX_F # Write buffer to pipe 1091 if nz # Not successful 1092 cc close(C) # Close 'Tell' 1093 ld (Tell) 0 # Clear 'Tell' 1094 end 1095 add S I # Drop buffer 1096 end 1097 set (Sync) 0 # Clear sync flag 1098 ret 1099 1100 (code 'rdHear_FE) 1101 push Z 1102 ld A (Hear) # Get 'hear' fd 1103 shl A 3 # Vector index 1104 add A (InFiles) # Get vector 1105 ld Z (A) # Input file 1106 ld (GetBinZ_FB) getBinaryZ_FB # Set binary read function 1107 ld (Extn) 0 # Set external symbol offset to zero 1108 call binReadZ_FE # Read item 1109 pop Z 1110 ret 1111 1112 # Return next byte from symbol name 1113 (code 'symByteCX_FACX 0) 1114 null C # New round? 1115 if z # Yes 1116 cmp X ZERO # Done? 1117 jeq ret # Yes: Return 'z' 1118 cnt X # Short? 1119 if nz # Yes 1120 ld C X # Get short 1121 shr C 4 # Normalize 1122 ld X ZERO # Clear for next round 1123 else 1124 ld C (X DIG) # Get next digit 1125 ld X (X BIG) 1126 end 1127 end 1128 ld A C # Get byte 1129 shr C 8 # Shift out 1130 or B B # Return B 1131 zxt 1132 ret 1133 1134 (code 'symCharCX_FACX 0) # Return next char from symbol name 1135 call symByteCX_FACX # First byte 1136 jz ret # Return 'z' if none 1137 cmp B (hex "FF") # Special? 1138 if ne # No 1139 cmp B 128 # Single byte? 1140 if ge # No 1141 test B (hex "20") # Two bytes? 1142 if z # Yes 1143 and B (hex "1F") # First byte 110xxxxx 1144 shl A 6 # xxxxx000000 1145 push A 1146 else # Three bytes 1147 and B (hex "F") # First byte 1110xxxx 1148 shl A 6 # xxxx000000 1149 push A 1150 call symByteCX_FACX # Second byte 1151 and B (hex "3F") # 10xxxxxx 1152 or A (S) # Combine 1153 shl A 6 # xxxxxxxxxx000000 1154 ld (S) A 1155 end 1156 call symByteCX_FACX # Last byte 1157 and B (hex "3F") # 10xxxxxx 1158 or (S) A # Combine 1159 pop A # Get result 1160 end 1161 ret 1162 end 1163 ld A TOP # Return special "top" character 1164 or A A 1165 ret 1166 1167 (code 'bufStringE_SZ 0) 1168 ld Z S # 8-byte-buffer 1169 push (Z) # Save return address 1170 push X # and X 1171 cmp E Nil # Empty? 1172 if ne # No 1173 ld X (E TAIL) 1174 call nameX_X # Get name 1175 ld C 0 1176 do 1177 call symByteCX_FACX 1178 while nz 1179 ld (Z) B # Store next byte 1180 inc Z 1181 test Z 7 # Buffer full? 1182 if z # Yes 1183 sub S 8 # Extend buffer 1184 cmp S (StkLimit) # Stack check 1185 jlt stkErr 1186 movm (S) (S 8) (Z) 1187 sub Z 8 # Reset buffer pointer 1188 end 1189 loop 1190 end 1191 set (Z) 0 # Null byte 1192 add Z 8 # Round up 1193 off Z 7 1194 pop X 1195 ret 1196 1197 (code 'pathStringE_SZ 0) 1198 ld Z S # 8-byte-buffer 1199 push (Z) # Save return address 1200 push X # and X 1201 cmp E Nil # Empty? 1202 if ne # No 1203 ld X (E TAIL) 1204 call nameX_X # Get name 1205 ld C 0 1206 call symByteCX_FACX # First byte 1207 if nz 1208 cmp B (char "+") # Plus? 1209 if eq 1210 ld (Z) B # Store "+" 1211 inc Z 1212 call symByteCX_FACX # Second byte 1213 jz 90 1214 end 1215 cmp B (char "@") # Home path? 1216 if ne # No 1217 do 1218 ld (Z) B # Store byte 1219 inc Z 1220 test Z 7 # Buffer full? 1221 if z # Yes 1222 sub S 8 # Extend buffer 1223 movm (S) (S 8) (Z) 1224 sub Z 8 # Reset buffer pointer 1225 end 1226 call symByteCX_FACX # Next byte? 1227 until z # No 1228 else 1229 push E 1230 ld E (Home) # Home directory? 1231 null E 1232 if nz # Yes 1233 do 1234 ld B (E) 1235 ld (Z) B # Store next byte 1236 inc Z 1237 test Z 7 # Buffer full? 1238 if z # Yes 1239 sub S 8 # Extend buffer 1240 movm (S) (S 8) (Z) 1241 sub Z 8 # Reset buffer pointer 1242 end 1243 inc E 1244 nul (E) # More? 1245 until z # No 1246 end 1247 pop E 1248 do 1249 call symByteCX_FACX 1250 while nz 1251 ld (Z) B # Store next byte 1252 inc Z 1253 test Z 7 # Buffer full? 1254 if z # Yes 1255 sub S 8 # Extend buffer 1256 movm (S) (S 8) (Z) 1257 sub Z 8 # Reset buffer pointer 1258 end 1259 loop 1260 end 1261 end 1262 end 1263 90 set (Z) 0 # Null byte 1264 add Z 8 # Round up 1265 off Z 7 1266 pop X 1267 ret 1268 1269 # (path 'any) -> sym 1270 (code 'doPath 2) 1271 push Z 1272 ld E ((E CDR)) # Get arg 1273 call evSymE_E # Evaluate to a symbol 1274 call pathStringE_SZ # Write to stack buffer 1275 ld E S # Make transient symbol 1276 call mkStrE_E 1277 ld S Z # Drop buffer 1278 pop Z 1279 ret 1280 1281 # Add next char to symbol name 1282 (code 'charSymACX_CX 0) 1283 cmp A (hex "80") # ASCII?? 1284 jlt byteSymBCX_CX # Yes: 0xxxxxxx 1285 cmp A (hex "800") # Double-byte? 1286 if lt # Yes 1287 push A # 110xxxxx 10xxxxxx 1288 shr A 6 # Upper five bits 1289 and B (hex "1F") 1290 or B (hex "C0") 1291 call byteSymBCX_CX # Add first byte 1292 pop A 1293 and B (hex "3F") # Lower 6 bits 1294 or B (hex "80") 1295 jmp byteSymBCX_CX # Add second byte 1296 end 1297 cmp A TOP # Special "top" character? 1298 if eq # Yes 1299 ld B (hex "FF") 1300 jmp byteSymBCX_CX 1301 end 1302 push A # 1110xxxx 10xxxxxx 10xxxxxx 1303 shr A 12 # Hightest four bits 1304 and B (hex "0F") 1305 or B (hex "E0") 1306 call byteSymBCX_CX # Add first byte 1307 ld A (S) 1308 shr A 6 # Middle six bits 1309 and B (hex "3F") 1310 or B (hex "80") 1311 call byteSymBCX_CX # Add second byte 1312 pop A 1313 and B (hex "3F") # Lowest 6 bits 1314 or B (hex "80") # Add third byte 1315 1316 # Add next byte to symbol name 1317 (code 'byteSymBCX_CX 0) 1318 zxt 1319 big X # Long name? 1320 if z # No: Direct buffer pointer 1321 # 0000.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx0010 1322 # 60 52 44 36 28 20 12 4 1323 cmp C 60 # Short digit full? 1324 if ne # No 1325 shl A C # Shift byte to character position 1326 or (X) A # Combine with name digit 1327 add C 8 # Increment position 1328 ret 1329 end 1330 ld C (X) # Get short number 1331 shr C 4 # De-normalize 1332 shl A 56 # Combine byte with digit 1333 or C A 1334 call boxNum_A # Box number 1335 ld (A DIG) C 1336 ld (X) A 1337 ld X A 1338 ld C 4 # Start new digit 1339 ret 1340 end 1341 cmp C 60 # Short digit full? 1342 if ne # No 1343 shl A C # Shift byte to character position 1344 or (X BIG) A # Combine with name digit 1345 add C 8 # Increment position 1346 ret 1347 end 1348 ld C (X BIG) # Get short number 1349 shr C 4 # De-normalize 1350 shl A 56 # Combine byte with digit 1351 or C A 1352 call boxNum_A # Box number 1353 ld (A DIG) C 1354 ld (X BIG) A 1355 ld X A 1356 ld C 4 # Start new digit 1357 ret 1358 1359 (code 'currFdX_C 0) 1360 ld C (EnvInFrames) # InFrames or OutFrames? 1361 or C (EnvOutFrames) 1362 jz noFdErrX # No 1363 (code 'currFd_C) 1364 ld C (EnvOutFrames) # OutFrames? 1365 null C 1366 if z # No 1367 ld C (EnvInFrames) # Use InFrames 1368 else 1369 null (EnvInFrames) # InFrames? 1370 if nz # Both 1371 cmp C (EnvInFrames) # OutFrames > InFrames? 1372 if gt # Yes 1373 ld C (EnvInFrames) # Take InFrames 1374 end 1375 end 1376 end 1377 ld C (C I) # Get 'fd' 1378 ret 1379 1380 (code 'rdOpenEXY) 1381 cmp E Nil # Standard input? 1382 if eq # Yes 1383 ld (Y I) 0 # fd = stdin 1384 ld (Y II) 0 # pid = 0 1385 else 1386 num E # Descriptor? 1387 if nz # Yes 1388 cnt E # Need short 1389 jz cntErrEX 1390 ld (Y II) 0 # pid = 0 1391 ld A E # Get fd 1392 shr A 4 # Normalize 1393 if c # Negative 1394 ld C (EnvInFrames) # Fetch from input frames 1395 do 1396 ld C (C) # Next frame 1397 null C # Any? 1398 jz badFdErrEX # No 1399 dec A # Found frame? 1400 until z # Yes 1401 ld A (C I) # Get fd from frame 1402 end 1403 ld (Y I) A # Store 'fd' 1404 shl A 3 # Vector index 1405 cmp A (InFDs) # 'fd' >= 'InFDs'? 1406 jge badFdErrEX # Yes 1407 add A (InFiles) # Get vector 1408 ld A (A) # Input file 1409 null A # Any? 1410 jz badFdErrEX # No 1411 else 1412 push Z 1413 sym E # File name? 1414 if nz # Yes 1415 ld (Y II) 1 # pid = 1 1416 call pathStringE_SZ 1417 do 1418 ld B (S) # First char 1419 cmp B (char "+") # Plus? 1420 if eq # Yes 1421 cc open(&(S 1) (| O_APPEND O_CREAT O_RDWR) (oct "0666")) 1422 else 1423 cc open(S O_RDONLY) 1424 end 1425 nul4 # OK? 1426 while s # No 1427 call errno_A 1428 cmp A EINTR # Interrupted? 1429 jne openErrEX # No 1430 null (Signal) # Signal? 1431 if nz # Yes 1432 call sighandlerX 1433 end 1434 loop 1435 ld (Y I) A # Save 'fd' 1436 ld B (S) # First char 1437 cmp B (char "+") # Plus? 1438 if eq # Yes 1439 cc strdup(&(S 1)) # Duplicate name 1440 else 1441 cc strdup(S) # Duplicate name 1442 end 1443 ld C (Y I) # Get 'fd' 1444 call initInFileCA_A 1445 ld A (Y I) # Get fd 1446 call closeOnExecAX 1447 ld S Z # Drop buffer 1448 else # Else pipe 1449 push X 1450 push 0 # End-of-buffers marker 1451 ld X E # Get list 1452 ld E (X) # Pathname 1453 call xSymE_E # Make symbol 1454 call pathStringE_SZ # Write to stack buffer 1455 do 1456 ld X (X CDR) # Arguments? 1457 atom X 1458 while z # Yes 1459 push Z # Buffer chain 1460 ld E (X) # Next argument 1461 call xSymE_E # Make symbol 1462 call bufStringE_SZ # Write to stack buffer 1463 loop 1464 push Z 1465 ld Z S # Point to chain 1466 ld X Z 1467 push 0 # NULL terminator 1468 do 1469 lea A (X I) # Buffer pointer 1470 push A # Push to vector 1471 ld X (X) # Follow chain 1472 null (X) # Done? 1473 until z # Yes 1474 ld X (X I) # Retrieve X 1475 push A # Create 'pipe' structure 1476 cc pipe(S) # Open pipe 1477 nul4 # OK? 1478 jnz pipeErrX 1479 ld4 (S) # Get pfd[0] 1480 call closeOnExecAX 1481 ld4 (S 4) # Get pfd[1] 1482 call closeOnExecAX 1483 cc fork() # Fork child process 1484 ld (Y II) A # Set 'pid' 1485 nul4 # In child? 1486 js forkErrX 1487 if z # Yes 1488 cc setpgid(0 0) # Set process group 1489 ld4 (S) # Close read pipe 1490 call closeAX 1491 ld4 (S 4) # Get write pipe 1492 cmp A 1 # STDOUT_FILENO? 1493 if ne # No 1494 cc dup2(A 1) # Dup to STDOUT_FILENO 1495 ld4 (S 4) # Close write pipe 1496 call closeAX 1497 end 1498 add S I # Drop 'pipe' structure 1499 cc execvp((S) S) # Execute program 1500 jmp execErrS # Error if failed 1501 end 1502 cc setpgid(A 0) # Set process group 1503 ld4 (S 4) # Close write pipe 1504 call closeAX 1505 ld4 (S) # Get read pipe 1506 ld (Y I) A # Set 'fd' 1507 call initInFileA_A 1508 add S I # Drop 'pipe' structure 1509 do 1510 ld S Z # Clean up buffers 1511 pop Z # Chain 1512 null Z # End? 1513 until z # Yes 1514 pop X 1515 end 1516 pop Z 1517 end 1518 end 1519 ret 1520 1521 (code 'wrOpenEXY) 1522 cmp E Nil # Standard output? 1523 if eq # Yes 1524 ld (Y I) 1 # fd = stdout 1525 ld (Y II) 0 # pid = 0 1526 else 1527 num E # Descriptor? 1528 if nz # Yes 1529 cnt E # Need short 1530 jz cntErrEX 1531 ld (Y II) 0 # pid = 0 1532 ld A E # Get fd 1533 shr A 4 # Normalize 1534 if c # Negative 1535 ld C (EnvOutFrames) # Fetch from output frames 1536 do 1537 ld C (C) # Next frame 1538 null C # Any? 1539 jz badFdErrEX # No 1540 dec A # Found frame? 1541 until z # Yes 1542 ld A (C I) # Get fd from frame 1543 end 1544 ld (Y I) A # Store 'fd' 1545 shl A 3 # Vector index 1546 cmp A (OutFDs) # 'fd' >= 'OutFDs'? 1547 jge badFdErrEX # Yes 1548 add A (OutFiles) # Get vector 1549 ld A (A) # Slot? 1550 null A # Any? 1551 jz badFdErrEX # No 1552 else 1553 push Z 1554 sym E # File name? 1555 if nz # Yes 1556 ld (Y II) 1 # pid = 1 1557 call pathStringE_SZ 1558 do 1559 ld B (S) # First char 1560 cmp B (char "+") # Plus? 1561 if eq # Yes 1562 cc open(&(S 1) (| O_APPEND O_CREAT O_WRONLY) (oct "0666")) 1563 else 1564 cc open(S (| O_CREAT O_TRUNC O_WRONLY) (oct "0666")) 1565 end 1566 nul4 # OK? 1567 while s # No 1568 call errno_A 1569 cmp A EINTR # Interrupted? 1570 jne openErrEX # No 1571 null (Signal) # Signal? 1572 if nz # Yes 1573 call sighandlerX 1574 end 1575 loop 1576 ld (Y I) A # Save 'fd' 1577 call initOutFileA_A 1578 ld A (Y I) # Get fd 1579 call closeOnExecAX 1580 ld S Z # Drop buffer 1581 else # Else pipe 1582 push X 1583 push 0 # End-of-buffers marker 1584 ld X E # Get list 1585 ld E (X) # Pathname 1586 call xSymE_E # Make symbol 1587 call pathStringE_SZ # Write to stack buffer 1588 do 1589 ld X (X CDR) # Arguments? 1590 atom X 1591 while z # Yes 1592 push Z # Buffer chain 1593 ld E (X) # Next argument 1594 call xSymE_E # Make symbol 1595 call bufStringE_SZ # Write to stack buffer 1596 loop 1597 push Z 1598 ld Z S # Point to chain 1599 ld X Z 1600 push 0 # NULL terminator 1601 do 1602 lea A (X I) # Buffer pointer 1603 push A # Push to vector 1604 ld X (X) # Follow chain 1605 null (X) # Done? 1606 until z # Yes 1607 ld X (X I) # Retrieve X 1608 push A # Create 'pipe' structure 1609 cc pipe(S) # Open pipe 1610 nul4 # OK? 1611 jnz pipeErrX 1612 ld4 (S) # Get pfd[0] 1613 call closeOnExecAX 1614 ld4 (S 4) # Get pfd[1] 1615 call closeOnExecAX 1616 cc fork() # Fork child process 1617 ld (Y II) A # Set 'pid' 1618 nul4 # In child? 1619 js forkErrX 1620 if z # Yes 1621 cc setpgid(0 0) # Set process group 1622 ld4 (S 4) # Close write pipe 1623 call closeAX 1624 ld4 (S) # Get read pipe 1625 null A # STDIN_FILENO? 1626 if ne # No 1627 cc dup2(A 0) # Dup to STDIN_FILENO 1628 ld4 (S) # Close read pipe 1629 call closeAX 1630 end 1631 add S I # Drop 'pipe' structure 1632 cc execvp((S) S) # Execute program 1633 jmp execErrS # Error if failed 1634 end 1635 cc setpgid(A 0) # Set process group 1636 ld4 (S) # Close read pipe 1637 call closeAX 1638 ld4 (S 4) # Get write pipe 1639 ld (Y I) A # Set 'fd' 1640 call initOutFileA_A 1641 add S I # Drop 'pipe' structure 1642 do 1643 ld S Z # Clean up buffers 1644 pop Z # Chain 1645 null Z # End? 1646 until z # Yes 1647 pop X 1648 end 1649 pop Z 1650 end 1651 end 1652 ret 1653 1654 (code 'erOpenEXY) 1655 num E # Need symbol 1656 jnz symErrEX 1657 sym E 1658 jz symErrEX 1659 cc dup(2) # Duplicate current stderr 1660 ld (Y I) A # Save it 1661 cmp E Nil # Use current output channel? 1662 if eq # Yes 1663 cc dup(((OutFile))) # Duplicate 'fd' 1664 ld C A # Keep in C 1665 else 1666 push Z 1667 call pathStringE_SZ # File name 1668 do 1669 ld B (S) # First char 1670 cmp B (char "+") # Plus? 1671 if eq # Yes 1672 cc open(&(S 1) (| O_APPEND O_CREAT O_WRONLY) (oct "0666")) 1673 else 1674 cc open(S (| O_CREAT O_TRUNC O_WRONLY) (oct "0666")) 1675 end 1676 nul4 # OK? 1677 while s # No 1678 call errno_A 1679 cmp A EINTR # Interrupted? 1680 jne openErrEX # No 1681 null (Signal) # Signal? 1682 if nz # Yes 1683 call sighandlerX 1684 end 1685 loop 1686 ld S Z # Drop buffer 1687 pop Z 1688 ld C A # Keep 'fd' in C 1689 call closeOnExecAX 1690 end 1691 cc dup2(C 2) # Dup 'fd' to STDERR_FILENO 1692 ld A C 1693 call closeAX 1694 ret 1695 1696 (code 'ctOpenEXY) 1697 num E # Need symbol 1698 jnz symErrEX 1699 sym E 1700 jz symErrEX 1701 cmp E Nil # Shared lock on current I/O channel? 1702 if eq # Yes 1703 ld (Y I) -1 # 'fd' 1704 call currFdX_C # Get current fd 1705 call rdLockFileC 1706 else 1707 cmp E TSym # Exclusive lock on current I/O channel? 1708 if eq # Yes 1709 ld (Y I) -1 # 'fd' 1710 call currFdX_C # Get current fd 1711 call wrLockFileC 1712 else 1713 push Z 1714 call pathStringE_SZ # File name 1715 do 1716 ld B (S) # First char 1717 cmp B (char "+") # Plus? 1718 if eq # Yes 1719 cc open(&(S 1) (| O_CREAT O_RDWR) (oct "0666")) 1720 else 1721 cc open(S (| O_CREAT O_RDWR) (oct "0666")) 1722 end 1723 nul4 # OK? 1724 while s # No 1725 call errno_A 1726 cmp A EINTR # Interrupted? 1727 jne openErrEX # No 1728 null (Signal) # Signal? 1729 if nz # Yes 1730 call sighandlerX 1731 end 1732 loop 1733 ld S Z # Drop buffer 1734 pop Z 1735 ld (Y I) A # Save 'fd' 1736 ld C A # Keep in C 1737 ld B (S) # First char 1738 cmp B (char "+") # Plus? 1739 if eq # Yes 1740 call rdLockFileC # Read lock 1741 else 1742 call wrLockFileC # Write lock 1743 end 1744 ld A (Y I) # Get fd 1745 call closeOnExecAX 1746 end 1747 end 1748 ret 1749 1750 (code 'getStdin_A 0) 1751 push Z 1752 ld Z (InFile) # Current InFile 1753 null Z # Any? 1754 if nz # Yes 1755 cmp Z ((InFiles)) # On stdin? 1756 if ne # No 1757 ld A (Z I) # Get 'ix' 1758 cmp A (Z II) # Equals 'cnt'? 1759 if eq # Yes 1760 null A # Closed? 1761 js 90 # Return -1 1762 call slowZ_F # Read into buffer 1763 jz 90 # Return -1 1764 ld A 0 # 'ix' 1765 end 1766 inc (Z I) # Increment 'ix' 1767 add A Z # Fetch byte 1768 ld B (A VII) # from buffer 1769 cmp B 10 # Newline? 1770 if eq # Yes 1771 inc (Z IV) # Increment line 1772 end 1773 zxt # Extend into A 1774 else 1775 push C 1776 push E 1777 push X 1778 atom (Led) # Line editor? 1779 if nz # No 1780 ld C 0 # Standard input 1781 ld E -1 # No timeout 1782 ld X 0 # Runtime expression 1783 call waitFdCEX_A # Wait for events 1784 call stdinByte_A # Get byte 1785 else 1786 ld C (LineC) 1787 null C # First call? 1788 if ns # No 1789 ld X (LineX) # Get line status 1790 else 1791 ld E (Led) # Run line editor 1792 call runE_E 1793 cmp E Nil # NIL 1794 if eq # Yes 1795 ld X ZERO # Empty 1796 else 1797 ld X (E TAIL) 1798 call nameX_X # Get name 1799 end 1800 ld C 0 1801 end 1802 call symByteCX_FACX # Extract next byte 1803 if z # None 1804 ld A 10 # Default to linefeed 1805 ld C -1 1806 end 1807 ld (LineX) X # Save line status 1808 ld (LineC) C 1809 end 1810 pop X 1811 pop E 1812 pop C 1813 end 1814 else 1815 90 ld A -1 # Return EOF 1816 end 1817 ld (Chr) A 1818 pop Z 1819 ret 1820 1821 (code 'getParse_A 0) 1822 push C 1823 push X 1824 ld X (EnvParseX) # Get parser status 1825 ld C (EnvParseC) 1826 call symByteCX_FACX # Extract next byte 1827 if z # Done 1828 ld A (EnvParseEOF) # Get parser trail bytes 1829 shr A 8 # More bytes? 1830 ld (EnvParseEOF) A 1831 if nz # Yes 1832 zxt # Return next byte 1833 else 1834 dec A # Return -1 1835 end 1836 end 1837 ld (Chr) A 1838 ld (EnvParseX) X # Save status 1839 ld (EnvParseC) C 1840 pop X 1841 pop C 1842 ret 1843 1844 (code 'pushInFilesY) 1845 ld A (InFile) # Current InFile? 1846 null A 1847 if nz # Yes 1848 ld (A III) (Chr) # Save Chr in next 1849 end 1850 ld A (Y I) # Get 'fd' 1851 shl A 3 # Vector index 1852 add A (InFiles) # Get InFile 1853 ld A (A) 1854 ld (InFile) A # Store new 1855 null A # Any? 1856 if nz # Yes 1857 ld A (A III) # Get 'next' 1858 else 1859 ld A -1 1860 end 1861 ld (Chr) A # Save in 'Chr' 1862 ld (Y III) (Get_A) # Save 'get' 1863 ld (Get_A) getStdin_A # Set new 1864 ld (Y) (EnvInFrames) # Set link 1865 ld (EnvInFrames) Y # Link frame 1866 ret 1867 1868 (code 'pushOutFilesY) 1869 ld A (Y I) # Get 'fd' 1870 shl A 3 # Vector index 1871 add A (OutFiles) # Get OutFile 1872 ld (OutFile) (A) # Store new 1873 ld (Y III) (PutB) # Save 'put' 1874 ld (PutB) putStdoutB # Set new 1875 ld (Y) (EnvOutFrames) # Set link 1876 ld (EnvOutFrames) Y # Link frame 1877 ret 1878 1879 (code 'pushErrFilesY) 1880 ld (Y) (EnvErrFrames) # Set link 1881 ld (EnvErrFrames) Y # Link frame 1882 ret 1883 1884 (code 'pushCtlFilesY) 1885 ld (Y) (EnvCtlFrames) # Set link 1886 ld (EnvCtlFrames) Y # Link frame 1887 ret 1888 1889 (code 'popInFiles) # C 1890 ld C (EnvInFrames) # Get InFrames 1891 null (C II) # 'pid'? 1892 if nz # Yes 1893 cc close((C I)) # Close 'fd' 1894 ld A (C I) # Close input file 1895 call closeInFileA 1896 call waitFileC # Wait for pipe process if necessary 1897 else 1898 ld A (InFile) # Current InFile? 1899 null A 1900 if nz # Yes 1901 ld (A III) (Chr) # Save Chr in next 1902 end 1903 end 1904 ld (Get_A) (C III) # Retrieve 'get' 1905 ld C (C) # Get link 1906 ld (EnvInFrames) C # Restore InFrames 1907 null C # Any? 1908 if z # No 1909 ld A ((InFiles)) # InFiles[0] (stdin) 1910 else 1911 ld A (C I) # Get 'fd' 1912 shl A 3 # Vector index 1913 add A (InFiles) 1914 ld A (A) # Get previous InFile 1915 end 1916 ld (InFile) A # Set InFile 1917 null A # Any? 1918 if nz # Yes 1919 ld A (A III) # Get 'next' 1920 else 1921 ld A -1 1922 end 1923 ld (Chr) A # Save in 'Chr' 1924 ret 1925 1926 (code 'popOutFiles) # C 1927 ld A (OutFile) # Flush OutFile 1928 call flushA_F 1929 ld C (EnvOutFrames) # Get OutFrames 1930 null (C II) # 'pid'? 1931 if nz # Yes 1932 cc close((C I)) # Close 'fd' 1933 ld A (C I) # Close input file 1934 call closeOutFileA 1935 call waitFileC # Wait for pipe process if necessary 1936 end 1937 ld (PutB) (C III) # Retrieve 'put' 1938 ld C (C) # Get link 1939 ld (EnvOutFrames) C # Restore OutFrames 1940 null C # Any? 1941 if z # No 1942 ld A ((OutFiles) I) # OutFiles[1] (stdout) 1943 else 1944 ld A (C I) # Get 'fd' 1945 shl A 3 # Vector index 1946 add A (OutFiles) 1947 ld A (A) # Get previous OutFile 1948 end 1949 ld (OutFile) A # Set OutFile 1950 ret 1951 1952 (code 'popErrFiles) # C 1953 ld C (EnvErrFrames) # Get ErrFrames 1954 cc dup2((C I) 2) # Restore stderr 1955 cc close((C I)) # Close 'fd' 1956 ld (EnvErrFrames) ((EnvErrFrames)) # Restore ErrFrames 1957 ret 1958 1959 (code 'popCtlFiles) # C 1960 ld C (EnvCtlFrames) # Get CtlFrames 1961 null (C I) # 'fd' >= 0? 1962 if ns # Yes 1963 cc close((C I)) # Close 'fd' 1964 else 1965 call currFd_C # Get current fd 1966 ld A (| F_UNLCK (hex "00000")) # Unlock, length 0 1967 call unLockFileAC # Unlock 1968 end 1969 ld (EnvCtlFrames) ((EnvCtlFrames)) # Restore CtlFrames 1970 ret 1971 1972 # Get full char from input channel 1973 (code 'getChar_A 0) 1974 ld A (Chr) # Get look ahead 1975 cmp B (hex "FF") # Special "top" character? 1976 if ne # No 1977 cmp B 128 # Single byte? 1978 if ge # No 1979 test B (hex "20") # Two bytes? 1980 if z # Yes 1981 and B (hex "1F") # First byte 110xxxxx 1982 shl A 6 # xxxxx000000 1983 push A 1984 else # Three bytes 1985 and B (hex "F") # First byte 1110xxxx 1986 shl A 6 # xxxx000000 1987 push A 1988 call (Get_A) # Get second byte 1989 and B (hex "3F") # 10xxxxxx 1990 or A (S) # Combine 1991 shl A 6 # xxxxxxxxxx000000 1992 ld (S) A 1993 end 1994 call (Get_A) # Get last byte 1995 and B (hex "3F") # 10xxxxxx 1996 or (S) A # Combine 1997 pop A # Get result 1998 end 1999 ret 2000 end 2001 ld A TOP 2002 ret 2003 2004 # Skip White Space and Comments 2005 (code 'skipC_A 0) 2006 ld A (Chr) 2007 null A # EOF? 2008 if ns # No 2009 do 2010 do 2011 cmp B 32 # White space? 2012 while le # Yes 2013 call (Get_A) # Get next 2014 null A # EOF? 2015 js 90 # Yes 2016 loop 2017 cmp A C # Comment char? 2018 while eq # Yes 2019 call (Get_A) 2020 do 2021 cmp B 10 # Linefeed? 2022 while ne #No 2023 null A # EOF? 2024 js 90 # Yes 2025 call (Get_A) 2026 loop 2027 loop 2028 end 2029 90 ret 2030 2031 (code 'comment_A 0) 2032 call (Get_A) 2033 cmp B (char "{") 2034 if ne # No 2035 do 2036 cmp B 10 # Linefeed? 2037 while ne #No 2038 null A # EOF? 2039 js 90 # Yes 2040 call (Get_A) 2041 loop 2042 else # Block comment 2043 do 2044 call (Get_A) 2045 null A # EOF? 2046 js 90 # Yes 2047 cmp B (char "}") # End of block comment? 2048 if eq 2049 call (Get_A) 2050 cmp B (char "#") 2051 break eq # Yes 2052 end 2053 loop 2054 call (Get_A) 2055 end 2056 90 ret 2057 2058 (code 'skip_A 0) 2059 ld A (Chr) 2060 do 2061 null A # EOF? 2062 while ns # No 2063 do 2064 cmp B 32 # White space? 2065 while le # Yes 2066 call (Get_A) # Get next 2067 null A # EOF? 2068 js 90 # Yes 2069 loop 2070 cmp B (char "#") # Comment char? 2071 while eq # Yes 2072 call comment_A # Skip comment 2073 loop 2074 90 ret 2075 2076 (code 'testEscA_F 0) 2077 do 2078 null A # EOF? 2079 if s # Yes 2080 clrc # Return NO 2081 ret 2082 end 2083 cmp B (char "\^") # Caret? 2084 if eq # Yes 2085 call (Get_A) # Skip '^' 2086 cmp B (char "@") # At-mark? 2087 jeq badInputErrB # Yes 2088 cmp B (char "?") # Question-mark? 2089 if eq # Yes 2090 ld B 127 # DEL 2091 else 2092 and B 31 # Control-character 2093 end 2094 10 setc # Return YES 2095 ret 2096 end 2097 cmp B (char "\\") # Backslash? 2098 jnz 10 # No 2099 call (Get_A) # Skip '\' 2100 cmp B 10 # Newline? 2101 jnz 10 # No 2102 do 2103 call (Get_A) # Skip white space 2104 cmp B 32 2105 continue eq 2106 cmp B 9 2107 until ne 2108 loop 2109 2110 (code 'anonymousX_FE 0) 2111 ld C 0 2112 call symByteCX_FACX # First byte 2113 cmp B (char "$") # Starting with '$'? 2114 jne Ret # No 2115 call symByteCX_FACX # Second byte 2116 cmp B (char "1") # >= '1'? 2117 if ge # Yes 2118 cmp B (char "7") # <= '7'? 2119 if le # Yes 2120 sub B (char "0") # Digit 2121 ld E A # Calculate number 2122 call symByteCX_FACX # Third byte 2123 do 2124 cmp B (char "0") # >= '0'? 2125 while ge # Yes 2126 cmp B (char "7") # <= '7'? 2127 while le # Yes 2128 shl E 3 # Times 8 2129 sub B (char "0") # Digit 2130 add E A # Add to result 2131 call symByteCX_FACX # Next byte? 2132 if z # No 2133 shl E 4 # Make symbol pointer 2134 or E SYM 2135 setz 2136 ret 2137 end 2138 loop 2139 end 2140 end 2141 ret 2142 2143 (code 'rdAtomBY_E) # X 2144 link 2145 push (EnvIntern) # <L II> Current symbol namespace 2146 push ZERO # <L I> Result 2147 ld C 4 # Build name 2148 ld X S 2149 link 2150 call byteSymBCX_CX # Pack first char 2151 ld A Y # Get second 2152 do 2153 null A # EOF? 2154 while ns # No 2155 cmp B (char "~") # Tilde? 2156 if eq # Yes 2157 ld X (L I) # Get name so far 2158 call findSymX_E # Find or create symbol 2159 ld X 0 # Clear error context 2160 atom (E) # Value must be a pair 2161 jnz symNsErrEX 2162 ld (EnvIntern) E # Switch symbol namespace 2163 ld C 4 # Build new name 2164 lea X (L I) # Safe 2165 ld (X) ZERO 2166 else 2167 memb Delim "(DelimEnd-Delim)" # Delimiter? 2168 break eq # Yes 2169 cmp B (char "\\") # Backslash? 2170 if eq # Yes 2171 call (Get_A) # Get next char 2172 end 2173 call byteSymBCX_CX # Pack char 2174 end 2175 call (Get_A) # Get next 2176 loop 2177 ld X (L I) # Get name 2178 ld A (Scl) # Scale 2179 shr A 4 # Normalize 2180 ld (Sep3) 0 # Thousand separator 2181 ld (Sep0) (char ".") # Decimal separator 2182 call symToNumXA_FE # Legal number? 2183 if nc # No 2184 ld X (L I) # Get name 2185 call anonymousX_FE # Anonymous symbol? 2186 if ne # No 2187 ld X (L I) # Get name 2188 call findSymX_E # Find or create symbol 2189 end 2190 end 2191 ld (EnvIntern) (L II) # Restore current symbol namespace 2192 drop 2193 ret 2194 2195 (code 'rdList_E) 2196 cmp S (StkLimit) # Stack check 2197 jlt stkErr 2198 call (Get_A) # Skip paren 2199 do 2200 call skip_A # and white space 2201 cmp B (char ")") # Empty list? 2202 if eq # Yes 2203 call (Get_A) # Skip paren 2204 ld E Nil # Return NIL 2205 ret 2206 end 2207 cmp B (char "]") # Empty list? 2208 jz retNil # Yes 2209 cmp B (char "~") # Tilde? 2210 if ne # No 2211 ld A 0 2212 call readA_E # Read expression 2213 call consE_A # Make a pair 2214 ld (A) E 2215 ld (A CDR) Nil 2216 link 2217 push A # <L I> Save it 2218 link 2219 ld E A # Keep last cell in E 2220 jmp 10 # Exit 2221 end 2222 call (Get_A) # Skip tilde 2223 ld A 0 2224 call readA_E # Read expression 2225 link 2226 push E # <L I> Save it 2227 link 2228 eval # Evaluate 2229 ld (L I) E # Save again 2230 atom E # Pair? 2231 if z # Yes 2232 do 2233 atom (E CDR) # Find last cell 2234 while z 2235 ld E (E CDR) 2236 loop 2237 jmp 10 # Exit 2238 end 2239 drop # Continue 2240 loop 2241 10 do 2242 call skip_A # Skip white space 2243 cmp B (char ")") # Done? 2244 if eq # Yes 2245 call (Get_A) # Skip paren 2246 jmp 90 # Done 2247 end 2248 cmp B (char "]") # Done? 2249 jz 90 # Yes 2250 cmp B (char ".") # Dotted pair? 2251 if eq # Yes 2252 call (Get_A) # Skip dot 2253 memb Delim "(DelimEnd-Delim)" # Delimiter? 2254 if eq # Yes 2255 call skip_A # and white space 2256 cmp B (char ")") # Circular list? 2257 jz 20 # Yes 2258 cmp B (char "]") 2259 if eq # Yes 2260 20 ld (E CDR) (L I) # Store list in CDR 2261 else 2262 push E 2263 ld A 0 2264 call readA_E # Read expression 2265 ld A E 2266 pop E 2267 ld (E CDR) A # Store in CDR 2268 end 2269 call skip_A # Skip white space 2270 cmp B (char ")") # Done? 2271 if eq # Yes 2272 call (Get_A) # Skip paren 2273 jmp 90 # Done 2274 end 2275 cmp B (char "]") 2276 jz 90 # Done 2277 ld E (L I) # Else bad dottet pair 2278 jmp badDotErrE 2279 end 2280 push X 2281 push Y 2282 push E 2283 ld Y A # Save first char 2284 ld B (char ".") # Restore dot 2285 call rdAtomBY_E # Read atom 2286 call consE_A # Make a pair 2287 ld (A) E 2288 ld (A CDR) Nil 2289 pop E 2290 ld (E CDR) A # Store in last cell 2291 ld E A 2292 pop Y 2293 pop X 2294 else 2295 cmp B (char "~") # Tilde? 2296 if ne # No 2297 push E 2298 ld A 0 2299 call readA_E # Read expression 2300 call consE_A # Make a pair 2301 ld (A) E 2302 ld (A CDR) Nil 2303 pop E 2304 ld (E CDR) A # Store in last cell 2305 ld E A 2306 else 2307 call (Get_A) # Skip tilde 2308 push E 2309 ld A 0 2310 call readA_E # Read expression 2311 ld A (S) 2312 ld (A CDR) E # Save in last cell 2313 eval # Evaluate 2314 pop A 2315 ld (A CDR) E # Store in last cell 2316 ld E A 2317 do 2318 atom (E CDR) # Pair? 2319 while z # Yes 2320 ld E (E CDR) # Find last cell 2321 loop 2322 end 2323 end 2324 loop 2325 90 ld E (L I) # Return list 2326 drop 2327 ret 2328 2329 (code 'readC_E) 2330 null (Chr) # Empty channel? 2331 if z # Yes 2332 call (Get_A) # Fill 'Chr' 2333 end 2334 cmp C (Chr) # Terminator? 2335 if eq # Yes 2336 ld E Nil # Return 'NIL' 2337 ret 2338 end 2339 ld A 1 # Read top level expression 2340 2341 (code 'readA_E) 2342 push X 2343 push Y 2344 push A # <S> Top flag 2345 call skip_A 2346 null A # EOF? 2347 if s # Yes 2348 null (S) # Top? 2349 jz eofErr # No: Error 2350 ld E Nil # Yes: Return NIL 2351 jmp 99 2352 end 2353 null (S) # Top? 2354 if nz # Yes 2355 ld C (InFile) # And reading file? 2356 null C 2357 if nz # Yes 2358 ld (C V) (C IV) # src = line 2359 end 2360 end 2361 cmp B (char "(") # Opening a list? 2362 if eq # Yes 2363 call rdList_E # Read it 2364 null (S) # Top? 2365 if nz # Yes 2366 cmp (Chr) (char "]") # And super-parentheses? 2367 if eq # Yes 2368 call (Get_A) # Skip ']' 2369 end 2370 end 2371 jmp 99 # Return list 2372 end 2373 cmp B (char "[") # Opening super-list? 2374 if eq # Yes 2375 call rdList_E # Read it 2376 cmp (Chr) (char "]") # Matching super-parentheses? 2377 jnz suparErrE # Yes: Error 2378 call (Get_A) # Else skip ']' 2379 jmp 99 2380 end 2381 cmp B (char "'") # Quote? 2382 if eq # Yes 2383 call (Get_A) # Skip "'" 2384 ld A (S) 2385 call readA_E # Read expression 2386 ld C E 2387 call consC_E # Cons with 'quote' 2388 ld (E) Quote 2389 ld (E CDR) C 2390 jmp 99 2391 end 2392 cmp B (char ",") # Comma? 2393 if eq # Yes 2394 call (Get_A) # Skip ',' 2395 ld A (S) 2396 call readA_E # Read expression 2397 ld X Uni # Maintain '*Uni' index 2398 cmp (X) TSym # Disabled? 2399 jeq 99 # Yes 2400 link 2401 push E # Else save expression 2402 link 2403 ld Y E 2404 call idxPutXY_E 2405 atom E # Pair? 2406 if z # Yes 2407 ld E (E) # Return index entry 2408 else 2409 ld E Y # 'read' value 2410 end 2411 drop 2412 jmp 99 2413 end 2414 cmp B (char "`") # Backquote? 2415 if eq # Yes 2416 call (Get_A) # Skip '`' 2417 ld A (S) 2418 call readA_E # Read expression 2419 link 2420 push E # Save it 2421 link 2422 eval # Evaluate 2423 drop 2424 jmp 99 2425 end 2426 cmp B (char "\"") # String? 2427 if eq # Yes 2428 call (Get_A) # Skip '"' 2429 cmp B (char "\"") # Empty string? 2430 if eq # Yes 2431 call (Get_A) # Skip '"' 2432 ld E Nil # Return NIL 2433 jmp 99 2434 end 2435 call testEscA_F 2436 jnc eofErr 2437 link 2438 push ZERO # <L I> Result 2439 ld C 4 # Build name 2440 ld X S 2441 link 2442 do 2443 call byteSymBCX_CX # Pack char 2444 call (Get_A) # Get next 2445 cmp B (char "\"") # Done? 2446 while ne 2447 call testEscA_F 2448 jnc eofErr 2449 loop 2450 call (Get_A) # Skip '"' 2451 ld X (L I) # Get name 2452 ld Y Transient 2453 ld E 0 # No symbol yet 2454 call internEXY_FE # Check transient symbol 2455 drop 2456 jmp 99 2457 end 2458 cmp B (char "{") # External symbol? 2459 if eq # Yes 2460 call (Get_A) # Skip '{' 2461 cmp B (char "}") # Empty? 2462 if eq # Yes 2463 call (Get_A) # Skip '}' 2464 call cons_E # New symbol 2465 ld (E) ZERO # anonymous 2466 or E SYM 2467 ld (E) Nil # Set to NIL 2468 jmp 99 2469 end 2470 ld E 0 # Init file number 2471 do 2472 cmp B (char "@") # File done? 2473 while ge # No 2474 cmp B (char "O") # In A-O range? 2475 jgt badInputErrB # Yes 2476 sub B (char "@") 2477 shl E 4 # Add to file number 2478 add E A 2479 call (Get_A) # Get next char 2480 loop 2481 cmp B (char "0") # Octal digit? 2482 jlt badInputErrB 2483 cmp B (char "7") 2484 jgt badInputErrB # No 2485 sub B (char "0") 2486 zxt 2487 ld C A # Init object ID 2488 do 2489 call (Get_A) # Get next char 2490 cmp B (char "}") # Done? 2491 while ne # No 2492 cmp B (char "0") # Octal digit? 2493 jlt badInputErrB 2494 cmp B (char "7") 2495 jgt badInputErrB # No 2496 sub B (char "0") 2497 shl C 3 # Add to object ID 2498 add C A 2499 loop 2500 call (Get_A) # Skip '}' 2501 call extNmCE_X # Build external symbol name 2502 call externX_E # New external symbol 2503 jmp 99 2504 end 2505 cmp B (char ")") # Closing paren? 2506 jeq badInputErrB # Yes 2507 cmp B (char "]") 2508 jeq badInputErrB 2509 cmp B (char "~") # Tilde? 2510 jeq badInputErrB # Yes 2511 cmp B (char "\\") # Backslash? 2512 if eq # Yes 2513 call (Get_A) # Get next char 2514 end 2515 ld Y A # Save in Y 2516 call (Get_A) # Next char 2517 xchg A Y # Get first char 2518 call rdAtomBY_E # Read atom 2519 99 pop A 2520 pop Y 2521 pop X 2522 ret 2523 2524 (code 'tokenCE_E) # X 2525 null (Chr) # Look ahead char? 2526 if z # No 2527 call (Get_A) # Get next 2528 end 2529 call skipC_A # Skip white space and comments 2530 null A # EOF? 2531 js retNull # Yes 2532 cmp B (char "\"") # String? 2533 if eq # Yes 2534 call (Get_A) # Skip '"' 2535 cmp B (char "\"") # Empty string? 2536 if eq # Yes 2537 call (Get_A) # Skip '"' 2538 ld E Nil # Return NIL 2539 ret 2540 end 2541 call testEscA_F 2542 jnc retNil 2543 call mkCharA_A # Make single character 2544 call consA_X # Cons it 2545 ld (X) A 2546 ld (X CDR) Nil # with NIL 2547 link 2548 push X # <L I> Result 2549 link 2550 do 2551 call (Get_A) # Get next 2552 cmp B (char "\"") # Done? 2553 if eq # Yes 2554 call (Get_A) # Skip '"' 2555 break T 2556 end 2557 call testEscA_F 2558 while c 2559 call mkCharA_A # Make char 2560 call consA_C # Cons it 2561 ld (C) A 2562 ld (C CDR) Nil # with NIL 2563 ld (X CDR) C # Append to result 2564 ld X C 2565 loop 2566 ld E (L I) # Get result 2567 drop 2568 ret 2569 end 2570 cmp B (char "0") # Digit? 2571 if ge 2572 cmp B (char "9") 2573 if le # Yes 2574 link 2575 push ZERO # <L I> Result 2576 ld C 4 # Build digit string 2577 ld X S 2578 link 2579 do 2580 call byteSymBCX_CX # Pack char 2581 call (Get_A) # Get next 2582 cmp B (char ".") # Dot? 2583 continue eq # Yes 2584 cmp B (char "0") # Or digit? 2585 while ge 2586 cmp B (char "9") 2587 until gt # No 2588 ld X (L I) # Get name 2589 ld A (Scl) # Scale 2590 shr A 4 # Normalize 2591 drop 2592 ld (Sep3) 0 # Thousand separator 2593 ld (Sep0) (char ".") # Decimal separator 2594 jmp symToNumXA_FE # Convert to number 2595 end 2596 end 2597 push Y 2598 push Z 2599 ld Y A # Keep char in Y 2600 call bufStringE_SZ # <S I/IV> Stack buffer 2601 push A # <S /III> String length 2602 slen (S) (S I) 2603 ld A Y # Restore char 2604 cmp B (char "+") # Sign? 2605 jeq 90 2606 cmp B (char "-") 2607 jeq 90 # Yes 2608 cmp B (char "a") # Lower case letter? 2609 if ge 2610 cmp B (char "z") 2611 jle 10 # Yes 2612 end 2613 cmp B (char "A") # Upper case letter? 2614 if ge 2615 cmp B (char "Z") 2616 jle 10 # Yes 2617 end 2618 cmp B (char "\\") # Backslash? 2619 if eq # Yes 2620 call (Get_A) # Use next char 2621 jmp 10 2622 end 2623 memb (S I) (S) # Member of character set? 2624 if eq # Yes 2625 10 link 2626 push ZERO # <L I> Result 2627 ld C 4 # Build name 2628 ld X S 2629 link 2630 do 2631 call byteSymBCX_CX # Pack char 2632 call (Get_A) # Get next 2633 cmp B (char "a") # Lower case letter? 2634 if ge 2635 cmp B (char "z") 2636 continue le # Yes 2637 end 2638 cmp B (char "A") # Upper case letter? 2639 if ge 2640 cmp B (char "Z") 2641 continue le # Yes 2642 end 2643 cmp B (char "0") # Digit? 2644 if ge 2645 cmp B (char "9") 2646 continue le # Yes 2647 end 2648 cmp B (char "\\") # Backslash? 2649 if eq # Yes 2650 call (Get_A) # Use next char 2651 continue T 2652 end 2653 memb (S IV) (S III) # Member of character set? 2654 until ne # No 2655 ld X (L I) # Get name 2656 call findSymX_E # Find or create symbol 2657 drop 2658 else 2659 90 call getChar_A 2660 call mkCharA_A # Return char 2661 ld E A 2662 call (Get_A) # Skip it 2663 end 2664 ld S Z # Drop buffer 2665 pop Z 2666 pop Y 2667 ret 2668 2669 # (read ['sym1 ['sym2]]) -> any 2670 (code 'doRead 2) 2671 atom (E CDR) # Arg? 2672 if nz # No 2673 ld C 0 # No terminator 2674 call readC_E # Read item 2675 else 2676 push X 2677 ld X (E CDR) # Args 2678 ld E (X) # Eval 'sym1' 2679 eval 2680 sym E # Need symbol 2681 jz symErrEX 2682 link 2683 push E # <L I> Safe 2684 link 2685 ld E ((X CDR)) # Eval 'sym2' 2686 eval 2687 sym E # Need symbol 2688 jz symErrEX 2689 call firstCharE_A # Get first character 2690 ld C A # as comment char 2691 ld E (L I) # Get Set of characters 2692 call tokenCE_E # Read token 2693 null E # Any? 2694 ldz E Nil # No 2695 drop 2696 pop X 2697 end 2698 cmp (Chr) 10 # Hit linefeed? 2699 if eq # Yes 2700 cmp (InFile) ((InFiles)) # Current InFile on stdin? 2701 if eq # Yes 2702 ld (Chr) 0 # Clear it 2703 end 2704 end 2705 ret 2706 2707 # Check if input channel has data 2708 (code 'inReadyC_F 0) 2709 ld A C 2710 shl A 3 # Vector index 2711 cmp A (InFDs) # 'fd' >= 'InFDs'? 2712 jge ret # No 2713 add A (InFiles) # Get vector 2714 ld A (A) # Slot? 2715 null A # Any? 2716 jz ret # No 2717 cmp (A I) (A II) # Data in buffer ('ix' < 'cnt')? 2718 ret # Yes: Return 'c' 2719 2720 (code 'fdSetCL_X 0) 2721 ld X C # Get fd 2722 and C 7 # Shift count 2723 ld B 1 # Bit mask 2724 shl B C # Shift it 2725 shr X 3 # Offset 2726 ? (not *LittleEndian) 2727 xor X 7 # Invert byte offset 2728 = 2729 add X L # Point to byte 2730 ret 2731 2732 (code 'fdRdSetCZL 0) # X 2733 cmp Z C # Maintain maximum 2734 ldc Z C 2735 call fdSetCL_X 2736 or (X (- (+ V FD_SET))) B # FD_SET in RdSet 2737 ret 2738 2739 (code 'fdWrSetCZL 0) # X 2740 cmp Z C # Maintain maximum 2741 ldc Z C 2742 call fdSetCL_X 2743 or (X (- (+ V FD_SET FD_SET))) B # FD_SET in WrSet 2744 ret 2745 2746 (code 'rdSetCL_F 0) # X 2747 call fdSetCL_X 2748 test (X (- (+ V FD_SET))) B # FD_SET in RdSet 2749 ret # Return 'nz' 2750 2751 (code 'wrSetCL_F 0) # X 2752 call fdSetCL_X 2753 test (X (- (+ V FD_SET FD_SET))) B # FD_SET in WrSet 2754 ret # Return 'nz' 2755 2756 (code 'rdSetRdyCL_F 0) # X 2757 ld A C 2758 shl A 3 # Vector index 2759 cmp A (InFDs) # 'fd' >= 'InFDs'? 2760 jge rdSetCL_F # Yes 2761 add A (InFiles) # Get vector 2762 ld A (A) # Slot? 2763 null A # Any? 2764 jz rdSetCL_F # No 2765 cmp (A I) (A II) # Data in buffer ('ix' < 'cnt')? 2766 if z # No 2767 push A 2768 call rdSetCL_F 2769 pop C 2770 if nz # Yes 2771 call slowNbC_FA # Try non-blocking read 2772 jge retnz 2773 setz 2774 end 2775 end 2776 ret 2777 2778 (code 'waitFdCEX_A) 2779 push Y 2780 push Z 2781 push (EnvTask) # <L IV> Save task list 2782 link 2783 push (At) # <L II> '@' 2784 push ZERO # <L I> '*Run' 2785 link 2786 push C # <L -I> File descriptor 2787 push E # <L -II> Milliseconds 2788 push E # <L -III> Timeout 2789 sub S (+ II FD_SET FD_SET) # <L -IV> Microseconds 2790 # <L -V> Seconds 2791 # <L - (V + FD_SET)> RdSet 2792 # <L - (V + FD_SET - FD_SET)> WrSet 2793 cmp S (StkLimit) # Stack check 2794 jlt stkErrX 2795 do 2796 ld B 0 # Zero fd sets 2797 mset (S) (+ FD_SET FD_SET) 2798 push X # Save context 2799 ld Z 0 # Maximum fd 2800 ld C (L -I) # File descriptor 2801 null C # Positive? 2802 if ns # Yes 2803 call inReadyC_F # Ready? 2804 if c # Yes 2805 ld (L -III) 0 # Timeout = 0 2806 else 2807 call fdRdSetCZL 2808 end 2809 end 2810 ld Y (Run) # Get '*Run' 2811 ld (L I) Y # Save it 2812 ld (EnvTask) Y 2813 do 2814 atom Y # '*Run' elements? 2815 while z # Yes 2816 ld E (Y) # Next element 2817 ld A (L IV) # memq in saved tasklist? 2818 do 2819 atom A # End of tasklist? 2820 while z # No 2821 cmp E (A) # Member? 2822 jeq 10 # Yes: Skip 2823 ld A (A CDR) 2824 loop 2825 ld C (E) # Get fd or timeout value 2826 shr C 4 # Negative? 2827 if c # Yes 2828 ld A ((E CDR)) # Get CADR 2829 shr A 4 # Normalize 2830 cmp A (L -III) # Less than current timeout? 2831 if lt # Yes 2832 ld (L -III) A # Set new timeout 2833 end 2834 else 2835 cmp C (L -I) # Different from argument-fd? 2836 if ne # Yes 2837 call inReadyC_F # Ready? 2838 if c # Yes 2839 ld (L -III) 0 # Timeout = 0 2840 else 2841 call fdRdSetCZL 2842 end 2843 end 2844 end 2845 10 ld Y (Y CDR) 2846 loop 2847 ld C (Hear) # RPC listener? 2848 null C 2849 if nz # Yes 2850 cmp C (L -I) # Different from argument-fd? 2851 if ne # Yes 2852 ld A C # Still open? 2853 shl A 3 # Vector index 2854 add A (InFiles) # Get vector 2855 ld A (A) # Slot? 2856 null A # Any? 2857 if nz # Yes 2858 cmp (A I) (A II) # Data in buffer ('ix' < 'cnt')? 2859 if nz # Yes 2860 ld (L -III) 0 # Timeout = 0 2861 else 2862 call fdRdSetCZL 2863 end 2864 end 2865 end 2866 end 2867 ld C (Spkr) # Speaker open? 2868 null C 2869 if nz # Yes 2870 call fdRdSetCZL 2871 ld Y (Child) # Iterate children 2872 ld E (Children) # Count 2873 do 2874 sub E VI # More? 2875 while ge # Yes 2876 null (Y) # 'pid'? 2877 if nz # Yes 2878 ld C (Y I) # Child's 'hear' fd 2879 call fdRdSetCZL 2880 null (Y IV) # Child's buffer count? 2881 if nz # Yes 2882 ld C (Y II) # Child's 'tell' fd 2883 call fdWrSetCZL 2884 end 2885 end 2886 add Y VI # Increment by sizeof(child) 2887 loop 2888 end 2889 pop X # Restore context 2890 inc Z # Maximum fd + 1 2891 ld C 0 # Timeval structure pointer 2892 ld A (L -III) # Timeout value? 2893 null A 2894 if ns # Yes 2895 div 1000 # Calculate seconds (C is zero) 2896 ld (L -V) A 2897 ld A C # and microseconds 2898 mul 1000 2899 ld (L -IV) A 2900 lea C (L -V) # Set timeval structure pointer 2901 ? (<> *TargetOS "Linux") # Non-Linux? 2902 call msec_A # Get milliseconds 2903 ld E A # into E 2904 = 2905 end 2906 do 2907 cc select(Z &(S FD_SET) S 0 C) # Wait for event or timeout 2908 nul4 # OK? 2909 while s # No 2910 call errno_A 2911 cmp A EINTR # Interrupted? 2912 if ne # No 2913 ld (Run) Nil # Clear '*Run' 2914 jmp selectErrX 2915 end 2916 null (Signal) # Signal? 2917 if nz # Yes 2918 call sighandlerX 2919 end 2920 loop 2921 null C # Timeval structure pointer? 2922 if nz # Yes 2923 ? (= *TargetOS "Linux") # Linux? 2924 ld A (L -V) # Seconds not slept 2925 mul 1000 # Calculate milliseconds 2926 ld E A 2927 ld A (L -IV) # Microseconds not slept 2928 div 1000 # Calculate milliseconds 2929 add A E # Milliseconds not slept 2930 sub (L -III) A # Time difference 2931 = 2932 ? (<> *TargetOS "Linux") # Else 2933 call msec_A # Get milliseconds 2934 sub A E # Time difference 2935 ld (L -III) A # Save it 2936 = 2937 end 2938 push X # Save context again 2939 null (Spkr) # Speaker open? 2940 if nz # Yes 2941 inc (EnvProtect) # Protect child communication 2942 ld Y (Child) # Iterate children 2943 ld Z (Children) # Count 2944 do 2945 sub Z VI # More? 2946 while ge # Yes 2947 null (Y) # 'pid'? 2948 if nz # Yes 2949 push Z # Outer loop count 2950 ld C (Y I) # Get child's 'hear' fd 2951 call rdSetCL_F # Ready? 2952 if nz # Yes 2953 ld C (Y I) # Get 'hear' fd again 2954 ld E 4 # Size of PID and count 2955 ld X Buf # Buffer pointer 2956 call rdBytesNbCEX_F # Read count? 2957 if ge # Yes 2958 if z 2959 call clsChildY # Close child 2960 jmp 20 # Continue 2961 end 2962 ld4 (Buf) # PID and size? 2963 null A 2964 if z # No 2965 cmp (Y) (Talking) # Currently active? 2966 if eq # Yes 2967 ld (Talking) 0 # Clear 2968 end 2969 else 2970 sub S PIPE_BUF # <S I> Pipe buffer 2971 push Y # <S> Outer child index 2972 ld C (Y I) # Get 'hear' fd again 2973 ld2 (Buf 2) # Get size 2974 ld E A 2975 lea X (S I) # Buffer pointer 2976 call rdBytesCEX_F # Read data? 2977 if nz # Yes 2978 ld Y (Child) # Iterate children 2979 ld Z (Children) # Count 2980 do 2981 cmp Y (S) # Same as outer loop child? 2982 if ne # No 2983 null (Y) # 'pid'? 2984 if nz # Yes 2985 ld2 (Buf) # Get PID 2986 null A # Any? 2987 jz 15 # Yes 2988 cmp A (Y) # Same as 'pid'? 2989 if eq # Yes 2990 15 ld2 (Buf 2) # Get size 2991 ld C A 2992 lea X (S I) # and data 2993 call wrChildCXY # Write to child 2994 end 2995 end 2996 end 2997 add Y VI # Increment by sizeof(child) 2998 sub Z VI # More? 2999 until z # No 3000 else 3001 call clsChildY # Close child 3002 pop Y 3003 add S PIPE_BUF # Drop 'tell' buffer 3004 jmp 20 # Continue 3005 end 3006 pop Y 3007 add S PIPE_BUF # Drop 'tell' buffer 3008 end 3009 end 3010 end 3011 ld C (Y II) # Get child's 'tell' fd 3012 call wrSetCL_F # Ready? 3013 if nz # Yes 3014 ld C (Y II) # Get 'tell' fd again 3015 ld X (Y V) # Get buffer pointer 3016 add X (Y III) # plus buffer offset 3017 ld4 (X) # Get size 3018 ld E A 3019 add X 4 # Point to data (beyond size) 3020 push E # Keep size 3021 call wrBytesCEX_F # Write data? 3022 pop E 3023 if z # Yes 3024 add E (Y III) # Add size to buffer offset 3025 add E 4 # plus size of size 3026 ld (Y III) E # New buffer offset 3027 add E E # Twice the offset 3028 cmp E (Y IV) # greater or equal to buffer count? 3029 if ge # Yes 3030 sub (Y IV) (Y III) # Decrement count by offset 3031 if nz 3032 ld X (Y V) # Get buffer pointer 3033 add X (Y III) # Add buffer offset 3034 movn ((Y V)) (X) (Y IV) # Copy data 3035 ld A (Y V) # Get buffer pointer 3036 ld E (Y IV) # and new count 3037 call allocAE_A # Shrink buffer 3038 ld (Y V) A # Store 3039 end 3040 ld (Y III) 0 # Clear buffer offset 3041 end 3042 else 3043 call clsChildY # Close child 3044 end 3045 end 3046 20 pop Z 3047 end 3048 add Y VI # Increment by sizeof(child) 3049 loop 3050 null (Talking) # Ready to sync? 3051 if z # Yes 3052 ld C (Spkr) # Get speaker 3053 call rdSetCL_F # Anybody? 3054 if nz # Yes 3055 ld C (Spkr) # Get fd 3056 ld E I # Size of slot 3057 ld X Buf # Buffer pointer 3058 call rdBytesNbCEX_F # Read slot? 3059 if gt # Yes 3060 ld Y (Child) # Get child 3061 add Y (Buf) # in slot 3062 ld A (Y) # 'pid'? 3063 null A 3064 if nz # Yes 3065 ld (Talking) A # Set to talking 3066 ld C 2 # Size of 'TBuf' 3067 ld X TBuf # Buffer pointer 3068 call wrChildCXY # Write to child 3069 end 3070 end 3071 end 3072 end 3073 dec (EnvProtect) 3074 end 3075 ld C (Hear) # RPC listener? 3076 null C 3077 if nz # Yes 3078 cmp C (L -I) # Different from argument-fd? 3079 if ne # Yes 3080 call rdSetRdyCL_F # Ready? 3081 if nz # Yes 3082 call rdHear_FE # Read expression? 3083 if nc # Yes 3084 cmp E TSym # Read 'T'? 3085 if eq # Yes 3086 set (Sync) 1 # Set sync flag 3087 else 3088 link 3089 push E # Save expression 3090 link 3091 call evListE_E # Execute it 3092 drop 3093 end 3094 else 3095 ld A (Hear) 3096 call closeAX # Close 'Hear' 3097 ld A (Hear) 3098 call closeInFileA 3099 ld A (Hear) 3100 call closeOutFileA 3101 ld (Hear) 0 # Clear value 3102 end 3103 end 3104 end 3105 end 3106 ld Y (L I) # Get '*Run' 3107 do 3108 atom Y # More elements? 3109 while z # Yes 3110 ld E (Y) # Next element 3111 ld A (L IV) # memq in saved tasklist? 3112 do 3113 atom A # End of tasklist? 3114 while z # No 3115 cmp E (A) # Member? 3116 jeq 30 # Yes: Skip 3117 ld A (A CDR) 3118 loop 3119 ld C (E) # Get fd or timeout value 3120 shr C 4 # Negative? 3121 if c # Yes 3122 ld C (E CDR) # Get CDR 3123 ld A (C) # and CADR 3124 shr A 4 # Normalize 3125 sub A (L -III) # Subtract time difference 3126 if gt # Not yet timed out 3127 shl A 4 # Make short number 3128 or A CNT 3129 ld (C) A # Store in '*Run' 3130 else # Timed out 3131 ld A (E) # Timeout value 3132 ld (C) A # Store in '*Run' 3133 ld (At) (E) # Set to CAR 3134 ld Z (C CDR) # Run body 3135 prog Z 3136 end 3137 else 3138 cmp C (L -I) # Different from argument-fd? 3139 if ne # Yes 3140 call rdSetRdyCL_F # Ready? 3141 if nz # Yes 3142 ld (At) (E) # Set to fd 3143 ld Z (E CDR) # Run body 3144 prog Z 3145 end 3146 end 3147 end 3148 30 ld Y (Y CDR) 3149 loop 3150 pop X # Restore context 3151 null (Signal) # Signal? 3152 if nz # Yes 3153 call sighandlerX 3154 end 3155 ld A (L -II) # Milliseconds 3156 or A A 3157 if nsz # Greater zero 3158 sub A (L -III) # Subtract time difference 3159 if s # < 0 3160 xor A A # Set to zero, 'z' 3161 end 3162 ld (L -II) A 3163 end 3164 while nz # Milliseconds non-zero 3165 ld (L -III) A # Set timeout 3166 ld C (L -I) # File descriptor 3167 null C # Positive? 3168 while ns # Yes 3169 call rdSetRdyCL_F # Ready? 3170 until nz # Yes 3171 ld (At) (L II) # Restore '@' 3172 ld A (L -II) # Return milliseconds 3173 drop 3174 pop (EnvTask) 3175 pop Z 3176 pop Y 3177 ret 3178 3179 # (wait ['cnt] . prg) -> any 3180 (code 'doWait 2) 3181 push X 3182 push Y 3183 push Z 3184 ld X E 3185 ld Y (E CDR) # Y on args 3186 ld E (Y) # Eval 'cnt' 3187 eval 3188 cmp E Nil # None? 3189 if eq # Yes 3190 push -1 # Wait infinite 3191 else 3192 call xCntEX_FE # Get 'cnt' 3193 push E # <S> Milliseconds 3194 end 3195 ld Y (Y CDR) # Y on 'prg' 3196 do 3197 ld Z Y # Run 'prg' 3198 prog Z 3199 cmp E Nil # NIL? 3200 while eq # Yes 3201 ld C -1 # No file descriptor 3202 ld E (S) # Milliseconds 3203 call waitFdCEX_A # Wait for events 3204 null A # Timeout? 3205 if z # Yes 3206 prog Y # Run 'prg' 3207 break T 3208 end 3209 ld (S) A # New milliseconds 3210 loop 3211 add S I # Drop milliseconds 3212 pop Z 3213 pop Y 3214 pop X 3215 ret 3216 3217 # (sync) -> flg 3218 (code 'doSync 2) 3219 null (Mic) # No 'mic' channel? 3220 jz retNil # Yes 3221 null (Hear) # No 'hear' channel? 3222 jz retNil # Yes 3223 nul (Sync) # Already synchronized? 3224 jnz retT # Yes 3225 push X 3226 ld X E 3227 ld E Slot # Buffer pointer 3228 ld C I # Count 3229 do 3230 cc write((Mic) E C) # Write 'Slot' to 'Mic' 3231 null A # OK? 3232 if ns # Yes 3233 sub C A # Decrement count 3234 break z # Done 3235 add E A # Increment buffer pointer 3236 else 3237 call errno_A 3238 cmp A EINTR # Interrupted? 3239 jne wrSyncErrX # No 3240 null (Signal) # Signal? 3241 if nz # Yes 3242 call sighandlerX 3243 end 3244 end 3245 loop 3246 set (Sync) 0 # Clear sync flag 3247 do 3248 ld C -1 # No file descriptor 3249 ld E C # Wait infinite 3250 call waitFdCEX_A # Wait for events 3251 nul (Sync) # Synchronized? 3252 until nz # Yes 3253 ld E TSym # Return T 3254 pop X 3255 ret 3256 3257 # (hear 'cnt) -> cnt 3258 (code 'doHear 2) 3259 push X 3260 ld X E 3261 ld E ((E CDR)) # E on arg 3262 eval # Eval it 3263 cnt E # # Short number? 3264 jz cntErrEX # No 3265 ld C E # Get fd 3266 shr C 4 # Normalize 3267 jc badFdErrEX # Negative 3268 ld A C # Keep 'fd' in C 3269 shl A 3 # Vector index 3270 cmp A (InFDs) # 'fd' >= 'InFDs'? 3271 jge badFdErrEX # Yes 3272 add A (InFiles) # Get vector 3273 ld A (A) # Slot? 3274 null A # Any? 3275 jz badFdErrEX # No 3276 ld A (Hear) # Current value? 3277 null A 3278 if nz # Yes 3279 call closeAX # Close 'Hear' 3280 ld A (Hear) 3281 call closeInFileA 3282 ld A (Hear) 3283 call closeOutFileA 3284 end 3285 ld (Hear) C # Set new value 3286 pop X 3287 ret 3288 3289 # (tell ['cnt] 'sym ['any ..]) -> any 3290 (code 'doTell 2) 3291 ld A (Tell) # RPC? 3292 or A (Children) 3293 jz retNil # No 3294 push X 3295 push Y 3296 push Z 3297 ld X (E CDR) # Args 3298 atom X # Any? 3299 if nz # No 3300 call unsync # Release sync 3301 ld E Nil # Return NIL 3302 else 3303 push (TellBuf) # Save current 'tell' env 3304 sub S PIPE_BUF # New 'tell' buffer 3305 ld Z S # Buffer pointer 3306 ld E (X) # Eval first argument 3307 eval 3308 num E # PID argument? 3309 if z # No 3310 push 0 # Send to all 3311 else 3312 shr E 4 # Normalize PID 3313 push E # Save it 3314 ld X (X CDR) # Next arg 3315 ld E (X) # Eval 3316 eval 3317 end 3318 call tellBegZ_Z # Start 'tell' message 3319 do 3320 ld Y E # Keep result 3321 call prTellEZ # Print to 'tell' 3322 ld X (X CDR) # More args? 3323 atom X 3324 while z # Yes 3325 ld E (X) # Eval next 3326 eval 3327 loop 3328 pop A # Get PID 3329 call tellEndAZ # Close 'tell' 3330 add S PIPE_BUF # Drop 'tell' buffer 3331 pop (TellBuf) 3332 ld E Y # Get result 3333 end 3334 pop Z 3335 pop Y 3336 pop X 3337 ret 3338 3339 (code 'fdSetC_Y 0) 3340 ld Y (C) # Get fd 3341 and Y 7 # Shift count 3342 ld B 1 # Bit mask 3343 shl B Y # Shift it 3344 ld Y (C) # Get fd again 3345 shr Y 3 # Offset 3346 add Y S # Pointer to byte minus I 3347 ret 3348 3349 # (poll 'cnt) -> cnt | NIL 3350 (code 'doPoll 2) 3351 push X 3352 ld X E 3353 ld E ((E CDR)) # E on arg 3354 eval # Eval it 3355 ld A E # Keep 3356 call xCntEX_FE # Get fd 3357 xchg A E 3358 null A # fd < 0? 3359 js badFdErrEX # Yes 3360 ld C A 3361 shl C 3 # Vector index 3362 cmp C (InFDs) # 'fd' >= 'InFDs'? 3363 jge badFdErrEX # Yes 3364 ld C A # Readable input file? 3365 shl C 3 # Vector index 3366 add C (InFiles) # Get vector 3367 ld C (C) # Slot? 3368 null C # Any? 3369 ldz E Nil # No: Return NIL 3370 if nz 3371 push Y 3372 sub S (+ II FD_SET) # <S FD_SET> Timeval, <S> RdSet 3373 do 3374 cmp (C I) (C II) # Data in buffer ('ix' < 'cnt')? 3375 while z # No 3376 ld B 0 # Zero fd set and timeval 3377 mset (S) (+ II FD_SET) 3378 call fdSetC_Y 3379 or (Y I) B # FD_SET in RdSet 3380 ld Y (C) # fd + 1 3381 inc Y 3382 do 3383 cc select(Y S 0 0 &(S FD_SET)) # Check 3384 nul4 # OK? 3385 while s # No 3386 call errno_A 3387 cmp A EINTR # Interrupted? 3388 if ne # No 3389 ld (Run) Nil # Clear '*Run' 3390 jmp selectErrX 3391 end 3392 loop 3393 call fdSetC_Y 3394 test (Y I) B # FD_SET in RdSet 3395 ldz E Nil # No: Return NIL 3396 while nz 3397 call slowNbC_FA # Try non-blocking read 3398 until ge 3399 add S (+ II FD_SET) 3400 pop Y 3401 end 3402 pop X 3403 ret 3404 3405 # (key ['cnt]) -> sym 3406 (code 'doKey 2) 3407 push X 3408 ld X E 3409 ld E ((E CDR)) # E on arg 3410 eval # Eval it 3411 cmp E Nil # None? 3412 if eq # Yes 3413 ld E -1 # Wait infinite 3414 else 3415 call xCntEX_FE # Get milliseconds 3416 end 3417 call flushAll # Flush all output channels 3418 call setRaw # Set terminal to raw mode 3419 ld C 0 # Standard input 3420 call waitFdCEX_A # Wait for events 3421 null A # Timeout? 3422 if nz # No 3423 call stdinByte_A # Read first byte 3424 cmp B (hex "FF") # Special "top" character? 3425 if ne # No 3426 cmp B 128 # Single byte? 3427 if ge # No 3428 test B (hex "20") # Two bytes? 3429 if z # Yes 3430 and B (hex "1F") # First byte 110xxxxx 3431 shl A 6 # xxxxx000000 3432 push A 3433 else # Three bytes 3434 and B (hex "F") # First byte 1110xxxx 3435 shl A 6 # xxxx000000 3436 push A 3437 call stdinByte_A # Read second byte 3438 and B (hex "3F") # 10xxxxxx 3439 or A (S) # Combine 3440 shl A 6 # xxxxxxxxxx000000 3441 ld (S) A 3442 end 3443 call stdinByte_A # Read last byte 3444 and B (hex "3F") # 10xxxxxx 3445 or (S) A # Combine 3446 pop A # Get result 3447 end 3448 else 3449 ld A TOP 3450 end 3451 call mkCharA_A # Return char 3452 ld E A 3453 pop X 3454 ret 3455 end 3456 ld E Nil 3457 pop X 3458 ret 3459 3460 # (peek) -> sym 3461 (code 'doPeek 2) 3462 ld A (Chr) # Look ahead char? 3463 null A 3464 if z # No 3465 call (Get_A) # Get next 3466 end 3467 null A # EOF? 3468 js retNil # Yes 3469 call mkCharA_A # Return char 3470 ld E A 3471 ret 3472 3473 # (char) -> sym 3474 # (char 'cnt) -> sym 3475 # (char T) -> sym 3476 # (char 'sym) -> cnt 3477 (code 'doChar 2) 3478 push X 3479 ld X E 3480 ld E (E CDR) # Any args? 3481 atom E 3482 if nz # No 3483 ld A (Chr) # Look ahead char? 3484 null A 3485 if z # No 3486 call (Get_A) # Get next 3487 end 3488 null A # EOF? 3489 if ns # No 3490 call getChar_A 3491 call mkCharA_A # Make char 3492 ld E A 3493 call (Get_A) # Get next 3494 else 3495 ld E Nil 3496 end 3497 pop X 3498 ret 3499 end 3500 ld E (E) 3501 eval # Eval arg 3502 cnt E # 'cnt'? 3503 if nz # Yes 3504 ld A E # Get 'cnt' 3505 shr A 4 # Normalize 3506 if nz 3507 call mkCharA_A # Make char 3508 ld E A 3509 else 3510 ld E Nil 3511 end 3512 pop X 3513 ret 3514 end 3515 sym E # 'sym'? 3516 jz atomErrEX # No 3517 cmp E TSym # T? 3518 if ne 3519 call firstCharE_A 3520 shl A 4 # Make short number 3521 or A CNT 3522 else 3523 ld A TOP # Special "top" character 3524 call mkCharA_A 3525 end 3526 ld E A 3527 pop X 3528 ret 3529 3530 # (skip ['any]) -> sym 3531 (code 'doSkip 2) 3532 ld E ((E CDR)) # Get arg 3533 call evSymE_E # Evaluate to a symbol 3534 call firstCharE_A # Get first character 3535 ld C A # Use as comment char 3536 call skipC_A # Skip white space and comments 3537 null A # EOF? 3538 js retNil # Yes 3539 ld A (Chr) # Return 'Chr' 3540 call mkCharA_A # Return char 3541 ld E A 3542 ret 3543 3544 # (eol) -> flg 3545 (code 'doEol 2) 3546 cmp (Chr) 10 # Linefeed? 3547 jeq retT # Yes 3548 null (Chr) # Chr <= 0? 3549 jsz retT # Yes 3550 ld E Nil # Return NIL 3551 ret 3552 3553 # (eof ['flg]) -> flg 3554 (code 'doEof 2) 3555 ld E ((E CDR)) # Get arg 3556 eval # Eval it 3557 cmp E Nil # NIL? 3558 if eq # Yes 3559 ld A (Chr) # Look ahead char? 3560 null A 3561 if z # No 3562 call (Get_A) # Get next 3563 end 3564 null A # EOF? 3565 jns RetNil # No 3566 else 3567 ld (Chr) -1 # Set EOF 3568 end 3569 ld E TSym # Return T 3570 ret 3571 3572 # (from 'any ..) -> sym 3573 (code 'doFrom 2) 3574 push X 3575 push Z 3576 ld X (E CDR) # X on args 3577 push 0 # End-of-buffers marker 3578 do 3579 call evSymX_E # Next argument 3580 call bufStringE_SZ # <S V> Stack buffer 3581 push 0 # <S IV> Index 3582 link 3583 push E # <S II> Symbol 3584 link 3585 push Z # <S> Buffer chain 3586 ld X (X CDR) # More arguments? 3587 atom X 3588 until nz # No 3589 ld A (Chr) # Look ahead char? 3590 null A 3591 if z # No 3592 call (Get_A) # Get next 3593 end 3594 do 3595 null A # EOF? 3596 while ns # No 3597 ld Z S # Buffer chain 3598 do 3599 do 3600 lea C (Z V) # Stack buffer 3601 add C (Z IV) # Index 3602 cmp B (C) # Bytes match? 3603 if eq # Yes 3604 inc (Z IV) # Increment index 3605 nul (C 1) # End of string? 3606 break nz # No 3607 call (Get_A) # Skip next input byte 3608 ld E (Z II) # Return matched symbol 3609 jmp 90 3610 end 3611 null (Z IV) # Still at beginning of string? 3612 break z # Yes 3613 lea C (Z (+ V 1)) # Offset pointer to second byte 3614 do 3615 dec (Z IV) # Decrement index 3616 while nz 3617 cmpn (Z V) (C) (Z IV) # Compare stack buffer 3618 while nz 3619 inc C # Increment offset 3620 loop 3621 loop 3622 ld Z (Z) # Next in chain 3623 null (Z) # Any? 3624 until z # No 3625 call (Get_A) # Get next input byte 3626 loop 3627 ld E Nil # Return NIL 3628 90 pop Z # Clean up buffers 3629 do 3630 drop 3631 ld S Z 3632 pop Z 3633 null Z # End? 3634 until z # Yes 3635 pop Z 3636 pop X 3637 ret 3638 3639 # (till 'any ['flg]) -> lst|sym 3640 (code 'doTill 2) 3641 push X 3642 push Z 3643 ld X (E CDR) # Args 3644 call evSymX_E # Evaluate to a symbol 3645 call bufStringE_SZ # <S I/IV> Stack buffer 3646 push A # <S /III> String length 3647 slen (S) (S I) 3648 ld A (Chr) # Look ahead char? 3649 null A 3650 if z # No 3651 call (Get_A) # Get next 3652 end 3653 null A # EOF? 3654 if ns # No 3655 memb (S I) (S) # Matched first char? 3656 if ne # No 3657 ld E ((X CDR)) # Eval 'flg' 3658 eval 3659 cmp E Nil # NIL? 3660 if eq # Yes 3661 call getChar_A # Get first character 3662 call mkCharA_A # Make char 3663 call consA_X # Build first cell 3664 ld (X) A 3665 ld (X CDR) Nil 3666 link 3667 push X # <L I> Result list 3668 link 3669 do 3670 call (Get_A) # Get next 3671 null A # EOF? 3672 while nsz # No 3673 memb (S IV) (S III) # Matched char? 3674 while ne # No 3675 call getChar_A # Get next character 3676 call mkCharA_A 3677 call consA_C # Build next cell 3678 ld (C) A 3679 ld (C CDR) Nil 3680 ld (X CDR) C # Append to sublist 3681 ld X C 3682 loop 3683 ld E (L I) # Get result list 3684 else 3685 link 3686 push ZERO # <L I> Result 3687 ld X S 3688 link 3689 ld C 4 # Build name 3690 do 3691 call getChar_A # Get next character 3692 call charSymACX_CX # Insert 3693 call (Get_A) # Get next 3694 null A # EOF? 3695 while nsz # No 3696 memb (S IV) (S III) # Matched char? 3697 until eq # Yes 3698 ld X (L I) # Get result name 3699 call consSymX_E 3700 end 3701 drop 3702 ld S Z # Drop buffer 3703 pop Z 3704 pop X 3705 ret 3706 end 3707 end 3708 ld E Nil # Return NIL 3709 ld S Z # Drop buffer 3710 pop Z 3711 pop X 3712 ret 3713 3714 (code 'eolA_F 0) 3715 null A # EOF? 3716 js retz # Yes 3717 cmp A 10 # Linefeed? 3718 if ne # No 3719 cmp A 13 # Return? 3720 jne Ret # No 3721 call (Get_A) # Get next 3722 cmp A 10 # Linefeed? 3723 jnz retz 3724 end 3725 ld (Chr) 0 # Clear look ahead 3726 ret # 'z' 3727 3728 # (line 'flg ['cnt ..]) -> lst|sym 3729 (code 'doLine 2) 3730 ld A (Chr) # Look ahead char? 3731 null A 3732 if z # No 3733 call (Get_A) # Get next 3734 end 3735 call eolA_F # End of line? 3736 jeq retNil # Yes 3737 push X 3738 push Y 3739 push Z 3740 ld Y (E CDR) # Y on args 3741 ld E (Y) # Eval 'flg' 3742 eval 3743 cmp E Nil # 'flg' was non-NIL? 3744 if ne # Yes: Pack 3745 ld Y (Y CDR) # More args? 3746 atom Y 3747 if nz # No 3748 link 3749 push ZERO # <L I> Result 3750 ld X S 3751 link 3752 ld C 4 # Build name 3753 do 3754 call getChar_A # Get next character 3755 call charSymACX_CX # Insert 3756 call (Get_A) # Get next 3757 call eolA_F # End of line? 3758 until eq # Yes 3759 ld X (L I) # Get result name 3760 call consSymX_E 3761 else 3762 call cons_Z # First cell of top list 3763 ld (Z) ZERO 3764 ld (Z CDR) Nil 3765 link 3766 push Z # <L I> Result 3767 link 3768 do 3769 ld C 4 # Build name 3770 ld X Z 3771 call getChar_A # Get next character 3772 call charSymACX_CX # Insert first char 3773 push C 3774 ld E (Y) 3775 eval # Eval next arg 3776 pop C 3777 shr E 4 # Normalize 3778 do 3779 dec E # Decrement count 3780 while nz 3781 call (Get_A) # Get next 3782 call eolA_F # End of line? 3783 if eq # Yes 3784 ld X (Z) # Get last sub-result 3785 call consSymX_E 3786 ld (Z) E 3787 jmp 20 3788 end 3789 call getChar_A # Get next character 3790 call charSymACX_CX # Insert 3791 loop 3792 ld X (Z) # Get last sub-result 3793 call consSymX_E 3794 ld (Z) E 3795 ld Y (Y CDR) # More args? 3796 atom Y 3797 jnz 10 # No 3798 call (Get_A) # Get next 3799 call eolA_F # End of line? 3800 jeq 20 # Yes 3801 call cons_A # New cell to top list 3802 ld (A) ZERO 3803 ld (A CDR) Nil 3804 ld (Z CDR) A 3805 ld Z A 3806 loop 3807 end 3808 else 3809 call getChar_A # Get first character 3810 call mkCharA_A # Make char 3811 call consA_Z # Build first cell 3812 ld (Z) A 3813 ld (Z CDR) Nil 3814 link 3815 push Z # <L I> Result 3816 link 3817 ld Y (Y CDR) # More args? 3818 atom Y 3819 if z # Yes 3820 ld X Z # Current sublist 3821 call cons_Z # First cell of top list 3822 ld (Z) X 3823 ld (Z CDR) Nil 3824 ld (L I) Z # New result 3825 do 3826 ld E (Y) 3827 eval # Eval next arg 3828 shr E 4 # Normalize 3829 do 3830 dec E # Decrement count 3831 while nz 3832 call (Get_A) # Get next 3833 call eolA_F # End of line? 3834 jeq 20 # Yes 3835 call getChar_A # Get next character 3836 call mkCharA_A 3837 call consA_C # Build next cell 3838 ld (C) A 3839 ld (C CDR) Nil 3840 ld (X CDR) C # Append to sublist 3841 ld X C 3842 loop 3843 ld Y (Y CDR) # More args? 3844 atom Y 3845 while z # Yes 3846 call (Get_A) # Get next 3847 call eolA_F # End of line? 3848 jeq 20 # Yes 3849 call getChar_A # Get next character 3850 call mkCharA_A 3851 call consA_X # Build new sublist 3852 ld (X) A 3853 ld (X CDR) Nil 3854 call consX_A # Append to top list 3855 ld (A) X 3856 ld (A CDR) Nil 3857 ld (Z CDR) A 3858 ld Z A 3859 loop 3860 end 3861 10 do 3862 call (Get_A) # Get next 3863 call eolA_F # End of line? 3864 while ne # No 3865 call getChar_A # Get next character 3866 call mkCharA_A 3867 call consA_C # Build next cell 3868 ld (C) A 3869 ld (C CDR) Nil 3870 ld (Z CDR) C # Append 3871 ld Z C 3872 loop 3873 20 ld E (L I) # Get result 3874 end 3875 drop 3876 pop Z 3877 pop Y 3878 pop X 3879 ret 3880 3881 # (lines 'any ..) -> cnt 3882 (code 'doLines 2) 3883 push X 3884 push Y 3885 push Z 3886 ld X (E CDR) # Args 3887 ld Y 0 # Result 3888 do 3889 atom X # More args? 3890 while z # Yes 3891 call evSymX_E # Evaluate next file name 3892 call pathStringE_SZ # Write to stack buffer 3893 cc fopen(S _r_) # Open file 3894 ld S Z # Drop buffer 3895 null A # OK? 3896 if nz # Yes 3897 ld E A # File pointer 3898 null Y # First hit? 3899 if z # Yes 3900 ld Y ZERO # Init short number 3901 end 3902 do 3903 cc getc_unlocked(E) # Next char 3904 nul4 # EOF? 3905 while ns # No 3906 cmp A 10 # Linefeed? 3907 if eq # Yes 3908 add Y (hex "10") # Increment count 3909 end 3910 loop 3911 cc fclose(E) # Close file pointer 3912 end 3913 ld X (X CDR) 3914 loop 3915 null Y # Result? 3916 ld E Y # Yes 3917 ldz E Nil # No 3918 pop Z 3919 pop Y 3920 pop X 3921 ret 3922 3923 (code 'parseBCE_E) 3924 push (EnvParseX) # Save old parser status 3925 push (EnvParseC) 3926 push (EnvParseEOF) 3927 push (Get_A) # Save 'get' status 3928 push (Chr) 3929 ld E (E TAIL) 3930 call nameE_E # Get name 3931 link 3932 push E # Save it 3933 link 3934 ld (EnvParseX) E # Set new parser status 3935 ld (EnvParseC) 0 3936 ld E 0 3937 null C # Token? 3938 if z # No 3939 ld E (hex "5D0A00") # linefeed, ']', EOF 3940 end 3941 ld (EnvParseEOF) E 3942 ld (Get_A) getParse_A # Set 'get' status 3943 ld (Chr) 0 3944 or B B # Skip? 3945 if nz # Yes 3946 call getParse_A # Skip first char 3947 end 3948 null C # Token? 3949 if z # No 3950 call rdList_E # Read a list 3951 else 3952 push X 3953 push C # <S III> Set of characters 3954 ld E C # in E 3955 ld C 0 # No comment char 3956 call tokenCE_E # Read token 3957 null E # Any? 3958 ldz E Nil 3959 if nz # Yes 3960 call consE_X # Build first result cell 3961 ld (X) E 3962 ld (X CDR) Nil 3963 link 3964 push X # <L I> Result 3965 link 3966 do 3967 ld C 0 # No comment char 3968 ld E (S III) # Get set of characters 3969 push X 3970 call tokenCE_E # Next token? 3971 pop X 3972 null E 3973 while nz # Yes 3974 call consE_A # Build next result cell 3975 ld (A) E 3976 ld (A CDR) Nil 3977 ld (X CDR) A 3978 ld X A 3979 loop 3980 ld E (L I) # Get result 3981 drop 3982 end 3983 add S I # Drop set 3984 pop X 3985 end 3986 drop 3987 pop (Chr) # Retrieve 'get' status 3988 pop (Get_A) 3989 pop (EnvParseEOF) # Restore old parser status 3990 pop (EnvParseC) 3991 pop (EnvParseX) 3992 ret 3993 3994 # (any 'sym) -> any 3995 (code 'doAny 2) 3996 push X 3997 ld X E 3998 ld E ((E CDR)) # E on arg 3999 eval # Eval it 4000 num E # Need symbol 4001 jnz symErrEX 4002 sym E 4003 jz symErrEX 4004 cmp E Nil # NIL? 4005 if ne # No 4006 push (EnvParseX) # Save old parser status 4007 push (EnvParseC) 4008 push (EnvParseEOF) 4009 push (Get_A) # Save 'get' status 4010 push (Chr) 4011 ld E (E TAIL) 4012 call nameE_E # Get name 4013 link 4014 push E # Save it 4015 link 4016 ld (EnvParseX) E # Set new parser status 4017 ld (EnvParseC) 0 4018 ld (EnvParseEOF) (hex "2000") # Blank, EOF 4019 ld (Get_A) getParse_A # Set 'get' status 4020 ld (Chr) 0 4021 call getParse_A # Skip first char 4022 ld A 1 # Top level 4023 call readA_E # Read expression 4024 drop 4025 pop (Chr) # Retrieve 'get' status 4026 pop (Get_A) 4027 pop (EnvParseEOF) # Restore old parser status 4028 pop (EnvParseC) 4029 pop (EnvParseX) 4030 end 4031 pop X 4032 ret 4033 4034 # (sym 'any) -> sym 4035 (code 'doSym 2) 4036 ld E ((E CDR)) # Eval arg 4037 eval 4038 link 4039 push E # Save 4040 link 4041 call begString # Start string 4042 call printE # Print to string 4043 call endString_E # Retrieve result 4044 drop 4045 ret 4046 4047 # (str 'sym ['sym1]) -> lst 4048 # (str 'lst) -> sym 4049 (code 'doStr 2) 4050 push X 4051 push Y 4052 ld X E 4053 ld Y (E CDR) # Y on args 4054 ld E (Y) # Eval first 4055 eval 4056 cmp E Nil # NIL? 4057 if ne # No 4058 num E # Number? 4059 jnz argErrEX # Yes 4060 sym E # Symbol? 4061 if nz # Yes 4062 link 4063 push E # <L II> 'sym' 4064 link 4065 ld X (Y CDR) # Second arg? 4066 atom X 4067 if nz # No 4068 ld C 0 # No token 4069 else 4070 call evSymX_E # Eval 'sym1' 4071 tuck E # Save 4072 link 4073 ld C E # Get token 4074 ld E (L II) # and 'sym' 4075 end 4076 ld B 0 # Don't skip 4077 call parseBCE_E # Parse 4078 drop 4079 else 4080 link 4081 push E # Save 'lst' 4082 link 4083 call begString # Start string 4084 ld X E # 'lst' 4085 do 4086 ld E (X) # Get CAR 4087 call printE # Print to string 4088 ld X (X CDR) # More items? 4089 atom X 4090 while z # Yes 4091 call space 4092 loop 4093 call endString_E # Retrieve result 4094 drop 4095 end 4096 end 4097 pop Y 4098 pop X 4099 ret 4100 4101 # Read-Eval-Print loop 4102 (code 'loadBEX_E) 4103 ld C A # Save prompt in C 4104 sym E # Symbolic argument? 4105 if nz # Yes 4106 ld A (E TAIL) 4107 call firstByteA_B # starting with "-"? 4108 cmp B (char "-") 4109 if eq # Yes 4110 ld C 0 # No token 4111 call parseBCE_E # Parse executable list 4112 link 4113 push E # Save expression 4114 link 4115 call evListE_E # Execute it 4116 drop 4117 ret 4118 end 4119 end 4120 push Y 4121 link 4122 push (EnvIntern) # <L III> Keep current namespace 4123 push ZERO # <L II> 4124 push ZERO # <L I> 4125 link 4126 push C # <L -I> Prompt 4127 sub S IV # InFrame 4128 ld Y S 4129 call rdOpenEXY 4130 call pushInFilesY 4131 ld E Nil # Close transient scope 4132 call doHide 4133 do 4134 cmp ((InFiles)) (InFile) # Reading from file? 4135 if ne # Yes 4136 ld C 0 # No terminator 4137 call readC_E # Read expression 4138 else 4139 null (L -I) # Prompt? 4140 if nz # Yes 4141 null (Chr) 4142 if z 4143 ld E (Prompt) # Output prompt prefix 4144 call runE_E # Execute 4145 call prinE_E 4146 ld A (L -I) # Output prompt 4147 call (PutB) 4148 call space 4149 call flushAll 4150 end 4151 end 4152 ld C 10 # Linefeed terminator 4153 cc isatty(0) # STDIN 4154 nul4 # on a tty? 4155 ldz C 0 # No 4156 call readC_E # Read expression 4157 ld A (Chr) 4158 do 4159 null A # EOF? 4160 while nsz # No 4161 cmp B 10 # Linefeed? 4162 if eq # Yes 4163 ld (Chr) 0 # Clear it 4164 break T 4165 end 4166 cmp B (char "#") # Comment char? 4167 if eq # Yes 4168 call comment_A # Skip comment 4169 else 4170 cmp B 32 # White space? 4171 break gt # No 4172 call (Get_A) 4173 end 4174 loop 4175 end 4176 cmp E Nil 4177 while ne 4178 ld (L I) E # Save read expression 4179 cmp ((InFiles)) (InFile) # Reading from file? 4180 if nz # Yes 4181 10 eval # Evaluate 4182 else 4183 null (Chr) # Line? 4184 jnz 10 # Yes 4185 ld A (L -I) 4186 or B B # Prompt? 4187 jz 10 # No 4188 call flushAll 4189 ld (L II) (At) # Save '@' 4190 eval # Evaluate 4191 ld (At) E # Save result 4192 ld (At3) (At2) 4193 ld (At2) (L II) # Retrieve previous '@' 4194 ld C Arrow 4195 call outStringC 4196 call flushAll 4197 call printE_E 4198 call newline 4199 end 4200 ld (L I) E # Save result 4201 loop 4202 ld (EnvIntern) (L III) # Restore namespace 4203 call popInFiles 4204 ld E Nil # Close transient scope 4205 call doHide 4206 ld E (L I) 4207 drop 4208 pop Y 4209 ret 4210 4211 # (load 'any ..) -> any 4212 (code 'doLoad 2) 4213 push X 4214 push Y 4215 ld X E 4216 ld Y (E CDR) # Y on args 4217 do 4218 ld E (Y) # Eval arg 4219 eval 4220 cmp E TSym # Load remaining command line args? 4221 if ne # No 4222 ld B (char ">") # Prompt 4223 call loadBEX_E 4224 else 4225 call loadAllX_E 4226 end 4227 ld Y (Y CDR) # More args? 4228 atom Y 4229 until nz # No 4230 pop Y 4231 pop X 4232 ret 4233 4234 # (in 'any . prg) -> any 4235 (code 'doIn 2) 4236 push X 4237 push Y 4238 ld X E # Expression in X 4239 ld E (E CDR) 4240 ld E (E) # Eval 'any' 4241 eval 4242 sub S IV # InFrame 4243 ld Y S 4244 call rdOpenEXY 4245 call pushInFilesY 4246 ld X ((X CDR) CDR) # Get 'prg' 4247 prog X 4248 call popInFiles 4249 add S IV # Drop InFrame 4250 pop Y 4251 pop X 4252 ret 4253 4254 # (out 'any . prg) -> any 4255 (code 'doOut 2) 4256 push X 4257 push Y 4258 ld X E # Expression in X 4259 ld E (E CDR) 4260 ld E (E) # Eval 'any' 4261 eval 4262 sub S IV # OutFrame 4263 ld Y S 4264 call wrOpenEXY 4265 call pushOutFilesY 4266 ld X ((X CDR) CDR) # Get 'prg' 4267 prog X 4268 call popOutFiles 4269 add S IV # Drop InFrame 4270 pop Y 4271 pop X 4272 ret 4273 4274 # (err 'sym . prg) -> any 4275 (code 'doErr 2) 4276 push X 4277 push Y 4278 ld X E # Expression in X 4279 ld E (E CDR) 4280 ld E (E) # Eval 'any' 4281 eval 4282 sub S II # ErrFrame 4283 ld Y S 4284 call erOpenEXY 4285 call pushErrFilesY 4286 ld X ((X CDR) CDR) # Get 'prg' 4287 prog X 4288 call popErrFiles 4289 add S II # Drop ErrFrame 4290 pop Y 4291 pop X 4292 ret 4293 4294 # (ctl 'sym . prg) -> any 4295 (code 'doCtl 2) 4296 push X 4297 push Y 4298 ld X E # Expression in X 4299 ld E (E CDR) 4300 ld E (E) # Eval 'any' 4301 eval 4302 sub S II # CtlFrame 4303 ld Y S 4304 call ctOpenEXY 4305 call pushCtlFilesY 4306 ld X ((X CDR) CDR) # Get 'prg' 4307 prog X 4308 call popCtlFiles 4309 add S II # Drop CtlFrame 4310 pop Y 4311 pop X 4312 ret 4313 4314 # (pipe exe) -> cnt 4315 # (pipe exe . prg) -> any 4316 (code 'doPipe 2) 4317 push X 4318 push Y 4319 ld X E # Expression in X 4320 sub S IV # In/OutFrame 4321 ld Y S 4322 push A # Create 'pipe' structure 4323 cc pipe(S) # Open pipe 4324 nul4 # OK? 4325 jnz pipeErrX 4326 ld4 (S) # Get pfd[0] 4327 call closeOnExecAX 4328 ld4 (S 4) # Get pfd[1] 4329 call closeOnExecAX 4330 call forkLispX_FE # Fork child process 4331 if c # In child 4332 atom ((X CDR) CDR) # 'prg'? 4333 if z # Yes 4334 cc setpgid(0 0) # Set process group 4335 end 4336 ld4 (S) # Close read pipe 4337 call closeAX 4338 ld4 (S 4) # Get write pipe 4339 cmp A 1 # STDOUT_FILENO? 4340 if ne # No 4341 cc dup2(A 1) # Dup to STDOUT_FILENO 4342 ld4 (S 4) # Close write pipe 4343 call closeAX 4344 end 4345 ld E Nil # Standard output 4346 call wrOpenEXY 4347 call pushOutFilesY 4348 ld ((OutFile) II) 0 # Clear 'tty' 4349 ld (Run) Nil # Switch off all tasks 4350 ld E ((X CDR)) # Get 'exe' 4351 eval # Evaluate it 4352 ld E 0 # Exit OK 4353 jmp byeE 4354 end 4355 ld (Y II) E # Set 'pid' 4356 ld4 (S 4) # Close write pipe 4357 call closeAX 4358 ld4 (S) # Get read pipe 4359 call initInFileA_A 4360 ld E (A) # Get file descriptor 4361 ld X ((X CDR) CDR) # Get 'prg' 4362 atom X # Any? 4363 if nz # No 4364 shl E 4 # In parent 4365 or E CNT # Return PID 4366 else 4367 ld (Y I) E # Save 'fd' 4368 cc setpgid((Y II) 0) # Set process group 4369 call pushInFilesY 4370 prog X 4371 call popInFiles 4372 end 4373 add S (+ 8 IV) # Drop 'pipe' structure and In/OutFrame 4374 pop Y 4375 pop X 4376 ret 4377 4378 # (open 'any ['flg]) -> cnt | NIL 4379 (code 'doOpen 2) 4380 push X 4381 push Z 4382 ld X E 4383 ld E ((E CDR)) # Get arg 4384 call evSymE_E # Evaluate to a symbol 4385 call pathStringE_SZ # Write to stack buffer 4386 ld E (((X CDR) CDR)) # Get flg 4387 eval 4388 cmp E Nil # Read-only? 4389 ldnz E O_RDONLY # Yes 4390 ldz E (| O_CREAT O_RDWR) # No 4391 do 4392 cc open(S E (oct "0666")) # Try to open 4393 nul4 # OK? 4394 while s # No 4395 call errno_A 4396 cmp A EINTR # Interrupted? 4397 if ne # No 4398 ld E Nil # Return NIL 4399 jmp 90 4400 end 4401 null (Signal) # Signal? 4402 if nz # Yes 4403 call sighandlerX 4404 end 4405 loop 4406 ld X A # Keep 'fd' 4407 call closeOnExecAX 4408 ld C X # 'fd' 4409 cc strdup(S) # Duplicate name 4410 call initInFileCA_A # Init input file structure 4411 ld A X # 'fd' again 4412 call initOutFileA_A # Init output file structure 4413 ld E X # Return 'fd' 4414 shl E 4 # Make short number 4415 or E CNT 4416 90 ld S Z # Drop buffer 4417 pop Z 4418 pop X 4419 ret 4420 4421 # (close 'cnt) -> cnt | NIL 4422 (code 'doClose 2) 4423 push X 4424 ld X E 4425 ld E ((E CDR)) # Eval 'cnt' 4426 eval 4427 ld C E # Keep in E 4428 call xCntCX_FC # Get fd 4429 do 4430 cc close(C) # Close it 4431 nul4 # OK? 4432 while nz # No 4433 call errno_A 4434 cmp A EINTR # Interrupted? 4435 if ne # No 4436 ld E Nil # Return NIL 4437 pop X 4438 ret 4439 end 4440 null (Signal) # Signal? 4441 if nz # Yes 4442 call sighandlerX 4443 end 4444 loop 4445 ld A C # Close InFile 4446 call closeInFileA 4447 ld A C # Close OutFile 4448 call closeOutFileA 4449 pop X 4450 ret 4451 4452 # (echo ['cnt ['cnt]] | ['sym ..]) -> sym 4453 (code 'doEcho 2) 4454 push X 4455 push Y 4456 ld X E 4457 ld Y (E CDR) # Y on args 4458 ld E (Y) # Eval first 4459 eval 4460 ld Y (Y CDR) # Next arg 4461 ld A (Chr) # Look ahead char? 4462 null A 4463 if z # No 4464 call (Get_A) # Get next 4465 end 4466 cmp E Nil # Empty arg? 4467 if eq # Yes 4468 atom Y # No further args? 4469 if nz # Yes 4470 do 4471 null A # EOF? 4472 while ns # No 4473 call (PutB) # Output byte 4474 call (Get_A) # Get next 4475 loop 4476 ld E TSym # Return T 4477 pop Y 4478 pop X 4479 ret 4480 end 4481 end 4482 num E # Number? 4483 if nz # Yes 4484 call xCntEX_FE # Get 'cnt' 4485 atom Y # Second 'cnt' arg? 4486 if z # Yes 4487 ld Y (Y) # Get second 'cnt' 4488 xchg Y E # First 'cnt' in Y 4489 call evCntEX_FE # Evaluate second 4490 ld A (Chr) # Get Chr again 4491 do 4492 dec Y # Decrement first 'cnt' 4493 while ns 4494 null A # EOF? 4495 if s # Yes 4496 ld E Nil # Return NIL 4497 pop Y 4498 pop X 4499 ret 4500 end 4501 call (Get_A) # Get next 4502 loop 4503 end 4504 null E # 'cnt'? 4505 if nsz # Yes 4506 do 4507 null A # EOF? 4508 if s # Yes 4509 ld E Nil # Return NIL 4510 pop Y 4511 pop X 4512 ret 4513 end 4514 call (PutB) # Output byte 4515 dec E # Decrement 'cnt' 4516 while nz 4517 call (Get_A) # Get next 4518 loop 4519 end 4520 ld (Chr) 0 # Clear look ahead 4521 ld E TSym # Return T 4522 pop Y 4523 pop X 4524 ret 4525 end 4526 sym E # Need symbol 4527 jz argErrEX 4528 push Z 4529 push 0 # End-of-buffers marker 4530 do 4531 call bufStringE_SZ # <S V> Stack buffer 4532 push 0 # <S IV> Index 4533 link 4534 push E # <S II> Symbol 4535 link 4536 push Z # <S> Buffer chain 4537 atom Y # More arguments? 4538 while z # Yes 4539 call evSymY_E # Next argument 4540 ld Y (Y CDR) 4541 loop 4542 ld X 0 # Clear current max 4543 ld A (Chr) # Look ahead char 4544 do 4545 null A # EOF? 4546 while ns # No 4547 ld Y X # Output max 4548 null Y # Any? 4549 if nz # Yes 4550 ld E (Y IV) # Set output index 4551 end 4552 ld Z S # Buffer chain 4553 do 4554 do 4555 lea C (Z V) # Stack buffer 4556 add C (Z IV) # Index 4557 cmp B (C) # Bytes match? 4558 if eq # Yes 4559 inc (Z IV) # Increment index 4560 nul (C 1) # End of string? 4561 if nz # No 4562 null X # Current max? 4563 if z # No 4564 ld X Z 4565 else 4566 cmp (X IV) (Z IV) # Smaller than index? 4567 ldc X Z # Yes 4568 end 4569 break T 4570 end 4571 null Y # Output max? 4572 if nz # Yes 4573 lea C (Y V) # Buffer of output max 4574 sub E (Z IV) # Diff to current index 4575 do # Done? 4576 while ge # No 4577 ld B (C) 4578 call (PutB) # Output bytes 4579 inc C 4580 sub E 1 4581 loop 4582 end 4583 ld (Chr) 0 # Clear look ahead 4584 ld E (Z II) # Return matched symbol 4585 jmp 90 4586 end 4587 null (Z IV) # Still at beginning of string? 4588 break z # Yes 4589 lea C (Z (+ V 1)) # Offset pointer to second byte 4590 do 4591 dec (Z IV) # Decrement index 4592 while nz 4593 cmpn (Z V) (C) (Z IV) # Compare stack buffer 4594 while nz 4595 inc C # Increment offset 4596 loop 4597 cmp X Z # On current max? 4598 if eq # Yes 4599 ld X 0 # Clear current max 4600 ld C S # Buffer chain 4601 do 4602 null (C IV) # Index? 4603 if nz # Yes 4604 null X # Current max? 4605 if z # No 4606 ld X C 4607 else 4608 cmp (X IV) (C IV) # Smaller than index? 4609 ldc X C # Yes 4610 end 4611 end 4612 ld C (C) # Next in chain 4613 null (C) # Any? 4614 until z # No 4615 end 4616 loop 4617 ld Z (Z) # Next in chain 4618 null (Z) # Any? 4619 until z # No 4620 null X # Current max? 4621 if z # No 4622 null Y # Output max? 4623 if nz 4624 push A # Save current byte 4625 push E # and output index 4626 lea C (Y V) # Buffer of output max 4627 do 4628 ld B (C) 4629 call (PutB) # Output bytes 4630 inc C 4631 dec E # Done? 4632 until z # Yes 4633 pop E 4634 pop A 4635 end 4636 call (PutB) # Output current byte 4637 else 4638 null Y # Output max? 4639 if nz 4640 lea C (Y V) # Buffer of output max 4641 sub E (X IV) # Diff to current max index 4642 do # Done? 4643 while ge # No 4644 ld B (C) 4645 call (PutB) # Output bytes 4646 inc C 4647 sub E 1 4648 loop 4649 end 4650 end 4651 call (Get_A) # Get next input byte 4652 loop 4653 ld E Nil # Return NIL 4654 90 pop Z # Clean up buffers 4655 do 4656 drop 4657 ld S Z 4658 pop Z 4659 null Z # End? 4660 until z # Yes 4661 pop Z 4662 pop Y 4663 pop X 4664 ret 4665 4666 (code 'putStdoutB 0) 4667 push Y 4668 ld Y (OutFile) # OutFile? 4669 null Y 4670 if nz # Yes 4671 push E 4672 push X 4673 ld E (Y I) # Get 'ix' 4674 lea X (Y III) # Buffer pointer 4675 cmp E BUFSIZ # Reached end of buffer? 4676 if eq # Yes 4677 push A 4678 push C 4679 ld (Y I) 0 # Clear 'ix' 4680 ld C (Y) # Get 'fd' 4681 call wrBytesCEX_F # Write buffer 4682 ld E 0 # Get 'ix' 4683 lea X (Y III) # Buffer pointer 4684 pop C 4685 pop A 4686 end 4687 add X E # Buffer index 4688 ld (X) B # Store byte 4689 inc E # Increment ix 4690 ld (Y I) E # Store 'ix' 4691 cmp B 10 # Linefeed? 4692 if eq # Yes 4693 null (Y II) # and 'tty'? 4694 if nz # Yes 4695 push C 4696 ld (Y I) 0 # Clear 'ix' 4697 ld C (Y) # Get 'fd' 4698 lea X (Y III) # Buffer pointer 4699 call wrBytesCEX_F # Write buffer 4700 pop C 4701 end 4702 end 4703 pop X 4704 pop E 4705 end 4706 pop Y 4707 ret 4708 4709 (code 'newline) 4710 ld B 10 4711 jmp (PutB) 4712 4713 (code 'space) 4714 ld B 32 4715 jmp (PutB) 4716 4717 # Output decimal number 4718 (code 'outNumE) 4719 shr E 4 # Normalize 4720 if c # Sign 4721 ld B (char "-") # Output sign 4722 call (PutB) 4723 end 4724 ld A E 4725 (code 'outWordA) 4726 cmp A 9 # Single digit? 4727 if gt # No 4728 ld C 0 # Divide by 10 4729 div 10 4730 push C # Save remainder 4731 call outWordA # Recurse 4732 pop A 4733 end 4734 add B (char "0") # Make ASCII digit 4735 jmp (PutB) 4736 4737 (code 'prExtNmX) 4738 call fileObjX_AC # Get file and object ID 4739 null A # File? 4740 if nz # Yes 4741 call outAoA # Output file number 4742 end 4743 ld A C # Get object ID 4744 # Output octal number 4745 (code 'outOctA 0) 4746 cmp A 7 # Single digit? 4747 if gt # No 4748 push A # Save 4749 shr A 3 # Divide by 8 4750 call outOctA # Recurse 4751 pop A 4752 and B 7 # Get remainder 4753 end 4754 add B (char "0") # Make ASCII digit 4755 jmp (PutB) 4756 4757 # Output A-O encoding 4758 (code 'outAoA 0) 4759 cmp A 15 # Single digit? 4760 if gt # No 4761 push A # Save 4762 shr A 4 # Divide by 16 4763 call outAoA # Recurse 4764 pop A 4765 and B 15 # Get remainder 4766 end 4767 add B (char "@") # Make ASCII letter 4768 jmp (PutB) 4769 4770 (code 'outStringS) # C 4771 lea C (S I) # Buffer above return address 4772 (code 'outStringC) 4773 do 4774 ld B (C) # Next char 4775 inc C 4776 or B B # Null? 4777 while ne # No 4778 call (PutB) 4779 loop 4780 ret 4781 4782 (code 'outNameE) 4783 push X 4784 ld X (E TAIL) 4785 call nameX_X # Get name 4786 call prNameX # Print it 4787 pop X 4788 ret 4789 4790 (code 'prNameX) 4791 ld C 0 4792 do 4793 call symByteCX_FACX # Next byte 4794 while nz 4795 call (PutB) # Output byte 4796 loop 4797 ret 4798 4799 # Print one expression 4800 (code 'printE_E) 4801 link 4802 push E # <L I> Save expression 4803 link 4804 call printE # Print it 4805 ld E (L I) # Restore 4806 drop 4807 ret 4808 4809 (code 'printE 0) 4810 cmp S (StkLimit) # Stack check 4811 jlt stkErr 4812 null (Signal) # Signal? 4813 if nz # Yes 4814 call sighandler0 4815 end 4816 cnt E # Short number? 4817 jnz outNumE # Yes 4818 big E # Bignum? 4819 if nz # Yes 4820 ld A -1 # Scale 4821 jmp fmtNum0AE_E # Print it 4822 end 4823 push X 4824 sym E # Symbol? 4825 if nz # Yes 4826 ld X (E TAIL) 4827 call nameX_X # Get name 4828 cmp X ZERO # Any? 4829 if eq # No 4830 ld B (char "$") # $xxxxxx 4831 call (PutB) 4832 shr E 4 # Normalize symbol pointer 4833 ld A E 4834 call outOctA 4835 pop X 4836 ret 4837 end 4838 sym (E TAIL) # External symbol? 4839 if nz # Yes 4840 ld B (char "{") # {AB123} 4841 call (PutB) 4842 call prExtNmX # Print it 4843 ld B (char "}") 4844 call (PutB) 4845 pop X 4846 ret 4847 end 4848 push Y 4849 ld Y ((EnvIntern)) 4850 call isInternEXY_F # Internal symbol? 4851 if eq # Yes 4852 cmp X (hex "2E2") # Dot? 4853 if eq # Yes 4854 ld B (char "\\") # Print backslash 4855 call (PutB) 4856 ld B (char ".") # Print dot 4857 call (PutB) 4858 else 4859 ld C 0 4860 call symByteCX_FACX # Get first byte 4861 do 4862 cmp B (char "\\") # Backslash? 4863 jeq 10 # Yes 4864 memb Delim "(DelimEnd-Delim)" # Delimiter? 4865 if eq # Yes 4866 10 push A # Save char 4867 ld B (char "\\") # Print backslash 4868 call (PutB) 4869 pop A 4870 end 4871 call (PutB) # Put byte 4872 call symByteCX_FACX # Next byte 4873 until z # Done 4874 end 4875 else # Else transient symbol 4876 ld Y 0 # 'tsm' flag in Y 4877 atom (Tsm) # Transient symbol markup? 4878 if z # Yes 4879 cmp (PutB) putStdoutB # to stdout? 4880 if eq # No 4881 ld Y ((OutFile) II) # and 'tty'? -> Y 4882 end 4883 end 4884 null Y # Transient symbol markup? 4885 if z # No 4886 ld B (char "\"") 4887 call (PutB) 4888 else 4889 ld E ((Tsm)) # Get CAR 4890 call outNameE # Write transient symbol markup 4891 end 4892 ld C 0 4893 call symByteCX_FACX # Get first byte 4894 do 4895 cmp B (char "\\") # Backslash? 4896 jeq 20 4897 cmp B (char "\^") # Caret? 4898 jeq 20 4899 null Y # Transient symbol markup? 4900 jnz 30 # Yes 4901 cmp B (char "\"") # Double quote? 4902 if eq # Yes 4903 20 push A # Save char 4904 ld B (char "\\") # Escape with backslash 4905 call (PutB) 4906 pop A 4907 else 4908 30 cmp B 127 # DEL? 4909 if eq # Yes 4910 ld B (char "\^") # Print ^? 4911 call (PutB) 4912 ld B (char "?") 4913 else 4914 cmp B 32 # White space? 4915 if lt # Yes 4916 push A # Save char 4917 ld B (char "\^") # Escape with caret 4918 call (PutB) 4919 pop A 4920 or A 64 # Make printable 4921 end 4922 end 4923 end 4924 call (PutB) # Put byte 4925 call symByteCX_FACX # Next byte 4926 until z # Done 4927 null Y # Transient symbol markup? 4928 if z # No 4929 ld B (char "\"") # Final double quote 4930 call (PutB) 4931 else 4932 ld E ((Tsm) CDR) # Get CDR 4933 call outNameE # Write transient symbol markup 4934 end 4935 end 4936 pop Y 4937 pop X 4938 ret 4939 end 4940 # Print list 4941 cmp (E) Quote # CAR 'quote'? 4942 if eq # Yes 4943 cmp E (E CDR) # Circular? 4944 if ne # No 4945 ld B (char "'") # Print single quote 4946 call (PutB) 4947 ld E (E CDR) # And CDR 4948 call printE 4949 pop X 4950 ret 4951 end 4952 end 4953 push Y 4954 ld B (char "(") # Open paren 4955 call (PutB) 4956 ld X E # Keep list in X 4957 call circE_YF # Circular? 4958 if nz # No 4959 do 4960 ld E (X) # Print CAR 4961 call printE 4962 ld X (X CDR) # NIL-terminated? 4963 cmp X Nil 4964 while ne # No 4965 atom X # Atomic tail? 4966 if nz # Yes 4967 call space # Print " . " 4968 ld B (char ".") 4969 call (PutB) 4970 call space 4971 ld E X # and the atom 4972 call printE 4973 break T 4974 end 4975 call space # Print space 4976 loop 4977 else 4978 cmp X Y # Fully circular? 4979 if eq # Yes 4980 do 4981 ld E (X) # Print CAR 4982 call printE 4983 call space # and space 4984 ld X (X CDR) # Done? 4985 cmp X Y 4986 until eq # Yes 4987 ld B (char ".") # Print "." 4988 call (PutB) 4989 else 4990 do # Non-circular part 4991 ld E (X) # Print CAR 4992 call printE 4993 call space # and space 4994 ld X (X CDR) # Done? 4995 cmp X Y 4996 until eq # Yes 4997 ld B (char ".") # Print ". (" 4998 call (PutB) 4999 call space 5000 ld B (char "(") 5001 call (PutB) 5002 do # Circular part 5003 ld E (X) # Print CAR 5004 call printE 5005 call space # and space 5006 ld X (X CDR) # Done? 5007 cmp X Y 5008 until eq # Yes 5009 ld B (char ".") # Print ".)" 5010 call (PutB) 5011 ld B (char ")") 5012 call (PutB) 5013 end 5014 end 5015 ld B (char ")") # Closing paren 5016 call (PutB) 5017 pop Y 5018 pop X 5019 ret 5020 5021 # Print string representation 5022 (code 'prinE_E 0) 5023 link 5024 push E # <L I> Save expression 5025 link 5026 call prinE # Print it 5027 ld E (L I) # Restore 5028 drop 5029 ret 5030 5031 (code 'prinE 0) 5032 cmp S (StkLimit) # Stack check 5033 jlt stkErr 5034 null (Signal) # Signal? 5035 if nz # Yes 5036 call sighandler0 5037 end 5038 cmp E Nil # NIL? 5039 if ne # No 5040 cnt E # Short number? 5041 jnz outNumE # Yes 5042 big E # Bignum? 5043 if nz # Yes 5044 ld A -1 # Scale 5045 jmp fmtNum0AE_E # Print it 5046 end 5047 push X 5048 sym E # Symbol? 5049 if nz # Yes 5050 ld X (E TAIL) 5051 call nameX_X # Get name 5052 cmp X ZERO # Any? 5053 if ne # Yes 5054 sym (E TAIL) # External symbol? 5055 if z # No 5056 call prNameX 5057 else 5058 ld B (char "{") # {AB123} 5059 call (PutB) 5060 call prExtNmX # Print it 5061 ld B (char "}") 5062 call (PutB) 5063 end 5064 end 5065 else 5066 ld X E # Get list in X 5067 do 5068 ld E (X) # Prin CAR 5069 call prinE 5070 ld X (X CDR) # Next 5071 cmp X Nil # NIL-terminated? 5072 while ne # No 5073 atom X # Done? 5074 if nz # Yes 5075 ld E X # Print atomic rest 5076 call prinE 5077 break T 5078 end 5079 loop 5080 end 5081 pop X 5082 end 5083 ret 5084 5085 # (prin 'any ..) -> any 5086 (code 'doPrin 2) 5087 push X 5088 ld X (E CDR) # Get arguments 5089 do 5090 ld E (X) 5091 eval # Eval next arg 5092 call prinE_E # Print string representation 5093 ld X (X CDR) # More arguments? 5094 atom X 5095 until nz # No 5096 pop X 5097 ret 5098 5099 # (prinl 'any ..) -> any 5100 (code 'doPrinl 2) 5101 call doPrin # Print arguments 5102 jmp newline 5103 5104 (code 'doSpace 2) 5105 push X 5106 ld X E 5107 ld E ((E CDR)) # Eval 'cnt' 5108 eval 5109 cmp E Nil # NIL? 5110 if eq # Yes 5111 call space # Output single space 5112 ld E ONE # Return 1 5113 else 5114 ld C E # Keep in E 5115 call xCntCX_FC # Get cnt 5116 do 5117 dec C # 'cnt' times 5118 while ns 5119 call space # Output spaces 5120 loop 5121 end 5122 pop X 5123 ret 5124 5125 # (print 'any ..) -> any 5126 (code 'doPrint 2) 5127 push X 5128 ld X (E CDR) # Get arguments 5129 do 5130 ld E (X) 5131 eval # Eval next arg 5132 call printE_E # Print it 5133 ld X (X CDR) # More arguments? 5134 atom X 5135 while z # Yes 5136 call space # Print space 5137 loop 5138 pop X 5139 ret 5140 5141 # (printsp 'any ..) -> any 5142 (code 'doPrintsp 2) 5143 push X 5144 ld X (E CDR) # Get arguments 5145 do 5146 ld E (X) 5147 eval # Eval next arg 5148 call printE_E # Print it 5149 call space # Print space 5150 ld X (X CDR) # More arguments? 5151 atom X 5152 until nz # No 5153 pop X 5154 ret 5155 5156 # (println 'any ..) -> any 5157 (code 'doPrintln 2) 5158 call doPrint # Print arguments 5159 jmp newline 5160 5161 # (flush) -> flg 5162 (code 'doFlush 2) 5163 ld A (OutFile) # Flush OutFile 5164 call flushA_F # OK? 5165 ld E TSym # Yes 5166 ldnz E Nil 5167 ret 5168 5169 # (rewind) -> flg 5170 (code 'doRewind 2) 5171 ld E Nil # Preload return value 5172 ld C (OutFile) # OutFile? 5173 null C 5174 if nz # Yes 5175 ld (C I) 0 # Clear 'ix' 5176 cc lseek((C) 0 SEEK_SET) # Seek to beginning of file 5177 null A # OK? 5178 if z # Yes 5179 cc ftruncate((C) 0) # Truncate file 5180 nul4 # OK? 5181 ldz E TSym # Return T 5182 end 5183 end 5184 ret 5185 5186 # (ext 'cnt . prg) -> any 5187 (code 'doExt 2) 5188 push X 5189 push Y 5190 ld X E 5191 ld Y (E CDR) # Y on args 5192 call evCntXY_FE # Eval 'cnt' 5193 push (ExtN) # Save external symbol offset 5194 ld (ExtN) E # Set new 5195 ld X (Y CDR) # Run 'prg' 5196 prog X 5197 pop (ExtN) # Restore external symbol offset 5198 pop Y 5199 pop X 5200 ret 5201 5202 # (rd ['sym]) -> any 5203 # (rd 'cnt) -> num | NIL 5204 (code 'doRd 2) 5205 push X 5206 push Z 5207 link 5208 push ZERO # <L I> Result 5209 link 5210 ld E ((E CDR)) # Get arg 5211 eval # Eval it 5212 ld Z (InFile) # Current InFile? 5213 null Z 5214 if nz # Yes 5215 cnt E # Read raw bytes? 5216 if z # No 5217 ld (L I) E # EOF 5218 ld (GetBinZ_FB) getBinaryZ_FB # Set binary read function 5219 ld (Extn) (ExtN) # Set external symbol offset 5220 call binReadZ_FE # Read item? 5221 ldc E (L I) # No: Return EOF 5222 else 5223 shr E 4 # Normalize 5224 jz 90 # Zero 5225 if c # Little endian 5226 lea X (L I) # X on result 5227 ld C 3 # Build signed number 5228 do 5229 call getBinaryZ_FB # Enough bytes? 5230 jc 90 # No 5231 call byteNumBCX_CX # Add next byte to number 5232 dec E # Done? 5233 until z # Yes 5234 ld A (L I) # Double result 5235 call twiceA_A 5236 else 5237 ld X E # Count in X 5238 do 5239 call getBinaryZ_FB # Enough bytes? 5240 jc 90 # No 5241 zxt 5242 push A # Save byte 5243 ld A (L I) # Multiply number by 256 5244 ld E (hex "1002") 5245 call muluAE_A 5246 ld (L I) A # Save digit 5247 pop E # Get digit 5248 shl E 4 # Make short number 5249 or E CNT 5250 call adduAE_A # Add to number 5251 ld (L I) A # Save again 5252 dec X # Done? 5253 until z # Yes 5254 end 5255 big A # Bignum? 5256 if nz # Yes 5257 call zapZeroA_A # Remove leading zeroes 5258 end 5259 ld E A # Get result 5260 end 5261 else 5262 90 ld E Nil # Return NIL 5263 end 5264 drop 5265 pop Z 5266 pop X 5267 ret 5268 5269 # (pr 'any ..) -> any 5270 (code 'doPr 2) 5271 push X 5272 ld X (E CDR) # Get arguments 5273 do 5274 ld E (X) 5275 eval # Eval next arg 5276 push E # Keep 5277 ld (Extn) (ExtN) # Set external symbol offset 5278 call prE # Print binary 5279 pop E 5280 ld X (X CDR) # More arguments? 5281 atom X 5282 until nz # No 5283 pop X 5284 ret 5285 5286 # (wr 'cnt ..) -> cnt 5287 (code 'doWr 2) 5288 push X 5289 ld X (E CDR) # Args 5290 do 5291 ld E (X) # Eval next 5292 eval 5293 ld A E # Get byte 5294 shr A 4 # Normalize 5295 call putStdoutB # Output 5296 ld X (X CDR) # X on rest 5297 atom X # Done? 5298 until nz # Yes 5299 pop X 5300 ret 5301 5302 # vi:et:ts=3:sw=3