main.l (83495B)
1 # 23jun13abu 2 # (c) Software Lab. Alexander Burger 3 4 (code 'Code) 5 initCode 6 7 ### Global return labels ### 8 (code 'Ret 0) 9 ret 10 (code 'Retc 0) 11 setc 12 ret 13 (code 'Retnc 0) 14 clrc 15 ret 16 (code 'Retz 0) 17 setz 18 ret 19 (code 'Retnz 0) 20 clrz 21 ret 22 (code 'RetNil 0) 23 ld E Nil 24 ret 25 (code 'RetT 0) 26 ld E TSym 27 ret 28 (code 'RetE_E 0) 29 ld E (E) # Get value or CAR 30 ret 31 32 ### Main entry point ### 33 (code 'main) 34 initMain 35 ld (AV0) X # Save command 36 ld (AV) Y # and argument vector 37 # Check debug mode 38 ld C (Z) # Last argument 39 ld B (C) # First byte 40 cmp B (char "+") # Single plus? 41 if eq # Yes 42 nul (C 1) 43 if z # Yes 44 ld (Dbg) TSym # Set '*Dbg' 45 ld (Z) 0 # Clear last argument 46 end 47 end 48 # Locate home directory 49 ld Y (Y) # First argument 50 null Y # Any? 51 if nz # Yes 52 ld B (Y) # First byte 53 cmp B (char "-") # Dash? 54 if ne # No 55 ld Z Y # Keep in Y 56 ld B (char "/") # Contains a slash? 57 slen C Y # String length in C 58 memb Z C 59 if eq # Yes 60 do 61 memb Z C # Find last one 62 until ne 63 ld A Z 64 sub A 2 # "./lib.l"? 65 cmp A Y # Last slash is second byte? 66 jne 10 # No 67 ld B (Y) # First byte is "."? 68 cmp B (char ".") 69 if ne # No 70 10 sub Z Y # Length 71 ld C Z # Keep in Z 72 inc C # Space for null byte 73 call allocC_A 74 ld (Home) A # Set 'Home' 75 movn (A) (Y) Z # Copy path including "/" 76 add Z (Home) # Pointer to null byte 77 set (Z) 0 # Clear it 78 end 79 end 80 end 81 end 82 # Initialize globals 83 cc getpid() # PID in A 84 shl A 4 # Make short number 85 or A CNT 86 ld (Pid) A 87 ld (Stack0) S # Save top level stack pointer 88 ld A S # Stack top in A 89 sub A (* 4 STACK) # Decrement by main segment size 90 ld (Stack1) A # Set coroutine stack base 91 ld (StkLimit) 0 # Initially without stack limit 92 ld L 0 # Init link register 93 call heapAlloc # Allocate initial heap 94 ld E Nil # Init internal symbols 95 lea Z (E VI) # Skip padding and 'pico' cell 96 do 97 ld X (E TAIL) # Get name 98 ld Y Pico # From initial symbol namespace 99 call internEXY_FE # Store to internals 100 ld E Z 101 cnt (Z TAIL) # Short name? 102 if nz # Yes 103 add Z II # Next symbol 104 else 105 add Z IV 106 end 107 cmp E SymTabEnd 108 until gt 109 ld (Get_A) getStdin_A 110 ld A 0 # Standard input 111 call initInFileA_A # Create input file 112 ld (InFile) A # Set to default InFile 113 ld (PutB) putStdoutB 114 ld A 2 # Standard error 115 call initOutFileA_A # Create output file 116 ld A 1 # Standard output 117 call initOutFileA_A # Create output file 118 ld (OutFile) A # Set to default OutFile 119 cc tcgetattr(0 OrgTermio) # Save terminal I/O 120 not B 121 ld (Tio) B # and flag 122 sub S (%% SIGSET_T) # Create signal mask structure 123 cc sigfillset(S) # Set all signals to unblocked 124 cc sigprocmask(SIG_UNBLOCK S 0) 125 add S (%% SIGSET_T) # Drop mask structure 126 ld E sig # Install standard signal handler 127 ld C SIGHUP 128 call iSignalCE # for SIGHUP 129 ld C SIGUSR1 130 call iSignalCE # for SIGUSR1 131 ld C SIGUSR2 132 call iSignalCE # for SIGUSR2 133 ld C SIGALRM 134 call iSignalCE # for SIGALRM 135 ld C SIGTERM 136 call iSignalCE # for SIGTERM 137 ld C SIGIO 138 call iSignalCE # for SIGIO 139 ld E sigTerm # Install terminating signal handler for SIGINT 140 ld C SIGINT 141 call iSignalCE 142 cc signal(SIGCHLD sigChld) # Install child signal handler for SIGCHLD 143 cc signal(SIGPIPE SIG_IGN) # Ignore signals 144 cc signal(SIGTTIN SIG_IGN) 145 cc signal(SIGTTOU SIG_IGN) 146 cc gettimeofday(Tv 0) # Get time 147 ld A (Tv) # tv_sec 148 mul 1000000 # Convert to microseconds 149 add A (Tv I) # tv_usec 150 ld (USec) A # Store 151 ld X 0 # Runtime expression 152 call loadAllX_E # Load arguments 153 ld E sig # Install standard signal handler for SIGINT 154 ld C SIGINT 155 set (Repl) 1 # Set REPL flag 156 call iSignalCE 157 (code 'restart) 158 ld B (char ":") # Prompt 159 ld E Nil # REPL 160 ld X 0 # Runtime expression 161 call loadBEX_E 162 jmp restart 163 164 # Load all remaining arguments 165 (code 'loadAllX_E) 166 do 167 ld E ((AV)) # Command line vector 168 null E # Next string pointer? 169 jz retNil # No 170 ld B (E) # Single-dash argument? 171 cmp B (char "-") 172 if eq 173 nul (E 1) 174 jz retNil # Yes 175 end 176 add (AV) I # Increment vector pointer 177 call mkStrE_E # Make transient symbol 178 ld B 0 # Prompt 179 call loadBEX_E 180 loop 181 182 # Give up 183 (code 'giveupX) 184 ld A (Pid) # Get PID 185 shr A 4 186 cc fprintf((stderr) Giveup A X) 187 ld E 1 188 jmp finishE 189 190 (code 'execErrS) 191 cc fprintf((stderr) ExecErr (S)) 192 cc exit(127) 193 194 # Install interrupting signal 195 (code 'iSignalCE) 196 sub S (%% (* 2 SIGACTION)) # 'sigaction' and 'oldact' 197 ld (S SA_HANDLER) E # Function pointer 198 cc sigemptyset(&(S SA_MASK)) 199 ld (S SA_FLAGS) 0 200 cc sigaction(C S &(S SIGACTION)) # Install handler 201 add S (%% (* 2 SIGACTION)) 202 ret 203 204 # Allocate memory 205 (code 'allocC_A 0) 206 cc malloc(C) # Allocate memory of size C 207 null A # OK? 208 jz NoMemory # No 209 ret 210 (code 'allocAE_A 0) 211 cc realloc(A E) # Reallocate pointer in A to size E 212 null A # OK? 213 jnz Ret # Return 214 : NoMemory 215 ld X AllocErr # No memory 216 jmp giveupX 217 218 219 # Allocate cell heap 220 (code 'heapAlloc 0) # AEX 221 ld A 0 # NULL pointer 222 ld E (+ HEAP I II) # Heap size + link + space 223 call allocAE_A 224 add A 15 # Align to cell boundary 225 off B 15 226 ld E A # Heap pointer 227 ld (A HEAP) (Heaps) # Set heap link 228 ld (Heaps) A 229 add A (- HEAP 16) # A on last cell in chunk 230 ld X (Avail) # Initialize free list 231 do 232 ld (A) X # Link avail 233 ld X A 234 sub A 16 235 cmp A E # Done? 236 until lt # Yes 237 ld (Avail) X # Set new Avail 238 ret 239 240 # Signal handler 241 (code 'sighandler0) 242 push E 243 ld E 0 244 call sighandlerE 245 pop E 246 ret 247 248 (code 'sighandlerX) 249 push E 250 ld E X 251 call sighandlerE 252 pop E 253 ret 254 255 (code 'sighandlerE) 256 null (EnvProtect) # Protected? 257 if z # No 258 inc (EnvProtect) 259 push A 260 push C 261 do 262 null (Signal (* I SIGIO)) # Test signals 263 if nz 264 dec (Signal) # Decrement signal counters 265 dec (Signal (* I SIGIO)) 266 ld E (Sigio) # Run 'Sigio' 267 call execE 268 else 269 null (Signal (* I SIGUSR1)) 270 if nz 271 dec (Signal) 272 dec (Signal (* I SIGUSR1)) 273 ld E (Sig1) # Run 'Sig1' 274 call execE 275 else 276 null (Signal (* I SIGUSR2)) 277 if nz 278 dec (Signal) 279 dec (Signal (* I SIGUSR2)) 280 ld E (Sig2) # Run 'Sig2' 281 call execE 282 else 283 null (Signal (* I SIGALRM)) 284 if nz 285 dec (Signal) 286 dec (Signal (* I SIGALRM)) 287 ld E (Alarm) # Run 'Alarm' 288 call execE 289 else 290 null (Signal (* I SIGINT)) 291 if nz 292 dec (Signal) 293 dec (Signal (* I SIGINT)) 294 nul (PRepl) # Child of REPL process? 295 if z # No 296 null E # Runtime expression? 297 ldz E Nil # No: Default to NIL 298 call brkLoadE_E # Enter debug breakpoint 299 end 300 else 301 null (Signal (* I SIGHUP)) 302 if nz 303 dec (Signal) 304 dec (Signal (* I SIGHUP)) 305 ld E (Hup) # Run 'Hup' 306 call execE 307 else 308 null (Signal (* I SIGTERM)) 309 if nz 310 push X 311 ld X (Child) # Iterate children 312 ld C (Children) # Count 313 ld E 0 # Flag 314 do 315 sub C VI # More? 316 while ge # Yes 317 null (X) # 'pid'? 318 if nz # Yes 319 cc kill((X) SIGTERM) # Try to terminate 320 nul4 # OK? 321 ldz E 1 # Yes: Set flag 322 end 323 add X VI # Increment by sizeof(child) 324 loop 325 pop X 326 null E # Still terminated any child? 327 if z # No 328 ld (Signal) 0 329 ld E 0 # Exit OK 330 jmp byeE 331 end 332 break T 333 end 334 end 335 end 336 end 337 end 338 end 339 end 340 null (Signal) # More signals? 341 until z # No 342 pop C 343 pop A 344 ld (EnvProtect) 0 345 end 346 ret 347 348 (code 'sig) 349 begin # Signal number in A 350 null (TtyPid) # Kill terminal process? 351 if nz # Yes 352 cc kill((TtyPid) A) 353 else 354 shl A 3 # Signal index 355 inc (A Signal) 356 inc (Signal) 357 end 358 return 359 360 (code 'sigTerm) 361 begin # Ignore signal number 362 null (TtyPid) # Kill terminal process? 363 if nz # Yes 364 cc kill((TtyPid) SIGTERM) 365 else 366 inc (Signal (* I SIGTERM)) 367 inc (Signal) 368 end 369 return 370 371 (code 'sigChld) 372 begin # Ignore signal number 373 call errno_A # Save 'errno' 374 push A 375 sub S I # 'stat' 376 do 377 cc waitpid(0 S WNOHANG) # Wait for child 378 nul4 # Pid greater zero? 379 while nsz # Yes 380 ld C A # Keep Pid 381 call wifsignaledS_F # WIFSIGNALED(S)? 382 if nz # Yes 383 call wtermsigS_A # Get signal number WTERMSIG(S) 384 cc fprintf((stderr) PidSigMsg C A) 385 end 386 loop 387 add S I # Drop 'stat' 388 pop C # Restore 'errno' 389 call errnoC 390 return 391 392 (code 'tcSetC) 393 null (Termio) # In raw mode? 394 if nz # Yes 395 do 396 cc tcsetattr(0 TCSADRAIN C) # Set terminal I/O 397 nul4 # OK? 398 while nz # No 399 call errno_A 400 cmp A EINTR # Interrupted? 401 until ne # No 402 end 403 ret 404 405 (code 'sigTermStop) 406 begin # Ignore signal number 407 ld C OrgTermio # Set original terminal I/O 408 call tcSetC 409 sub S (%% SIGSET_T) # Create mask structure 410 cc sigemptyset(S) # Init to empty signal set 411 cc sigaddset(S SIGTSTP) # Add stop signal 412 cc sigprocmask(SIG_UNBLOCK S 0) # Remove blocked signals 413 add S (%% SIGSET_T) # Drop mask structure 414 cc signal(SIGTSTP SIG_DFL) 415 cc raise(SIGTSTP) 416 cc signal(SIGTSTP sigTermStop) 417 ld C (Termio) 418 call tcSetC 419 return 420 421 (code 'setRaw 0) 422 nul (Tio) # Terminal I/O? 423 if nz # Yes 424 null (Termio) # Already in raw mode? 425 if z # No 426 ld C TERMIOS # Allocate space for termio structure 427 call allocC_A 428 ld (Termio) A # Save it 429 ld C A # Pointer in C 430 movn (C) (OrgTermio) TERMIOS # Copy original termio structure 431 ld A 0 # Clear c_iflag 432 st4 (C C_IFLAG) 433 ld A ISIG # ISIG in c_lflag 434 st4 (C C_LFLAG) 435 set (C (+ C_CC VMIN)) 1 436 set (C (+ C_CC VTIME)) 0 437 call tcSetC # Set terminal I/O 438 cc signal(SIGTSTP SIG_IGN) # Ignore stop signals 439 cmp A SIG_DFL # Not set yet? 440 if eq # Yes 441 cc signal(SIGTSTP sigTermStop) # Handle stop signals 442 end 443 end 444 end 445 ret 446 447 (code 'setCooked 0) 448 ld C OrgTermio # Set original terminal I/O 449 call tcSetC 450 cc free((Termio)) # Clear Termio 451 ld (Termio) 0 452 ret 453 454 # (raw ['flg]) -> flg 455 (code 'doRaw 2) 456 ld E (E CDR) # Arg? 457 atom E 458 if nz # No 459 null (Termio) # Return termio flag 460 jnz retT 461 ld E Nil 462 ret 463 end 464 ld E (E) # Evaluate arg 465 eval 466 cmp E Nil # NIL? 467 if eq # Yes 468 call setCooked # Set terminal to cooked mode 469 ld E Nil 470 ret 471 end 472 call setRaw # Set terminal to raw mode 473 ld E TSym 474 ret 475 476 # (alarm 'cnt . prg) -> cnt 477 (code 'doAlarm 2) 478 push X 479 push Y 480 ld X E 481 ld Y (E CDR) # Y on args 482 call evCntXY_FE # Get 'cnt' 483 cc alarm(E) # Set alarm 484 ld (Alarm) (Y CDR) 485 ld E A # Get old alarm 486 shl E 4 # Make short number 487 or E CNT 488 pop Y 489 pop X 490 ret 491 492 # (sigio 'cnt . prg) -> cnt 493 (code 'doSigio 2) 494 push X 495 push Y 496 ld X E 497 ld Y (E CDR) # Y on args 498 call evCntXY_FE # Get fd 499 ld (Sigio) (Y CDR) # Set handler 500 ld A (Pid) # Get process ID 501 shr A 4 # Normalize 502 cc fcntl(E F_SETOWN A) # Receive SIGIO events 503 cc fcntl(E F_GETFL 0) # Get file status flags 504 or A (| O_NONBLOCK O_ASYNC) 505 cc fcntl(E F_SETFL A) # Set file status flags 506 shl E 4 # Return fd 507 or E CNT 508 pop Y 509 pop X 510 ret 511 512 # (protect . prg) -> any 513 (code 'doProtect 2) 514 push X 515 ld X (E CDR) # Get 'prg' 516 inc (EnvProtect) 517 prog X # Run 'prg' 518 dec (EnvProtect) 519 pop X 520 ret 521 522 # (heap 'flg) -> cnt 523 (code 'doHeap 2) 524 ld E ((E CDR)) # Get arg 525 eval # Eval it 526 cmp E Nil # NIL? 527 if eq # Yes 528 ld E ZERO # Init count 529 ld A (Heaps) # Get heap list 530 do 531 add E (hex "10") # Increment count 532 ld A (A HEAP) # Get link 533 null A # Done? 534 until z # Yes 535 ret 536 end 537 ld A 0 # Init count 538 ld C (Avail) # Get avail list 539 do 540 null C # Any? 541 while nz # Yes 542 inc A # Increment count 543 ld C (C) # Follow link 544 loop 545 div CELLS # (C is zero) 546 ld E A 547 shl E 4 # Make short number 548 or E CNT 549 ret 550 551 # (stack ['cnt]) -> cnt | (.. sym . cnt) 552 (code 'doStack 2) 553 push X 554 ld X E 555 ld E (E CDR) # Arg? 556 atom E 557 if z # Yes 558 null (Stacks) # Stack segments allocated? 559 if z # No 560 ld E (E) # Eval 'cnt' 561 call evCntEX_FE 562 shl E 22 # Main stack segment size [times 4 MB] 563 ld A (Stack0) # Get stack top 564 sub A E # Decrement by main segment size 565 ld (Stack1) A # New coroutine stack base 566 shr E 2 # [to MB] 567 ld (StkSize) E # Set new stack size 568 shr E 16 # Make short number [MB] 569 or E CNT 570 pop X 571 ret 572 end 573 end 574 ld E (StkSize) # Return current stack size 575 shr E 16 # Make short number [MB] 576 or E CNT 577 ld X (Stack1) # Collect coroutines 578 ld C (Stacks) # Segment bitmask 579 do 580 null C # Any? 581 while nz # Yes 582 null (X -I) # In use? 583 if nz # Yes 584 call consE_A # Cons 'tag' 585 ld (A) (X -I) 586 ld (A CDR) E 587 ld E A 588 dec C # Decrement count 589 end 590 sub X (StkSize) # Next segment 591 loop 592 pop X 593 ret 594 595 # (adr 'var) -> num 596 # (adr 'num) -> var 597 (code 'doAdr 2) 598 ld E ((E CDR)) # Eval arg 599 eval 600 num E # 'num' argument? 601 if nz # Yes 602 off E CNT # Make 'var' 603 ret 604 end 605 or E CNT # Make 'num' 606 ret 607 608 # (env ['lst] | ['sym 'val] ..) -> lst 609 (code 'doEnv 2) 610 push X 611 ld X (E CDR) 612 link 613 push Nil # <L II> Safe 614 push Nil # <L I> Result 615 link 616 atom X # Args? 617 if nz # No 618 push Y 619 ld Y (EnvBind) # Bindings 620 null Y # Any? 621 if nz # Yes 622 null (Break) # In breakpoint? 623 ldnz Y ((Y) I) # Yes: Skip frame 624 end 625 do 626 null Y # Bindings? 627 while nz # Yes 628 ld C (Y) # End of bindings 629 null (Y -I) # Env swap zero? 630 if z # Yes 631 add Y I # Y on bindings 632 do 633 ld E (Y) # Next symbol 634 ld X (L I) # Get result 635 do 636 atom X # More result items? 637 if nz # No 638 call cons_A # Cons symbol and its value 639 ld (A) E 640 ld (A CDR) (E) 641 call consA_X # Cons to result 642 ld (X) A 643 ld (X CDR) (L I) 644 ld (L I) X 645 break T 646 end 647 cmp E ((X)) # Symbol already in result? 648 while ne # No 649 ld X (X CDR) # Next result item 650 loop 651 add Y II # Skip value 652 cmp Y C # More? 653 until eq # No 654 end 655 ld Y (C I) # Bind link 656 loop 657 pop Y 658 else 659 do 660 ld E (X) # Eval 'lst' or 'sym' 661 eval 662 ld (L II) E # Save 663 atom E # 'lst'? 664 if z # Yes 665 do 666 call cons_A # Prepare new cell 667 ld C (E) # Next item already a pair? 668 atom C 669 if z # Yes 670 ld (A) (C) # Copy it 671 ld (A CDR) (C CDR) 672 else 673 ld (A) C # Cons symbol and its value 674 ld (A CDR) (C) 675 end 676 call consA_C # Cons to result 677 ld (C) A 678 ld (C CDR) (L I) 679 ld (L I) C 680 ld E (E CDR) # Next item in 'lst' 681 atom E # Any? 682 until nz # No 683 else 684 cmp E Nil # NIL? 685 if ne # No 686 ld X (X CDR) # Next arg 687 ld E (X) # Eval 688 eval 689 call consE_A # Cons symbol and value 690 ld (A) (L II) # Safe 691 ld (A CDR) E 692 call consA_C # Cons to result 693 ld (C) A 694 ld (C CDR) (L I) 695 ld (L I) C 696 end 697 end 698 ld X (X CDR) # More args? 699 atom X 700 until nz # No 701 end 702 ld E (L I) # Get result 703 drop 704 pop X 705 ret 706 707 # (trail ['flg]) -> lst 708 (code 'doTrail 2) 709 push X 710 push Y 711 push Z 712 ld E ((E CDR)) # Evaluate arg 713 eval 714 ld Z E # Keep 'flg' in Z 715 ld X (EnvBind) # Bindings 716 null X # Any? 717 if nz # Yes 718 null (Break) # In breakpoint? 719 ldnz X ((X) I) # Yes: Skip frame 720 end 721 ld E Nil # Result 722 do 723 null X # Bindings? 724 while nz # Yes 725 ld C (X) # End of bindings 726 null (X -I) # Env swap zero? 727 if z # Yes 728 add X I # X on bindings 729 do 730 ld Y (X) # Next symbol 731 add X II # Next entry 732 cmp Y At # Lambda frame? 733 if eq # Yes 734 cmp X C # Last entry? 735 if eq # Yes 736 call cons_A # Cons 'exe' 737 ld (A) (C II) # Cons 'exe' 738 ld (A CDR) E 739 ld E A 740 break T 741 end 742 end 743 cmp Z Nil # 'flg'? 744 if ne # Yes 745 call cons_A # Cons value 746 ld (A) (Y) 747 ld (A CDR) E 748 call consA_E # Cons symbol 749 ld (E) Y 750 ld (E CDR) A 751 ld (Y) (X -I) # Set old value 752 end 753 cmp X C # More? 754 until eq # No 755 end 756 ld X (C I) # Bind link 757 loop 758 ld X E # Restore values 759 do 760 atom X # More? 761 while z # Yes 762 ld Y (X) # Next entry 763 ld X (X CDR) 764 atom Y # Symbol? 765 if nz # Yes 766 ld (Y) (X) # Set old value 767 ld X (X CDR) 768 end 769 loop 770 pop Z 771 pop Y 772 pop X 773 ret 774 775 # (up [cnt] sym ['val]) -> any 776 (code 'doUp 2) 777 push X 778 ld C 1 # Count 779 ld E (E CDR) # First arg 780 ld X (E) # Get 'sym' 781 cnt X # 'cnt'? 782 if nz # Yes 783 ld C X # Count 784 shr C 4 # Normalize 785 ld E (E CDR) # Skip arg 786 ld X (E) # 'sym' 787 end 788 cmp X Nil # NIL? 789 if eq # Yes 790 ld X (EnvBind) # Bindings 791 null X # Any? 792 if nz # Yes 793 null (Break) # In breakpoint? 794 ldnz X ((X) I) # Yes: Skip frame 795 end 796 do 797 null X # Bindings? 798 while nz # Yes 799 ld A (X) # End of bindings in A 800 cmp (A -II) At # Lambda frame? 801 if eq # Yes 802 dec C # Done? 803 if z # Yes 804 ld E (A II) # Return 'exe' 805 pop X 806 ret 807 end 808 end 809 ld X (A I) # Bind link 810 loop 811 ld E Nil # Return NIL 812 pop X 813 ret 814 end 815 push Y 816 push Z 817 ld E (E CDR) # Last arg 818 ld Y (EnvBind) # Bindings 819 null Y # Any? 820 if nz # Yes 821 null (Break) # In breakpoint? 822 ldnz Y ((Y) I) # Yes: Skip frame 823 end 824 ld Z X # Value pointer 825 do 826 null Y # Bindings? 827 while nz # Yes 828 ld A (Y) # End of bindings in A 829 add Y I 830 do 831 cmp X (Y) # Found symbol? 832 if eq # Yes 833 lea Z (Y I) # Point to saved value 834 dec C # Decrement count 835 jz 10 # Done 836 end 837 add Y II 838 cmp Y A # More? 839 until eq # No 840 ld Y (A I) # Bind link 841 loop 842 10 atom E # 'val' arg? 843 if nz # No 844 ld E (Z) # Get value 845 else 846 ld E (E) # Eval last arg 847 eval 848 ld (Z) E # Store value 849 end 850 pop Z 851 pop Y 852 pop X 853 ret 854 855 # (sys 'any ['any]) -> sym 856 (code 'doSys 2) 857 push X 858 push Z 859 ld X (E CDR) # X on args 860 call evSymX_E # Evaluate first symbol 861 call bufStringE_SZ # Write to stack buffer 862 ld X (X CDR) # Next arg? 863 atom X 864 if nz # No 865 cc getenv(S) # Get value from system 866 ld E A 867 call mkStrE_E # Make transient symbol 868 else 869 push Z 870 call evSymX_E # Evaluate second symbol 871 lea X (S I) # Keep pointer to first buffer 872 call bufStringE_SZ # Write to stack buffer 873 cc setenv(X S 1) # Set system value 874 nul4 # OK? 875 ldnz E Nil # No 876 ld S Z # Drop buffer 877 pop Z 878 end 879 ld S Z # Drop buffer 880 pop Z 881 pop X 882 ret 883 884 (code 'circE_YF) 885 ld Y E # Keep list in Y 886 do 887 or (E) 1 # Mark 888 ld E (E CDR) # Normal list? 889 atom E 890 if nz # Yes 891 do 892 off (Y) 1 # Unmark 893 ld Y (Y CDR) 894 atom Y # Done? 895 until nz # Yes 896 ret # 'nz' - No circularity found 897 end 898 test (E) 1 # Detected circularity? 899 if nz # Yes 900 do 901 cmp Y E # Skip non-circular part 902 while ne 903 off (Y) 1 # Unmark 904 ld Y (Y CDR) 905 loop 906 do 907 off (Y) 1 # Unmark circular part 908 ld Y (Y CDR) 909 cmp Y E # Done? 910 until eq # Yes 911 ret # 'z' - Circularity in Y 912 end 913 loop 914 915 ### Comparisons ### 916 (code 'equalAE_F 0) 917 cmp A E # Pointer-equal? 918 jeq ret # Yes: 'eq' 919 cnt A # A short? 920 jnz ret # Yes: 'ne' 921 big A # A big? 922 if nz # Yes 923 big E # E also big? 924 jz Retnz # No: 'ne' 925 test A SIGN # A negative? 926 if nz # Yes 927 test E SIGN # E also negative? 928 jz Retnz # No: 'ne' 929 off A SIGN # Make both positive 930 off E SIGN 931 end 932 do 933 cmp (A DIG) (E DIG) # Digits equal? 934 while eq # Yes 935 ld A (A BIG) # Else next digits 936 ld E (E BIG) 937 cmp A E # Pointer-equal? 938 while ne # No 939 cnt A # A short? 940 while z # No 941 cnt E # E short? 942 until nz # Yes 943 ret 944 end 945 sym A # A symbolic? 946 if nz # Yes 947 num E # E also symbolic? 948 jnz Retnz 949 sym E 950 jz Retnz # No: 'ne' 951 ld A (A TAIL) 952 call nameA_A # Get name of A 953 cmp A ZERO # Any? 954 jeq retnz # No: 'ne' 955 ld E (E TAIL) 956 call nameE_E # Get name of E 957 cmp E ZERO # Any? 958 jeq retnz # No: 'ne' 959 jmp equalAE_F 960 end 961 atom E # E atomic? 962 jnz ret # Yes: 'ne' 963 push X 964 push Y 965 ld X A # Keep list heads 966 ld Y E 967 do 968 push A # Save lists 969 push E 970 cmp S (StkLimit) # Stack check 971 jlt stkErr 972 ld A (A) # Recurse on CARs 973 ld E (E) 974 off E 1 # Clear possible mark 975 call equalAE_F # Equal? 976 pop E # Retrieve lists 977 pop A 978 break ne # No: 'ne' 979 atom (A CDR) # A's CDR atomic? 980 if nz # Yes 981 push A # Save lists 982 push E 983 ld A (A CDR) # Recurse on CDRs 984 ld E (E CDR) 985 call equalAE_F # Compare with E's CDR 986 pop E # Retrieve lists 987 pop A 988 break T 989 end 990 atom (E CDR) # E's CDR atomic? 991 break nz # Yes: 'ne' 992 or (A) 1 # Mark 993 ld A (A CDR) 994 ld E (E CDR) 995 test (A) 1 # Detected circularity? 996 if nz 997 do 998 cmp X A # Skip non-circular parts 999 if eq # Done 1000 cmp Y E # Circular parts same length? 1001 if eq # Perhaps 1002 do 1003 ld X (X CDR) # Compare 1004 ld Y (Y CDR) 1005 cmp Y E # End of second? 1006 if eq # Yes 1007 cmp X A # Also end of first? 1008 break T 1009 end 1010 cmp X A # End of first? 1011 break eq # Yes 1012 loop 1013 end 1014 break T 1015 end 1016 cmp Y E 1017 if eq 1018 clrz # Result "No" 1019 break T 1020 end 1021 off (X) 1 # Unmark 1022 ld X (X CDR) 1023 ld Y (Y CDR) 1024 loop 1025 push F # Save result 1026 do 1027 off (X) 1 # Unmark circular part 1028 ld X (X CDR) 1029 cmp X A 1030 until eq 1031 pop F # Get result 1032 pop Y 1033 pop X 1034 ret 1035 end 1036 loop 1037 push F # Save result 1038 do 1039 cmp X A # Skip non-circular part 1040 while ne 1041 off (X) 1 # Unmark 1042 ld X (X CDR) 1043 loop 1044 pop F # Get result 1045 pop Y 1046 pop X 1047 ret 1048 1049 (code 'compareAE_F 0) # C 1050 cmp A E # Pointer-equal? 1051 jeq ret # Yes 1052 cmp A Nil 1053 if eq # [NIL E] 1054 10 or B B # nz 1055 20 setc # lt 1056 ret 1057 end 1058 cmp A TSym 1059 if eq # [T E] 1060 30 or B B # nz 1061 40 clrc # gt 1062 ret 1063 end 1064 num A # Number? 1065 if nz # Yes 1066 num E # Both? 1067 jnz cmpNumAE_F # [<num> <num>] 1068 cmp E Nil 1069 jeq 30 # [<num> NIL] 1070 setc # lt 1071 ret 1072 end 1073 sym A 1074 if nz # [<sym> ..] 1075 num E 1076 jnz 40 # [<sym> <num>] 1077 cmp E Nil 1078 jeq 30 # [<sym> NIL] 1079 atom E 1080 jz 10 # [<sym> <pair>] 1081 cmp E TSym 1082 jeq 10 # [<sym> T] 1083 push X # [<sym> <sym>] 1084 ld X (A TAIL) 1085 call nameX_X # Get A's name in X 1086 cmp X ZERO # Any? 1087 if eq # No 1088 ld X (E TAIL) 1089 call nameX_X # Second name in X 1090 cmp X ZERO # Any? 1091 if eq # No 1092 cmp A E # Compare symbol addresses 1093 else 1094 setc # lt 1095 end 1096 pop X 1097 ret 1098 end 1099 ld E (E TAIL) 1100 call nameE_E # Get E's name in E 1101 cmp E ZERO # Any? 1102 if eq # No 1103 50 or B B # nz 1104 60 clrc # gt 1105 70 pop X 1106 ret 1107 end 1108 do 1109 cnt X # Get next digit from X into A 1110 if nz 1111 ld A X # Short 1112 shr A 4 # Normalize 1113 ld X 0 1114 else 1115 ld A (X DIG) # Get next digit 1116 ld X (X BIG) 1117 end 1118 cnt E # Get next digit from E into C 1119 if nz 1120 ld C E # Short 1121 shr C 4 # Normalize 1122 ld E 0 1123 else 1124 ld C (E DIG) # Get next digit 1125 ld E (E BIG) 1126 end 1127 do 1128 cmp B C # Bytes equal? 1129 jne 70 # No: lt or gt 1130 shr A 8 # Next byte in A? 1131 if z # No 1132 shr C 8 # Next byte in C? 1133 if nz # Yes 1134 setc # lt 1135 pop X 1136 ret 1137 end 1138 null X # X done? 1139 if z # Yes 1140 null E # E also done? 1141 jz 70 # Yes: eq 1142 setc # lt 1143 pop X 1144 ret 1145 end 1146 null E # E done? 1147 jz 50 # Yes: gt 1148 break T 1149 end 1150 shr C 8 # Next byte in C? 1151 jz 50 # No: gt 1152 loop 1153 loop 1154 end 1155 atom E 1156 if nz # [<pair> <sym>] 1157 cmp E TSym 1158 if eq # [<pair> T] 1159 or B B # nz 1160 setc # lt 1161 ret 1162 end 1163 clrc # gt 1164 ret 1165 end 1166 push X # [<pair> <pair>] 1167 push Y 1168 ld X A # Keep originals 1169 ld Y E 1170 do 1171 push A # Recurse on CAR 1172 push E 1173 ld A (A) 1174 ld E (E) 1175 cmp S (StkLimit) # Stack check 1176 jlt stkErr 1177 call compareAE_F # Same? 1178 pop E 1179 pop A 1180 while eq # Yes 1181 ld A (A CDR) # Next elements 1182 ld E (E CDR) 1183 atom A # End of A? 1184 if nz # Yes 1185 cmp S (StkLimit) # Stack check 1186 jlt stkErr 1187 call compareAE_F # Compare CDRs 1188 break T 1189 end 1190 atom E # End of E? 1191 if nz # Yes 1192 cmp E TSym 1193 if ne 1194 clrc # gt [<pair> <atom>] 1195 break T 1196 end 1197 or B B # nz [<pair> T] 1198 setc # lt 1199 break T 1200 end 1201 cmp A X # Circular list? 1202 if eq 1203 cmp E Y 1204 break eq # Yes 1205 end 1206 loop 1207 pop Y 1208 pop X 1209 ret # F 1210 1211 (code 'binSizeX_A 0) 1212 cnt X # Short number? 1213 if nz # Yes 1214 shr X 3 # Normalize short, keep sign bit 1215 jmp 20 1216 end 1217 big X # Big number? 1218 if nz # Yes 1219 ld A 9 # Count 8 significant bytes plus 1 1220 do 1221 ld C (X DIG) # Keep digit 1222 ld X (X BIG) # More cells? 1223 cnt X 1224 while z # Yes 1225 add A 8 # Increment count by 8 1226 loop 1227 shr X 4 # Normalize short 1228 shl C 1 # Get most significant bit of last digit 1229 addc X X # Any significant bits in short number? 1230 jmp 40 1231 end 1232 ld A 1 # Preload 1 1233 cmp X Nil # NIL? 1234 if ne # No 1235 sym X # Symbol? 1236 if nz # Yes 1237 ld X (X TAIL) 1238 call nameX_X # Get name 1239 cmp X ZERO # Any? 1240 if ne # Yes 1241 cnt X # Short name? 1242 if nz # Yes 1243 shl X 2 # Strip status bits 1244 shr X 6 # Normalize 1245 20 ld A 2 # Count significant bytes plus 1 1246 do 1247 shr X 8 # More bytes? 1248 while nz # Yes 1249 inc A # Increment count 1250 loop 1251 ret 1252 end 1253 ld A 9 # Count significant bytes plus 1 1254 do 1255 ld X (X BIG) # More cells? 1256 cnt X 1257 while z # Yes 1258 add A 8 # Increment count by 8 1259 loop 1260 shr X 4 # Any significant bits in short name/number? 1261 40 if nz # Yes 1262 do 1263 inc A # Increment count 1264 shr X 8 # More bytes? 1265 until z # No 1266 end 1267 cmp A (+ 63 1) # More than one chunk? 1268 if ge # Yes 1269 ld X A # Keep size+1 in X 1270 sub A 64 # Size-63 1271 ld C 0 # Divide by 255 1272 div 255 1273 setc # Plus 1 1274 addc A X # Plus size+1 1275 end 1276 end 1277 ret 1278 end 1279 push X # <S I> List head 1280 push 2 # <S> Count 1281 do 1282 push (X CDR) # Save rest 1283 ld X (X) # Recurse on CAR 1284 call binSizeX_A 1285 pop X 1286 add (S) A # Add result to count 1287 cmp X Nil # CDR is NIL? 1288 while ne # No 1289 cmp X (S I) # Circular? 1290 if eq # Yes 1291 inc (S) # Increment count once more 1292 break T 1293 end 1294 atom X # Atomic CDR? 1295 if nz # Yes 1296 call binSizeX_A # Get size 1297 add (S) A # Add result to count 1298 break T 1299 end 1300 loop 1301 pop A # Get result 1302 add S I # Drop list head 1303 end 1304 ret 1305 1306 (code 'memberXY_FY 0) 1307 ld C Y # Keep head in C 1308 do 1309 atom Y # List? 1310 while z # Yes 1311 ld A X 1312 ld E (Y) 1313 call equalAE_F # Member? 1314 jeq ret # Return list 1315 ld Y (Y CDR) # Next item 1316 cmp C Y # Hit head? 1317 jeq retnz # Yes 1318 loop 1319 ld A X 1320 ld E Y 1321 jmp equalAE_F # Same atoms? 1322 1323 # (quit ['any ['any]]) 1324 (code 'doQuit 2) 1325 ld X (E CDR) # Args 1326 call evSymX_E # Evaluate to a symbol 1327 call bufStringE_SZ # Write to stack buffer 1328 ld X (X CDR) # Next arg? 1329 atom X 1330 ldnz E 0 # No 1331 if z # Yes 1332 ld E (X) 1333 eval # Eval 1334 end 1335 ld X 0 # No context 1336 ld Y QuitMsg # Format string 1337 ld Z S # Buffer pointer 1338 jmp errEXYZ # Jump to error handler 1339 1340 ### Evaluation ### 1341 # Apply EXPR in C to CDR of E 1342 (code 'evExprCE_E 0) 1343 push X 1344 push Y 1345 push Z 1346 cmp S (StkLimit) # Stack check 1347 jlt stkErrE 1348 ld X (E CDR) # Get CDR 1349 ld Y (C) # Parameter list in Y 1350 ld Z (C CDR) # Body in Z 1351 push E # Save 'exe' 1352 push (EnvBind) # Build bind frame 1353 link 1354 push (At) # Bind At 1355 push At 1356 do 1357 atom Y # More evaluating parameters? 1358 while z # Yes 1359 ld E (X) # Get next argument 1360 ld X (X CDR) 1361 eval+ # Evaluate and save 1362 push E 1363 push (Y) # Save symbol 1364 ld Y (Y CDR) 1365 loop 1366 cmp Y Nil # NIL-terminated parameter list? 1367 if eq # Yes: Bind parameter symbols 1368 ld Y S # Y on bindings 1369 do 1370 ld X (Y) # Symbol in X 1371 add Y I 1372 ld A (X) # Old value in A 1373 ld (X) (Y) # Set new value 1374 ld (Y) A # Save old value 1375 add Y I 1376 cmp Y L # End? 1377 until eq # Yes 1378 link 1379 ld (EnvBind) L # Close bind frame 1380 push 0 # Init env swap 1381 prog Z # Run body 1382 add S I # Drop env swap 1383 pop L # Get link 1384 do # Unbind symbols 1385 pop X # Next symbol 1386 pop (X) # Restore value 1387 cmp S L # More? 1388 until eq # No 1389 pop L # Restore link 1390 pop (EnvBind) # Restore bind link 1391 add S I # Drop 'exe' 1392 pop Z 1393 pop Y 1394 pop X 1395 ret 1396 end 1397 # Non-NIL parameter 1398 cmp Y At # '@'? 1399 if ne # No 1400 push (Y) # Save last parameter's old value 1401 push Y # and the last parameter 1402 ld (Y) X # Set to unevaluated argument list 1403 lea Y (S II) # Y on evaluated bindings 1404 do 1405 ld X (Y) # Symbol in X 1406 add Y I 1407 ld A (X) # Old value in A 1408 ld (X) (Y) # Set new value 1409 ld (Y) A # Save old value 1410 add Y I 1411 cmp Y L # End? 1412 until eq # Yes 1413 link 1414 ld (EnvBind) L # Close bind frame 1415 push 0 # Init env swap 1416 prog Z # Run body 1417 add S I # Drop env swap 1418 pop L # Get link 1419 do # Unbind symbols 1420 pop X # Next symbol 1421 pop (X) # Restore value 1422 cmp S L # More? 1423 until eq # No 1424 pop L # Restore link 1425 pop (EnvBind) # Restore bind link 1426 add S I # Drop 'exe' 1427 pop Z 1428 pop Y 1429 pop X 1430 ret 1431 end 1432 # Evaluated argument list 1433 link # Close bind frame 1434 ld Y L # Y on frame 1435 push 0 # Init env swap 1436 push (EnvNext) # Save current 'next' 1437 push (EnvArgs) # and varArgs base 1438 atom X # Any args? 1439 if nz # No 1440 ld (EnvArgs) 0 1441 ld (EnvNext) 0 1442 else 1443 link # Build varArgs frame 1444 do 1445 ld E (X) # Get next argument 1446 eval+ # Evaluate and save 1447 push E 1448 ld X (X CDR) 1449 atom X # More args? 1450 until nz # No 1451 ld (EnvArgs) S # Set new varArgs base 1452 ld (EnvNext) L # Set new 'next' 1453 link # Close varArgs frame 1454 end 1455 ld (EnvBind) Y # Close bind frame 1456 ld C (Y) # End of bindings in C 1457 add Y I 1458 do 1459 ld X (Y) # Symbol in X 1460 add Y I 1461 ld A (X) # Old value in A 1462 ld (X) (Y) # Set new value 1463 ld (Y) A # Save old value 1464 add Y I 1465 cmp Y C # End? 1466 until eq # Yes 1467 prog Z # Run body 1468 null (EnvArgs) # VarArgs? 1469 if nz # Yes 1470 drop # Drop varArgs 1471 end 1472 pop (EnvArgs) # Restore varArgs base 1473 pop (EnvNext) # and 'next' 1474 add S I # Drop env swap 1475 pop L # Get link 1476 do # Unbind symbols 1477 pop X # Next symbol 1478 pop (X) # Restore value 1479 cmp S L # More? 1480 until eq # No 1481 pop L # Restore link 1482 pop (EnvBind) # Restore bind link 1483 add S I # Drop 'exe' 1484 pop Z 1485 pop Y 1486 pop X 1487 ret 1488 1489 # Evaluate a list 1490 (code 'evListE_E 0) 1491 ld C (E) # Get CAR in C 1492 num C # Number? 1493 jnz ret # Yes: Return list 1494 sym C # Symbol? 1495 if nz # Yes 1496 10 do # C is a symbol 1497 null (Signal) # Signal? 1498 if nz # Yes 1499 push E 1500 call sighandlerE 1501 pop E 1502 end 1503 ld A (C) # Get VAL 1504 cnt A # Short number? 1505 jnz (A T) # Yes: Eval SUBR 1506 big A # Undefined if bignum 1507 jnz undefinedCE 1508 cmp A (A) # Auto-symbol? 1509 if ne # No 1510 ld C A 1511 atom C # Symbol? 1512 jz evExprCE_E # No: Apply EXPR 1513 else 1514 call sharedLibC_FA # Try dynamic load 1515 jnz (A T) # Eval SUBR 1516 jmp undefinedCE 1517 end 1518 loop 1519 end 1520 push E 1521 ld E C 1522 cmp S (StkLimit) # Stack check 1523 jlt stkErr 1524 call evListE_E 1525 ld C E 1526 pop E 1527 cnt C # Short number? 1528 jnz (C T) # Yes: Eval SUBR 1529 big C # Undefined if bignum 1530 jnz undefinedCE 1531 link 1532 push C # Save function 1533 link 1534 atom C # Symbol? 1535 if z 1536 call evExprCE_E # No: Apply EXPR 1537 else 1538 call 10 1539 end 1540 drop 1541 ret 1542 1543 (code 'sharedLibC_FA) 1544 push C 1545 push E 1546 push Y 1547 push Z 1548 ld E C # Get symbol in E 1549 call bufStringE_SZ # Write to stack buffer 1550 ld C 0 1551 ld Y S # Search for colon and slash 1552 do 1553 ld B (Y) # Next byte 1554 or B B # End of string? 1555 jz 90 # Yes 1556 cmp B (char ":") # Colon? 1557 while ne # No 1558 cmp B (char "/") # Slash? 1559 if eq # Yes 1560 ld C Y # Keep pointer to slash 1561 end 1562 inc Y # Increment buffer pointer 1563 loop 1564 cmp Y Z # At start of buffer? 1565 jeq 90 # Yes 1566 nul (Y 1) # At end of buffer? 1567 jz 90 # Yes 1568 set (Y) 0 # Replace colon with null byte 1569 inc Y # Point to token 1570 null C # Contained '/'? 1571 ld C S # Pointer to lib name 1572 if z # No 1573 sub S 8 # Extend buffer 1574 sub C 4 # Prepend "lib/" 1575 set (C 3) (char "/") 1576 set (C 2) (char "b") 1577 set (C 1) (char "i") 1578 set (C) (char "l") 1579 ld A (Home) # Home directory? 1580 null A 1581 if nz # Yes 1582 do 1583 inc A # Find end 1584 nul (A) 1585 until z 1586 sub A (Home) # Calculate length 1587 sub C A # Adjust buffer 1588 ld S C 1589 off S 7 1590 movn (C) ((Home)) A # Insert home path 1591 end 1592 end 1593 cc dlopen(C (| RTLD_LAZY RTLD_GLOBAL)) # Open dynamic library 1594 null A # OK? 1595 if nz # Yes 1596 cc dlsym(A Y) # Find dynamic symbol 1597 null A # OK? 1598 if nz # Yes 1599 initLib 1600 ? *AlignedCode 1601 or A CNT # Make short number 1602 = 1603 ld (E) A # 'nz' - Set function definition 1604 end 1605 end 1606 90 ld S Z # Drop buffer 1607 pop Z 1608 pop Y 1609 pop E 1610 pop C 1611 ret 1612 1613 # (errno) -> cnt 1614 (code 'doErrno 2) 1615 call errno_A # Get 'errno' 1616 ld E A 1617 shl E 4 # Make short number 1618 or E CNT 1619 ret 1620 1621 # (native 'cnt1|sym1 'cnt2|sym2 'any 'any ..) -> any 1622 (code 'doNative 2) 1623 push X 1624 push Y 1625 push Z 1626 ld X E 1627 ld Y (E CDR) # Y on args 1628 ld E (Y) # Eval library 'cnt1|sym1' 1629 eval 1630 cnt E # Library handle? 1631 if nz # Yes 1632 shr E 4 # Normalize 1633 push E # <S> Library handle 1634 else 1635 big E # Library handle? 1636 if nz # Yes 1637 push (E DIG) # <S> Library handle 1638 else 1639 call needSymEX # Check symbol 1640 ld A (E TAIL) # Check for main program library 1641 call nameA_A # Get name 1642 cmp A (| CNT (>> -4 (char "@"))) # "@"? 1643 if eq # Yes 1644 cc dlopen(0 (| RTLD_LAZY RTLD_GLOBAL)) # Open main library 1645 else 1646 call pathStringE_SZ # Write to stack buffer 1647 cc dlopen(S (| RTLD_LAZY RTLD_GLOBAL)) # Open dynamic library 1648 ld S Z # Drop buffer 1649 end 1650 null A # OK? 1651 jz dlErrX # No 1652 push A # <S> Library handle 1653 test A (hex "F000000000000000") # Fit in short number? 1654 if z # Yes 1655 shl A 4 # Make short number 1656 or A CNT 1657 else 1658 call boxNumA_A # Make bignum 1659 end 1660 ld (E) A # Set value of 'sym1' 1661 end 1662 end 1663 ld Y (Y CDR) # Second arg 1664 ld E (Y) # Eval function 'cnt2|sym2' 1665 eval 1666 ld Z S # Stack marker in Z 1667 cnt E # Function pointer? 1668 if nz # Yes 1669 shr E 4 # Normalize 1670 ld (S) E # <Z> Function pointer 1671 else 1672 big E # Function pointer?? 1673 if nz # Yes 1674 ld (S) (E DIG) # <Z> Function pointer 1675 else 1676 call needSymEX # Check symbol 1677 call bufStringE_SZ # Write to stack buffer 1678 cc dlsym((Z) S) # Find dynamic symbol 1679 null A # OK? 1680 jz dlErrX # No 1681 ld S Z # Drop buffer 1682 ld (S) A # <Z> Function pointer 1683 test A (hex "F000000000000000") # Fit in short number? 1684 if z # Yes 1685 shl A 4 # Make short number 1686 or A CNT 1687 else 1688 call boxNumA_A # Make bignum 1689 end 1690 ld (E) A # Set value 1691 end 1692 end 1693 ld Y (Y CDR) # Third arg 1694 ld E (Y) # Eval result specification 1695 eval 1696 link 1697 push E # <Z -II> Result specification 1698 do 1699 ld Y (Y CDR) # Arguments? 1700 atom Y 1701 while z # Yes 1702 ld E (Y) # Eval argument specification 1703 eval+ 1704 push E 1705 loop 1706 ld X S # X on last argument 1707 link 1708 push (CLink) # Save Link 1709 ld (CLink) L 1710 lea Y (Z -II) # Limit 1711 do 1712 cmp X Y # More args? 1713 while ne # Yes 1714 ld E (X) # Argument specification 1715 num E # Number? 1716 if nz # Yes 1717 cnt E # Short? 1718 if nz # Yes 1719 shr E 4 # Normalize 1720 if c # Sign? 1721 neg E # Yes 1722 end 1723 else 1724 test E SIGN # Sign? 1725 if z # No 1726 ld E (E DIG) 1727 else 1728 ld E (E (- DIG SIGN)) 1729 neg E # Negate 1730 end 1731 end 1732 push E # Pass long argument 1733 push 0 # as Integer/pointer value 1734 else 1735 sym E # String? 1736 if nz # Yes 1737 push Z 1738 call bufStringE_SZ # Write to stack buffer 1739 cc strdup(S) # Make new string 1740 ld S Z # Drop buffer 1741 pop Z 1742 push A # Pass pointer argument 1743 push 0 # as Integer/pointer value 1744 else 1745 ld C (E CDR) # Fixpoint? 1746 cnt C 1747 if nz # Yes 1748 push (E) # Pass number or flag 1749 push C # as fixpoint value 1750 else # Structure 1751 ld E C # Ignore variable 1752 ld C ((E)) # Get buffer size 1753 shr C 4 # Normalize 1754 call allocC_A # Allocate buffer 1755 push A # Pass pointer argument 1756 push 0 # as Integer/pointer value 1757 push Z 1758 ld Z A # Buffer pointer in Z 1759 do 1760 ld E (E CDR) 1761 cnt E # Fill rest? 1762 if nz # Yes 1763 ld A E # Byte value 1764 shr A 4 # in B 1765 do 1766 dec C # Done? 1767 while ns # No 1768 ld (Z) B # Store byte in buffer 1769 inc Z # Increment buffer pointer 1770 loop 1771 break T 1772 end 1773 atom E # Fill structure? 1774 while z # Yes 1775 ld A (E) # Next value 1776 call natBufACZ_CZ # Store in buffer 1777 null C # Buffer full? 1778 until z # Yes 1779 pop Z 1780 end 1781 end 1782 end 1783 add X I # Next arg 1784 loop 1785 lea X (L -I) # Top of arguments 1786 ld Y (Z) # Get function pointer 1787 cc (Y) X # Call C-function 1788 ld (CLink) (L -I) # Restore Link 1789 ld E (Z -II) # Get result specification 1790 ld C 0 # No pointer yet 1791 call natRetACE_CE # Extract return value 1792 ld (Z -II) E # Save result 1793 lea Y (Z -III) # Clean up allocated C args 1794 do 1795 cmp Y L # Args? 1796 while ne # Yes 1797 add S I # Drop type 1798 pop X # Next C arg 1799 ld E (Y) # Next Lisp arg 1800 num E # Number? 1801 if z # No 1802 sym E # String? 1803 jnz 10 # Yes 1804 cnt (E CDR) # Fixpoint? 1805 if z # No 1806 cmp (E) Nil # Variable? 1807 if ne # Yes 1808 ld C X # Structure pointer 1809 ld E (((E CDR)) CDR) # Result specification 1810 call natRetACE_CE # Extract value 1811 ld (((Y))) E # Store in variable 1812 end 1813 10 cc free(X) # Free string or buffer 1814 end 1815 end 1816 sub Y I 1817 loop 1818 ld E (Z -II) # Get result 1819 drop 1820 add S I # Drop library handle 1821 pop Z 1822 pop Y 1823 pop X 1824 ret 1825 1826 (code 'natBufACZ_CZ 0) 1827 atom A # Byte or unsigned? 1828 if nz # Yes 1829 shr A 4 # Byte? 1830 if nc # Yes 1831 ld (Z) B # Store byte in buffer 1832 inc Z # Increment buffer pointer 1833 dec C # Decrement size 1834 ret 1835 end 1836 st4 (Z) # Store unsigned in buffer 1837 add Z 4 # Size of unsigned 1838 sub C 4 # Decrement size 1839 ret 1840 end 1841 # (num|sym . cnt) or ([-]1.0 . lst) 1842 push X 1843 ld X (A CDR) # 'cnt' or 'lst' 1844 ld A (A) # 'num', 'sym' or [-]1.0 1845 cnt X # 'cnt'? 1846 if nz # Yes 1847 push Y 1848 ld Y Z # Y on buffer 1849 shr X 4 # Normalize length 1850 add Z X # Field width 1851 sub C X # New buffer size 1852 num A # (num . cnt)? 1853 if nz # Yes 1854 cnt A # Short? 1855 if nz # Yes 1856 shr A 4 # Normalize 1857 if c # Sign? 1858 neg A # Yes 1859 end 1860 else 1861 test A SIGN # Sign? 1862 if z # No 1863 ld A (A DIG) 1864 else 1865 ld A (A (- DIG SIGN)) 1866 neg A # Negate 1867 end 1868 end 1869 ? *LittleEndian 1870 do 1871 ld (Y) B # Store byte 1872 inc Y # Increment pointer 1873 shr A 8 1874 dec X # Done? 1875 until z # Yes 1876 = 1877 ? (not *LittleEndian) 1878 ld Y Z 1879 do 1880 dec Y # Decrement pointer 1881 ld (Y) B # Store byte 1882 shr A 8 1883 dec X # Done? 1884 until z # Yes 1885 = 1886 else 1887 sym A # (sym . cnt)? 1888 if nz # Yes 1889 push C 1890 ld X (A TAIL) # Get name 1891 call nameX_X 1892 ld C 0 1893 do 1894 call symByteCX_FACX # Next byte 1895 while nz 1896 ld (Y) B # Store it 1897 inc Y # Increment pointer 1898 loop 1899 set (Y) 0 # Null byte 1900 pop C 1901 end 1902 end 1903 pop Y 1904 else # ([-]1.0 . lst) 1905 do 1906 atom X # More fixpoint numbers? 1907 while z # Yes 1908 float # Convert to floating point 1909 test A SIGN # Scale negative? 1910 if z # No 1911 std # Store double value 1912 add Z 8 # Size of double 1913 sub C 8 # Decrement buffer size 1914 else 1915 stf # Store float value 1916 add Z 4 # Size of float 1917 sub C 4 # Decrement buffer size 1918 end 1919 ld X (X CDR) 1920 loop 1921 end 1922 pop X 1923 ret 1924 1925 (code 'natRetACE_CE 0) 1926 cmp E Nil # NIL? 1927 if ne 1928 cnt E # Scale? 1929 if nz # Yes 1930 null C # Pointer? 1931 if nz # Yes 1932 test E SIGN # Negative? 1933 if z # No 1934 ldd # Get double value 1935 add C 8 # Size of double 1936 else 1937 ldf # Get float value 1938 add C 4 # Size of float 1939 end 1940 end 1941 fixnum # Get fixpoint number or flg 1942 else 1943 cmp E ISym # 'I'? 1944 if eq # Yes 1945 null C # Pointer? 1946 if nz # Yes 1947 ld4 (C) 1948 add C 4 # Size of int 1949 end 1950 ld E (hex "FFFFFFFF") # Sign-extend integer 1951 and E A # into E 1952 ld A (hex "80000000") 1953 xor E A 1954 sub E A # Negative? 1955 if ns # No 1956 shl E 4 # Make short number 1957 or E CNT 1958 else 1959 neg E # Negate 1960 shl E 4 # Make negative short number 1961 or E (| SIGN CNT) 1962 end 1963 else 1964 cmp E NSym # 'N'? 1965 if eq # Yes 1966 null C # Pointer? 1967 if nz # Yes 1968 ld A (C) 1969 add C 8 # Size of long/pointer 1970 end 1971 ld E A # Number 1972 call boxE_E 1973 else 1974 cmp E SSym # 'S'? 1975 if eq # Yes 1976 null C # Pointer? 1977 if nz # Yes 1978 ld A (C) 1979 add C 8 # Size of pointer 1980 end 1981 ld E A # Make transient symbol 1982 call mkStrE_E 1983 else 1984 cmp E CSym # 'C'? 1985 if eq # Yes 1986 null C # Pointer? 1987 if nz # Yes 1988 call fetchCharC_AC # Fetch char 1989 end 1990 ld E Nil # Preload 1991 null A # Char? 1992 if nz # Yes 1993 call mkCharA_A # Make char 1994 ld E A 1995 end 1996 else 1997 cmp E BSym # 'B'? 1998 if eq # Yes 1999 null C # Pointer? 2000 if nz # Yes 2001 ld B (C) 2002 inc C # Size of byte 2003 end 2004 zxt # Byte 2005 ld E A 2006 shl E 4 # Make short number 2007 or E CNT 2008 else 2009 atom E # Atomic? 2010 if z # No: Arrary or structure 2011 null C # Primary return value? 2012 ldz C A # Yes: Get into C 2013 null C # Value NULL? 2014 ldz E Nil # Yes: Return NIL 2015 if nz 2016 push X 2017 push Y 2018 push Z 2019 ld X E # Get specification in X 2020 ld E (X) 2021 call natRetACE_CE # First item 2022 call cons_Y # Make cell 2023 ld (Y) E 2024 ld (Y CDR) Nil 2025 link 2026 push Y # <L I> Result 2027 link 2028 do 2029 ld Z (X CDR) 2030 cnt Z # (sym . cnt) 2031 if nz 2032 shr Z 4 # Normalize 2033 do 2034 dec Z # Decrement count 2035 while nz 2036 ld E (X) # Repeat last type 2037 call natRetACE_CE # Next item 2038 call cons_A # Cons into cell 2039 ld (A) E 2040 ld (A CDR) Nil 2041 ld (Y CDR) A # Append to result 2042 ld Y A 2043 loop 2044 break T 2045 end 2046 atom Z # End of specification? 2047 while z # No 2048 ld X Z 2049 ld E (X) # Next type 2050 call natRetACE_CE # Next item 2051 call cons_A # Cons into cell 2052 ld (A) E 2053 ld (A CDR) Nil 2054 ld (Y CDR) A # Append to result 2055 ld Y A 2056 loop 2057 ld E (L I) # Get result 2058 drop 2059 pop Z 2060 pop Y 2061 pop X 2062 end 2063 end 2064 end 2065 end 2066 end 2067 end 2068 end 2069 end 2070 end 2071 ret 2072 2073 # (struct 'num 'any 'any ..) -> any 2074 (code 'doStruct 2) 2075 push X 2076 push Y 2077 push Z 2078 ld X E 2079 ld Y (E CDR) # Y on args 2080 ld E (Y) # Eval native value (pointer or scalar) 2081 eval 2082 num E # Number? 2083 jz numErrEX # No 2084 cnt E # Short? 2085 if nz # Yes 2086 shr E 4 # Normalize 2087 ld Z E # Native value in Z 2088 else 2089 ld Z (E DIG) # Native value in Z 2090 end 2091 ld Y (Y CDR) # Next arg 2092 ld E (Y) 2093 eval # Eval 'any' 2094 link 2095 push E # <L I> Result specification 2096 link 2097 push Z # Save native value 2098 do 2099 ld Y (Y CDR) # Arguments? 2100 atom Y 2101 while z # Yes 2102 ld E (Y) # Eval next struct element 2103 eval 2104 ld A E # in A (unused C) 2105 call natBufACZ_CZ # Store in buffer 2106 loop 2107 pop A # Get native value 2108 ld C 0 # No pointer yet 2109 ld E (L I) # Result specification 2110 call natRetACE_CE # Extract return value 2111 drop 2112 pop Z 2113 pop Y 2114 pop X 2115 ret 2116 2117 (code 'fetchCharC_AC 0) 2118 ld B (C) # Fetch first byte 2119 zxt 2120 or B B # Any? 2121 if nz # Yes 2122 inc C 2123 cmp B 128 # Single byte? 2124 if ge # No 2125 test B (hex "20") # Two bytes? 2126 if z # Yes 2127 and B (hex "1F") # First byte 110xxxxx 2128 shl A 6 # xxxxx000000 2129 push A 2130 else # Three bytes 2131 and B (hex "F") # First byte 1110xxxx 2132 shl A 6 # xxxx000000 2133 push A 2134 ld B (C) # Fetch second byte 2135 zxt 2136 inc C 2137 and B (hex "3F") # 10xxxxxx 2138 or A (S) # Combine 2139 shl A 6 # xxxxxxxxxx000000 2140 ld (S) A 2141 end 2142 ld B (C) # Fetch last byte 2143 zxt 2144 inc C 2145 and B (hex "3F") # 10xxxxxx 2146 or (S) A # Combine 2147 pop A # Get result 2148 end 2149 end 2150 ret 2151 2152 : cbl 2153 push L # Save C frame pointer 2154 ld L (CLink) # Restore link register 2155 link # Apply args 2156 push (Z I) # 'fun' 2157 xchg A E # First arg 2158 call boxE_E # Make number 2159 push E 2160 ld E C # Second arg 2161 call boxE_E # Make number 2162 push E 2163 ld E A # Third arg 2164 call boxE_E # Make number 2165 push E 2166 ld E X # Fourth arg 2167 call boxE_E # Make number 2168 push E 2169 ld E Y # Fifth arg 2170 call boxE_E # Make number 2171 push E 2172 ld Z S # Z on last argument 2173 link # Close frame 2174 lea Y (S VI) # Pointer to 'fun' in Y 2175 call applyXYZ_E # Apply 2176 ld A E # Return value 2177 shr A 4 # Normalize 2178 if c # Sign? 2179 neg A # Yes 2180 end 2181 drop 2182 pop L # Restore C frame pointer 2183 return 2184 2185 (code 'cbl1 0) 2186 begin # Arguments in A, C, E, X and Y 2187 lea Z (Lisp) # Address of callback function 2188 jmp cbl 2189 : cbl2 2190 begin 2191 lea Z (Lisp II) 2192 jmp cbl 2193 : cbl3 2194 begin 2195 lea Z (Lisp (* 2 II)) 2196 jmp cbl 2197 : cbl4 2198 begin 2199 lea Z (Lisp (* 3 II)) 2200 jmp cbl 2201 : cbl5 2202 begin 2203 lea Z (Lisp (* 4 II)) 2204 jmp cbl 2205 : cbl6 2206 begin 2207 lea Z (Lisp (* 5 II)) 2208 jmp cbl 2209 : cbl7 2210 begin 2211 lea Z (Lisp (* 6 II)) 2212 jmp cbl 2213 : cbl8 2214 begin 2215 lea Z (Lisp (* 7 II)) 2216 jmp cbl 2217 : cbl9 2218 begin 2219 lea Z (Lisp (* 8 II)) 2220 jmp cbl 2221 : cbl10 2222 begin 2223 lea Z (Lisp (* 9 II)) 2224 jmp cbl 2225 : cbl11 2226 begin 2227 lea Z (Lisp (* 10 II)) 2228 jmp cbl 2229 : cbl12 2230 begin 2231 lea Z (Lisp (* 11 II)) 2232 jmp cbl 2233 : cbl13 2234 begin 2235 lea Z (Lisp (* 12 II)) 2236 jmp cbl 2237 : cbl14 2238 begin 2239 lea Z (Lisp (* 13 II)) 2240 jmp cbl 2241 : cbl15 2242 begin 2243 lea Z (Lisp (* 14 II)) 2244 jmp cbl 2245 : cbl16 2246 begin 2247 lea Z (Lisp (* 15 II)) 2248 jmp cbl 2249 : cbl17 2250 begin 2251 lea Z (Lisp (* 16 II)) 2252 jmp cbl 2253 : cbl18 2254 begin 2255 lea Z (Lisp (* 17 II)) 2256 jmp cbl 2257 : cbl19 2258 begin 2259 lea Z (Lisp (* 18 II)) 2260 jmp cbl 2261 : cbl20 2262 begin 2263 lea Z (Lisp (* 19 II)) 2264 jmp cbl 2265 : cbl21 2266 begin 2267 lea Z (Lisp (* 20 II)) 2268 jmp cbl 2269 : cbl22 2270 begin 2271 lea Z (Lisp (* 21 II)) 2272 jmp cbl 2273 : cbl23 2274 begin 2275 lea Z (Lisp (* 22 II)) 2276 jmp cbl 2277 : cbl24 2278 begin 2279 lea Z (Lisp (* 23 II)) 2280 jmp cbl 2281 2282 # (lisp 'sym ['fun]) -> num 2283 (code 'doLisp 2) 2284 push X 2285 push Y 2286 ld X E 2287 ld Y (E CDR) # Get tag 2288 call evSymY_E # Evaluate to a symbol 2289 ld A Lisp # Search lisp callback definitions 2290 ld C cbl1 2291 do 2292 cmp E (A) # Found tag? 2293 jeq 10 # Yes 2294 add A II # Next entry 2295 add C "cbl2-cbl1" 2296 cmp A LispEnd 2297 until eq 2298 ld A Lisp # Not found, search for empty slot 2299 ld C cbl1 2300 do 2301 cmp (A I) Nil # Empty? 2302 if eq # Yes 2303 10 push C # Save function pointer 2304 push A # And callback entry 2305 ld (A) E # Store tag 2306 ld E ((Y CDR)) # Eval 'fun' 2307 eval 2308 pop A 2309 ld (A I) E # Store in slot 2310 pop E # Get function pointer 2311 func 2312 pop Y 2313 pop X 2314 test E (hex "F000000000000000") # Fit in short number? 2315 jnz boxNumE_E # No 2316 shl E 4 # Else make short number 2317 or E CNT 2318 ret 2319 end 2320 add A II # Next entry 2321 add C "cbl2-cbl1" 2322 cmp A LispEnd 2323 until eq 2324 ld Y CbErr 2325 jmp errEXYZ 2326 2327 (code 'lisp 0) 2328 begin # Function name in A, arguments in C, E, X, Y and Z 2329 push L # Save C frame pointer 2330 ld L (CLink) # Restore link register 2331 link # Apply args 2332 push ZERO # Space for 'fun' 2333 xchg C E # First arg 2334 call boxE_E # Make number 2335 push E 2336 ld E C # Second arg 2337 call boxE_E # Make number 2338 push E 2339 ld E X # Third arg 2340 call boxE_E # Make number 2341 push E 2342 ld E Y # Fourth arg 2343 call boxE_E # Make number 2344 push E 2345 ld E Z # Fifth arg 2346 call boxE_E # Make number 2347 push E 2348 ld Z S # Z on last argument 2349 link # Close frame 2350 ld C 4 # Build name 2351 ld E A # Function name argument 2352 lea X (S VI) # Pointer to 'fun' entry 2353 do 2354 ld B (E) 2355 call byteSymBCX_CX # Pack byte 2356 inc E # Next byte 2357 nul (E) # Any? 2358 until z 2359 ld X (S VI) # Get name 2360 call findSymX_E # Find or create symbol 2361 lea Y (S VI) # Pointer to 'fun' in Y 2362 ld (Y) E # Store 'fun' 2363 call applyXYZ_E # Apply 2364 ld A E # Return value 2365 shr A 4 # Normalize 2366 if c # Sign? 2367 neg A # Yes 2368 end 2369 drop 2370 pop L # Restore C frame pointer 2371 return 2372 2373 (code 'execE 0) 2374 push X 2375 ld X E 2376 link 2377 push (At) # <L I> Preserve '@' 2378 link 2379 exec X # Execute body 2380 ld (At) (L I) 2381 drop 2382 pop X 2383 ret 2384 2385 (code 'runE_E 0) 2386 push X 2387 ld X E 2388 link 2389 push (At) # <L I> Preserve '@' 2390 link 2391 prog X # Run body 2392 ld (At) (L I) 2393 drop 2394 pop X 2395 ret 2396 2397 (code 'funqE_FE 0) 2398 cnt E # Short number? 2399 jnz retz # Yes 2400 big E # Big number? 2401 jnz ret # No 2402 sym E # Symbol? 2403 jnz ret # Yes 2404 ld C (E CDR) # Check function body 2405 do 2406 atom C # More? 2407 while z # Yes 2408 cmp C E # Circular? 2409 jeq retnz # Yes 2410 ld A (C) # Next item 2411 atom A # Pair? 2412 if z # Yes 2413 num (A) # CAR a number? 2414 if nz # Yes 2415 atom (C CDR) # Must be the last 2416 jz retnz 2417 else 2418 cmp (A) Nil # CAR is NIL? 2419 jeq retnz # Yes 2420 cmp (A) TSym # CAR is T? 2421 jeq retnz # Yes 2422 end 2423 else 2424 cmp (C CDR) Nil # Atomic item must be the last 2425 jne ret 2426 end 2427 ld C (C CDR) 2428 loop 2429 cmp C Nil # Must be NIL-terminated 2430 jne ret 2431 ld E (E) # Get parameter(s) 2432 cmp E Nil # Any? 2433 ldz E TSym # No: Return T 2434 if ne # Yes 2435 ld C E 2436 do 2437 atom C # Atomic parameter? 2438 while z # No 2439 ld A (C) # Next parameter 2440 num A # Number? 2441 jnz ret # Yes 2442 atom A # List? 2443 jz retnz # Yes 2444 cmp A Nil # NIL? 2445 jeq retnz # Yes 2446 cmp A TSym # T? 2447 jeq retnz # Yes 2448 ld C (C CDR) # Rest 2449 cmp C E # Circular? 2450 jeq retnz # Yes 2451 loop 2452 cmp C TSym # T? 2453 jeq retnz # Yes 2454 num C # Number? 2455 jnz ret # Yes 2456 end 2457 ret 2458 2459 (code 'evSymX_E 0) 2460 ld E (X) # Get CAR 2461 jmp evSymE_E 2462 (code 'evSymY_E 0) 2463 ld E (Y) # Get CAR 2464 (code 'evSymE_E) 2465 eval # Evaluate 2466 (code 'xSymE_E) 2467 num E # Number? 2468 if z # No 2469 sym E # Symbol? 2470 jnz ret # Yes 2471 end 2472 push X 2473 link 2474 push E # Save 'any' 2475 push ZERO # <L II> Number safe 2476 push ZERO # <L I> Result 2477 ld C 4 # Build name 2478 ld X S 2479 link 2480 call packECX_CX 2481 ld X (L I) # Get result 2482 call consSymX_E # Make transient symbol 2483 drop 2484 pop X 2485 ret 2486 2487 (code 'evCntXY_FE 0) 2488 ld E (Y) # Get CAR 2489 (code 'evCntEX_FE) 2490 eval # Evaluate 2491 (code 'xCntEX_FE 0) 2492 cnt E # # Short number? 2493 jz cntErrEX # No 2494 shr E 4 # Normalize 2495 if c # Sign? 2496 neg E # Yes 2497 end 2498 ret # 'z' if null, 's' if negative 2499 2500 (code 'xCntCX_FC 0) 2501 cnt C # # Short number? 2502 jz cntErrCX # No 2503 shr C 4 # Normalize 2504 if c # Sign? 2505 neg C # Yes 2506 end 2507 ret # 'z' if null, 's' if negative 2508 2509 (code 'xCntAX_FA 0) 2510 cnt A # # Short number? 2511 jz cntErrAX # No 2512 shr A 4 # Normalize 2513 if c # Sign? 2514 neg A # Yes 2515 end 2516 ret # 'z' if null, 's' if negative 2517 2518 (code 'boxE_E 0) 2519 null E # Positive? 2520 if ns # Yes 2521 test E (hex "F000000000000000") # Fit in short number? 2522 jnz boxNumE_E # No 2523 shl E 4 # Make short number 2524 or E CNT 2525 ret 2526 end 2527 neg E # Else negate 2528 test E (hex "F000000000000000") # Fit in short? 2529 if z # Yes 2530 shl E 4 # Make negative short number 2531 or E (| SIGN CNT) 2532 ret 2533 end 2534 call boxNumE_E # Make bignum 2535 or E SIGN # Set negative 2536 ret 2537 2538 (code 'putStringB 0) 2539 push X 2540 push C 2541 ld X (StrX) # Get string status 2542 ld C (StrC) 2543 call byteSymBCX_CX # Add byte to result 2544 ld (StrC) C # Save string status 2545 ld (StrX) X 2546 pop C 2547 pop X 2548 ret 2549 2550 (code 'begString 0) 2551 pop A # Get return address 2552 link 2553 push ZERO # <L I> Result 2554 ld (StrC) 4 # Build name 2555 ld (StrX) S 2556 link 2557 push (PutB) # Save 'put' 2558 ld (PutB) putStringB # Set new 2559 jmp (A) # Return 2560 2561 (code 'endString_E 0) 2562 pop A # Get return address 2563 pop (PutB) # Restore 'put' 2564 ld E Nil # Preload NIL 2565 cmp (L I) ZERO # Name? 2566 if ne # Yes 2567 call cons_E # Cons symbol 2568 ld (E) (L I) # Set name 2569 or E SYM # Make symbol 2570 ld (E) E # Set value to itself 2571 end 2572 drop 2573 jmp (A) # Return 2574 2575 ? (<> *TargetOS "Linux") 2576 (code 'msec_A) 2577 push C 2578 cc gettimeofday(Buf 0) # Get time 2579 ld A (Buf) # tv_sec 2580 mul 1000 # Convert to milliseconds 2581 ld (Buf) A # Save 2582 ld A (Buf I) # tv_usec 2583 div 1000 # Convert to milliseconds (C is zero) 2584 add A (Buf) 2585 pop C 2586 ret 2587 = 2588 2589 # (args) -> flg 2590 (code 'doArgs 2) 2591 cmp (EnvNext) (EnvArgs) # VarArgs? 2592 ld E Nil 2593 ldnz E TSym # Yes 2594 ret 2595 2596 # (next) -> any 2597 (code 'doNext 2) 2598 ld C (EnvNext) # VarArgs 2599 cmp C (EnvArgs) # Any? 2600 if ne # Yes 2601 sub C I # Get next 2602 ld E (C) 2603 ld (EnvNext) C 2604 ret 2605 end 2606 ld E Nil # No (more) arguments 2607 null C # Any previous arg? 2608 if nz # Yes 2609 ld (C) E # Set to NIL 2610 end 2611 ret 2612 2613 # (arg ['cnt]) -> any 2614 (code 'doArg 2) 2615 null (EnvArgs) # Any args? 2616 jz retNil # No 2617 ld E (E CDR) # 'cnt' arg? 2618 atom E 2619 if nz # No 2620 ld E ((EnvNext)) # Return arg from last call to 'next' 2621 ret 2622 end 2623 ld E (E) 2624 eval # Eval 'cnt' 2625 test E SIGN # Negative? 2626 if z # No 2627 shr E 1 # Normalize to word index 2628 off E 1 # Clear 'cnt' tag 2629 if nz # Greater zero 2630 ld C (EnvNext) # VarArgs 2631 sub C E # Subtract from VarArgs pointer 2632 cmp C (EnvArgs) # Out of range? 2633 if ge # No 2634 ld E (C) # Get value 2635 ret 2636 end 2637 end 2638 end 2639 ld E Nil 2640 ret 2641 2642 # (rest) -> lst 2643 (code 'doRest 2) 2644 ld E Nil # Return value 2645 ld C (EnvArgs) # VarArgs 2646 do 2647 cmp C (EnvNext) # Any? 2648 while ne # Yes 2649 call consE_A # New cell 2650 ld (A) (C) 2651 ld (A CDR) E 2652 ld E A 2653 add C I # Next 2654 loop 2655 ret 2656 2657 (code 'tmDateC_E 0) 2658 ld4 (C TM_MDAY) # Get day 2659 ld X A 2660 ld4 (C TM_MON) # month 2661 inc A 2662 ld Y A 2663 ld4 (C TM_YEAR) # and year 2664 add A 1900 2665 ld Z A 2666 # Date function 2667 (code 'dateXYZ_E 0) 2668 null Y # Month <= 0? 2669 jsz retNil 2670 cmp Y 12 # Month > 12? 2671 jgt retNil 2672 null X # Day <= 0? 2673 jsz retNil 2674 ld B (Y Month) # Max monthly days 2675 cmp X B # Day > max? 2676 if gt # Yes 2677 cmp Y 2 # February? 2678 jne retNil 2679 cmp X 29 # 29th? 2680 jne retNil 2681 test Z 3 # year a multiple of 4? 2682 jnz retNil 2683 ld A Z # Year 2684 ld C 0 2685 div 100 2686 null C # Multiple of 100? 2687 if z # Yes 2688 ld A Z # Year 2689 div 400 2690 null C # Multiple of 400? 2691 jnz retNil 2692 end 2693 end 2694 ld A Z # Get year 2695 mul 12 # times 12 2696 add A Y # plus month 2697 sub A 3 # minus 3 2698 ld C 0 2699 div 12 # divide by 12 2700 ld E A # n = (12 * year + month - 3) / 12 2701 ld C 0 2702 div 100 # divide by 100 2703 ld C E 2704 shr E 2 # n/4 2705 add C C # n*2 2706 sub E C # n/4 - n*2 2707 sub E A # n/4 - n*2 - n/100 2708 shr A 2 # n/400 2709 add E A # E = n/4 - n*2 - n/100 + n/400 2710 ld A Z # Year 2711 mul 4404 # times 4404 2712 ld Z A 2713 ld A Y # Month 2714 mul 367 # times 367 2715 add A Z # plus year*4404 2716 sub A 1094 # minus 1094 2717 div 12 # A = (4404*year + 367*month - 1094) / 12 2718 add E A # Add up 2719 add E X # plus days 2720 shl E 4 # Make short number 2721 or E CNT 2722 ret 2723 2724 # (date ['T]) -> dat 2725 # (date 'dat) -> (y m d) 2726 # (date 'y 'm 'd) -> dat | NIL 2727 # (date '(y m d)) -> dat | NIL 2728 (code 'doDate 2) 2729 push X 2730 push Y 2731 push Z 2732 ld X E 2733 ld Y (E CDR) # Y on args 2734 atom Y # Any? 2735 if nz # No 2736 cc gettimeofday(Tv 0) # Get current time 2737 cc localtime(Tv) # Convert to local time 2738 ld (Time) A # Keep in 'Time' 2739 ld C A 2740 call tmDateC_E # Extract date 2741 else 2742 ld E (Y) # Eval first 2743 eval 2744 cmp E TSym # T? 2745 if eq # Yes 2746 cc gettimeofday(Tv 0) # Get current time 2747 cc gmtime(Tv) # Convert to Greenwich Mean Time 2748 ld (Time) A # Keep in 'Time' 2749 ld C A 2750 call tmDateC_E # Extract date 2751 else 2752 cmp E Nil # NIL? 2753 if ne # No 2754 atom E # List? 2755 if z # Yes 2756 ld C (E) # Extract year 2757 call xCntCX_FC 2758 ld Z C 2759 ld E (E CDR) 2760 ld C (E) # month 2761 call xCntCX_FC 2762 ld Y C 2763 ld C ((E CDR)) # and day 2764 call xCntCX_FC 2765 ld X C 2766 call dateXYZ_E 2767 else 2768 ld Y (Y CDR) # More args? 2769 atom Y 2770 if nz # No 2771 call xCntEX_FE # Get date 2772 ld A E # 100 * n 2773 mul 100 2774 sub A 20 # minus 20 2775 ld C 0 # divide by 3652425 2776 div 3652425 2777 ld Z A # year = (100*n - 20) / 3652425 2778 add E A # n += (year - year/4) 2779 shr A 2 2780 sub E A 2781 ld A E # n 2782 mul 100 # 100 * n 2783 sub A 20 # minus 20 2784 div 36525 # divide by 36525 2785 ld Z A # year = (100*n - 20) / 36525 2786 mul 36525 # times 36525 2787 div 100 # divide by 100 2788 sub E A # n -= 36525*y / 100 2789 ld A E # n 2790 mul 10 # times 10 2791 sub A 5 # minus 5 2792 div 306 # divide by 306 2793 ld Y A # month = (10*n - 5) / 306 2794 mul 306 # times 306 2795 ld X A 2796 ld A E # n 2797 mul 10 # times 10 2798 sub A X # minus 306*month 2799 add A 5 # push 5 2800 div 10 # divide by 10 2801 ld X A # day = (10*n - 306*month + 5) / 10 2802 cmp Y 10 # month < 10? 2803 if lt # Yes 2804 add Y 3 # month += 3 2805 else 2806 inc Z # Increment year 2807 sub Y 9 # month -= 9 2808 end 2809 shl X 4 # Make short day 2810 or X CNT 2811 call cons_E # into cell 2812 ld (E) X 2813 ld (E CDR) Nil 2814 shl Y 4 # Make short month 2815 or Y CNT 2816 call consE_C # Cons 2817 ld (C) Y 2818 ld (C CDR) E 2819 shl Z 4 # Make short year 2820 or Z CNT 2821 call consC_E # Cons 2822 ld (E) Z 2823 ld (E CDR) C 2824 else 2825 call xCntEX_FE # Extract year 2826 ld Z E # into Z 2827 call evCntXY_FE # Eval month 2828 push E # Save 2829 ld Y (Y CDR) # Eval day 2830 call evCntXY_FE 2831 ld X E # Get day 2832 pop Y # and month 2833 call dateXYZ_E 2834 end 2835 end 2836 end 2837 end 2838 end 2839 pop Z 2840 pop Y 2841 pop X 2842 ret 2843 2844 (code 'tmTimeY_E 0) 2845 ld4 (Y TM_HOUR) # Get hour 2846 mul 3600 2847 ld E A 2848 ld4 (Y TM_MIN) # Get minute 2849 mul 60 2850 add E A 2851 ld4 (Y TM_SEC) # Get second 2852 add E A 2853 shl E 4 # Make short number 2854 or E CNT 2855 ret 2856 2857 # (time ['T]) -> tim 2858 # (time 'tim) -> (h m s) 2859 # (time 'h 'm ['s]) -> tim | NIL 2860 # (time '(h m [s])) -> tim | NIL 2861 (code 'doTime 2) 2862 push X 2863 push Y 2864 ld Y (E CDR) # Y on args 2865 atom Y # Any? 2866 if nz # No 2867 cc gettimeofday(Tv 0) # Get current time 2868 cc localtime(Tv) # Convert to local time 2869 ld Y A 2870 call tmTimeY_E # Extract time 2871 else 2872 ld E (Y) # Eval first 2873 eval 2874 cmp E TSym # T? 2875 if eq # Yes 2876 ld Y (Time) # Get time from last call to 'date' 2877 null Y # Any? 2878 ldz E Nil 2879 if nz # Yes 2880 call tmTimeY_E # Extract time 2881 end 2882 else 2883 cmp E Nil # NIL? 2884 if ne # No 2885 atom E # List? 2886 if z # Yes 2887 ld A (E) # Extract hour 2888 call xCntAX_FA 2889 mul 3600 2890 ld Y A 2891 ld E (E CDR) 2892 ld A (E) # minute 2893 call xCntAX_FA 2894 mul 60 2895 add Y A 2896 ld E (E CDR) # and second 2897 atom E # Any? 2898 ldnz E Y # No 2899 if z # Yes 2900 ld E (E) 2901 call xCntEX_FE 2902 add E Y # add minutes and hours 2903 end 2904 shl E 4 # Make short number 2905 or E CNT 2906 else 2907 ld Y (Y CDR) # More args? 2908 atom Y 2909 if nz # No 2910 call xCntEX_FE # Get time in total seconds 2911 ld A E 2912 ld C 0 2913 div 60 # Seconds in C 2914 shl C 4 # Make short number 2915 or C CNT 2916 call cons_Y # into cell 2917 ld (Y) C 2918 ld (Y CDR) Nil 2919 ld A E 2920 ld C 0 2921 div 60 # Total minutes in A 2922 ld C 0 2923 div 60 # Minutes in C 2924 shl C 4 # Make short number 2925 or C CNT 2926 call consY_X 2927 ld (X) C 2928 ld (X CDR) Y 2929 xchg A E # Get total seconds again 2930 ld C 0 2931 div 3600 # Hours in A 2932 shl A 4 # Make short number 2933 or A CNT 2934 call consX_E 2935 ld (E) A 2936 ld (E CDR) X 2937 else 2938 call xCntEX_FE # Extract hour 2939 ld A E 2940 mul 3600 2941 push A # Save hour 2942 call evCntXY_FE # Eval minute 2943 ld A E 2944 mul 60 2945 add (S) A # Add to hour 2946 ld Y (Y CDR) # Eval second 2947 atom Y # Any? 2948 if z # Yes 2949 call evCntXY_FE 2950 add (S) E 2951 end 2952 pop E # Get result 2953 shl E 4 # Make short number 2954 or E CNT 2955 end 2956 end 2957 end 2958 end 2959 end 2960 pop Y 2961 pop X 2962 ret 2963 2964 # (usec ['flg]) -> num 2965 (code 'doUsec 2) 2966 ld E ((E CDR)) # Eval arg 2967 eval 2968 cmp E Nil # NIL? 2969 ldnz E (Tv I) # No: tv_usec from last 'time' call 2970 if eq # Yes 2971 cc gettimeofday(Tv 0) # Get time 2972 ld A (Tv) # tv_sec 2973 mul 1000000 # Convert to microseconds 2974 add A (Tv I) # tv_usec 2975 sub A (USec) # Diff to startup time 2976 ld E A 2977 end 2978 shl E 4 # Make short number 2979 or E CNT 2980 ret 2981 2982 # (pwd) -> sym 2983 (code 'doPwd 2) 2984 cc getcwd(0 MAXPATHLEN) # Get current working directory 2985 null A # OK? 2986 jz retNil # No 2987 push A # Save buffer pointer 2988 ld E A # Make transient symbol 2989 call mkStrE_E 2990 cc free(pop) # Free buffer 2991 ret 2992 2993 # (cd 'any) -> sym 2994 (code 'doCd 2) 2995 push Z 2996 ld E ((E CDR)) # Get arg 2997 call evSymE_E # Evaluate to a symbol 2998 call pathStringE_SZ # Write to stack buffer 2999 ld E Nil # Preload return value 3000 cc getcwd(0 MAXPATHLEN) # Get current working directory 3001 null A # OK? 3002 if nz # Yes 3003 push A # Save buffer pointer 3004 nul (S I) # CWD empty? 3005 jz 10 # Yes 3006 cc chdir(&(S I)) # Stack buffer 3007 nul4 # OK? 3008 if z # Yes 3009 10 ld E (S) # Make transient symbol 3010 call mkStrE_E 3011 end 3012 cc free(pop) # Free buffer 3013 end 3014 ld S Z # Drop buffer 3015 pop Z 3016 ret 3017 3018 # (ctty 'sym|pid) -> flg 3019 (code 'doCtty 2) 3020 push X 3021 ld X E 3022 ld E ((E CDR)) # E on arg 3023 eval # Eval it 3024 cnt E # 'pid'? 3025 if nz # Yes 3026 shr E 4 # Normalize 3027 ld (TtyPid) E # Keep in global 3028 ld E TSym # Return T 3029 else 3030 sym E # Need symbol 3031 jz argErrEX 3032 push Z 3033 call bufStringE_SZ # Write to stack buffer 3034 ld E Nil # Preload return value 3035 cc freopen(S _r_ (stdin)) # Re-open standard input 3036 null A # OK? 3037 if nz # Yes 3038 cc freopen(S _w_ (stdout)) # Re-open standard output 3039 null A # OK? 3040 if nz # Yes 3041 cc freopen(S _w_ (stderr)) # Re-open standard error 3042 null A # OK? 3043 if nz # Yes 3044 ld (((OutFiles) I) II) 1 # (stdout) OutFiles[1]->tty 3045 ld E TSym # Return T 3046 end 3047 end 3048 end 3049 ld S Z # Drop buffer 3050 pop Z 3051 end 3052 pop X 3053 ret 3054 3055 # (info 'any ['flg]) -> (cnt|T dat . tim) 3056 (code 'doInfo 2) 3057 push X 3058 push Y 3059 push Z 3060 ld X (E CDR) # Args 3061 ld E (X) # Get 'any' 3062 call evSymE_E # Evaluate to a symbol 3063 call pathStringE_SZ # Write to stack buffer 3064 ld Y S # path name pointer 3065 sub S (%% STAT) # 'stat' structure 3066 ld X (X CDR) # Eval 'flg' 3067 ld E (X) 3068 eval 3069 cmp E Nil # NIL? 3070 if eq # Yes 3071 cc stat(Y S) # Get status 3072 else 3073 cc lstat(Y S) # or link status 3074 end 3075 ld E Nil # Preload return value 3076 nul4 # 'stat' OK? 3077 if ns 3078 cc gmtime(&(S ST_MTIME)) # Get modification time 3079 ld Y A # Keep time pointer in Y 3080 call tmTimeY_E # Extract time 3081 push E # Save time 3082 push Z 3083 ld C Y # Extract date 3084 call tmDateC_E 3085 pop Z 3086 call cons_X # New cell 3087 ld (X) E # Set date 3088 pop (X CDR) # and time 3089 call consX_E # New cell 3090 ld4 (S ST_MODE) # Get 'st_mode' from 'stat' 3091 and A S_IFMT 3092 cmp A S_IFDIR # Directory? 3093 if eq # Yes 3094 ld (E) TSym # CAR is T 3095 else 3096 ld A (S ST_SIZE) # Get size 3097 shl A 4 # Make short number 3098 or A CNT 3099 ld (E) A 3100 end 3101 ld (E CDR) X 3102 end 3103 ld S Z # Drop buffers 3104 pop Z 3105 pop Y 3106 pop X 3107 ret 3108 3109 # (file) -> (sym1 sym2 . num) | NIL 3110 (code 'doFile 2) 3111 ld C (InFile) # Current InFile? 3112 null C 3113 jz retNil # No 3114 ld E (C VI) # Filename? 3115 null E 3116 jz retNil # No 3117 ld B (char "/") # Contains a slash? 3118 slen C E # String length in C 3119 memb E C 3120 if eq # Yes 3121 do 3122 memb E C # Find last one 3123 until ne 3124 push Z 3125 ld Z E # Pointer to rest 3126 dec Z # without slash in Z 3127 call mkStrE_E # Make string 3128 call consE_C # Cons 3129 ld (C) E 3130 ld A ((InFile) V) # with 'src' 3131 shl A 4 # Make short number 3132 or A CNT 3133 ld (C CDR) A 3134 link 3135 push C # Save 3136 link 3137 ld E ((InFile) VI) # Filename again 3138 call mkStrEZ_A # Make string up to Z 3139 call consA_E # Cons into list 3140 ld (E) A 3141 ld (E CDR) (L I) 3142 drop 3143 pop Z 3144 else 3145 call mkStrE_E # Make string 3146 call consE_C # Cons 3147 ld (C) E 3148 ld A ((InFile) V) # with 'src' 3149 shl A 4 # Make short number 3150 or A CNT 3151 ld (C CDR) A 3152 call consC_A # Cons symbol 3153 ld (A) (hex "2F2E2") # "./" 3154 or A SYM # Make symbol 3155 ld (A) A # Set value to itself 3156 call consAC_E # Cons into list 3157 ld (E) A 3158 ld (E CDR) C 3159 end 3160 ret 3161 3162 # (dir ['any] ['flg]) -> lst 3163 (code 'doDir 2) 3164 push X 3165 push Z 3166 ld X (E CDR) # Args 3167 ld E (X) # Get 'any' 3168 call evSymE_E # Evaluate to a symbol 3169 cmp E Nil # NIL? 3170 if eq # Yes 3171 cc opendir(_dot_) # Open "." directory 3172 else 3173 call pathStringE_SZ # Write to stack buffer 3174 cc opendir(S) # Open directory 3175 ld S Z # Drop buffer 3176 end 3177 null A # OK? 3178 jz 10 # No 3179 ld Z A # Get directory pointer 3180 ld X (X CDR) # Eval 'flg' 3181 ld E (X) 3182 eval 3183 ld X E # into X 3184 do 3185 cc readdir(Z) # Find first directory entry 3186 null A # OK? 3187 if z # No 3188 cc closedir(Z) # Close directory 3189 10 ld E Nil # Return NIL 3190 pop Z 3191 pop X 3192 ret 3193 end 3194 lea E (A D_NAME) # Pointer to name entry 3195 cmp X Nil # flg? 3196 while eq # Yes 3197 ld B (E) # First char 3198 cmp B (char ".") # Skip dot names 3199 until ne 3200 call mkStrE_E # Make transient symbol 3201 call consE_C # Cons first cell 3202 ld (C) E 3203 ld (C CDR) Nil 3204 link 3205 push C # <L I> Result 3206 link 3207 do 3208 cc readdir(Z) # Read next directory entry 3209 null A # OK? 3210 while nz # Yes 3211 lea E (A D_NAME) # Pointer to name entry 3212 cmp X Nil # flg? 3213 jne 20 # Yes 3214 ld B (E) # First char 3215 cmp B (char ".") # Ignore dot names 3216 if ne 3217 20 call mkStrE_E # Make transient symbol 3218 call consE_A # Cons next cell 3219 ld (A) E 3220 ld (A CDR) Nil 3221 ld (C CDR) A # Concat to result 3222 ld C A 3223 end 3224 loop 3225 ld E (L I) # Get result 3226 drop 3227 cc closedir(Z) # Close directory 3228 pop Z 3229 pop X 3230 ret 3231 3232 # (cmd ['any]) -> sym 3233 (code 'doCmd 2) 3234 ld E ((E CDR)) # Get arg 3235 call evSymE_E # Evaluate to a symbol 3236 cmp E Nil # NIL? 3237 if eq 3238 ld E (AV0) # Return invocation command 3239 jmp mkStrE_E # Return transient symbol 3240 end 3241 push Z 3242 call bufStringE_SZ # Write to stack buffer 3243 slen C S # String length in C 3244 inc C # plus null byte 3245 movn ((AV0)) (S) C # Copy to system buffer 3246 ld S Z # Drop buffer 3247 pop Z 3248 ret 3249 3250 # (argv [var ..] [. sym]) -> lst|sym 3251 (code 'doArgv 2) 3252 push X 3253 push Y 3254 push Z 3255 ld X E 3256 ld Y (E CDR) # Y on args 3257 ld Z (AV) # Command line vector 3258 ld E (Z) 3259 null E # Empty? 3260 if nz # No 3261 ld B (E) # Single-dash argument? 3262 cmp B (char "-") 3263 if eq 3264 nul (E 1) 3265 if z # Yes 3266 add Z I # Skip "-" 3267 end 3268 end 3269 end 3270 cmp Y Nil # Any args? 3271 if eq # No 3272 ld E Nil # Preload return value 3273 null (Z) # More command line arguments? 3274 if nz # Yes 3275 ld E (Z) # Next 3276 call mkStrE_E # Make transient symbol 3277 call consE_C # First result cell 3278 ld (C) E 3279 ld (C CDR) Nil 3280 link 3281 push C # <L I> Result 3282 link 3283 do 3284 add Z I # Next command line argument 3285 null (Z) # Any? 3286 while nz # Yes 3287 ld E (Z) # Get it 3288 call mkStrE_E # Make transient symbol 3289 call consE_A # Next result cell 3290 ld (A) E 3291 ld (A CDR) Nil 3292 ld (C CDR) A # Concat to result 3293 ld C A 3294 loop 3295 ld E (L I) # Get result 3296 drop 3297 end 3298 else 3299 do 3300 atom Y # Atomic tail? 3301 while z # No 3302 ld E (Y) # Next 'var' 3303 call needVarEX 3304 ld E (Z) # Next command line argument 3305 null E # Any? 3306 if nz # No 3307 add Z I # Increment command line index 3308 end 3309 call mkStrE_E # Make transient symbol 3310 ld ((Y)) E # Set value 3311 ld Y (Y CDR) # Next arg 3312 cmp Y Nil # End of list? 3313 jeq 90 # Yes 3314 loop 3315 num Y # Need symbol 3316 jnz symErrYX 3317 call checkVarYX # Check variable 3318 ld E (Z) # Next command line argument 3319 null E # Any? 3320 if z # No 3321 ld E Nil # Set and return NIL 3322 ld (Y) E 3323 else 3324 call mkStrE_E # Make transient symbol 3325 call consE_C # First result cell 3326 ld (C) E 3327 ld (C CDR) Nil 3328 link 3329 push C # <L I> Result 3330 link 3331 do 3332 add Z I # Next command line argument 3333 null (Z) # Any? 3334 while nz # Yes 3335 ld E (Z) # Get it 3336 call mkStrE_E # Make transient symbol 3337 call consE_A # Next result cell 3338 ld (A) E 3339 ld (A CDR) Nil 3340 ld (C CDR) A # Concat to result 3341 ld C A 3342 loop 3343 ld E (L I) # Get and set result 3344 ld (Y) E 3345 drop 3346 end 3347 end 3348 90 pop Z 3349 pop Y 3350 pop X 3351 ret 3352 3353 # (opt) -> sym 3354 (code 'doOpt 2) 3355 ld E ((AV)) # Command line vector 3356 null E # Next string pointer? 3357 jz retNil # No 3358 ld B (E) # Single-dash argument? 3359 cmp B (char "-") 3360 if eq 3361 nul (E 1) 3362 jz retNil # Yes 3363 end 3364 add (AV) I # Increment vector pointer 3365 jmp mkStrE_E # Return transient symbol 3366 3367 # (version ['flg]) -> lst 3368 (code 'doVersion 2) 3369 ld E ((E CDR)) # Eval flg 3370 eval 3371 cmp E Nil # Suppress output? 3372 if eq # No 3373 ld E Version # Print version 3374 do 3375 ld A (E) # Next number 3376 shr A 4 # Normalize 3377 call outWordA # Print it 3378 ld E (E CDR) # More numbers? 3379 atom E 3380 while z # Yes 3381 ld B `(char ".") # Output dot 3382 call (PutB) 3383 loop 3384 call newline 3385 end 3386 ld E Version # Return version 3387 ret 3388 3389 # vi:et:ts=3:sw=3