1:         .title  expr - expression evaluator
   2: 
   3:         .ident  /16jan4/
   4: 
   5:         .mcall  (at)always,st.flg,ch.mne,xmit,genedt
   6:         .mcall  (at)sdebug
   7:         .mcall  (at)jne,jeq
   8:         always
   9:         st.flg
  10:         ch.mne
  11:         .mcall  (at)setnz,error,search
  12: 
  13:         .globl  abserr, absexp, abstrm, abstst, expr
  14:         .globl  exprg,  relexp, reltst
  15: 
  16: 
  17:         .if df  rsx11d
  18:         .globl  ed.gbl, edmask, cpopj
  19:         .endc
  20: 
  21:         .globl  chrpnt, clcnam, clcsec, cradix, mode
  22:         .globl  cvtnum, dmprld, expflg, flags,  lsrch
  23:         .globl  getchr, getnb,  getsym, insert
  24:         .globl  pass,   rellvl, rolndx, r50dot, savreg
  25:         .globl  setnb,  setrld, setsec, setsym, setxpr
  26:         .globl  symbeg, symbol, symrol, pstrol, value
  27:         .globl  secrol, objsec
  28: 
  29:         .globl  crfref
  30:         .if ndf oldcod
  31: cc.opr= 040
  32: cc.nam= 020
  33: cc.sec= 010
  34: cc.val= 004
  35: cc.dsp= 002
  36:         .endc
  37: 
  38: 
  39:         .macro  chscan  table   ;character scan
  40:         mov     #table,r0
  41:         call    chscan
  42:         .endm
  43: 
  44:         .macro  gchtbl  char,   addr    ;gen char scan table
  45:         .word   addr,   char
  46:         .endm
  47:         xitsec                  ;start in default sector
  48: 
  49: exprg:                          ;external expression
  50:         .if ndf oldcod
  51:         decb    oprflg+1        ;flag "ok for external expression"
  52:         call    expr            ;process
  53:         incb    oprflg+1        ;restore
  54:         tst     r0              ;reset r0 flags
  55:         return
  56:         .endc
  57: 
  58: expr:                           ;expression evaluation
  59:         call    savreg          ;save registers
  60:         call    term            ;try for a term
  61:         beq     5$              ;exit if null
  62:         clr     -(sp)           ;non-null, set register flag storage
  63: 1$:     call    setxpr          ;set expression registers
  64:         bis     (r3),(sp)       ;save register flag
  65:         chscan  boptbl          ;scan the binary operator table
  66:         beq     2$              ;  branch if not found
  67:         call    10$             ;found, call handler
  68:         br      1$              ;test for more
  69: 
  70: 2$:     bic     #-1-regflg,(sp) ;mask all but register flag
  71:         beq     6$              ;branch if not register
  72:         bit     #177770,(r4)    ;in bounds?
  73:         beq     6$
  74:         error   70,r,<pdp-11 only has 8 registers>
  75:         br      77$
  76: 6$:     asr     rellvl          ;test relocaton level
  77:         bne     3$              ;branch if not 0 or 1
  78:         bcc     4$              ;branch if 0
  79:         tst     (sp)            ;relocatable, test register flag
  80:         beq     4$              ;branch if not set
  81: 7$:     error   1,r,<cannot relocate a register>
  82: 77$:    clr     (sp)            ;clear register bit
  83:         br      4$
  84: 
  85: 3$:     error   2,a,<improper relocation>
  86: 4$:     bis     (sp)+,(r3)      ;merge register bit
  87:         setnz   r0              ;set true
  88: 5$:     return
  89: 10$:
  90:         mov     r0,-(sp)        ;stack operator address
  91:         mov     r1,r3           ;leave pointer to "symbol" in r3
  92:         mov     (r1)+,-(sp)     ;stack symbol
  93:         mov     (r1)+,-(sp)
  94:         mov     (r1)+,-(sp)     ;  mode,
  95:         mov     (r1)+,-(sp)     ;  value,
  96:         mov     (r1)+,-(sp)     ;  and rel level
  97:         call    glbtrm          ;evaluate next tern
  98:         mov     #expbak+^d10,r1 ;set to unstack previous
  99:         mov     (sp)+,-(r1)     ;rel level
 100:         mov     (sp)+,-(r1)     ;value
 101:         mov     r1,r2           ;r2 points to previous value
 102:         mov     (sp)+,-(r1)     ;mode
 103:         mov     (sp)+,-(r1)
 104:         mov     (sp)+,-(r1)     ;r1 points to previous symbol
 105:         .if ndf oldcod
 106:         tst     oprflg
 107:         bpl     11$
 108:         tst     pass
 109:         beq     11$
 110:         bit     #glbflg!relflg,mode
 111:         bne     expxxx
 112:         bit     #glbflg!relflg,expbak+4
 113:         bne     expxxx
 114: 11$:
 115:         .endc
 116:         mov     @(sp)+,-(sp)
 117:         asr     (sp)            ;absolute only?
 118:         bcs     12$             ;  no
 119:         bis     -(r2),-(r4)     ;yes, merge flags
 120:         call    abstst          ;test for absolute
 121:         cmp     (r2)+,(r4)+     ;restore registers
 122: 12$:    asl     (sp)            ;even out address
 123:         jmp     @(sp)+          ;exit through handler
 124:         .if ndf oldcod
 125: expxxx: inc     oprflg
 126:         mov     #200,r0
 127:         mov     #expbak,r1
 128:         call    expyyy
 129:         mov     (sp)+,r0
 130:         sub     #boptbl,r0
 131:         asr     r0
 132:         asr     r0
 133:         add     #201,r0
 134:         mov     #symbol,r1
 135:         call    expyyy
 136:         mov     #symbol,r1
 137:         clr     (r1)+
 138:         movb    oprflg,(r1)+
 139:         clrb    (r1)+
 140:         mov     #glbflg,(r1)+
 141:         clr     (r1)+
 142:         return
 143: 
 144: expyyy: mov     r0,-(sp)
 145:         call    setrld
 146:         mov     r2,-(sp)
 147:         movb    #cc.opr,(r2)+
 148:         clr     -(sp)
 149:         bit     #glbflg!relflg,4(r1)
 150:         beq     2$
 151:         bit     #glbflg,4(r1)
 152:         bne     1$
 153:         mov     #cc.sec,(sp)
 154:         cmpb    5(r1),objsec
 155:         beq     2$
 156: 1$:     bis     #cc.nam,(sp)
 157:         .rept   4
 158:         movb    (r1)+,(r2)+
 159:         .endm
 160:         cmp     -(r1),-(r1)
 161: 2$:     add     #6,r1
 162:         tst     (r1)
 163:         beq     3$
 164:         bis     #cc.val,(sp)
 165:         movb    (r1)+,(r2)+
 166:         movb    (r1)+,(r2)+
 167: 3$:     bisb    (sp)+,@(sp)+
 168:         movb    (sp)+,(r2)+
 169:         movb    oprflg,(r2)+
 170:         jmp     dmprld
 171: 
 172:         entsec  implin
 173: oprflg: .blkw
 174:         xitsec
 175:         .endc
 176: 
 177:         entsec  impure
 178: expbak: .blkw   5               ;previous term storage
 179:         xitsec
 180:         entsec  dpure
 181: boptbl:                         ;binary op table
 182:         gchtbl  ch.add, bopadd+1        ; "+"
 183:         gchtbl  ch.sub, bopsub+1        ; "-"
 184:         gchtbl  ch.mul, bopmul  ; "*"
 185:         gchtbl  ch.div, bopdiv  ; "/"
 186:         gchtbl  ch.and, bopand  ; "&"
 187:         gchtbl  ch.ior, bopior  ; "!"
 188:         .word   0
 189:         xitsec
 190: 
 191: bopsub: call    reltst          ;make sure no globals
 192:         neg     (r4)            ; -, negate value
 193:         neg     rellvl          ;  and rellvl
 194: 
 195: bopadd: add     (r2)+,(r4)+     ; +, add values
 196:         add     (r2),(r4)       ;  and relocation levels
 197:         cmp     -(r2),-(r4)     ;point back to values
 198:         bit     #glbflg!relflg,-(r2)    ;abs * xxx?
 199:         beq     3$              ;  yes, all set
 200:         bit     #glbflg!relflg,-(r4)    ;xxx * abs?
 201:         beq     4$              ;  yes, old flags
 202:         bitb    #glbflg,(r2)+   ;error if either global
 203:         bne     5$
 204:         bitb    #glbflg,(r4)+
 205:         bne     5$
 206:         cmpb    (r4),(r2)       ;rel +- rel, same sector?
 207:         bne     5$              ;  no, error
 208:         bisb    #relflg,-(r4)
 209:         tst     rellvl
 210:         bne     3$
 211:         bic     #177400!relflg,(r4)
 212: 3$:     return
 213: 
 214: 4$:     mov     (r1)+,(r3)+
 215:         mov     (r1)+,(r3)+
 216:         bis     (r1)+,(r3)+
 217:         return
 218: 
 219: 5$:     jmp     abserr
 220: 
 221: 
 222: bopand: com     (r2)
 223:         bic     (r2),(r4)
 224:         return
 225: 
 226: bopior: bis     (r2),(r4)
 227:         return
 228: bopmul:                         ; *
 229:         mov     (r2),r0         ;fetch first arg
 230:         mov     r0,-(sp)        ;save a copy
 231:         bpl     1$              ;positive?
 232:         neg     r0              ;  no, make it so
 233: 1$:     mov     (r4),r3         ;set second arg
 234:         bpl     2$              ;branch if positive
 235:         neg     r3              ;negative, make it +
 236:         com     (sp)            ;toggle result sign
 237: 2$:     mul     r3,r0           ;multiply
 238:         mov     r1,r0           ;set for exit
 239:         br      bopdvx          ;exit through divide
 240: 
 241: bopdiv:                         ; /
 242:         mov     (r4),r3         ;set divisor
 243:         mov     r3,-(sp)        ;save a copy
 244:         bpl     1$              ;branch if plus
 245:         neg     r3              ;make it thus
 246: 1$:     mov     (r2),r1         ;set quotient
 247:         bpl     2$              ;again!!!
 248:         neg     r1
 249:         com     (sp)
 250: 2$:     clr     r0              ;operate
 251:         div     r3,r0
 252: 
 253: bopdvx: tst     (sp)+           ;test result
 254:         bpl     1$              ;  ok as is
 255:         neg     r0              ;no, negate it
 256: 1$:     mov     r0,(r4)         ;set result
 257:         return
 258: 
 259:                                 ;special entry point to expr
 260:                                 ;null field causes error
 261:                                 ;r0 set to value
 262: 
 263: glbtrm: call    term
 264:         beq     abserr
 265:         br      abserx
 266: 
 267: glbexp:                         ;non-null expression
 268:         call    expr
 269:         beq     abserr
 270:         br      abserx
 271: 
 272: reltrm: call    glbtrm
 273:         br      reltst
 274: 
 275: relexp:
 276:         call    glbexp
 277: reltst: bit     #glbflg,flags
 278:         beq     abserx
 279:         br      abserr
 280: 
 281: abstrm: call    glbtrm
 282:         br      abstst
 283: 
 284: absexp:
 285:         call    glbexp
 286: abstst: bit     #glbflg!relflg,flags
 287:         beq     abserx
 288: abserr: clr     mode
 289:         clr     rellvl
 290: abserf: error   3,a,<bad expression>
 291: abserx: mov     value,r0        ;return with value in r0
 292:         return
 293:         .sbttl  term evaluator
 294: 
 295: term:                           ;term evaluator
 296:         call    savreg          ;save registers
 297:         call    setxpr          ;  and set "expression" type
 298:         clr     (r3)            ;clear mode
 299:         clr     (r4)            ;  and value
 300:         call    term10          ;process
 301:         bic     #defflg!lblflg!mdfflg,(r3)      ;clear extraneous
 302:         clr     rellvl          ;assume absolute
 303:         bit     #relflg,(r3)    ;true?
 304:         beq     1$
 305:         inc     rellvl          ;  no, relocatable
 306: 1$:     inc     expflg          ;mark as expression
 307:         jmp     setnb           ;exit with non-blank and r0 set
 308: 
 309: term10: call    getsym          ;try for a symbol
 310:         jeq     term20          ;branch if not a symbol
 311:         .if ndf xcref
 312:         mov     #symrol,rolndx
 313:         call    crfref
 314:         .endc
 315:         cmp     symbol,r50dot   ;location counter?
 316:         beq     14$             ;  yes, treat special
 317:         search  symrol          ;search the symbol table
 318:         beq     16$             ;branch if not found
 319:         bit     #mdfflg,(r3)    ;multiply defined?
 320:         beq     11$             ;  no
 321:         error   5,m,<multiply defined>
 322: 11$:    bit     #defflg,(r3)    ;defined?
 323:         beq     13$             ;  no
 324:         call    setsec          ;refer by sector name
 325:         br      12$
 326: 
 327: 13$:    bit     #glbflg,(r3)    ;no, global?
 328:         jne     term28          ;  yes
 329:         error   4,u,<undefined symbol>
 330:         sdebug  <undef 1>
 331: 12$:    bic     #glbflg,(r3)    ;clear internal global flag
 332:         jmp     term28
 333: 
 334: 14$:    mov     #clcnam,r1      ;dot, move to working area
 335:         mov     #symbol,r2
 336:         xmit    4
 337:         bicb    #^c<relflg>,(r3)        ;clear all but rel flag
 338:         jmp     term28
 339: 
 340: 16$:    search  pstrol          ;not user defined, perhaps an op-code?
 341:         tst     (r3)            ;op code?
 342:         bmi     17$             ;yes
 343:         search  symrol          ;set search pointers
 344:         .if df  rsx11d
 345:         bis     #dfgflg!glbflg,(r3)
 346:         bit     #ed.gbl,edmask
 347:         beq     20$
 348:         bic     #dfgflg!glbflg,(r3)
 349:         .endc
 350:         error   4,u,<undefined symbol>
 351:         sdebug  <undef 2>
 352: 20$:    call    insert          ;not in table, insert as undefined
 353: 17$:    clr     (r3)            ;be sure mode is zero
 354:         jmp     term28
 355: 
 356:         .iif df rsx11d, genedt  gbl
 357: 
 358: term20:
 359:         mov     cradix,r2       ;assume number, current radix
 360: 21$:    mov     chrpnt,symbeg   ;in case of re-scan
 361:         call    cvtnum          ;convert
 362:         beq     term30          ;  nope, missed again
 363:         bpl     22$             ;number, any overflow?
 364:         error   7,t,<number too big>
 365: 22$:    cmp     r5,#ch.dot      ;number, decimal?
 366:         beq     24$             ;  yes
 367:         .if ndf xedlsb
 368:         cmp     r5,#ch.dol      ;no, local symbol?
 369:         beq     24$             ;  yes
 370:         .endc
 371:         tstb    r0              ;no, any numbers out of range?
 372:         jeq     term28          ;  no
 373:         error   6,n,<digit illegal in current radix>
 374:         br      23$
 375: 
 376: 24$:    cmp     r2,#10.         ;"." or "$", were we decimal?
 377:         beq     25$             ;  yes
 378: 23$:    call    setsym          ;no,
 379:         mov     #10.,r2         ;  try again with decimal radix
 380:         br      21$
 381: 
 382: 25$:    cmp     r5,#ch.dot      ;decimal?
 383:         beq     term27          ;  yes
 384:         .if ndf xedlsb
 385:         call    lsrch           ;no, local symbol
 386:         bne     term27          ;branch if found
 387:         .endc
 388: term26: error   8,u,<local symbol not defined>  ;  no, flag as undefined
 389: term27: call    getchr          ;bypass dot or dollar
 390: term28: call    setnb           ;return pointing to non-blank
 391:         setnz   r0              ;flag as found
 392: term29: return
 393: term30:
 394:         chscan  uoptbl          ;scan unary operator table
 395:         beq     term29          ;  not there
 396:         clr     r2              ;clear for future use
 397:         call    @(r0)+          ;found, go and process
 398:         jmp     term28          ;exit true
 399: 
 400: 
 401:         entsec  dpure
 402: uoptbl:
 403:         gchtbl  ch.add, glbtrm  ; "+"
 404:         gchtbl  ch.sub, term42  ; "-"
 405:         gchtbl  ch.qtm, term44  ; """
 406:         gchtbl  ch.xcl, term45  ; "'"
 407:         gchtbl  ch.pct, term46  ; "%"
 408:         gchtbl  ch.lab, term47  ; "<"
 409:         gchtbl  ch.uar, term50  ; "^"
 410:         .word   0
 411:         xitsec
 412: 
 413: term42: call    abstrm          ;evaluate absolute
 414:         neg     (r4)            ;negate value
 415:         return
 416: 
 417: term44: inc     r2              ; """, mark it
 418: term45: mov     r4,r1           ; "'", set temp store register
 419:         call    setsym          ;point back to operator
 420: 1$:     call    getchr          ;get the next character
 421:         beq     term48          ;error if eol
 422:         .if ndf xedlc
 423:         movb    @chrpnt,(r1)    ;store absolute char
 424:         bicb    #200,(r1)+      ;clear possible sign bit and index
 425:         .iff
 426:         movb    r5,(r1)+
 427:         .endc
 428:         dec     r2              ;another character
 429:         beq     1$              ;  yes
 430:         br      term27          ;bypass last char
 431: 
 432: term46: call    abstrm          ;register expression
 433:         bis     #regflg,(r3)    ;flag it
 434:         return
 435: 
 436: term47:                         ; "<"
 437:         call    glbexp          ;process non-null expression
 438:         cmp     r5,#ch.rab      ;">"?
 439:         beq     term27          ;  yes, bypass and exit
 440: term48: jmp     abserf          ;error, flag it
 441: term50:                         ; "^"
 442:         chscan  uartbl          ;scan on next character
 443:         beq     term48          ;  invalid, error
 444:         jmp     @(r0)+          ;call routine
 445: 
 446:         entsec  dpure
 447: uartbl:                         ;up arrow table
 448:         gchtbl  let.c,  term51  ;  ^c
 449:         gchtbl  let.d,  term52  ;  ^d
 450:         gchtbl  let.o,  term53  ;  ^o
 451:         gchtbl  let.b   term54  ;  ^b
 452:         gchtbl  let.r,  trmr50  ;  ^r
 453:         .if ndf xfltg
 454:         gchtbl  let.f,  term55  ;  ^f
 455:         .endc
 456:         .if ndf oldcod
 457:         gchtbl  let.p,  term56  ;  ^p
 458:         .endc
 459:         .word   0
 460:         xitsec
 461: 
 462: term51: call    abstrm          ;process absolute
 463:         com     (r4)            ;complement value
 464:         return
 465: 
 466: term52: add     #2.,r2
 467: term53: add     #6.,r2
 468: term54: add     #2.,r2
 469:         mov     cradix,-(sp)    ;stack current radix
 470:         mov     r2,cradix       ;replace with local
 471:         call    glbtrm          ;evaluate term
 472:         mov     (sp)+,cradix    ;restore radix
 473:         return
 474: 
 475:         .globl  setr50,mulr50
 476: r50gch: call    getchr          ;get next character
 477:         cmp     r2,#3           ;filled word?
 478:         beq     r50xit          ;  yes
 479: trmr50: call    setr50          ;test radix 50
 480:         call    r50prc          ;process the character
 481:         bcc     r50gch          ;if cc no terminator seen
 482: 
 483: 1$:     cmp     r2,#3           ;filled word?
 484:         beq     r50xit          ;  yes
 485:         clr     r0              ;  no - pad with blanks
 486:         call    r50prc
 487:         br      1$
 488: 
 489: r50xit: return                  ;done with argument
 490: 
 491: r50prc: cmp     r0,#50          ;rad50?
 492:         bhis    1$              ;  no
 493:         mov     r0,-(sp)        ;save current char
 494:         mov     (r4),r0         ;get partial
 495:         call    mulr50          ;multiply
 496:         add     (sp)+,r0        ;add in current
 497:         mov     r0,(r4)         ;save
 498:         inc     r2              ;bump count
 499:         clc                     ;no terminator seen
 500:         return
 501: 
 502: 1$:     sec                     ;terminator seen
 503:         return
 504: 
 505:         .if ndf xfltg
 506:         .globl  fltg1w
 507: term55: call    fltg1w          ;process one word floating
 508:         beq     term48          ;error if null
 509:         return
 510:         .endc
 511:         .if ndf oldcod
 512: term56:                         ;  ^p
 513:         call    mk.upp          ;make upper case
 514:         cmp     r5,#'l&^c40     ;low limit?
 515:         beq     1$              ;  yes
 516:         cmp     r5,#'h&^c40     ;  high?
 517:         bne     term48          ;  no, error
 518:         inc     r2              ;yes, reflect high
 519: 1$:     add     #3,r2           ;make 3 or 4
 520:         mov     r2,-(sp)        ;save operator
 521:         call    setrld          ;set up rld
 522:         movb    #cc.opr,(r2)+   ;flag operator
 523:         movb    (sp)+,(r2)+     ;unary type
 524:         call    getnb           ;bypass char
 525:         call    getsym          ;get the argument
 526:         mov     #secrol,rolndx
 527:         call    crfref          ;cref into proper roll
 528:         mov     #symbol,r1
 529:         .rept   4               ;move into code buffer
 530:         movb    (r1)+,(r2)+
 531:         .endm
 532:         inc     oprflg          ;get unique number
 533:         movb    oprflg,(r2)+    ;stuff it
 534:         call    dmprld          ;dump it
 535:         mov     #symbol,r1
 536:         clr     (r1)+           ;symbol is zero
 537:         movb    oprflg,(r1)+    ;  followed by unique numbwr
 538:         clrb    (r1)+
 539:         mov     #glbflg,(r1)+
 540:         clr     (r1)+
 541:         return
 542: 
 543:         .endc
 544: chscan:                         ;character scan routine
 545:         call    mk.upp          ;make char. upper-case
 546: 1$:     tst     (r0)+           ;end (zero)?
 547:         beq     2$              ;  yes
 548:         cmp     (r0)+,r5        ;this the one?
 549:         bne     1$              ;  no
 550:         tst     -(r0)           ;yes, move pointer back
 551:         mov     chrpnt,symbeg   ;save current pointer
 552:         call    getnb           ;get next non-blank
 553:         tst     -(r0)           ;move addr or zero into r0
 554:         return
 555: 
 556: 2$:     clr     r0
 557:         return
 558: 
 559: 
 560: mk.upp: cmp     r5,#141         ; between a - z ?
 561:         blt     1$              ;no
 562:         cmp     r5,#172
 563:         bgt     1$              ;no
 564:         sub     #40,r5          ;yes, make it upper-case
 565: 1$:     return
 566: 
 567:         .end
Last modified: 1982-12-11
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 1729
Valid CSS Valid XHTML 1.0 Strict