1: ; Copyright (c) 1981 Harvard-Radcliffe Student Timesharing System 2: ; Science Center, Harvard University 3: .title system code 4: 5: .page 6: ; the major system code file for lisp 7: ; forrest howard. 8: 9: .if eq,multiseg 10: .psect startc con,shr 11: 12: .if ne,nilas0 13: .psect nil shr 14: .endc 15: 16: .if ne,onepage 17: .psect onepage con,prv 18: .endc 19: .psect uswdda con,prv 20: .psect usport con,prv 21: .psect usbyda con,prv 22: .psect shbydat con,shr 23: .psect shrwddat con,shr 24: .psect shrcode con,shr 25: .psect dsubr con,shr 26: .psect usbyda con,prv 27: .psect ddtpr con,prv 28: .psect datom con,prv 29: .psect initcd con,prv ;initialization stuff--goes away 30: .psect errorm con,prv ;error mssage psect--goes away 31: .if ne,xfer 32: .psect bcdmap con,prv ;also goes away 33: .endc 34: 35: .iff 36: .psect nil con,prv,dat 37: .if ne,prvispace 38: .psect startc con,prv,ins 39: .psect shrcode con,prv,ins 40: .iff 41: .psect startc con,shr,ins 42: .psect shrcode con,shr,ins 43: .endc 44: .psect shrwddat con,prv,dat 45: .psect shbydat con,prv,dat 46: .psect uswdda con,prv,dat 47: .psect usport con,prv,dat 48: .psect usbyda con,prv,dat 49: .psect dsubr con,prv,dat 50: .psect ddtpr con,prv,dat 51: .psect datom con,prv,dat 52: .psect initcd con,shr,ins ;goes away 53: .psect errorm con,prv,dat ;ditto 54: .if ne,xfer 55: .psect bcdmap con,prv,dat ;as does this... 56: .endc 57: .endc 58: 59: .psect startc con 60: frstcl: jmp @where ;start things off 61: 62: 63: 64: .mcall $exit,$indir,$read,$write,$open,$close,$create,$switch,$sig 65: 66: 67: .if ne,xfer 68: .mcall $fork,$exec,$kill,$ptrace,$wait 69: .endc 70: 71: .psect shrcode 72: 73: 74: 75: 76: 77: ; 78: ;register restore routines-- the following routines are also 79: ;snags for various amount of registers on the cstack 80: r4rres: 81: mov sp,j3 82: tst (j3)+ 83: mov (j3)+,b 84: mov (j3)+,j1 85: mov (j3)+,j2 86: mov (j3),j3 87: add #12,sp 88: ret 89: 90: r3rres: 91: mov sp,j3 92: tst (j3)+ 93: mov (j3)+,j1 94: mov (j3)+,j2 95: mov (j3),j3 96: add #10,sp 97: ret 98: r2rres: 99: mov 2(sp),j2 100: mov 4(sp),j3 101: add #6,sp 102: ret 103: 104: r1rres: 105: mov 2(sp),j3 106: add #4,sp 107: ret 108: 109: 110: 111: 112: .rsect shrcode con 113: progsnag: halt 114: brksna: halt 115: .if ne,xfer 116: .globl eexit1 117: eexit1: halt 118: .endc 119: 120: 121: eexit: 122: .if df,noeval 123: tstb tracfl 124: beq 1$ 125: npush #anil 126: propush a 127: call printr 128: outstr linefeed 129: .if df,width 130: clrb poport+1 131: .endc 132: unpropop a 133: 1$: 134: .endc 135: tst (sp)+ ;flush func 136: mov ltop,np ;;fix up name stack and 137: pop ltop 138: tst (sp)+ ;and c stack for real return 139: ret ;and take it 140: 141: 142: 143: 144: 145: .rsect shrcode con 146: 147: 148: ;evalquote makes lisp appear as an evalquote 149: ;machine 150: 151: .if eq,xfer ;evalquote needs a little more smarts 152: ;in xfer case 153: evalquote: call readr ;get token 154: cmp a,#atme ;if e, then call readr directly 155: beq readr 156: propush a 157: call readr 158: jmpifnil a,4$ ;see if rest of list nil 159: cmptype a,j1,#ndtpr ;if not nil,better be 160: bne 2$ 161: propush a ;save to protect it 162: mov a,j2 ;and get it in right place 163: 5$: jmpifnil j2,3$ 164: car j2,a ;get first thing needing quoting 165: consbnil ;make (foo) 166: mov #aquote,a ;get quote and 167: consa ;make (quote foo) 168: mov a,(j2)+ ;smash old list, and get ready for 169: mov (j2),j2 ; cdr in this instruction 170: br 5$ ;and loop 171: 4$: mov a,b ;set up for nil case 172: br 6$ 173: 3$: unpropop b 174: 6$: unpropop a 175: consa 176: ret 177: 2$: error </read list error/> 178: 179: 180: 181: .iff 182: 183: evalquote: call readr ;get a form 184: cmp a,#atme ;is it the magic e 185: bne 1$ ;no, skip around 186: call readr 187: ret ;this is necessary so we know we've seen e 188: 1$: propush a ;stick a away 189: call readr ;and get form 190: jmpifnil a,10$ ;if nil, then just cons 191: cmptype a,j1,#ndtpr ;in not nil, gotta be dtpr 192: bne 40$ ;so scream 193: propush a ;we have to copy here, so save it 194: call 20$ ;this gets quoted list in a 195: tst (sp)+ ;flush protecting form 196: 10$: mov a,b ;get form 197: unpropop a ;and future car 198: consa ;melt them together 199: ret ;and quit 200: 201: 20$: cmptype a,j1,#ndtpr ;end of list??? 202: bne 23$ 203: mov (a)+,-(sp) ;push car (already protected) and get cdrp 204: mov (a),a ;change cdrp to cdr 205: call 20$ ;do rest 206: pop j1 ;old form to j1 207: propush a ;gotta protect this 208: mov j1,a ;get form 209: consbnil ;make (form) 210: mov #aquote,a ;move in quote 211: consa ;and make 'form 212: unprop b ;get back rest 213: consa ;and cons the world 214: 23$: ret ;and return 215: 216: 40$: error </Evalquote Read List Error/> 217: 218: .endc 219: 220: .rsect shrcode con 221: ;readr takes port on top of name stack 222: ;and returns form in a 223: ;ratomr clobers j1-j4,therefore so does readr 224: 225: readr: clr rbktf ;set flag for super right paren(]) 226: call 29$ ;call routine 227: mov b,a ;leave result in right place 228: ret ;and go home 229: 230: 29$: call xratm2 ;xratm1 knows about ]'s becomming )^n 231: 30$: cmp a,#lpara ;is (? 232: beq 1$ ;yes, then... 233: cmp a,#rpara ;is ) 234: beq 32$ ;yes, then error 235: cmp a,#lbkta ;is [ 236: beq 31$ ;if so, go same a ( via a little extra code 237: cmp a,#perda ;is period 238: beq 32$ ;yes, error 239: cmp a,#asquote ;is it "'"??? 240: bne 40$ ;if not, skip around 241: call readr ;do recursive call 242: consbnil ;make (form) 243: mov #aquote,a ;get quote atom 244: consa ;make (quote form) 245: 40$: mov a,b ;and return it in right place 246: ret 247: 248: 249: 1$: call xratm2 ;now get rest of list 250: cmp a,#rpara ;is the list ()? 251: bne 2$ ;if not br ahead 252: loadnil b ;yes, return nil 253: ret 254: 255: 2$: call 30$ ;read a list as a car of the list we're on 256: propush b ;save it 257: call xratm1 ;get a token 258: cmp a,#rpara ;are we done? 259: beq 3$ ;yes, goto 3 260: cmp a,#perda ;is this explicit dotted pair 261: beq 4$ ;yes, goto 4 262: call 2$ ;now get rest of list 263: unpropop a 264: consb ;cons car and rest of list together 265: ret ;send home a good list 266: 267: 3$: unpropop a ;here if we see ) 268: consbnil ;provide last nil 269: ret ;and go home 270: 271: 4$: call 29$ ;we read period,need new token 272: unpropop a 273: consb 274: propush a ;save it (for sake of b and xfer) 275: call xratm1 ;next thing better be ) 276: cmp a,#rpara 277: bne 32$ ;if not, error 278: unpropop a ;and get form back 279: ret 280: 281: 31$: call 1$ ;this takes care of [-pretend 282: clr rbktf ;but flush )^n when back to proper level 283: ret ;and return 284: 285: 32$: error </read list error/> ;read list error 286: 287: 288: ;register save routines...... 289: ;called by macros save1,save2,save3,save4 290: 291: xsave1: 292: mov #r1rres,-(sp) ;leave pointer to reg save routine 293: mov 2(sp),-(sp) ;and get address to return to 294: mov j3,4(sp) ;restore the register 295: ret ;and go home 296: 297: xsave2: 298: mov (sp),-(sp) ;fill with ok thing for second 299: mov #r2rres,-(sp) ;and put on snag 300: mov j2,2(sp) 301: mov 4(sp),j2 302: mov j3,4(sp) 303: jmp (j2) ;and go home 304: 305: xsave3: 306: mov (sp),-(sp) 307: mov (sp),-(sp) ;make 3 register slots 308: mov #r3rres,-(sp) ;stack snag 309: mov j3,6(sp) 310: mov sp,j3 311: tst (j3)+ 312: mov j1,(j3)+ 313: mov (j3),j1 314: mov j2,(j3) 315: jmp @j1 ;and simulate return 316: 317: 318: xsave4: 319: mov (sp),-(sp) 320: mov (sp),-(sp) 321: mov (sp),-(sp) 322: mov #r4rress,-(sp) 323: mov j3,10(sp) 324: mov sp,j3 325: tst (j3)+ 326: mov b,(j3)+ 327: mov j1,(j3)+ 328: mov (j3),j1 329: mov j2,(j3) 330: jmp @j1 331: 332: 333: ;evalb takes a list for subr or lambda 334: ;and puts it in name stack elements 335: 336: 337: evalb: jmpifnil b,29$ ;if nothing to stack, go home 338: mov (b)+,a ;if some work to do, then get form 339: mov @b,-(sp) ;and save rest (is protected by fun block) 340: call eval 341: npush a ;put it on stack 342: pop b ;get others 343: br evalb ;and do it again 344: 29$: 345: 1$: ret 346: 347: ;stkb takes a list of atom names in b, and 348: ;pairs them with the evaled name stack entrys...uses j3,j4 349: 350: 351: stkb: mov np,j3 ;get np copy 352: mov ltop,np ;and new np 353: sub np,j3 ;figure out args 354: blos 1$ ;no args..... 355: asr j3 ;stack entrys to words 356: asr j3 357: 3$: jmpifnil b,2$ ;any more args??? 358: tst (np)+ ;yes, so... 359: mov (b)+,(np)+ ;push name and kick 360: mov (b),b ;and get cdr 361: sob j3,3$ ;and loop 362: 1$: jmpifnil b,2$ ;any that we supply args for 363: npush #anil 364: mov (b)+,-2(np) ;push name 365: mov (b),b 366: br 1$ 367: 2$: ret 368: 369: ;lookup uses j3,np, and finds current binding of 370: ;thing in a 371: ;leaves a so that cdr(a)=desired binding 372: 373: lookup: push np ;save np 374: mov np,j3 ;get np and copy 375: sub npbottom,j3 ;figure out i length of name stack 376: blos 1$ ;if name stack is empty, go home 377: asr j3 378: asr j3 ;make words 379: 2$: cmp -(np),a ;is this ns entry our choice? 380: beq 3$ ;if yes, then go 381: tst -(np) ;get ready for next try 382: sob j3,2$ ;and if anything left, do it again 383: 1$: pop np 384: ret ;return atom 385: 3$: mov np,a 386: br 1$ ;return a pointer to the ns cell 387: 388: 389: 390: 391: 392: 393: ;chas and 394: chanl: mov #4,a ;nlambda's always have one 395: br chas1 ;now go to the common code 396: chas: movb 1(a),a ;a has pointer to header of bcd 397: bic #177700,a ;clear bits 398: asl a ;and get in right form 399: chas1: add ltop,a ;get where ns should be 400: 1$: cmp np,a ;is it? 401: blt 2$ ;it bigger or equal--that's ok 402: mov a,np ;just return the right thing 403: rts %7 ;and go home 404: 2$: npush #anil ;otherwise push nil 405: br 1$ ;and see if that was enough 406: 407: 408: 409: 410: 411: 412: 413: 414: 415: 416: ;stuff to output terminal forms 417: 418: portout:mov #sportsym,b 419: jmp putstr 420: 421: bcdout: mov #sbcdout,b 422: jmp putstr 423: 424: atmout: add #6,a ;point to string 425: mov a,j3 ;move to j3 426: movb (j3)+,b ;get char 427: beq 40$ ;null atom print as "" 428: cmpb b, #'- ;minus sign?? 429: bne 10$ ;no, go to 10$ 430: movb (j3)+,b ;next char 431: beq 20$ ; atom with one minus is atom 432: cmpb b, #'- ;this one - also??? 433: beq 20$ ;20$ is where we scan string 434: 10$: cmpb ctable(b),#vnum ;numeric otherwise 435: beq 40$ ;yes, so "" out 436: 20$: mov a,j3 ;get fresh atom name 437: 21$: movb (j3)+,b ;get char 438: beq 50$ ;string is clean if we get here 439: bitb #1,ctable(b) ;ok...check for funny out 440: beq 21$ ;not funny, loop 441: 40$: outstr dq ;must be funny 442: mov a,b ;now name 443: call putstr ;dump name 444: mov #dq,b ; and last '"' 445: br 51$ 446: 50$: mov a,b ;get string 447: 51$: jmp putstr 448: 449: xpatom: mov a,b ;print atom without " 450: add #6,b 451: jmp putstr 452: 453: 454: 455: 456: 457: .if eq,fpsim 458: 459: .rsect shrcode con 460: ;numstr takes number in a, and leaves ptr to string in b 461: ;uses ac0,ac1,ac2,ac3,ac4 462: 463: numstr: mov #<strbuf+30>,b ;pointer to result left in b 464: mov #2$,-(sp) ;set normal return 465: clrb -(b) ;input in a 466: numga0 ;leaves binary number(in floating formi 467: ; in ac0 468: cfcc ;copy codes 469: absd ac0 470: bge 10$ ;fix up if neg. 471: mov #3$,(sp) ;and set negative return 472: 10$: 473: seti 474: modf ac5,ac0 ;mul by .1, int part in ac1 475: stf ac0,ac2 ;fract in ac0 476: addf #37114,ac2 ;fudge good enough for bell labs..... 477: modf ac4,ac2 ;mult fract by 10 478: stcfi ac3,a ;convert int part to integer 479: add #60,a ;convert it to char 480: movb a,-(b) ;and store it 481: ldf ac1,ac0 ;sets float cc vs stf which sets ccs 482: cfcc ;are we done?(i.e. ac1=0) 483: bne 10$ ;no,loop 484: ret 485: 486: 3$: movb #'-,-(b) 487: 2$: setl ;convert back to long integer mode 488: retnil ;and clean up a 489: 490: 491: 492: 493: 494: 495: 496: ;reminder 497: ;ten=41040,0,0,0 498: ;tenth=037314,146314,146314,146315 499: .iff 500: .rsect shrcode 501: 502: ;numstr here converts a int to string by using the idiv routine 503: ;only register a+b killed..... 504: 505: numstr: save3 ;save j1-j3 506: mov #strbuf+30,j3 507: mov #3$,-(sp) ;use to return with correct sign 508: numga 509: clrb -(j3) 510: tst a 511: bge 1$ 512: com a 513: com b 514: mov #2$,(sp) 515: add #1,b 516: adc a 517: 1$: 518: clr j1 519: mov #10.,j2 520: call idiv 521: add #'0,j2 522: movb j2,-(j3) 523: tst a 524: bne 1$ 525: tst b 526: bne 1$ 527: ret 528: 529: 2$: 530: movb #'-,-(j3) 531: 3$: 532: mov j3,b 533: loadnil a 534: saveret 535: .endc 536: 537: 538: numout: mov #putstr,-(sp) 539: br numstr ;call routines 540: 541: 542: 543: .rsect shrcode con 544: ;sratm1 converts ] to )^n 545: 546: .enabl lsb 547: xratm1: mov rbktf,a 548: bne 2$ 549: xratm2: call ratomr 550: cmp a,#rbkta 551: beq 1$ 552: ret 553: 1$: mov #rpara,a 554: mov a,rbktf 555: 2$: ret 556: .dsabl lsb 557: 558: ;consa,consb,consbnil macros call these routines 559: ;these protect a and b in case of garbage collection 560: 561: 562: .rsect shrcode con 563: xconsa: 564: .if ne,nilas0 565: tst fdtpr 566: 567: .iff 568: cmp fdtpr,#anil 569: .endc 570: bne 1$ 571: call xconscom 572: 1$: push a 573: mov fdtpr,a 574: car a,fdtpr 575: pop (a) 576: mov b,2(a) 577: ret 578: 579: loadnil b 580: xconsb: 581: .if ne,nilas0 582: tst fdtpr 583: .iff 584: cmp fdtpr,#anil 585: .endc 586: bne 1$ 587: call xconscom 588: 1$: push b 589: mov fdtpr,b 590: car b,fdtpr 591: pop 2(b) 592: mov a,(b) 593: ret 594: 595: xconscom: propush a 596: propush b 597: call gcol 598: unpropop b 599: unpropop a 600: ret 601: 602: 603: ;dispatch macro calls xdispatch 604: ;call dispatch 605: ;;;; jmp if number 606: ; jmp if#dtpr 607: ; jmp if#atom 608: ; jmp if#bcd 609: ; jmp if#port 610: ;note that jmps must be used 611: ;also note that disastor will befall 612: ;the system if it gets ahold of something other than 613: ;these things 614: 615: 616: .rsect shrcode con 617: 618: xdispatch: push j3 ;be nice to user 619: ldtype a,j3 620: ash #2,j3 621: add j3,2(sp) 622: pop j3 623: ret 624: 625: .if eq,fpsim 626: 627: 628: 629: ;strnum takes a number in strbuf 630: ;and converts it to binary stored in core pointed to by a 631: 632: .rsect shrcode con 633: 634: 635: strnum: mov #b4$,-(sp) ;normal return 636: mov #strbuf,j2 ;string is in strbuf 637: clrd ac0 ;use fac0 638: seti ;integer mode 639: cmpb (j2),#'- ;is neg? 640: bne b1$ ;no, jmp around 641: inc j2 ;point after - sign 642: mov #b3$,(sp) ;push on negate address 643: b1$: movb (j2)+,j3 ;get the char 644: beq b8$ ;if zero, we're done 645: bicb #177760,j3 ;strip extra info 646: ldcid j3,ac2 647: muld ac4,ac0 648: cfcc 649: addd ac2,ac0 650: bvc b1$ 651: b2$: error </arithemetic overflow/> ;arithmetic overflow 652: 653: b3$: negd ac0 654: b4$: 655: b7$: setl 656: 657: numstac0 ;store the number 658: b8$: ret ;and go home 659: 660: 661: 662: 663: 664: .iff 665: 666: .rsect shrcode 667: 668: ;strnum takes a number in strbuf, and converts it to an internal 669: ;int 670: 671: ;this version uses imul routine.... 672: 673: strnum: 674: mov #3$,-(sp) ;store normal exit 675: mov #strbuf,j3 676: clr a 677: clr b 678: cmpb (j3),#'- 679: bne 1$ 680: inc j3 681: mov #2$,(sp) ;set negate return 682: 1$: 683: tstb (j3) 684: beq 8$ 685: mov #10.,j2 686: clr j1 687: call imul 688: bvs 5$ 689: movb (j3)+,j2 690: sub #'0,j2 691: add j2,b 692: adc a 693: bvs 5$ 694: br 1$ 695: 696: 2$: com a 697: com b 698: add #1,b 699: adc a 700: 3$: 701: nmstore 702: 8$: ret 703: 704: 5$: 705: error </number too large /> 706: 707: .endc 708: .rsect shrcode con 709: 710: 711: ;this section of code handles nice things like ports. since 712: ;there are at most at any time numports, where numports is an assembly 713: ;parameter (about 15), and ports 1,2,and 3 are the tty ports, it 714: ;does not make much sense to have an entire page allocated to them. 715: ;except for the tty ports, the ports are 512 bytes long, starting on an 716: ;even word boundary(even a512 word boundry) 717: 718: ;a port for output looks like this 719: ; .byte count,200!<portnum*2>!gcbit 720: ; .word nextchar 721: ; .word firstchar 722: ; .word charsleft 723: ; .word bufferlength 724: 725: ;where count is used by chrct and linelength, and the purpose of the rest should be fairly obvious 726: 727: 728: ;a port for input looks like 729: ; .byte savedc,<portnum*2>!gcbit 730: ; .word nextchar 731: ; .word firstchar ;start o buffer 732: ; .word charsleft 733: ; .word bufferlength 734: 735: ;where savedc is the character saved by last savec 736: 737: 738: ;************************** 739: ; 740: ;it is up to the using routine to guarantee that the thing on top of 741: ;the np (the arguement to all these things) is either a port or nil!!! 742: ;destruction will result if abused!!!!!! 743: ; 744: ;************************** 745: 746: ;savec saves character for next lex. 747: ;mungs no registers!!!! 748: ;makes no check on port's validity 749: 750: .rsect shrcode con 751: 752: xsavec: save1 753: mov @np,j3 754: jmpnnil j3,2$,nl 755: movb char,piport+1 756: saveret 757: 2$: movb char,1(j3) 758: saveret 759: 760: 761: ;putstr takes a string pointed to by b and 762: ;outputs it on the port pointed to by the top of 763: ;the np 764: ;mungs no registers 765: .rsect shrcode con 766: 767: putstr: save3 768: mov @np,j2 ;is @np nil? 769: jmpnnil j2,1$,nl ;if nil use poport 770: mov #poport,j2 771: 1$: tstb (j2) ;if not nil, check tosee if output port 772: bge 30$ ;if this byte is positive, then 773: ; not output port 774: 2$: movb (b)+,@2(j2) ;b has pointer to string that we're putting 775: ;and ports are output when full, so always room 776: ;for one more char 777: beq 10$ ;if zero,we're done 778: incb 1(j2) ;update width 779: 3$: inc 2(j2) ;update pointer to buffer 780: dec 6(j2) ;update count 781: .if df,width 782: bgt 20$ ;char ok...see about linefeed 783: .iff 784: bgt 2$ ;if non-zero, we do it again 785: .endc 786: call wrbop ;write-buffer-of-port 787: .if df,width 788: 20$: jmpnnil (np),2$ ;only concerned about poport 789: cmpb 1(j2),lnleng ;are we past right margin?? 790: ble 2$ ;we're ok... 791: movb #12,@2(j2) ;output lf 792: clrb 1(j2) ;and clear port count 793: br 3$ ;and go to middle of loop 794: .iff 795: br 2$ 796: .endc 797: 10$: loadnil b ;return nil in b 798: saveret 799: 30$: 800: erm5p: error </i-o error/> 801: ;wrbop outputs a buffer 802: ;it is called either with dmpport or implicitly by putstr 803: ;it should not be used otherwise 804: 805: .rsect shrcode con 806: wrbop: mov 4(j2),$$write+2 ;set up write system call 807: mov 2(j2),j1 ;j2 points to port; put f.c. in r0 808: sub 4(j2),j1 ;get length 809: blos 1$ ;if less or = zero then don't bother 810: mov j1,$$write+4 811: mov (j2),j1 ;now the file cookie 812: bic #177701,j1 813: asr j1 814: $indir ;trap indirect 815: $$write 816: bcc 10$ ;if error-free, skip a bit 817: cmp j1,#4 ;otherwise, ^c??? 818: bne erm5p ;if is not ^c, scream 819: 10$: tst protocell 820: beq 1$ 821: cmp j2,#poport 822: beq 3$ 823: cmp j2,#erport 824: bne 1$ 825: 3$: mov b,j3 ;save for a minute 826: mov $$write+2,b 827: add $$write+4,b 828: clrb @b 829: mov $$write+2,b 830: npush protocell 831: call putstr 832: cmp -(np),-(np) 833: mov j3,b ;and get back b 834: 1$: mov 4(j2),2(j2) 835: mov 10(j2),6(j2) 836: ret 837: 838: 839: 840: 841: 842: ; note--by rights one should make sure that ^c is only 843: ; allowable on the command port (np)==nil. 844: ; however, it is not clear what to do in the case when 845: ; ^c is gotten on another port. i.e., do we print a 846: ; message, and continue??? or do we 847: ; just let the ^c handeler take care of it??? 848: ;dmpport outputs buffer whether full or not 849: ;saves all registers 850: 851: .rsect shrcode con 852: 853: dmpport: 854: save4 855: mov @np,j2 856: jmpnnil j2,2$,nl 857: mov #poport,j2 858: 2$: tstb (j2) 859: bge erm5p 860: call wrbop ;set up j2 with ptr(port), then call wrbop 861: saveret 862: 863: 864: .enabl lsb 865: .globl $death 866: .rsect shrcode con 867: 868: ;getc 869: ;returns in char the next character in the port on np 870: ;this has had so many additions, that it is getting 871: ;kludgy, and should be re-written 872: 873: 874: xgetc: save4 875: mov @np,j2 876: jmpnnil j2,10$,nl 877: mov #piport,j2 878: incb keybin ;say we're in keyboard input 879: br 11$ 880: 10$: bic #1,(j2) ;turn off the gc bit 881: tstb (j2) 882: ble 5$ ;all this does is get valid input port 883: 11$: movb 1(j2),char ;is savec non-zero?? 884: bgt 2$ ;no, then go through mung 885: blt 32$ ;means we got past eof 886: 1$: dec 6(j2) ;is anything left in port? 887: blt 4$ ;no, then get some chars 888: movb @2(j2),char ;get next char in port 889: inc 2(j2) ;kick pointer 890: 2$: clrb 1(j2) ;set savec to zero 891: bicb #177600,char ;clear out high bits 892: 3$: clrb keybin ;turn off flag 893: saveret ;and go home 894: 4$: mov 4(j2),$$read+2 ;set up system call 895: mov 10(j2),$$read+4 896: mov (j2),j1 ;savec is zero!! 897: asr j1 898: $indir ;get indirect 899: $$read 900: bcs erm5p ;error? 901: ;prehaps a check should be made 902: ;for ^c here (assuming one opened 903: ; /dev/tty? or something) 904: ;however, this will be left 905: ;for now 906: mov 4(j2),2(j2) ;reset port 907: mov %0,6(j2) ;save number of chars got 908: beq 21$ ;if not zero,all set 909: tst protocell ;protocol? 910: beq 1$ 911: jmpnnil @np,1$ 912: mov #tib,b 913: clrb tib(%0) ;turn into asciz string 914: npush protocell 915: call putstr 916: cmp -(np),-(np) 917: br 1$ 918: 21$: tstb keybin ;if is > zero, we want 919: bgt ssy31$ ;to do funnies on ^d and ^c 920: blt 22$ ;if less than zero, no savec 921: movb #200,1(j2) ;indicate eof in savec 922: 22$: movb #200,char ;if zero, return eof char 923: br 3$ ;and return, clearing keybin 924: 925: 5$: error </not a port for input/> 926: 32$: error </can't read past end of port/> ;past eof 927: 928: 929: ssy31$: jmp $death ;user typed ^d 930: 931: xgetca: call xgetc ;get char 932: clr a 933: bisb char,a ;and the character in a 934: ret ;and go home 935: 936: .dsabl lsb 937: 938: 939: 940: ;fixname is called from opeen and load 941: ; takes two args on nstack and constructs path 942: ;from them. if second (top) arg is non-nil, 943: ;the path is in the system library. 944: ;if nil, the file itself is used 945: 946: 947: .rsect shrcode con 948: 949: fixname: npop a ;get top arg 950: jmpifnil a,fixnm1 ;if nil, just use first 951: mov #strbuf,a ;make name in stringbuf 952: mov #master,j1 953: 1$: movb (j1)+,(a)+ 954: bne 1$ 955: dec a 956: mov @np,j1 957: cmptype j1,j2,#natom ;make sure this is atom 958: bne filerror ;then complain 959: add #6,j1 ;get pname 960: 2$: movb (j1)+,(a)+ 961: bne 2$ 962: mov #strbuf,a ;strbuf is first ptr instring 963: ret 964: fixnm1: mov @np,a ;here if to use only path 965: cmptype a,j1,#natom 966: bne filerror 967: add #6,a 968: ret 969: 970: 971: filerror: error </file not available/> 972: filer1: $close ;close 973: error </attempt to open too many files/> 974: 975: ;openc is code that is called by openr and openw 976: ;it gets buffer and sets up common parts of ports 977: 978: 979: openc: bcs filerror 980: cmp %0,#<nports-1> 981: bgt filer1 982: asl j1 983: mov j1,a 984: ash #2,a 985: add j1,a 986: add #piport,a 987: mov #400,10(a) 988: mov j1,(a) ;save cookie 989: mov a,-(sp) ;save port 990: tryba: call globalc 991: tst a 992: beq nobuf 993: movb #-2,qmap(a) 994: swab a 995: mov a,j3 996: mov (sp)+,a 997: mov j3,2(a) 998: mov j3,4(a) 999: ret 1000: nobuf: 1001: .if ne,xfer 1002: mov (sp)+,a 1003: clr 2(a) 1004: clr 4(a) 1005: call @(sp)+ ;co-routine call to openr/openw 1006: call noroom 1007: call noroom 1008: nroomf: 1009: .iff 1010: error </cannot allocate buffer for file/>,tryba 1011: .endc 1012: 1013: 1014: 1015: 1016: ;openr takes ptr to asciz string in a 1017: ;and opens the file if possible 1018: 1019: openr: mov a,$$open+2 1020: $indir 1021: $$open 1022: call openc 1023: clr 6(a) ;peculiars of read open 1024: ret 1025: 1026: 1027: ;openw takse string n a and opens file for output 1028: 1029: openw: mov a,$$create+2 1030: $indir 1031: $$create 1032: call openc 1033: mov #400,6(a) ;peculair to write ports 1034: bis #40200,(a) 1035: ret 1036: 1037: 1038: 1039: 1040: 1041: .rsect shrcode con 1042: ;close closes the (hopefully) port on np 1043: 1044: close: mov @np,a 1045: mov 4(a),j1 1046: swab j1 1047: movb #-3,qmap(j1) ;give back buffer 1048: mov (a),j1 1049: asr j1 1050: bic #177700,j1 1051: clr (a) 1052: $close 1053: ret 1054: 1055: 1056: 1057: 1058: 1059: .rsect shrcode 1060: 1061: ;ncomp compares the two numbers on ttop of np 1062: ;call and return 1063: 1064: ; call ncomp 1065: ; return if not number 1066: ; return if number with condition codes set 1067: ; clobers all registers (at least in some cases) 1068: ; 1069: ;type checking is done 1070: 1071: .if eq,fpsim 1072: 1073: 1074: ncomp: mov @np,a 1075: cmptype a,j1,0 1076: bne 12$ 1077: numga1 1078: mov -4(np),a 1079: cmptype a,j1,0 1080: bne 12$ 1081: numga0 1082: cmpd ac0,ac1 1083: add #2,(sp) 1084: cfcc 1085: 12$: ret 1086: .iff 1087: 1088: ncomp: mov (np),a ;get right arg 1089: cmptype a,b,0 ;is int 1090: bne 22$ ;no..... 1091: numgj1 ;get int 1092: mov -4(np),a 1093: cmptype a,b,0 1094: bne 22$ 1095: numga ;got them 1096: add #2,(sp) ;make good return 1097: sub j1,a ;subtract the high order 1098: sub j2,b ;we don't care about codes of low order 1099: sbc a ;and get the borrow 1100: bne 22$ ;if result is non-zero, we're cool 1101: cmp b,a ;we know a is zero, and gotta set the v bit 1102: 22$: ret 1103: 1104: .endc
|
Last modified: 1981-05-10
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 311 |
|