1: ; Copyright (c) 1981 Harvard-Radcliffe Student Timesharing System 2: ; Science Center, Harvard University 3: 4: ;pdp11 lisp subr file 5: ;8/1/74 6: 7: .sbttl subrs 8: subrbeg xquote nlambda,1 9: chanl 10: mov @np,a 11: jmpifnil a,1$,no ;(quote)=nil 12: car a,a 13: 1$: ret 14: subrend 15: 16: 17: 18: atom read,aread,,,xreadc 19: 20: subrbeg xreadc lambda,1 21: chas 22: mov @np,a 23: jmpifnil a,1$,t ;see if valid port 24: cmptype a,#nport 25: bne read2$ 26: 1$: jmp readr ;if ok, then do it 27: read2$: jmp erm5er 28: subrend 29: 30: 31: atom evalquote,aevquote,,,xevqc 32: 33: subrbeg xevqc,lambda,1 34: chas 35: mov @np,a 36: jmpifnil a,1$,t ;see if valid port 37: cmptype a,#nport 38: bne read2$ 39: 1$: jmp evalquote 40: subrend 41: 42: atom ratom,,,,xcrtm 43: 44: subrbeg xcrtm lambda,1 45: chas 46: mov @np,a 47: jmpifnil a,1$,t ;see if valid port 48: cmptype a,#nport 49: bne 2$ 50: 1$: jmp ratomr 51: 2$: jmp erm5er 52: subrend 53: 54: 55: atom print,aprint,,,xprintc 56: 57: subrbeg xprintc lambda,2 58: chas 59: mov -4(np),a 60: mov @np,j2 61: jmpifnil j2,1$,t ;is good port 62: cmptype j2,#nport 63: bne 2$ 64: jmp printr 65: 1$: call printr 66: jmp dmpport 67: 2$: jmp erm5er 68: subrend 69: 70: 71: atom patom,,,,xptmc 72: 73: subrbeg xptmc lambda,2 74: chas 75: mov (np),j2 ;check out port 76: jmpifnil j2,1$,nl ;nil is good port 77: cmptype j2,#nport ;is port??? 78: bne 30$ ;no, scream 79: 1$: mov -4(np),a ;get token 80: ldtype a,j2 ;get its type code 81: cmp j2,#natom ;is this an atom 82: beq 10$ ;yes, we know what to do 83: tst j2 ;what about int??? 84: bne 20$ ;no, scream 85: numgj1 ;get the number 86: mov #strbuf+1,b ;get space 87: clrb (b) ;null termination 88: movb j2,-(b) ;and our friend 89: jmp putstr 90: 10$: jmp xpatom 91: 20$: 92: 30$: 93: erm5er: 94: error </i-o error/> 95: 96: subrend 97: 98: 99: atom infile,,,,infile 100: 101: subrbeg infile lambda,2 102: chas 103: call fixname ;leaves a ptr to name in a 104: call openr ;opens file;leaves port in a 105: ret 106: subrend 107: 108: atom outfile,,,,outfile 109: 110: subrbeg outfile lambda,1 111: chas 112: call fixnm1 ;leaves name in a 113: call openw ;open port;leave in a 114: ret 115: subrend 116: 117: 118: atom close,,,,subclose 119: 120: subrbeg subclose lambda,1 121: chas 122: mov @np,a 123: jmpifnil a,1$,t ;can't close nil 124: cmptype a,j1,#nport 125: bne 2$ ;better be port 126: tstb (a) ;see if open 127: bge 3$ ;if not,... 128: call dmpport ;output all chars in buffer 129: 3$: call close ;close it 130: 1$: retnil ;and go home 131: 2$: jmp erm5er 132: subrend 133: 134: atom load,,,,load 135: subrbeg load lambda,2 136: chas 137: call fixname ;get name 138: call openr ;open it 139: mov a,@np ;put it on np 140: 1$: call readr ;read 141: cmp a,#aeof ;done? 142: beq 2$ ;yes,clean up 143: call eval ;eval thing 144: br 1$ ;and loop 145: 2$: call close ;close port 146: retnil ;and go home 147: subrend 148: 149: 150: atom cont,,,,cont 151: subrbeg cont lambda,1 152: chas 153: 1$: cmp (sp),#brksnag ;search for snag 154: beq 2$ ;yes, then take care of 155: tst (sp)+ 156: cmp sp,cptop 157: blo 1$ 158: jmp lsploo ;otherwise,reset 159: 2$: mov sp,a ;get other stack ptr 160: cmp (a)+,(a)+ ;point to ltop 161: mov (a)+,ltop 162: mov (a)+,j3 163: mov (a)+,j2 164: mov (a)+,j1 165: mov (a)+,b 166: mov @np,a ;return top of ns 167: mov 2(sp),np ;and old ns 168: add #16,sp ;to return 169: dec brkl+2 ;decrement count 170: ret ;and try to continue with new a 171: subrend 172: 173: 174: atom terpr,,,,terpr 175: 176: subrbeg terpr lambda,1 177: chas 178: mov #linefeed,b ;set up in anticipation 179: mov @np,j3 180: jmpifnil j3,20$,t ;is nil? 181: cmptype j3,j2,#nport ;if not, better be port 182: bne 2$ ;signal error 183: 1$: call putstr ;output cr 184: clrb 1(j3) ;reset linelength port 185: br 3$ 186: 20$: call putstr ;output string 187: call dmpport ;print line 188: clrb poport+1 ;reset char count 189: 3$: mov b,a ;mov nil to a 190: ret 191: 2$: error </i-o error/> 192: subrend 193: 194: 195: 196: atom drain,,,,drain 197: 198: subrbeg drain,lambda,1 199: chas 200: mov @np,j3 201: jmpifnil j3,20$,t 202: cmptype j3,#nport 203: bne 2$ 204: 20$: call dmpport 205: retnil 206: 2$: jmp erm5er 207: subrend 208: 209: atom break,,,,break 210: 211: subrbeg break lambda,1 212: chas 213: push #br2$ ;push return 214: mov @np,a ;print message 215: loadnil @np 216: call printr 217: generm </ /> 218: mov #tmp-<^pl errorm>,a 219: jmp errort 220: br2$: ret 221: 222: subrend 223: 224: 225: atom prog,,,,prog 226: 227: subrbeg prog nlambda,1 228: chanl 229: mov (np),a ;get prog body 230: push ltop ;save state of world for goto 231: 232: cdr a,-(sp) ;push function list 233: car a,a ;get prog vars 234: 235: 3$: jmpifnil a,1$,t ;if none, then go to next stage 236: 2$: npush #anil 237: mov (a)+,-2(np) 238: mov @a,a ;get rest of vars 239: br 3$ ;and goto loop 240: 1$: push np ;save np for goto restoration 241: mov 2(sp),-(sp) ;get function list 242: push #progsnag ;and mark stack 243: progloop:mov 2(sp),a ;get current function list 244: jmpifnil a,1$ ;if nil, go home 245: cdr a,2(sp) ;store part of list we don't care about 246: car a,a ;and get our function 247: cmptype a,j1,#ndtpr ;if not dtpr, 248: bne progloop ;don't eval 249: call eval 250: br progloop 251: 1$: add #10,sp ;flush back sp 252: pop ltop ;restore ltop 253: ret ;and let eexit do rest 254: 255: subrend 256: 257: 258: atom return,,,,return 259: 260: 261: subrbeg return lambda,1 262: chanl 263: call fdprog 264: add #6,sp 265: pop ltop 266: mov @np,a 267: ret 268: 269: fdprog: 270: mov (sp),j1 ;save return addr 271: 2$: cmp (sp),#brksna ;gotta bypass breaks 272: beq 36$ 273: cmp (sp),#r4rres 274: beq 34$ 275: cmp (sp),#r3rres 276: beq 33$ 277: cmp (sp),#r2rres 278: beq 32$ 279: cmp (sp),#r1rres 280: beq 31$ 281: cmp (sp)+,#progsnag ;search for prog 282: bne 30$ ;go to test 283: jmp (j1) ;return to calling routine 284: 36$: dec brkl+2 285: cmp (sp)+,(sp)+ ;+4 286: 34$: tst (sp)+ ;+2 287: 33$: tst (sp)+ ;+2 288: 32$: tst (sp)+ ;+2 289: 31$: cmp (sp)+,(sp)+ ;+4 290: 30$: cmp sp,cptop 291: blo 2$ 292: error </no prog to go to or return from/>,lsploop 293: subrend 294: 295: 296: atom go,,,,xgoto 297: subrbeg xgoto,nlambda,1 298: chanl 299: mov @np,a 300: car a,a 301: cmptype a,j1,#natom ;if value isn't atom, then 302: ; eval to get atom 303: beq go1$ 304: call eval 305: go1$: call fdprog 306: mov 4(sp),j3 ;now see if label there 307: 3$: jmpifnil j3,go1$ ;if list nil, then get next prog 308: mov (j3)+,j2 ;get car 309: mov @j3,j3 ;and cdr 310: cmp a,j2 ;are things equal 311: bne 3$ ;no, then try again 312: mov j3,(sp) ;set up prog block 313: mov 2(sp),np ;and flush back to progvars 314: jmp progloop-4 ;and go to progloop 315: subrend 316: 317: atom car,,,,xccar 318: 319: subrbeg xccar lambda,1 320: chas 321: care1: mov @np,a 322: care: 323: .if eq,multiseg 324: .if ne,nilas0 325: beq cdd12$ ;is ignored if nil#0 326: .endc 327: .endc 328: 329: ldtype a,j1 330: dec j1 ;is dtpr? 331: beq 1$ ;yes,... 332: dec j1 ;is atom? 333: bne 2$ ;yes,... 334: 1$: car a,a 335: ret 336: erm9er=* . 337: 2$: error </can't follow car or cdr/> 338: .if eq,multiseg 339: .if ne,nilas0 340: cdd12$: mov atmnil,a 341: ret 342: .endc 343: .endc 344: subrend 345: 346: atom cdr,,,,xccdr 347: 348: subrbeg xccdr lambda,1 349: chas 350: cdre1: mov @np,a 351: cdre: 352: .if eq,multiseg 353: .if ne,nilas0 354: beq cddd12$ ;is ignored if nil"#0 355: .endc 356: .endc 357: ldtype a,j1 358: dec j1 359: beq 1$ ;make sure dtpr or atom 360: dec j1 361: bne 2$ 362: 1$: cdr a,a 363: ret 364: 2$: br erm9er 365: .if eq,multiset 366: .if ne,nilas0 367: cddd12$: mov atmnil+2,a 368: ret 369: .endc 370: .endc 371: subrend 372: 373: atom caar,,,,caar 374: 375: subrbeg caar,lambda,1 376: chanl 377: call care1 378: br care 379: subrend 380: 381: atom cadr,,,,cadr 382: subrbeg cadr,lambda,1 383: chanl 384: call cdre1 385: br care 386: subrend 387: 388: atom cddr,,,,cddr 389: 390: subrbeg cddr,lambda,1 391: chanl 392: call cdre1 393: br cdre 394: subrend 395: 396: atom cdar,,,,cdar 397: 398: subrbeg cdar,lambda,1 399: chanl 400: call care1 401: br cdre 402: subrend 403: 404: 405: atom and,,,,andc 406: 407: subrbeg andc,nlambda,1 408: chanl 409: 1$: mov @np,j1 410: jmpifnil j1,2$,nl 411: mov (j1)+,a 412: mov (j1),@np 413: call eval 414: .if eq,nilas0 415: cmp a,#anil 416: .iff 417: tst a 418: .endc 419: bne 1$ 420: retnil 421: 2$: rettrue 422: 423: subrend 424: 425: atom or,,,,orc 426: 427: subrbeg orc,nlambda,1 428: chanl 429: 1$: mov @np,j1 430: jmpifnil j1,2$,nl 431: mov (j1)+,a 432: mov (j1),@np 433: call eval 434: jmpifnil a,1$ 435: rettrue 436: 2$: retnil 437: subrend 438: 439: 440: atom cons,,,,xccons 441: 442: subrbeg xccons,lambda,2 443: chas 444: call gdtpr 445: mov @np,2(a) 446: mov -4(np),@a 447: ret 448: subrend 449: 450: atom oblist,,,,xcobl 451: 452: subrbeg xcobl,nlambda,0 453: nop 454: nop ;where chas would usually go 455: mov xoblist,a 456: ret 457: subrend 458: 459: atom setq,,,,setq 460: subrbeg setq,nlambda,1 461: chanl 462: mov @np,a 463: jmpifnil a,1$,t ;(setq)=> error! 464: mov @2(a),a ;cadr 465: call eval ;eval it 466: mov a,j1 ;save in j1 467: mov @np,a ;get atom name 468: car a,a 469: .if eq,multiseg 470: .if ne,nilas0 471: bne 2$ ;is alway taken if nil#0 472: mov #atmnil,a 473: br 3$ 474: .endc 475: .endc 476: 2$: cmptype a,j3,#natom ;better be atom 477: bne 1$ 478: call lookup ;get current binding cell 479: 3$: mov j1,2(a) ;smash it 480: mov j1,a ;and return right thing 481: ret 482: erm11er=* . 483: 1$: error </improper use of setq/> 484: subrend 485: 486: atom set,,,,set 487: 488: subrbeg set,lambda,2 489: chas 490: mov -4(np),a ;get atom 491: .if eq,multiseg 492: .if ne,nilas0 493: bne 2$ 494: mov #atmnil,a 495: 2$: 496: .endc 497: .endc 498: cmptype a,j1,#natom 499: bne 1$ 500: call lookup 501: mov a,j1 502: mov @np,a 503: mov a,2(j1) 504: ret 505: 1$: br erm11er 506: subrend 507: 508: 509: 510: atom cond,,,,cond 511: 512: subrbeg cond,nlambda,1 513: chanl 514: mov @np,a ;get thing in a 515: 10$: jmpifnil a,1$,t ;if nil, return nil 516: mov @(a)+,a ;get caar 517: call eval ;eval it 518: .cond1=* . ;for xfer lisp 519: jmpnnil a,2$ ;if not nil, then..... 520: mov @np,a ;advance through body 521: cdr a,a 522: mov a,@np ;store for future use 523: br 10$ ;and loop 524: 2$: mov @np,j1 ;now we want to eval the consequences 525: car j1,j1 ;get car 526: cdr j1,j1 ;and get cdr(list of consequences) 527: 4$: jmpifnil j1,1$,t ;if nil, then return 528: mov (j1)+,a ;get car for evaling 529: mov @j1,@np ;store cdr for latter reference 530: call eval 531: .cond2=* . ;again for xfer lisp 532: mov @np,j1 ;get back np 533: br 4$ ;and loop 534: 1$: ret ;go home 535: subrend 536: 537: 538: 539: 540: atom eval,aeval,,,xceval 541: 542: subrbeg xceval,lambda,1 543: chanl 544: mov @np,a 545: jmp eval 546: subrend 547: 548: 549: .enabl lsb 550: 551: atom numbp,,,,numbp 552: atom numberp,,,,numbp 553: 554: subrbeg numbp,lambda,1 555: chas 556: clr j2 557: 1$: mov @np,j1 558: cmptype j1,j2 559: 2$: bne 10$ 560: 3$: rettrue 561: 10$: retnil 562: subrend 563: 564: atom atom,,,,xatomc 565: atom atomp,,,,xatomc 566: 567: subrbeg xatomc,lambda,1 568: chas 569: ldtype (np),j1 570: tst j1 571: beq 3$ ;if number, is considered atom 572: cmp j1,#natom 573: br 2$ ;let branch above decide 574: subrend 575: 576: atom dtpr,,,,xdtpr 577: 578: subrbeg xdtpr,lambda,1 579: chas 580: mov #ndtpr,j2 581: br 1$ 582: subrend 583: 584: atom bcd,,,,xbcd 585: 586: subrbeg xbcd,lambda,1 587: chas 588: mov #nbcd,j2 589: br 1$ 590: subrend 591: 592: atom port,,,,xportc 593: 594: subrbeg xportc,lambda,1 595: chas 596: mov #nport,j2 597: br 1$ 598: subrend 599: 600: .dsabl lsb 601: 602: 603: 604: atom reset,,,,xreset 605: 606: subrbeg xreset,lambda,1 607: nop 608: nop 609: jmp lsploo 610: subrend 611: 612: atom def,,,,xcdef 613: 614: subrbeg xcdef,nlambda,1 615: chanl 616: mov @np,j2 617: car j2,a 618: .if eq,multiset 619: .if ne,nilas0 620: beq def12$ 621: .endc 622: .endc 623: cmptype a,j1,#natom ;make sure is atom 624: bne 1$ 625: mov @2(j2),4(a) ;store function binding 626: ret 627: erm16er=* . 628: 1$: error </only atoms have function definitions/> 629: .if eq,multiseg 630: .if ne,nilas0 631: def12$: mov @2(j2),atmnil+4 632: ret 633: .endc 634: .endc 635: subrend 636: 637: atom getd,,,,xcgetdef 638: 639: subrbeg xcgetdef,lambda,1 640: chanl 641: mov @np,a 642: .if ne,nilas0 643: .if eq,multiseg 644: beq 12$ 645: .endc 646: .endc 647: cmptype a,j1,#natom ;make sure atom 648: bne 1$ 649: mov 4(a),a ;get fnb 650: ret 651: 1$: br erm16er 652: .if eq,multiseg 653: .if ne,nilas0 654: 12$: mov atmnil+4,a 655: ret 656: .endc 657: .endc 658: subrend 659: 660: atom ddt,,,,odt 661: 662: subrbeg odt,nlambda,0 663: nop 664: nop 665: tst #frstcl ;is non-zero if ddt loadedd 666: beq 1$ 667: bpt 668: 1$: retnil 669: subrend 670: 671: atom lessp,,,,xlessp 672: 673: subrbeg xlessp,lambda,2 674: chas 675: call ncomp 676: br 1$ 677: blt 2$ 678: retnil 679: 2$: rettrue 680: 1$: jmp erm10e 681: subrend 682: 683: atom greaterp,,,,xgreatp 684: 685: subrbeg xgreatp,lambda,2 686: chas 687: call ncomp 688: br 1$ 689: bgt 2$ 690: retnil 691: 2$: rettrue 692: 1$: error </non-numeric arg to arithmetic subr/> 693: subrend 694: 695: 696: atom eq,,,,xeqc 697: 698: subrbeg xeqc,lambda,2 699: chas 700: mov np,j1 701: cmp (j1),-4(j1) ;try quick test 702: beq 1$ 703: call ncomp 704: br 2$ ;not number 705: beq 1$ ;equal 706: 2$: retnil ;and return appropriatly 707: 1$: rettrue 708: subrend 709: 710: 711: 712: atom rplaca,,,,rplaca 713: 714: 715: subrbeg rplaca,lambda,2 716: chas 717: mov -4(np),a 718: .if eq,multiseg 719: .if ne,nilas0 720: beq ra12$ 721: .endc 722: .endc 723: ldtype a,j2 ;make sure atom or dtpr 724: dec j2 725: beq 1$ 726: dec j2 727: bne 2$ 728: 1$: mov (np),(a) 729: ret 730: 2$: jmp erm9er 731: .if eq,multiseg 732: .if ne,nilas0 733: ra12$: mov (np),atmnil 734: ret 735: .endc 736: .endc 737: subrend 738: 739: atom rplacd,,,,rplacd 740: 741: subrbeg rplacd,lambda,2 742: chas 743: mov -4(np),a 744: .if eq,multiseg 745: .if ne,nilas0 746: beq rd12$ 747: .endc 748: .endc 749: ldtype a,j2 750: dec j2 ;make sure atom or dtpr 751: beq 1$ 752: dec j2 753: bne 2$ 754: 1$: mov (np),2(a) 755: ret 756: 2$: jmp erm9er 757: .if eq,multiseg 758: .if ne,nilas0 759: rd12$: mov (np),atmnil+2 760: ret 761: .endc 762: .endc 763: subrend 764: 765: atom linelength,,,,xlnlen 766: 767: subrbeg xlnlen,lambda,1 768: chanl 769: cmptype @np,a,0 ;if handed int, make it new linelength 770: beq 1$ 771: mov lnleng,b ;otherwise return current 772: clr a ;linelength 773: nmstore 774: ret 775: 1$: mov @np,a ;store low order of int in 776: numgj1 777: .if df,width 778: cmpb j2,#5 ;eliminate rediculous widths 779: blo 2$ 780: .endc 781: mov j2,lnleng ;linelength 782: 2$: ret 783: subrend 784: 785: atom charcnt,,,,xchrct 786: 787: subrbeg xchrct,lambda,1 788: chanl 789: mov @np,j2 790: jmpifnil j2,1$,t 791: cmptype j2,j3,#nport ;port? 792: bne 2$ 793: tstb (j2) ;output? 794: blt 3$ 795: 2$: jmp erm17e 796: 1$: mov #poport,j2 ;if was nil, map to poport 797: 3$: mov lnleng,b ;caculate chars left 798: movb 1(j2),a 799: sub a,b 800: sxt a 801: nmstore ;andd return that 802: ret 803: subrend 804: 805: atom $mumble,,,,xmums 806: 807: .if ne,xfer 808: subrbeg xmums,lambda,4,elists 809: .iff 810: subrbeg xmums,lambda,4 811: .endc 812: chas 813: clr b 814: .if eq,nilas0 815: clrb tracflg 816: jmpifnil (np),27$ 817: incb tracflg 818: .iff 819: movb 1(np),tracflg 820: .iftf 821: mumscon=* . 822: 27$: cmptype -4(np),a,0 ;if int, then make new nstk length 823: bne 1$ 824: mov -4(np),a 825: numgj1 826: incb noint ;no interupts, please!!!! 827: ash #2,j2 828: mov npres,j3 829: sub j2,j3 830: mov j3,j1 ;see about core 831: sub #300.,j1 ;insure some stack room 832: mov j1,j2 ;get copy 833: bic #17777,j2 ;get to bottom of seg 834: cmp j2,$$break+2 ;better be above this 835: blo 52$ 836: mov sp,j2 ;mov sp to j2 837: mov j1,sp ;and get new low stack 838: $sig 839: 11. 840: 51$ ;see about overflow... 841: tst (sp) ;wellllllllll..... 842: $sig 843: 11. 844: segfault 845: mov j3,cptop 846: inc b ;set flag for reset 847: 1$: 848: .ift 849: clrb supcol ;see about supercollect 850: jmpifnil -10(np),2$ ;if non-nil,then set supcol 851: incb supcol 852: .iff 853: movb -7(np),supcol 854: .iftf 855: 2$: mov -14(np),a 856: .if ne,nilas0 857: beq 3$ 858: .iff 859: jmpifnil a,3$ 860: .endc 861: mov #eqprompt,prompt 862: mov #beqprompt,bprompt ;set up prompts 863: .if ne,xfer 864: mov #eqlist,readh ;make list (...(evalquote nil] 865: .iff 866: mov #evalqu,readh 867: .endc 868: br 4$ 869: 3$: mov #eprompt,prompt 870: mov #beprompt,bprompt 871: .if ne,xfer 872: mov #elist,readh 873: .iff 874: mov #readr,readh 875: .endc 876: 4$: tst b ;if j3#0, then reset 877: bne 5$ 878: ret 879: 5$: jmp lsploo 880: .endc 881: 882: 51$: $sig 883: 11. 884: segfault 885: mov j2,sp 886: 52$: decb noint ;interupts are now ok 887: error </cannot meet stack request/>,mumscon 888: 889: subrend 890: 891: atom quo,,,,xdivc 892: atom quotient,,,,xdivc 893: 894: subrbeg xdivc,lambda,2 895: chas 896: mov (np),a 897: cmptype a,b,0 ;again, check for number 898: bne xdiv2$ 899: .if eq,fpsim 900: numga1 ;put numb in floating ac1 901: cfcc 902: .iff 903: numgj1 904: tst j2 905: bne 16$ 906: tst j1 907: .iftf 908: beq xdiv3$ 909: .iff 910: 16$: 911: 912: .endc 913: mov -4(np),a 914: cmptype a,b,0 ;here too 915: bne xdiv2$ 916: .if eq,fpsim 917: numga0 ;numb into floating ac0 918: divd ac1,ac0 ;divide 919: numsta0 ;store floating number 920: .iff 921: numga 922: 923: .globl idiv,imul 924: 925: call idiv 926: nmstore 927: .endc 928: 929: ret 930: xdiv2$: jmp erm10er 931: xdiv3$: jmp erm18er 932: subrend 933: 934: .if ne,multiseg 935: 936: 937: 938: atom getadr,,,,xgetad 939: 940: subrbeg xgetad,lambda,1 941: chanl 942: mov @np,b 943: clr a 944: nmstore 945: ret 946: subrend 947: 948: 949: 950: ;gettyp maps types into pdp11 internal codes 951: atom gettyp,,,,xgettyp 952: 953: subrbeg xgettyp,lambda,1 954: chanl 955: mov @np,b 956: ldtype b 957: 10$: clr a 958: nmstore 959: ret 960: subrend 961: 962: 963: ;routines to access imem 964: 965: ;atom readimem,,,,xrim 966: ; 967: ;subrbeg xrim,lambda,1 968: ; chanl 969: ; mov @np,a 970: ; numga 971: ; .word 006513 ;mfpi (b) 972: ; pop b 973: ; clr a 974: ; nmstore 975: ; ret 976: ;subrend 977: 978: 979: ;atom writeimem,,,,xwim 980: ; 981: ;subrbeg xwim,lambda,2 982: ; chas 983: ; mov (np),a 984: ; numgj1 985: ; mov -4(np),a 986: ; numga 987: ; push b 988: ; mtpi (j2) 989: ; retnil 990: ;subrend 991: ; 992: ; 993: ;;and to get contents of dspace 994: .endc 995: ; 996: .if df,notrap 997: atom readdmem,,,,xrdm 998: 999: subrbeg xrdm,lambda,1 1000: chanl 1001: mov @np,a 1002: numga 1003: bit #1,b 1004: bne 1$ 1005: mov (b),b 1006: br 2$ 1007: 1$: mov np,b 1008: tst a 1009: bge 2$ 1010: mov sp,b 1011: 2$: 1012: clr a 1013: nmstore 1014: ret 1015: subrend 1016: 1017: 1018: .endc 1019: 1020: atom reclaim,,,,xreclaim 1021: 1022: subrbeg xreclaim,lambda,2 1023: chas 1024: mov (np),a 1025: jmpifnil a,1$,t ;see if args are being given 1026: numgj1 ;get int 1027: cmp j2,#20 ;enforce minimum 1028: bhi 10$ 1029: mov #20,j2 1030: 10$: mov j2,mfnumber ;store low ordder 1031: 1$: mov -4(np),a 1032: jmpifnil a,2$,t 1033: numgj1 ;get number 1034: cmp j2,#20 1035: bhi 11$ 1036: mov #20,j2 ;enforce min 1037: 11$: mov j2,mfdtpr ;and store 1038: 2$: call gcol 1039: mov cnumber,b ;return (fddtpr.fnumbr) 1040: clr a 1041: nmstore 1042: push a 1043: mov cdtpr,b 1044: clr a 1045: nmstore 1046: pop b 1047: jmp xconsa 1048: subrend 1049: 1050: atom null,,,,nulls 1051: 1052: subrbeg nulls,lambda,1 1053: chanl 1054: mov @np,a 1055: jmpifnil a,1$,t 1056: retnil 1057: 1$: rettrue 1058: subrend 1059: 1060: 1061: 1062: atom putd,,,,xputd 1063: 1064: subrbeg xputd,lambda,2 1065: chas 1066: mov -4(np),a 1067: .if eq,multiseg 1068: .if ne,nilas0 1069: beq 12$ 1070: .endc 1071: .endc 1072: cmptype a,b,#natom ;make sure is atom 1073: bne 1$ 1074: mov (np),4(a) 1075: ret 1076: 1$: jmp erm16er 1077: .if eq,multiseg 1078: .if ne,nilas0 1079: 12$: mov (np),atmnil+4 1080: ret 1081: .endc 1082: .endc 1083: subrend 1084: 1085: atom pntlen,,,,xpntln 1086: 1087: subrbeg xpntln,lambda,1 1088: chanl 1089: mov @np,a 1090: dispatch ;dispatch on type 1091: br pnt1$ 1092: .word 0 1093: br 2$ 1094: .word 0 1095: br pnt3$ 1096: .word 0 1097: br 2$ 1098: .word 0 1099: erm17e=* . 1100: 2$: error </bad arg to special subr/> ;these things don't have lengths on name strings 1101: 1102: pnt1$: call numstr ;convert to string 1103: neg b ;and caculate length 1104: add #<strbuf+27>,b 1105: br pnt4$ 1106: pnt3$: add #6,a ;go down string till zero seen 1107: mov a,b 1108: 5$: tstb (b)+ 1109: bne 5$ 1110: dec b 1111: sub a,b 1112: pnt4$: clr a 1113: nmstore 1114: ret 1115: subrend 1116: 1117: 1118: ;new plus,times,diff,difference,sub,sub1,add,add1 1119: 1120: 1121: atom add1,,,,xadd1 1122: 1123: subrbeg xadd1,lambda,1 1124: chas 1125: mov #1,j2 1126: clr j1 1127: br pickplus 1128: subrend 1129: 1130: atom sub1,,,,xsub1 1131: 1132: subrbeg xsub1,lambda,1 1133: chas 1134: mov #-1,j1 1135: mov j1,j2 1136: br pickplus 1137: 1138: subrend 1139: 1140: atom add,,,,xadd 1141: 1142: subrbeg xadd,lambda,2 1143: chas 1144: br ppickplus 1145: subrend 1146: 1147: atom diff,,,,xsub 1148: atom difference,,,,xsub 1149: 1150: subrbeg xsub,lambda,2 1151: chas 1152: mov np,j3 1153: mov (j3),a 1154: cmp -(j3),-(j3) 1155: cmptype a,b,0 1156: bne erm10er 1157: numgj1 1158: com j1 1159: com j2 1160: add #1,j2 1161: adc j1 1162: br .pickplus 1163: subrend 1164: 1165: 1166: atom plus,,,,plusc 1167: 1168: subrbeg plusc,lambda,0 1169: nop 1170: nop 1171: ppickplus: 1172: clr j1 1173: clr j2 1174: pickplus: 1175: mov np,j3 1176: .pickplus: 1177: cmp j3,ltop 1178: blos 2$ 1179: mov @j3,a 1180: cmp -(j3),-(j3) 1181: cmptype a,b,0 1182: bne erm10e 1183: numga 1184: add b,j2 1185: adc j1 1186: bvs erm18er 1187: add a,j1 1188: bvs erm18er 1189: br .pickplus 1190: 2$: mov j1,a 1191: mov j2,b 1192: nmstore 1193: ret 1194: erm10e: error </non-numeric arg to arithmetic subr/> 1195: erm18e: error </arithmetic overflow/> 1196: 1197: subrend 1198: 1199: 1200: atom times,,,,xtimes 1201: 1202: subrbeg xtimes,lambda,0 1203: nop 1204: nop 1205: .if eq,fpsim 1206: ldd #^f1.0,ac0 1207: mov np,j3 1208: 1$: cmp j3,ltop 1209: blos 2$ 1210: mov @j3,a 1211: cmp -(j3),-(j3) 1212: cmptype a,j1,0 1213: bne erm10er 1214: numga1 1215: muld ac1,ac0 1216: cfcc 1217: bvs erm18er 1218: br 1$ 1219: 2$: numstac0 1220: ret 1221: 1222: .iff 1223: mov #1,j2 1224: clr j1 1225: mov np,j3 1226: 1$: cmp j3,ltop 1227: blos 2$ 1228: mov @j3,a 1229: cmp -(j3),-(j3) 1230: cmptype a,b,0 1231: bne erm10er 1232: numga 1233: call imul 1234: bvs erm18er 1235: mov b,j2 1236: mov a,j1 1237: br 1$ 1238: 2$: 1239: mov j2,b 1240: mov j1,a 1241: nmstore 1242: ret 1243: .endc 1244: subrend 1245: .globl $death 1246: 1247: 1248: atom exit,,,,xexitc 1249: atom sys,,,,xexitc 1250: 1251: subrbeg xexitc,nlambda,0 1252: nop 1253: nop 1254: $death: call dmppro ;clean up protocol 1255: clr %0 ;clean up for going home 1256: clr %1 1257: $exit ;and he'll never return 1258: subrend 1259: 1260: 1261: 1262: 1263: 1264: ;close all ports 1265: atom resetio,,,,xrstio 1266: 1267: subrbeg xrstio,nlambda,0 1268: nop 1269: nop 1270: xrestio: clr protocell 1271: mov #erport,b 1272: mov #nports-3,j2 1273: 2$: add #12,b 1274: movb (b),j1 1275: beq 1$ ;if 0, then isn't open 1276: asr j1 ;get port number 1277: bic #177700,j1 1278: $close 1279: clr (b) ;indicate as closed 1280: mov 4(b),j1 ;and return buffer 1281: swab j1 1282: movb #-3,qmap(j1) 1283: 1$: sob j2,2$ 1284: .if ne,nilas0 1285: clr a ;return nil 1286: .iff 1287: mov #anil,a 1288: .endc 1289: mov a,b 1290: ret 1291: subrend 1292: 1293: 1294: atom bt,,,,xbtc 1295: 1296: subrbeg xbtc,nlambda,1 1297: chanl 1298: loadnil @np 1299: mov sp,j1 1300: cmp (j1)+,(j1)+ ;want to get past this frame... 1301: 1$: call findframe 1302: br 10$ ;nothing left 1303: push j1 ;is even... 1304: call printr ;form in a 1305: mov #linefeed,b 1306: call putstr 1307: .if df,width 1308: clrb poport+1 1309: .endc 1310: pop j1 1311: br 1$ 1312: 10$: retnil 1313: subrend 1314: ; subrs for frame manipulation added by john burruss 1315: 1316: .if ne,jcbms 1317: 1318: ; bframe -- subr to search up control stack to find last entered 1319: ; frame, returning the calling form. starts at current frame 1320: ; if arg is not nil, else starts from val(frmptr) -- 1321: ; a ptr to the last frame found (5/3/75) 1322: 1323: atom bframe,,,,frmfnd 1324: 1325: subrbeg frmfnd,lambda,1 1326: chanl 1327: jmpifnil (np),1$ ;if nil use old fp 1328: mov sp,frmptr 1329: 1$: mov frmptr,j1 1330: cmp j1,sp 1331: blo 10$ ;if lower than sp, problems... 1332: call findframe ;get frame 1333: br 10$ ;none left 1334: mov j1,frmptr ;save for next time 1335: ret 1336: 10$: retnil 1337: subrend 1338: 1339: .endc 1340: 1341: 1342: 1343: atom protocol,atmpro,,,proto 1344: 1345: subrbeg proto,lambda,1 1346: chanl 1347: tst protocell 1348: bne 2$ 1349: mov #protostr,a 1350: .if ne,multiseg 1351: mov @np,proto+2 ;save name for future..... 1352: .iff 1353: mov @np,atmpro 1354: .endc 1355: jmpifnil @np,1$,t 1356: call fixnm1 1357: 1$: call openw 1358: mov a,protocell 1359: 2$: retnil 1360: 1361: subrend 1362: 1363: atom unprotocol1,,,,unproto 1364: 1365: subrbeg unproto,nlambda,1 1366: chas 1367: dmppro: mov protocell,@np 1368: beq 1$ 1369: call dmpport 1370: call close 1371: clr protocell 1372: .if ne,multiseg 1373: mov proto+2,a 1374: loadnil proto+2 1375: .iff 1376: mov atmpro,a 1377: loadnil atmpro 1378: .endc 1379: ret 1380: 1$: retnil 1381: subrend 1382: 1383: 1384: 1385: 1386: 1387: 1388: 1389: 1390: ;this routine saves lisp in a re-runable format(i hope) 1391: 1392: atom saveme,,,,saveme 1393: 1394: subrbeg saveme,lambda,1 1395: 1396: 1397: .if ne,multiseg ;this forces the saveme into initcd 1398: .globl lispbin 1399: 1400: .psect initcde,con,shr 1401: tmp =* . ;save place 1402: 1403: .psect dsubr 1404: 1405: .=.-2 ;back up one 1406: 1407: .word tmp ;and dump new locatiom 1408: .psect initcd 1409: 1410: .iftf ;the following are true in any case 1411: nop 1412: nop 1413: .ift 1414: mov #lsploo,saveme+4 ;save address gets clobbered 1415: 1416: .iftf 1417: incb noint 1418: call xrestio 1419: mov $$break+2,a ;high data limit 1420: .ift 1421: $open 1422: .word lispbin,0 ;for reading 1423: bcs 1$ ;go error 1424: mov %0,j2 1425: $create 1426: .word savenm ;name 1427: .word 755 ;rx,rwx 1428: bcs 1$ 1429: mov %0,j3 1430: 1431: ;so j2 has read cookie 1432: ; j3 has write cookie 1433: ;a has high address of lisp 1434: 1435: mov j2,%0 1436: $read 1437: strbuf 1438: 20 1439: ;no v7 mods for this following code, cause harv411 doesn't exist 1440: .if eq,bell411 ;i.e. write harv 411 file 1441: mov #strbuf+4,j1 ;get pointer to pd 1442: add #20,(j1) 1443: mov (j1),$$seek+2 ;get pointer to isection 1444: mov a,(j1)+ ;fix 1445: clr (j1)+ 1446: mov #<^ph shrcode>,(j1)+ ;install new high si limit 1447: clr (j1)+ ;and clear pi 1448: clr (j1)+ ;no symbols 1449: mov j3,%0 1450: $write 1451: strbuf 1452: 20 1453: clr $$write+2 ;write from 0 1454: mov a,$$write+4 1455: mov j3,%0 1456: $indir 1457: $$write 1458: ;ok, now write i-mem..... 1459: clr $$seek+4 ;absolute seek... 1460: mov j2,%0 1461: $indir 1462: $$seek 1463: mov #<^ph shrcode>,a ;amount to write 1464: .iff ;ie this is bell 411 1465: mov #strbuf+2,j1 ;ptr to tsize 1466: mov #<^ph shrcode>,(j1)+ ;write out new tsize 1467: mov a,(j1)+ ;and new data size 1468: clr (j1)+ ;and write bss size 1469: clr (j1) ;clear symbols 1470: mov j3,%0 ;set up write 1471: $write 1472: strbuf 1473: 20 1474: mov a,-(sp) ;save a 1475: mov #<^ph shrcode>,a ;amount to copy 1476: 1477: 1478: .iftf 1479: ;now we just loop till done...... 1480: 21$: mov #strbuf,$$write+2 1481: 22$: tst a 1482: beq 23$ ;if zero, we're done 1483: mov j2,%0 1484: $read 1485: strbuf 1486: strlen ;read stuff... 1487: cmp a,%0 1488: bhi 24$ ;is larger??? 1489: mov a,%0 ;only write a bytes 1490: 24$: mov %0,$$write+4 ;write out amount 1491: sub %0,a ;and fix up count 1492: mov j3,%0 ;set up write cookie... 1493: $indir 1494: $$write 1495: br 22$ 1496: 23$: 1497: .iff ;back to bell type 411 1498: 1499: mov (sp)+,$$write+4 ;amount of d to write 1500: clr $$write+2 ;and location 1501: mov j3,%0 ;get cookie 1502: $indir 1503: $$write 1504: .iftf ;time to close 1505: mov j2,%0 1506: $close 1507: mov j3,%0 1508: $close 1509: jmp lsploo 1510: 1511: 1$: jmp xresetio ;close all ports... 1512: 1513: .endc ;of harv vs bell 1514: 1515: .iff 1516: ;ie if we have a non-i&d...... 1517: 1518: 1519: ;all we do is output header, output sd, and then non-sd. 1520: ;we loose symbols..... 1521: 1522: sub #<<^pl uswdda>&<^c17777>>,a ;and is for case of onepage=1 1523: $create 1524: .word savenm,705 ;open output 1525: bcs 1$ 1526: mov %0,j3 1527: ;now we gotta build file header...... 1528: mov #strbuf,j2 1529: mov #410,(j2)+ 1530: mov #<^ph dsubr>,(j2)+ 1531: mov a,(j2)+ 1532: clr (j2)+ 1533: clr (j2)+ 1534: clr (j2)+ 1535: clr (j2)+ 1536: mov #1,(j2)+ 1537: $write 1538: strbuf 1539: 20 ;write header 1540: mov j3,%0 1541: $write 1542: 0 1543: <^ph dsubr> ;wrote share stuff 1544: 1545: mov a,$$write+4 1546: mov #<<^pl uswdda>&<^c 17777>>,$$write+2 1547: mov j3,%0 1548: $indir 1549: $$write 1550: ;done. now close 1551: mov j3,%0 1552: $close 1553: jmp lsploo 1554: 1$: retnil 1555: .endc 1556: subrend 1557: ;retbrk-- return to n'th break level; 1558: ; if arg is positive, return to that level; 1559: ; if arg is -, then return to curlevel+arg 1560: ; 1561: ; retbk1 is alternate entry to return to previous level, or tl. 1562: ; 1563: 1564: 1565: atom retbrk,,,,retbrk 1566: 1567: subrbeg retbrk,lambda,1 1568: chas 1569: mov @np,a 1570: cmptype a,j1,0 1571: bne 10$ 1572: numga ;ignore except low order bits 1573: tst b 1574: bge 1$ ;if neg... 1575: 4$: add brkl+2,b 1576: 1$: cmp sp,cptop 1577: bhis 11$ ;we're done 1578: clr a ;use a for count of levels 1579: cmp (sp),#brksna 1580: beq 26$ 1581: cmp (sp),#r4rres 1582: beq 25$ 1583: cmp (sp),#r3rres 1584: beq 24$ 1585: cmp (sp),#r2rres 1586: beq 23$ 1587: cmp (sp),#r1rres 1588: beq 22$ 1589: tst (sp)+ 1590: br 1$ 1591: 26$: cmp brkl+2,b ;are we done 1592: bgt 27$ 1593: mov #4,b 1594: add 2(sp),b 1595: mov b,np 1596: mov 4(sp),ltop 1597: jmp errloop 1598: 27$: dec brkl+2 1599: cmp (a)+,(a)+ 1600: 25$: tst (a)+ 1601: 24$: tst (a)+ 1602: 23$: tst (a)+ 1603: 22$: cmp (a)+,(a)+ 1604: add a,sp 1605: br 1$ 1606: 10$: retnil 1607: 11$: jmp lsploop 1608: retbk1= . 1609: clr b 1610: br 4$ 1611: subrend 1612: 1613: 1614: 1615: atom append,,,,apend 1616: 1617: subrbeg apend,lambda,2 1618: 1619: chas 1620: mov -4(np),a 1621: 2$: cmptype a,j1,#ndtpr 1622: bne 1$ 1623: ;inner loop 1624: mov (a)+,-(sp) 1625: mov (a),a 1626: call 2$ 1627: mov a,b 1628: pop a 1629: consa 1630: ret 1631: 1$: mov @np,a 1632: ret 1633: subrend 1634: 1635: 1636: atom member,,,,member 1637: 1638: subrbeg member,lambda,2 1639: chas 1640: mov (np),a 1641: mov -4(np),j3 ;comparee 1642: 3$: cmptype a,j1,#ndtpr 1643: bne 1$ 1644: cmp (a)+,j3 1645: beq 2$ 1646: mov (a),a 1647: br 3$ 1648: 1$: retnil 1649: 2$: rettrue 1650: subrend 1651: 1652: 1653: atom conc,,,,nconc 1654: atom nconc,,,,nconc 1655: 1656: subrbeg nconc,lambda,2 1657: chas 1658: mov -4(np),a 1659: mov a,b 1660: mov b,j1 1661: cmptype j1,j2,#ndtpr 1662: bne 1$ 1663: 11$: cmptype j1,j2,#ndtpr 1664: bne 2$ 1665: mov j1,b 1666: cdr j1,j1 1667: br 11$ 1668: 2$: mov (np),2(b) 1669: ret 1670: 1$: mov (np),a 1671: ret 1672: subrend 1673: 1674: 1675: atom list,,,,list 1676: 1677: subrbeg list,lambda,0 1678: nop 1679: nop 1680: loadnil a 1681: mov np,j3 1682: 1$: cmp j3,ltop 1683: blos 2$ 1684: mov a,b 1685: mov @j3,a 1686: cmp -(j3),-(j3) 1687: consa 1688: br 1$ 1689: 2$: ret 1690: subrend 1691: 1692: 1693: 1694: atom length,,,,length 1695: 1696: subrbeg length,lambda,1 1697: chanl 1698: clr b 1699: mov @np,a 1700: 1$: cmptype a,j1,#ndtpr 1701: bne 2$ 1702: inc b 1703: cdr a,a 1704: br 1$ 1705: 2$: clr a 1706: nmstore 1707: ret 1708: subrend 1709: 1710: 1711: 1712: atom <apply*>,,,,applstar 1713: 1714: subrbeg applstar,nlambda,1 1715: chanl 1716: mov @np,a 1717: car a,a 1718: call eval 1719: mov @np,b 1720: cdr b,b 1721: consa 1722: jmp eval 1723: subrend 1724: 1725: 1726: atom last,,,,last 1727: 1728: subrbeg last,lambda,1 1729: chanl 1730: mov @np,a 1731: mov a,b 1732: 1$: cmptype a,j1,#ndtpr 1733: bne 2$ 1734: mov a,b 1735: cdr b,a 1736: br 1$ 1737: 2$: mov b,a 1738: ret 1739: subrend 1740: 1741: 1742: 1743: atom mapc,,,,mapc 1744: 1745: subrbeg mapc,lambda,2 1746: chas 1747: loadnil a 1748: 1$: mov @np,j1 1749: cmptype j1,j2,#ndtpr 1750: bne 2$ 1751: mov (j1)+,a 1752: mov (j1),@np 1753: consbnil 1754: mov #aquote,a 1755: consa 1756: consbnil 1757: mov -4(np),a 1758: consa 1759: call eval 1760: br 1$ 1761: 2$: ret 1762: subrend 1763: 1764: 1765: atom mapcar,,,,mapcar 1766: 1767: subrbeg mapcar,lambda,2 1768: chas 1769: call 1$ 1770: ret 1771: 1$: mov @np,j1 1772: loadnil a 1773: cmptype j1,j2,#ndtpr 1774: bne 2$ 1775: mov (j1)+,a 1776: mov (j1),(np) 1777: consbnil 1778: mov #aquote,a 1779: consa 1780: consbnil 1781: mov -4(np),a 1782: consa 1783: call eval 1784: propush a 1785: call 1$ 1786: mov a,b 1787: unpropop a 1788: consa 1789: 2$: ret 1790: 1791: subrend 1792: 1793: 1794: atom function,,,,xfunc 1795: 1796: subrbeg xfunc,nlambda,1 1797: chanl 1798: mov @np,a 1799: car a,a ;get car of arg list 1800: cmptype a,j1,#natom 1801: bne 1$ 1802: mov 4(a),a ;return function d 1803: 1$: ret 1804: subrend 1805: 1806: atom copy,,,,copyc 1807: 1808: subrbeg copyc,lambda,1 1809: chanl 1810: mov @np,a 1811: 1$: cmptype a,j1,#ndtpr 1812: bne 2$ 1813: mov (a)+,-(sp) ;no pro needed 1814: mov (a),a 1815: call 1$ 1816: mov (sp)+,b 1817: propush a 1818: mov b,a 1819: call 1$ 1820: unpropop b 1821: consa 1822: 2$: ret 1823: subrend
|
Last modified: 1981-05-10
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 316 |
|