1: ; Copyright (c) 1981 Harvard-Radcliffe Student Timesharing System 2: ; Science Center, Harvard University 3: 4: .rsect shrcode con 5: 6: ;this routine handles errors 7: ;the message is in register a 8: ;and the return is on the stack 9: 10: 11: errort: inc brkl+2 ;increment break level 12: clrb intflg ;get ok 13: mov np,-(sp) ;push on 7 "safe" words 14: mov np,-(sp) 15: mov np,-(sp) 16: mov np,-(sp) 17: mov np,-(sp) 18: mov np,-(sp) 19: mov #brksnag,-(sp) ;and put on snag safely 20: mov b,14(sp) ;now really save b 21: mov sp,b 22: add #14,b 23: mov j1,-(b) ;and safely save the other registers 24: mov j2,-(b) 25: mov j3,-(b) 26: mov ltop,-(b) 27: ;and np is already there 28: call geterr ;get message in b so putstr can output it 29: npush #anil ;set tty port 30: call dmpport 31: mov #erport,@np ;set error port 32: call putstr ;output message 33: mov sp,j1 ;this is to set up for call to ... 34: call findframe 35: br 12$ ;error return (no frame...) 36: mov #broken,b 37: call putstr 38: call printr ;findframe returned form 39: 12$: call dmpport 40: loadnil @np ;set up port for break level 41: errloop= . 42: 1$: mov #linefeed,b ;go into break loop 43: call putstr 44: mov #brkl,a 45: call numout 46: mov bprompt,b 47: call putstr ;output prompt 48: call dmpport 49: .if df,width 50: clrb poport+1 ;reset line width to zero!!!! 51: .endc 52: ;below, if regular lisp, just call the read/eval/print 53: ;routines. if transfer lisp, put in the top level form 54: ; and call eval. 55: 56: .if eq,xfer 57: call @readh ;call proper readr 58: call eval ;eval it 59: call printr ;and print it 60: .iff 61: mov readh,a ;get read control list 62: call eval ;an eval it 63: .endc 64: br 1$ ;and go forever 65: 66: 67: 68: ;findframe takes arg in j1 (assumed to point into stack) 69: ;returns in a the previous form 70: ;j1 points to stack at correct place for next findframe 71: 72: ; 73: ; if this is xfer lisp, it ignores the driver forms, feval1,feval2 74: ; fevq1,feq2 75: 76: findframe: 77: cmp j1,cptop 78: bhis 10$ 79: cmp (j1),#brksnag ;skip over the special frames 80: beq 11$ 81: cmp (j1),#r4rres 82: beq 12$ 83: cmp (j1),#r3rres 84: beq 13$ 85: cmp (j1),#r2rres 86: beq 14$ 87: cmp (j1),#r1rres 88: beq 15$ 89: .if ne,xfer 90: cmp (j1),#eexit1 91: beq 40$ 92: .iftf 93: cmp (j1)+,#eexit 94: bne findframe 95: .ift 96: br 41$ 97: 40$: tst (j1)+ 98: 41$: 99: .endc 100: cmp (j1)+,(j1)+ ;adjust j1 to get to form 101: mov (j1)+,a 102: 103: .if ne,xfer 104: cmp a,#feval1 105: beq findframe 106: cmp a,#feval2 107: beq findframe 108: cmp a,#fevq1 109: beq findframe 110: cmp a,#fevq2 111: beq findframe 112: cmp a,#fevq3 113: beq findframe 114: cmp a,#feval3 115: beq findframe 116: 117: .globl feval1,feval2,fevq1,fevq2,feval3,fevq3 118: 119: .endc 120: 121: add #2,(sp) 122: 10$: ret 123: 11$: cmp (j1)+,(j1)+ ;adjust stack for the size of different frames 124: 12$: tst (j1)+ 125: 13$: tst (j1)+ 126: 14$: tst (j1)+ 127: 15$: cmp (j1)+,(j1)+ 128: br findframe 129: 130: .rsect shrcode 131: once: 132: .if eq,bell411 133: mov %1,pidsav ;save process id 134: .iff 135: .mcall $getpid 136: 137: $getpid ;use system call 138: mov %0,pidsav 139: .endc 140: mov sp,nptop ;save unix handed sp 141: sub #npresc,sp 142: mov sp,npres 143: sub #nplen,sp ;figure out allocation for nstack 144: mov sp,cptop 145: tst (sp) ;force monitor to allocate enough 146: mov npbottom,np 147: loadnil @np 148: $indir 149: $$break ;set our high core allocation 150: mov #headr-<^pl errorm>,a 151: call geterr 152: call putstr 153: 154: .rsect shrcode 155: lsploop: 156: .if eq,fpsim 157: $sig 158: ^d8 ;trap for floating error 159: 1 160: .endc 161: 162: $sig 163: 2 ;and ^c trap 164: inthandler 165: 166: .if ndf,notrap 167: $sig 168: ^d10 169: buserr ;and signal for buss error + segfault 170: .endc 171: 172: $sig 173: ^d11 174: segfault 175: 176: .if ne,brksig 177: $sig 178: brksig 179: 1. ;reset break 180: .endc 181: 182: clr brkl+2 ;set break level to zero 183: clrb intflg ;clear the flags 184: clrb noint 185: clrb nsext 186: 187: .if eq,fpsim 188: ldfps #300 ;set floating point status 189: ldd ten,ac0 ;and load constants 190: ldd tenth,ac1 ;in floating ac's 191: std ac0,ac4 192: std ac1,ac5 193: .endc 194: 195: mov cptop,sp ;set up stack ptr 196: tst (sp) ;make sure core for from mon. 197: mov cptop,np ;and nstack 198: mov npres,nplim ;set up top of np 199: npush #anil ;set standard ports 200: mov np,ltop ;and initilize ltop 201: 1$: mov prompt,b 202: call putstr ;write prompt 203: loadnil a ;leave nice things in ac's so no problems 204: mov a,b ;occur 205: call dmpport ;write prompt 206: .if df,width 207: clrb poport+1 208: .endc 209: .if eq,xfer 210: call @readh 211: call eval 212: call printr 213: .iff 214: mov readh,a 215: call eval ;and do the eval 216: .endc 217: ;2$: mov xoblist,a 218: ; call printr 219: br 1$ 220: 221: 222: 223: 224: .rsect shrcode 225: inthandler: push %0 226: $sig 227: 2 ;reset trap 228: inthandler 229: pop %0 230: incb intflg 231: tstb noint 232: bne 10$ 233: cmpb intflg,#5 ;panic??? 234: bge 1$ 235: 10$: tstb keybin ;^c during type in 236: bne int$11 237: rti 238: 1$: generm </5 ^c's panic--return to last top level/> 239: mov #tmp-<^pl errorm>,a 240: int$12: loadnil @np 241: call geterr 242: call putstr 243: clrb intflg 244: cmp (sp)+,(sp)+ ;flush of ps word 245: jmp retbk1 246: int$11: 247: 248: clrb keybin 249: generm </^c during type in/> 250: mov #tmp-<^pl errorm>,a 251: br int$12 252: 253: 254: .rsect shrcode 255: segfault: 256: ;we want to figure out if is real mf or 257: ;just a stack overflow 258: ;what we'll do is arm for m.f. and push stuff on 259: ;stack, and see what happens 260: 261: $sig ;signal 262: 11. ;mem fault 263: seger1 ;below 264: cmp -(sp),-(sp) ;double dose 265: cmp (sp)+,(sp)+ ;if we're here, was real m.f. 266: mov (sp)+,j3 ;flush off "test word", and leave 267: mov (sp)+,j2 ;pc+ps in j2+j3 for db (if core dump) 268: $sig 269: 11. 270: 0 ;rearm to d.s.a 271: error </seg violation /> 272: 273: seger1: 274: tst gcolf ;gcol stack oflow 275: beq seger2 276: jmp gcolovr 277: seger2: 278: mov cptop,sp 279: generm </control stack overflow; reset generated/> 280: mov #tmp-<^pl errorm>,a 281: jmp hnstko 282: buserr: 283: tst gcolf ;are we in gcol??? 284: beq ber1$ ;no, skip around 285: mov np,-(sp) 286: mov npbottom,np ;leave so db can possibly help 287: loadnil @np ;clear out 288: call dmpport ;try to get message out 289: generm <//<12>/***buss error during gcol-- lisp exit***/<12>/***********/> 290: mov #tmp-<^pl errorm>,a 291: call geterr 292: clr %0 293: $write 294: strbuf 295: 50. 296: iot ;and leave a core dump behind 297: ber1$: 298: mov (sp)+,j3 299: mov (sp)+,j2 ;ps and pc to j3 and j2 300: error </bus error /> 301: 302: .rsect shrcode 303: 304: ; geterr is called with location of error in file in a. 305: ; returns with b pointing to string, or indicating error # 306: 307: geterr: 308: .if eq, version7 309: .ift ; i.e. version7==0 (V6, PWB) seek 310: mov a,$$seek+2 311: clr $$seek+4 ;want to seek absolutely 312: .iff ; i.e. version7==1 V7 long seek 313: clr $$seek+2 ; 16-bit only, clear hiword 314: mov a,$$seek+4 315: clr $$seek+6 ;want to seek absolutely 316: .endc 317: push %0 318: $open 319: erf 320: 0 321: bcs 29$ 322: mov %0,a 323: $indir 324: $$seek 325: mov #strbuf,b 326: mov a,%0 327: $read 328: strbuf 329: strlen 330: mov a,%0 331: $close 332: br 39$ 333: 29$: ;here we have no file; print error 334: incb noint 335: .if eq, version7 336: .ift ;V6/PWB index 337: mov $$seek+2,-(sp) 338: .iff ;V7 index 339: mov $$seek+4,-(sp) 340: .endc 341: clr -(sp) 342: mov sp,a 343: call numstr 344: cmp (sp)+,(sp)+ 345: decb noint 346: movb #'#,-(b) 347: 39$: loadnil a 348: pop %0 349: ret 350: .psect initcd con 351: 352: init: mov (sp),%3 353: mov %1,-(sp) 354: dec %3 355: beq 50$ 356: $create 357: erf 358: 604 ;rw--r 359: bcs 50$ 360: mov %0,-(sp) 361: $write 362: <^pl errorm> 363: <^ph errorm>-<^pl errorm> 364: mov (sp)+,%0 365: $close 366: 50$: 367: 368: .if ne,xfer 369: .globl xbcdm 370: $create 371: xbcdm ;the bcd map 372: 604 ;rw--r 373: bcs 51$ 374: mov %0,-(sp) 375: $write 376: <^pl bcdmap> 377: <^ph bcdmap> - <^pl bcdmap> 378: mov (sp)+,%0 379: $close 380: 51$: 381: 382: .endc 383: mov #once,where ;only once for this code 384: mov #qmap,a 385: 22$: movb #3,(a)+ 386: cmp a,#qmap+<<frstdtpr/400>&377> ;watch out for sign... 387: blo 22$ 388: 2$: movb #1,(a)+ 389: cmp a,#qmap+<<<^pl datom>/400>&377> 390: blo 2$ 391: 32$: movb #2,(a)+ 392: cmp a,#qmap+<<<^ph datom>/400>&377> 393: blo 32$ 394: 3$: movb #-5,(a)+ 395: .if ne,smlint 396: cmp a,#qmap+377-5 397: blo 3$ 398: 33$: clrb (a)+ 399: cmp a,#qmap+377 400: bne 33$ 401: .iff 402: cmp a,#qmap+377 403: bne 3$ 404: .endc 405: 4$: movb #4,qmap+<<<piport/400>&377>> 406: movb #4,qmap+<<<piport+<nports*10>>/400>&377> 407: .if ne,nilas0 408: movb #2,qmap 409: .endc 410: mov (sp)+,%1 411: jmp once 412: 413: .if eq,fpsim 414: .psect shrwddat con 415: ten: .word 41040,0,0,0 416: tenth: .word 37314,146314,146314,146315 417: 418: .endc 419: 420: 421: .rsect shrcode con 422: cantcont: call errort 423: error </can't continue/> 424: 425: 426: .globl $rettrue 427: 428: $rettrue: 429: mov #atrue,a 430: ret 431: 432: .if eq,nilas0 433: 434: .globl $retnil 435: 436: $retnil: 437: loadnil a 438: ret 439: .endc 440: 441: ;gatom is called with the number of words in the printname 442: ;(i.e. int((length(name(atom))+2)/2)) in a. 443: ;return atom initilized to nil,nil,nil in a 444: ;no regiaters killed. 445: 446: gatom: add #3,a ;get real word length 447: save4 448: 1$: mov #fratom,j1 ;get atom freelist 449: 2$: mov (j1),j2 ;get entry we're interested in 450: jmpifnil j2,10$,nl 451: cmp 2(j2),a ;see about lengths 452: blt 5$ ;;if too small,loop 453: mov 2(j2),b ;now get length 454: sub a,b ;see how much left 455: cmp b,#4 ;if less than four words left 456: bge 4$ ;throw piece away 457: mov (j2),(j1) ;with this instruction 458: 4$: mov b,2(j2) ;now fix length of freelist entry 459: asl b ;convert freelist entry to bytes 460: add b,j2 ;and get the end of the entry 461: mov j2,a ;which is our atom 462: loadnil (j2)+ 463: loadnil (j2)+ 464: loadnil (j2) 465: saveret ;and go home 466: 5$: mov j2,j1 ;move to next entry 467: br 2$ ;and loop 468: 10$: mov a,j3 ;allocate a new page 469: call globalc 470: tst a 471: beq 19$ ;correct return??? 472: movb #2,qmap(a) ;and set the type properly 473: swab a ;get address 474: mov fratom,(a) ;fix up freelist 475: mov #200,2(a) ;and fix up entry 476: mov a,fratom ;put entry first on list 477: mov j3,a ;move a back 478: br 1$ ;and do it again 479: 480: 481: ;here we have no room; do error stuff 482: 483: 19$: 484: 485: .if ne,xfer 486: call noroom 487: nrooma: 488: 489: .iff 490: error </cannot allocate another atom page/> 491: ;must be non-cont since strbuff will be clobbered!!!! 492: .endc 493: 494: 495: 496: ;globallc is called 497: ;returns in a the page number of the allocated page 498: ;which is converted to an address by swab 499: ;to give a page back simply set the qmap bit to 500: ;-3 501: ;if no more room is present, returns 0 in a 502: 503: .rsect shrcode 504: globallc: 505: clr a 506: save1 507: 10$: cmpb qmap(a),#-3 ;simply search map till 508: beq 2$ ;we find a free page 509: blt 3$ ;or we find monitor core 510: incb a 511: bne 10$ ;loop till done 512: br 4$ 513: 3$: mov a,j3 ;and get good addr 514: swab j3 515: add #400,j3 ;with proper address 516: bit #17777,j3 ;see about bits 517: bne 30$ ;if all are zero, we gotta worry 518: add #400,j3 ;if was last page, force first page on next seg 519: 30$: mov $$break+2,-(sp) ;save old address 520: mov j3,$$break+2 ;and put in new 521: mov (sp)+,j3 ;re-recover old 522: $indir 523: $$break 524: bcc 32$ ;if error, complain 525: mov j3,$$break+2 ;reset old address 526: 4$: clr a ;and set error return 527: 32$: 528: 2$: saveret 529: 530: 531: 532: ;xnums stores a number in core from regiser a&b 533: 534: xnums: 535: .if eq,smlint 536: br 3$ 537: .endc 538: tst a ;see if in small int range, ie +/-xxx 539: beq 2$ 540: cmp a,#-1 541: bne 3$ 542: cmp b,#-^d319 543: blo 3$ 544: 4$: mov b,a ;now make small int 545: asl a 546: add #-^d640,a 547: 17$: mov a,b 548: ret 549: 550: 2$: cmp b,#^d319 551: blo 4$ 552: 3$: asl a ;shift high order word 553: bvs xnumer 554: 7$: jmpnnil frnumber,6$ ;any cells??? 555: call gcol 556: 6$: mov frnumber,-(sp) ;move cell ptr to stack 557: mov @(sp),frnumber ;and fix free list 558: mov a,@(sp) ;put in a 559: mov (sp)+,a ;and get ptr to cell 560: mov b,2(a) ;load second word 561: br 17$ 562: 563: xnumer: error </arithmetic overflow/> 564: 565: 566: .if eq,fpsim 567: 568: 569: 570: xnumsac0: 571: incb noint ;no 5 ^c's for a minute 572: stcdl ac0,-(sp) 573: mov (sp)+,a 574: mov (sp)+,b 575: decb noint ;turn back on 576: cfcc 577: bcs xnumer 578: br xnums 579: .endc 580: .if eq,fpsim 581: .globl xnumg0,xnumg1,xnumsac 582: 583: 584: xnumg0:brifsmalint a,f1$ 585: asr (a) ;fix representation 586: ldcld (a),ac0 ;and load in ac0 587: asl (a) ;restore int 588: ret ;;;and go home 589: f1$: push a 590: sub #-^d640,a 591: asr a 592: seti 593: ldcid a,ac0 594: setl 595: pop a 596: ret 597: 598: .endc 599: 600: .rsect shrcode con 601: nperror: cmp np,nptop 602: bhis npe1$ 603: mov nptop,nplim 604: save1 ;save register a 605: mov a,j3 606: error </name stack overflow/>,npe2$ 607: npe2$: mov j3,a 608: mov 2(sp),j3 609: cmp (sp)+,(sp)+ 610: ret 611: npe1$: 612: generm </hard name stack overflow; reset executed/> 613: mov #tmp-<^pl errorm>,a 614: hnstko: 615: mov npbottom,np 616: call geterr 617: loadnil @np 618: call putstr 619: jmp lsploo 620: 621: 622: 623: .rsect shrcode con 624: ;;gets a doted pair 625: gdtpr: jmpifnil frdtpr,10$ 626: mov frdtpr,a 627: mov (a),frdtpr 628: ret 629: 10$: call gcol 630: br gdtpr 631: 632: .if eq,fpsim 633: ; counterpart of xnumg0 634: 635: xnumg1: brifsmalint a,g1$ 636: asr (a) 637: ldcld (a),ac1 638: asl (a) 639: ret 640: g1$: push a 641: sub #-^d640,a 642: asr a 643: seti 644: ldcid a,ac1 645: setl 646: pop a 647: ret 648: 649: .endc 650: 651: ;xnum1 pputs number in register a&b 652: 653: xnum1: brifsmalint a,1$ 654: mov 2(a),b 655: mov (a),a 656: asr a 657: ret 658: 1$: mov a,b 659: sub #-^d640,b 660: asr b 661: sxt a 662: ret 663: ;num2 puts register in j1&j2 664: xnum2: brifsmalint a,1$ 665: mov 2(a),j2 666: mov (a),j1 667: asr j1 668: ret 669: 1$: mov a,j2 670: sub #-^d640,j2 671: asr j2 672: sxt j1 673: ret
|
Last modified: 1981-05-10
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 1451 |
|