1: ; Copyright (c) 1981 Harvard-Radcliffe Student Timesharing System 2: ; Science Center, Harvard University 3: 4: .rept 0 5: 6: this file contains the evaluator for xfer lisp. 7: it is identical to the eval-apply routines of 8: pdp-10 lisp. 9: 10: note that it is necessary to conform to 10-lisp (vs make 10 conform to 11: 11 lisp) because of the syntatic extentions that have been added to the 12: 11 evaluator. 13: 14: i.e. 15: 16: ((cond (nil 'car)(t 'cdr)) '(a)] is legal in 17: 18: 10 lisp, but must be illegal in xfer lisp. 19: 20: 21: 22: 9/28/75--- forrest w. howard, jr. 23: 24: 25: .endr 26: 27: .sharable 28: 29: .sbttl the evaluator.... 30: 31: eval: 32: 33: .if df,noeval 34: tstb tracflg ;see if we're to output records 35: ;of eval activations... 36: beq 1$ 37: propush a 38: npush #anil 39: call printr 40: outstr linefeed 41: call dmpport 42: .if df,width 43: clrb poport+1 ;reset width 44: .endc 45: cmp -(np),-(np) 46: unpropop a 47: .endc 48: 49: dispatch ;see what type of stuff we have 50: ret ;an int--return 51: .word 0 ;allow for 2 word instructions 52: br evdtpr ;a dtpr..take care of it 53: .word 0 54: br evatom ;a atom 55: .word 0 56: ret ;binary code 57: .word 0 58: ret ;ports 59: 60: 61: 62: evatom: jmpifnil a,1$ ;if nil or true, leave alone 63: jmpiftrue a,1$ 64: call lookup ;lookup returns ptr to storage cell in a 65: mov 2(a),a ;get current binding 66: 1$: ret 67: 68: 69: .sharable 70: 71: evdtpr: push a ;create function block 72: push np 73: loadnil -(sp) ;nil for function for now 74: .if ne,xfer 75: .globl eexit1 76: mov #eexit1,-(sp) ;move on not entered snag 77: .iff 78: mov #eexit,-(sp) ;and snag 79: .endc 80: 81: ; we now have 82: 83: ; (sp)--> eexit 84: ; nil 85: ; np/ltop 86: ; form 87: ; real return 88: 89: 90: car a,a ;get function def 91: econt: cmptype a,j3,#natom ;is atom??? 92: bne 1$ ;if not,skip to remainder 93: mov 4(a),j3 ;this gets binding of atom 94: jmpnnil j3,11$,nl ;if not nil, assume is function 95: call lookup ;get binding of atom 96: mov 2(a),j3 ;this moves actual form 97: 11$: mov j3,a ;in any case, move binding to a 98: 1$: mov a,2(sp) ;save in function block 99: ldtype a,j3 100: cmp j3,#ndtpr ;is it a dtpr 101: beq 2$ 102: cmp j3,#nbcd 103: bne 3$ ;if not bcd or dtpr,error 104: tst (a) 105: bmi dofsbr ;if <0,fsubr 106: br dosubr ;else, is subr 107: 108: 2$: cmp @a,#alambda 109: beq dolam 110: cmp @a,#anlambda 111: beq donlam 112: 113: 3$: error </undefined procedure/>,econt 114: 115: 116: 117: .sharable 118: 119: dofsbr: mov 6(sp),b ;get form 120: npush 2(b) ;push the cdr 121: subcm: mov 4(sp),j3 ;exchange ltop and np 122: mov ltop,4(sp) 123: mov j3,ltop 124: .if ne,xfer 125: mov #eexit,(sp) 126: .endc 127: call intcheck 128: .if eq,multiseg 129: jmp 4(a) 130: .iff 131: jmp @4(a) 132: .endc 133: 134: dosubr: mov 6(sp),b 135: cdr b,b 136: call evalb 137: mov 2(sp),a 138: br subcm 139: 140: 141: 142: .sharable 143: 144: donlam: mov 6(sp),b 145: npush 2(b) 146: br apply 147: 148: dolam: mov 6(sp),b 149: cdr b,b 150: call evalb 151: mov 2(sp),a 152: br apply 153: 154: 155: 156: .sharable 157: 158: intcheck: 159: tstb intflg 160: beq p832$ 161: propush a 162: error </^c interrupt/>,31$ 163: 31$: unpropop a 164: p832$: ret 165: 166: 167: 168: .sharable 169: 170: ; apply 171: 172: ; fn block is on cstack 173: ; args are bound on nstk 174: ; a/ptr lambda or nlambda 175: ; putnames on name stack with already present values 176: ; then call eval on body of lambda or nlambda 177: 178: apply: 179: cdr a,b 180: mov @2(b),a 181: car b,b ;this sequence leaves function in a, arg list 182: ;in b 183: mov 4(sp),j3 ;exchange the ltop and saved np 184: mov ltop,4(sp) 185: mov j3,ltop 186: call stkb ;put on the names and adjust the stack 187: call intcheck ;any ^c's pending??? 188: .if ne,xfer 189: mov #eexit,(sp) ;set up "entered" snag 190: .endc 191: call eval ;and do a bit or recursion 192: ret ;and go home
|
Last modified: 1981-05-10
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 1425 |
|