err.l (14978B)
1 # 05jul13abu 2 # (c) Software Lab. Alexander Burger 3 4 # Debug print routine 5 (code 'dbgS) 6 xchg E (S) # Get return address 7 xchg E (S I) # Get argument, save return 8 push C # Save all registers 9 push A 10 push (OutFile) # Save output channel 11 ld (OutFile) ((OutFiles) II) # Set to OutFiles[2] (stderr) 12 push (PutB) # Save 'put' 13 ld (PutB) putStdoutB # Set new 14 call printE_E # Print argument 15 call newline # and a newline 16 pop (PutB) # Restore 'put' 17 pop (OutFile) # and output channel 18 pop A 19 pop C 20 pop E 21 ret 22 23 # System error number 24 (code 'errnoEXY) 25 call errno_A # Get 'errno' 26 cc strerror(A) # Convert to string 27 ld Z A 28 29 # E reason 30 # X context 31 # Y message format 32 # Z message parameter 33 (code 'errEXYZ) 34 null E # Reason? 35 if nz # Yes 36 link 37 push E # Save reason 38 link 39 else 40 push E # Push reason 41 sub S I # and dummy 42 end 43 sub S (+ 240 IV) # <S> Message, <S 240> outFrame, <S (+ 240 V)> reason 44 cc snprintf(S 240 Y Z) # Build message 45 null X # Error context? 46 ld A Nil 47 ldnz A X # Yes 48 ld (Up) A # Save it 49 nul (S) # Message empty? 50 if nz # No 51 ld E S # Make transient symbol 52 call mkStrE_E 53 ld (Msg) E # Store in '*Msg' 54 ld C (Catch) # Search catch frames 55 do 56 null C # Any? 57 while nz # Yes 58 ld Y (C I) # Tag non-zero? 59 null Y 60 if nz # Yes 61 do 62 atom Y # List? 63 while z # Yes 64 ld A (Y) # Next element of tag list 65 ld E (Msg) # Substring of '*Msg'? 66 push C 67 call subStrAE_F 68 pop C 69 if eq # Yes 70 ld Y (Y) # Get tag list element 71 cmp Y Nil # NIL? 72 ldz Y (Msg) # Yes: Use *Msg instead 73 push Y # Save tag list element 74 call unwindC_Z # Unwind environments 75 pop E # Return tag list element from 'catch' 76 ld S Z # Restore stack 77 jmp caught 78 end 79 ld Y (Y CDR) # Tag list 80 loop 81 end 82 ld C (C) # Next frame 83 loop 84 end 85 ld (Chr) 0 # Init globals 86 ld (ExtN) 0 87 ld (Break) 0 88 ld (Alarm) Nil 89 ld (Sigio) Nil 90 ld (LineX) ZERO 91 ld (LineC) -1 92 lea Y (S 240) # Pointer to outFrame 93 ld (Y I) 2 # fd = stderr 94 ld (Y II) 0 # pid = 0 95 call pushOutFilesY 96 ld Y (InFile) # Current InFile 97 null Y # Any? 98 if nz # Yes 99 ld C (Y VI) # Filename? 100 null C 101 if nz # Yes 102 ld B (char "[") # Output location 103 call (PutB) 104 call outStringC # Print filename 105 ld B (char ":") # Separator ':' 106 call (PutB) 107 ld A (Y V) # Get 'src' 108 call outWordA # Print line number 109 ld B (char "]") 110 call (PutB) 111 call space 112 end 113 end 114 null X # Error context? 115 if nz # Yes 116 ld C ErrTok # Print error token 117 call outStringC 118 ld E X # Get context 119 call printE # Print context 120 call newline 121 end 122 ld E (S (+ 240 V)) # Get reason 123 null E # any? 124 if nz # Yes 125 call printE # Print reason 126 ld C Dashes # Print " -- " 127 call outStringC 128 end 129 nul (S) # Message empty? 130 if nz # No 131 call outStringS # Print message 132 call newline 133 cmp (Err) Nil # Error handler? 134 if ne # Yes 135 nul (Jam) # Jammed? 136 if z # No 137 set (Jam) 1 # Set flag 138 ld X (Err) # Run error handler 139 prog X 140 set (Jam) 0 # Reset flag 141 end 142 end 143 ld E 1 # Exit error code 144 cc isatty(0) # STDIN 145 nul4 # on a tty? 146 jz byeE # No 147 cc isatty(1) # STDOUT 148 nul4 # on a tty? 149 jz byeE # No 150 ld B (char "?") # Prompt 151 ld E Nil # Load argument 152 ld X 0 # Runtime expression 153 call loadBEX_E 154 end 155 ld C 0 # Top frame 156 call unwindC_Z # Unwind 157 ld (EnvProtect) 0 # Reset environments 158 ld (EnvIntern) pico 159 ld (EnvTask) Nil 160 ld (EnvCo7) 0 161 ld (EnvArgs) 0 162 ld (EnvNext) 0 163 ld (EnvMake) 0 164 ld (EnvYoke) 0 165 ld (EnvTrace) 0 166 ld L 0 # Init link register 167 ld S (Stack0) # stack pointer 168 null (Stacks) # Coroutines? 169 if nz # Yes 170 lea A (S 4096) # Set stack limit 171 sub A (StkSize) 172 ld (StkLimit) A 173 end 174 jmp restart # Restart interpreter 175 176 (code 'unwindC_Z 0) 177 push C # <S> Target frame 178 ld X (Catch) # Catch link 179 ld Y (EnvBind) # Bindings 180 do 181 null X # Catch frames? 182 while nz # Yes 183 do 184 null Y # Bindings? 185 while nz # Yes 186 ld C (Y -I) # First env swap 187 null C # Zero? 188 if nz # No 189 ld A C # 'j' 190 ld E 0 # 'n' 191 ld Z Y # Bindings in Z 192 do 193 inc E # Increment 'n' 194 inc A # Done? 195 while nz # No 196 ld Z ((Z) I) # Follow link 197 null Z # Any? 198 while nz # Yes 199 cmp (Z -I) C # Env swap nesting? 200 if lt # Yes 201 dec A # Adjust 202 end 203 loop 204 do 205 ld Z Y # Get bindings 206 ld A E # and 'n' 207 do 208 dec A # 'n-1' times 209 while nz 210 ld Z ((Z) I) # Follow link 211 loop 212 sub (Z -I) C # Increment 'eswp' by absolute first eswp 213 if ge # Last pass 214 if gt # Overflowed 215 ld (Z -I) 0 # Reset 216 end 217 lea A ((Z) -II) # End of bindings in A 218 do 219 xchg ((A)) (A I) # Exchange next symbol value with saved value 220 sub A II 221 cmp A Z # More? 222 until lt # No 223 end 224 dec E # Decrement 'n' 225 until z # Done 226 end 227 cmp Y (X III) # Reached last bind frame? 228 while ne # No 229 ld C (Y) # C on link 230 null (Y -I) # Env swap now zero? 231 if z # Yes 232 add Y I # Y on bindings 233 do 234 ld Z (Y) # Next symbol 235 add Y I 236 ld (Z) (Y) # Restore value 237 add Y I 238 cmp Y C # More? 239 until eq # No 240 end 241 ld Y (C I) # Bind link 242 loop 243 do 244 cmp (EnvInFrames) (X (pack III "+(EnvInFrames-Env)")) # Open input frames? 245 while ne # Yes 246 call popInFiles # Clean up 247 loop 248 do 249 cmp (EnvOutFrames) (X (pack III "+(EnvOutFrames-Env)")) # Open output frames? 250 while ne # Yes 251 call popOutFiles # Clean up 252 loop 253 do 254 cmp (EnvErrFrames) (X (pack III "+(EnvErrFrames-Env)")) # Open error frames? 255 while ne # Yes 256 call popErrFiles # Clean up 257 loop 258 do 259 cmp (EnvCtlFrames) (X (pack III "+(EnvCtlFrames-Env)")) # Open control frames? 260 while ne # Yes 261 call popCtlFiles # Clean up 262 loop 263 ld Z (EnvCo7) # Get coroutines 264 do 265 cmp Z (X (pack III "+(EnvCo7-Env)")) # Skipped? 266 while ne # Yes 267 ld C (Stack1) # Find stack segment 268 do 269 cmp C (Z II) # Found 'seg'? 270 while ne # No 271 sub C (StkSize) # Next segment 272 loop 273 ld (C -I) 0 # Mark segment as unused 274 dec (Stacks) # Last coroutine? 275 if z # Yes 276 ld (StkLimit) 0 # Clear stack limit 277 end 278 ld Z (Z) # Next coroutine 279 loop 280 load (Env) (EnvEnd) (X III) # Restore environment 281 ld E (X II) # 'fin' 282 eval # Evaluate 'finally' expression 283 cmp X (S) # Reached target catch frame? 284 ld X (X) # Catch link 285 ld (Catch) X 286 if eq # Yes 287 pop Z # Get target frame 288 ret 289 end 290 loop 291 add S I # Drop target frame 292 do # Top level bindings 293 null Y # Any? 294 while nz # Yes 295 ld C (Y) # C on link 296 null (Y -I) # Env swap zero? 297 if z # Yes 298 add Y I # Y on bindings 299 do 300 ld Z (Y) # Next symbol 301 add Y I 302 ld (Z) (Y) # Restore value 303 add Y I 304 cmp Y C # More? 305 until eq # No 306 end 307 ld Y (C I) # Bind link 308 loop 309 ld (EnvBind) 0 310 do 311 null (EnvInFrames) # Open input frames? 312 while nz # Yes 313 call popInFiles # Clean up 314 loop 315 do 316 null (EnvOutFrames) # Open output frames? 317 while nz # Yes 318 call popOutFiles # Clean up 319 loop 320 do 321 null (EnvErrFrames) # Open error frames? 322 while nz # Yes 323 call popErrFiles # Clean up 324 loop 325 do 326 null (EnvCtlFrames) # Open control frames? 327 while nz # Yes 328 call popCtlFiles # Clean up 329 loop 330 ld X (Stack1) # Search through stack segments 331 ld C (Stacks) # Segment count 332 do 333 null C # Any? 334 while nz # Yes 335 null (X -I) # In use? 336 if nz # Yes 337 null (X -II) # Active? 338 if z # Yes 339 ld (X -I) 0 # Mark segment as unused 340 dec (Stacks) # Last coroutine? 341 if z # Yes 342 ld (StkLimit) 0 # Clear stack limit 343 end 344 end 345 dec C # Decrement count 346 end 347 sub X (StkSize) # Next segment 348 loop 349 ret 350 351 ### Checks ### 352 (code 'needSymAX 0) 353 num A # Need symbol 354 jnz symErrAX 355 sym A 356 jz symErrAX 357 cmp A Nil # A < NIL ? 358 jlt ret # Yes 359 cmp A TSym # A > T ? 360 jgt Ret # Yes 361 ld E A 362 jmp protErrEX 363 364 (code 'needSymEX 0) 365 num E # Need symbol 366 jnz symErrEX 367 sym E 368 jz symErrEX 369 cmp E Nil # E < NIL ? 370 jlt ret # Yes 371 cmp E TSym # E > T ? 372 jgt Ret # Yes 373 jmp protErrEX 374 375 (code 'needVarAX 0) 376 num A # Need variable 377 jnz varErrAX 378 cmp A Nil # A < NIL ? 379 jlt ret # Yes 380 cmp A TSym # A > T ? 381 jgt Ret # Yes 382 ld E A 383 jmp protErrEX 384 385 (code 'needVarEX 0) 386 num E # Need variable 387 jnz varErrEX 388 cmp E Nil # E < NIL ? 389 jlt ret # Yes 390 cmp E TSym # E > T ? 391 jgt Ret # Yes 392 jmp protErrEX 393 394 (code 'checkVarAX 0) 395 cmp A Nil # A < NIL ? 396 jlt ret # Yes 397 cmp A TSym # A > T ? 398 jgt Ret # Yes 399 ld E A 400 jmp protErrEX 401 402 (code 'checkVarYX 0) 403 cmp Y Nil # Y < NIL ? 404 jlt ret # Yes 405 cmp Y TSym # Y > T ? 406 jgt Ret # Yes 407 ld E Y 408 jmp protErrEX 409 410 (code 'checkVarEX 0) 411 cmp E Nil # E < NIL ? 412 jlt ret # Yes 413 cmp E TSym # E > T ? 414 jgt Ret # Yes 415 (code 'protErrEX) 416 ld Y ProtErr 417 jmp errEXYZ 418 419 (code 'symNsErrEX) 420 ld Y SymNsErr 421 jmp errEXYZ 422 423 ### Error messages ### 424 (code 'stkErr) 425 ld E 0 426 (code 'stkErrE) 427 ld X E 428 (code 'stkErrX) 429 ld E 0 430 (code 'stkErrEX) 431 ld Y StkErr 432 ld (StkLimit) 0 # Reset stack limit 433 jmp errEXYZ 434 435 (code 'argErrAX) 436 ld E A 437 (code 'argErrEX) 438 ld Y ArgErr 439 jmp errEXYZ 440 441 (code 'numErrAX) 442 ld E A 443 (code 'numErrEX) 444 ld Y NumErr 445 jmp errEXYZ 446 447 (code 'cntErrAX) 448 ld C A 449 (code 'cntErrCX) 450 ld E C 451 (code 'cntErrEX) 452 ld Y CntErr 453 jmp errEXYZ 454 455 (code 'symErrAX) 456 ld Y A 457 (code 'symErrYX) 458 ld E Y 459 (code 'symErrEX) 460 ld Y SymErr 461 jmp errEXYZ 462 463 (code 'extErrEX) 464 ld Y ExtErr 465 jmp errEXYZ 466 467 (code 'pairErrAX) 468 ld E A 469 (code 'pairErrEX) 470 ld Y PairErr 471 jmp errEXYZ 472 473 (code 'atomErrAX) 474 ld E A 475 (code 'atomErrEX) 476 ld Y AtomErr 477 jmp errEXYZ 478 479 (code 'lstErrAX) 480 ld E A 481 (code 'lstErrEX) 482 ld Y LstErr 483 jmp errEXYZ 484 485 (code 'varErrAX) 486 ld E A 487 (code 'varErrEX) 488 ld Y VarErr 489 jmp errEXYZ 490 491 (code 'divErrX) 492 ld E 0 493 ld Y DivErr 494 jmp errEXYZ 495 496 (code 'renErrEX) 497 ld Y RenErr 498 jmp errEXYZ 499 500 (code 'makeErrX) 501 ld E 0 502 ld Y MakeErr 503 jmp errEXYZ 504 505 (code 'reentErrEX) 506 ld Y ReentErr 507 jmp errEXYZ 508 509 (code 'yieldErrX) 510 ld E 0 511 (code 'yieldErrEX) 512 ld Y YieldErr 513 jmp errEXYZ 514 515 (code 'msgErrYX) 516 ld A Y 517 (code 'msgErrAX) 518 ld E A 519 (code 'msgErrEX) 520 ld Y MsgErr 521 jmp errEXYZ 522 523 (code 'brkErrX) 524 ld E 0 525 ld Y BrkErr 526 jmp errEXYZ 527 528 # I/O errors 529 (code 'openErrEX) 530 ld Y OpenErr 531 jmp errnoEXY 532 533 (code 'closeErrX) 534 ld E 0 535 (code 'closeErrEX) 536 ld Y CloseErr 537 jmp errnoEXY 538 539 (code 'pipeErrX) 540 ld E 0 541 ld Y PipeErr 542 jmp errnoEXY 543 544 (code 'forkErrX) 545 ld E 0 546 ld Y ForkErr 547 jmp errEXYZ 548 549 (code 'waitPidErrX) 550 ld E 0 551 ld Y WaitPidErr 552 jmp errnoEXY 553 554 (code 'badFdErrEX) 555 ld Y BadFdErr 556 jmp errEXYZ 557 558 (code 'noFdErrX) 559 ld E 0 560 ld Y NoFdErr 561 jmp errEXYZ 562 563 (code 'eofErr) 564 ld E 0 565 ld X 0 566 ld Y EofErr 567 jmp errEXYZ 568 569 (code 'suparErrE) 570 ld X 0 571 ld Y SuparErr 572 jmp errEXYZ 573 574 (code 'badInputErrB) 575 zxt 576 ld Z A 577 ld E 0 578 ld X 0 579 ld Y BadInput 580 jmp errEXYZ 581 582 (code 'badDotErrE) 583 ld X 0 584 ld Y BadDot 585 jmp errEXYZ 586 587 (code 'selectErrX) 588 ld E 0 589 ld Y SelectErr 590 jmp errnoEXY 591 592 (code 'wrBytesErr) 593 ld E 0 594 ld X 0 595 ld Y WrBytesErr 596 jmp errnoEXY 597 598 (code 'wrChildErr) 599 ld E 0 600 ld X 0 601 ld Y WrChildErr 602 jmp errnoEXY 603 604 (code 'wrSyncErrX) 605 ld E 0 606 ld Y WrSyncErr 607 jmp errnoEXY 608 609 (code 'wrJnlErr) 610 ld E 0 611 ld X 0 612 ld Y WrJnlErr 613 jmp errnoEXY 614 615 (code 'wrLogErr) 616 ld E 0 617 ld X 0 618 ld Y WrLogErr 619 jmp errnoEXY 620 621 (code 'truncErrX) 622 ld E 0 623 ld Y TruncErr 624 jmp errnoEXY 625 626 (code 'dbSyncErrX) 627 ld E 0 628 ld Y DbSyncErr 629 jmp errnoEXY 630 631 (code 'trSyncErrX) 632 ld E 0 633 ld Y TrSyncErr 634 jmp errnoEXY 635 636 (code 'lockErr) 637 ld E 0 638 ld X 0 639 ld Y LockErr 640 jmp errnoEXY 641 642 (code 'dbfErrX) 643 ld E 0 644 ld Y DbfErr 645 jmp errEXYZ 646 647 (code 'jnlErrX) 648 ld E 0 649 ld Y JnlErr 650 jmp errEXYZ 651 652 (code 'idErrXL) 653 ld E (L I) # Get symbol 654 ld Y IdErr 655 jmp errEXYZ 656 657 (code 'dbRdErr) 658 ld E 0 659 ld X 0 660 ld Y DbRdErr 661 jmp errnoEXY 662 663 (code 'dbWrErr) 664 ld E 0 665 ld X 0 666 ld Y DbWrErr 667 jmp errnoEXY 668 669 (code 'dbSizErr) 670 ld E 0 671 ld X 0 672 ld Y DbSizErr 673 jmp errEXYZ 674 675 (code 'tellErr) 676 ld E 0 677 ld X 0 678 ld Y TellErr 679 jmp errEXYZ 680 681 (code 'ipSocketErrX) 682 ld E 0 683 ld Y IpSocketErr 684 jmp errnoEXY 685 686 (code 'ipGetsocknameErrX) 687 ld E 0 688 ld Y IpGetsocknameErr 689 jmp errnoEXY 690 691 (code 'ipV6onlyErrX) 692 ld E 0 693 ld Y IpV6onlyErr 694 jmp errnoEXY 695 696 (code 'ipReuseaddrErrX) 697 ld E 0 698 ld Y IpReuseaddrErr 699 jmp errnoEXY 700 701 (code 'ipBindErrX) 702 ld E 0 703 ld Y IpBindErr 704 jmp errnoEXY 705 706 (code 'ipListenErrX) 707 ld E 0 708 ld Y IpListenErr 709 jmp errnoEXY 710 711 (code 'udpOvflErr) 712 ld E 0 713 ld X 0 714 ld Y UdpOvflErr 715 jmp errEXYZ 716 717 ### Undefined symbol ### 718 (code 'undefinedCE) 719 ld X E 720 (code 'undefinedCX) 721 ld E C 722 (code 'undefinedEX) 723 ld Y UndefErr 724 jmp errEXYZ 725 726 (code 'dlErrX) 727 ld E 0 728 cc dlerror() # Get dynamic loader error message 729 ld Y DlErr 730 ld Z A 731 jmp errEXYZ 732 733 ### Global return labels ### 734 (code 'ret 0) 735 ret 736 (code 'retc 0) 737 setc 738 ret 739 (code 'retnc 0) 740 clrc 741 ret 742 (code 'retz 0) 743 setz 744 ret 745 (code 'retnz 0) 746 clrz 747 ret 748 (code 'retNull 0) 749 ld E 0 750 ret 751 (code 'retNil 0) 752 ld E Nil 753 ret 754 (code 'retT 0) 755 ld E TSym 756 ret 757 (code 'retE_E 0) 758 ld E (E) # Get value or CAR 759 ret 760 761 # vi:et:ts=3:sw=3