2.9BSD - /usr/src/ucb/lisp/v7source/prob8.m11

   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