Ultrix-3.1/src/ucb/m11/expr.m11
;//////////////////////////////////////////////////////////////////////
;/ Copyright (c) Digital Equipment Corporation 1984, 1985, 1986. /
;/ All Rights Reserved. /
;/ Reference "/usr/src/COPYRIGHT" for applicable restrictions. /
;//////////////////////////////////////////////////////////////////////
.title expr - expression evaluator
.ident /16jan4/
.mcall (at)always,st.flg,ch.mne,xmit,genedt
.mcall (at)sdebug
.mcall (at)jne,jeq
always
st.flg
ch.mne
.mcall (at)setnz,error,search
.globl abserr, absexp, abstrm, abstst, expr
.globl exprg, relexp, reltst
.if df rsx11d
.globl ed.gbl, edmask, cpopj
.endc
.globl chrpnt, clcnam, clcsec, cradix, mode
.globl cvtnum, dmprld, expflg, flags, lsrch
.globl getchr, getnb, getsym, insert
.globl pass, rellvl, rolndx, r50dot, savreg
.globl setnb, setrld, setsec, setsym, setxpr
.globl symbeg, symbol, symrol, pstrol, value
.globl secrol, objsec
.globl crfref
.if ndf oldcod
cc.opr= 040
cc.nam= 020
cc.sec= 010
cc.val= 004
cc.dsp= 002
.endc
.macro chscan table ;character scan
mov #table,r0
call chscan
.endm
.macro gchtbl char, addr ;gen char scan table
.word addr, char
.endm
xitsec ;start in default sector
exprg: ;external expression
.if ndf oldcod
decb oprflg+1 ;flag "ok for external expression"
call expr ;process
incb oprflg+1 ;restore
tst r0 ;reset r0 flags
return
.endc
expr: ;expression evaluation
call savreg ;save registers
call term ;try for a term
beq 5$ ;exit if null
clr -(sp) ;non-null, set register flag storage
1$: call setxpr ;set expression registers
bis (r3),(sp) ;save register flag
chscan boptbl ;scan the binary operator table
beq 2$ ; branch if not found
call 10$ ;found, call handler
br 1$ ;test for more
2$: bic #-1-regflg,(sp) ;mask all but register flag
beq 6$ ;branch if not register
bit #177770,(r4) ;in bounds?
beq 6$
error 70,r,<pdp-11 only has 8 registers>
br 77$
6$: asr rellvl ;test relocaton level
bne 3$ ;branch if not 0 or 1
bcc 4$ ;branch if 0
tst (sp) ;relocatable, test register flag
beq 4$ ;branch if not set
7$: error 1,r,<cannot relocate a register>
77$: clr (sp) ;clear register bit
br 4$
3$: error 2,a,<improper relocation>
4$: bis (sp)+,(r3) ;merge register bit
setnz r0 ;set true
5$: return
10$:
mov r0,-(sp) ;stack operator address
mov r1,r3 ;leave pointer to "symbol" in r3
mov (r1)+,-(sp) ;stack symbol
mov (r1)+,-(sp)
mov (r1)+,-(sp) ; mode,
mov (r1)+,-(sp) ; value,
mov (r1)+,-(sp) ; and rel level
call glbtrm ;evaluate next tern
mov #expbak+^d10,r1 ;set to unstack previous
mov (sp)+,-(r1) ;rel level
mov (sp)+,-(r1) ;value
mov r1,r2 ;r2 points to previous value
mov (sp)+,-(r1) ;mode
mov (sp)+,-(r1)
mov (sp)+,-(r1) ;r1 points to previous symbol
.if ndf oldcod
tst oprflg
bpl 11$
tst pass
beq 11$
bit #glbflg!relflg,mode
bne expxxx
bit #glbflg!relflg,expbak+4
bne expxxx
11$:
.endc
mov @(sp)+,-(sp)
asr (sp) ;absolute only?
bcs 12$ ; no
bis -(r2),-(r4) ;yes, merge flags
call abstst ;test for absolute
cmp (r2)+,(r4)+ ;restore registers
12$: asl (sp) ;even out address
jmp @(sp)+ ;exit through handler
.if ndf oldcod
expxxx: inc oprflg
mov #200,r0
mov #expbak,r1
call expyyy
mov (sp)+,r0
sub #boptbl,r0
asr r0
asr r0
add #201,r0
mov #symbol,r1
call expyyy
mov #symbol,r1
clr (r1)+
movb oprflg,(r1)+
clrb (r1)+
mov #glbflg,(r1)+
clr (r1)+
return
expyyy: mov r0,-(sp)
call setrld
mov r2,-(sp)
movb #cc.opr,(r2)+
clr -(sp)
bit #glbflg!relflg,4(r1)
beq 2$
bit #glbflg,4(r1)
bne 1$
mov #cc.sec,(sp)
cmpb 5(r1),objsec
beq 2$
1$: bis #cc.nam,(sp)
.rept 4
movb (r1)+,(r2)+
.endm
cmp -(r1),-(r1)
2$: add #6,r1
tst (r1)
beq 3$
bis #cc.val,(sp)
movb (r1)+,(r2)+
movb (r1)+,(r2)+
3$: bisb (sp)+,@(sp)+
movb (sp)+,(r2)+
movb oprflg,(r2)+
jmp dmprld
entsec implin
oprflg: .blkw
xitsec
.endc
entsec impure
expbak: .blkw 5 ;previous term storage
xitsec
entsec dpure
boptbl: ;binary op table
gchtbl ch.add, bopadd+1 ; "+"
gchtbl ch.sub, bopsub+1 ; "-"
gchtbl ch.mul, bopmul ; "*"
gchtbl ch.div, bopdiv ; "/"
gchtbl ch.and, bopand ; "&"
gchtbl ch.ior, bopior ; "!"
.word 0
xitsec
bopsub: call reltst ;make sure no globals
neg (r4) ; -, negate value
neg rellvl ; and rellvl
bopadd: add (r2)+,(r4)+ ; +, add values
add (r2),(r4) ; and relocation levels
cmp -(r2),-(r4) ;point back to values
bit #glbflg!relflg,-(r2) ;abs * xxx?
beq 3$ ; yes, all set
bit #glbflg!relflg,-(r4) ;xxx * abs?
beq 4$ ; yes, old flags
bitb #glbflg,(r2)+ ;error if either global
bne 5$
bitb #glbflg,(r4)+
bne 5$
cmpb (r4),(r2) ;rel +- rel, same sector?
bne 5$ ; no, error
bisb #relflg,-(r4)
tst rellvl
bne 3$
bic #177400!relflg,(r4)
3$: return
4$: mov (r1)+,(r3)+
mov (r1)+,(r3)+
bis (r1)+,(r3)+
return
5$: jmp abserr
bopand: com (r2)
bic (r2),(r4)
return
bopior: bis (r2),(r4)
return
bopmul: ; *
mov (r2),r0 ;fetch first arg
mov r0,-(sp) ;save a copy
bpl 1$ ;positive?
neg r0 ; no, make it so
1$: mov (r4),r3 ;set second arg
bpl 2$ ;branch if positive
neg r3 ;negative, make it +
com (sp) ;toggle result sign
2$: mul r3,r0 ;multiply
mov r1,r0 ;set for exit
br bopdvx ;exit through divide
bopdiv: ; /
mov (r4),r3 ;set divisor
mov r3,-(sp) ;save a copy
bpl 1$ ;branch if plus
neg r3 ;make it thus
1$: mov (r2),r1 ;set quotient
bpl 2$ ;again!!!
neg r1
com (sp)
2$: clr r0 ;operate
div r3,r0
bopdvx: tst (sp)+ ;test result
bpl 1$ ; ok as is
neg r0 ;no, negate it
1$: mov r0,(r4) ;set result
return
;special entry point to expr
;null field causes error
;r0 set to value
glbtrm: call term
beq abserr
br abserx
glbexp: ;non-null expression
call expr
beq abserr
br abserx
reltrm: call glbtrm
br reltst
relexp:
call glbexp
reltst: bit #glbflg,flags
beq abserx
br abserr
abstrm: call glbtrm
br abstst
absexp:
call glbexp
abstst: bit #glbflg!relflg,flags
beq abserx
abserr: clr mode
clr rellvl
abserf: error 3,a,<bad expression>
abserx: mov value,r0 ;return with value in r0
return
.sbttl term evaluator
term: ;term evaluator
call savreg ;save registers
call setxpr ; and set "expression" type
clr (r3) ;clear mode
clr (r4) ; and value
call term10 ;process
bic #defflg!lblflg!mdfflg,(r3) ;clear extraneous
clr rellvl ;assume absolute
bit #relflg,(r3) ;true?
beq 1$
inc rellvl ; no, relocatable
1$: inc expflg ;mark as expression
jmp setnb ;exit with non-blank and r0 set
term10: call getsym ;try for a symbol
jeq term20 ;branch if not a symbol
.if ndf xcref
mov #symrol,rolndx
call crfref
.endc
cmp symbol,r50dot ;location counter?
beq 14$ ; yes, treat special
search symrol ;search the symbol table
beq 16$ ;branch if not found
bit #mdfflg,(r3) ;multiply defined?
beq 11$ ; no
error 5,m,<multiply defined>
11$: bit #defflg,(r3) ;defined?
beq 13$ ; no
call setsec ;refer by sector name
br 12$
13$: bit #glbflg,(r3) ;no, global?
jne term28 ; yes
error 4,u,<undefined symbol>
sdebug <undef 1>
12$: bic #glbflg,(r3) ;clear internal global flag
jmp term28
14$: mov #clcnam,r1 ;dot, move to working area
mov #symbol,r2
xmit 4
bicb #^c<relflg>,(r3) ;clear all but rel flag
jmp term28
16$: search pstrol ;not user defined, perhaps an op-code?
tst (r3) ;op code?
bmi 17$ ;yes
search symrol ;set search pointers
.if df rsx11d
bis #dfgflg!glbflg,(r3)
bit #ed.gbl,edmask
beq 20$
bic #dfgflg!glbflg,(r3)
.endc
error 4,u,<undefined symbol>
sdebug <undef 2>
20$: call insert ;not in table, insert as undefined
17$: clr (r3) ;be sure mode is zero
jmp term28
.iif df rsx11d, genedt gbl
term20:
mov cradix,r2 ;assume number, current radix
21$: mov chrpnt,symbeg ;in case of re-scan
call cvtnum ;convert
beq term30 ; nope, missed again
bpl 22$ ;number, any overflow?
error 7,t,<number too big>
22$: cmp r5,#ch.dot ;number, decimal?
beq 24$ ; yes
.if ndf xedlsb
cmp r5,#ch.dol ;no, local symbol?
beq 24$ ; yes
.endc
tstb r0 ;no, any numbers out of range?
jeq term28 ; no
error 6,n,<digit illegal in current radix>
br 23$
24$: cmp r2,#10. ;"." or "$", were we decimal?
beq 25$ ; yes
23$: call setsym ;no,
mov #10.,r2 ; try again with decimal radix
br 21$
25$: cmp r5,#ch.dot ;decimal?
beq term27 ; yes
.if ndf xedlsb
call lsrch ;no, local symbol
bne term27 ;branch if found
.endc
term26: error 8,u,<local symbol not defined> ; no, flag as undefined
term27: call getchr ;bypass dot or dollar
term28: call setnb ;return pointing to non-blank
setnz r0 ;flag as found
term29: return
term30:
chscan uoptbl ;scan unary operator table
beq term29 ; not there
clr r2 ;clear for future use
call @(r0)+ ;found, go and process
jmp term28 ;exit true
entsec dpure
uoptbl:
gchtbl ch.add, glbtrm ; "+"
gchtbl ch.sub, term42 ; "-"
gchtbl ch.qtm, term44 ; """
gchtbl ch.xcl, term45 ; "'"
gchtbl ch.pct, term46 ; "%"
gchtbl ch.lab, term47 ; "<"
gchtbl ch.uar, term50 ; "^"
.word 0
xitsec
term42: call abstrm ;evaluate absolute
neg (r4) ;negate value
return
term44: inc r2 ; """, mark it
term45: mov r4,r1 ; "'", set temp store register
call setsym ;point back to operator
1$: call getchr ;get the next character
beq term48 ;error if eol
.if ndf xedlc
movb @chrpnt,(r1) ;store absolute char
bicb #200,(r1)+ ;clear possible sign bit and index
.iff
movb r5,(r1)+
.endc
dec r2 ;another character
beq 1$ ; yes
br term27 ;bypass last char
term46: call abstrm ;register expression
bis #regflg,(r3) ;flag it
return
term47: ; "<"
call glbexp ;process non-null expression
cmp r5,#ch.rab ;">"?
beq term27 ; yes, bypass and exit
term48: jmp abserf ;error, flag it
term50: ; "^"
chscan uartbl ;scan on next character
beq term48 ; invalid, error
jmp @(r0)+ ;call routine
entsec dpure
uartbl: ;up arrow table
gchtbl let.c, term51 ; ^c
gchtbl let.d, term52 ; ^d
gchtbl let.o, term53 ; ^o
gchtbl let.b term54 ; ^b
gchtbl let.r, trmr50 ; ^r
.if ndf xfltg
gchtbl let.f, term55 ; ^f
.endc
.if ndf oldcod
gchtbl let.p, term56 ; ^p
.endc
.word 0
xitsec
term51: call abstrm ;process absolute
com (r4) ;complement value
return
term52: add #2.,r2
term53: add #6.,r2
term54: add #2.,r2
mov cradix,-(sp) ;stack current radix
mov r2,cradix ;replace with local
call glbtrm ;evaluate term
mov (sp)+,cradix ;restore radix
return
.globl setr50,mulr50
r50gch: call getchr ;get next character
cmp r2,#3 ;filled word?
beq r50xit ; yes
trmr50: call setr50 ;test radix 50
call r50prc ;process the character
bcc r50gch ;if cc no terminator seen
1$: cmp r2,#3 ;filled word?
beq r50xit ; yes
clr r0 ; no - pad with blanks
call r50prc
br 1$
r50xit: return ;done with argument
r50prc: cmp r0,#50 ;rad50?
bhis 1$ ; no
mov r0,-(sp) ;save current char
mov (r4),r0 ;get partial
call mulr50 ;multiply
add (sp)+,r0 ;add in current
mov r0,(r4) ;save
inc r2 ;bump count
clc ;no terminator seen
return
1$: sec ;terminator seen
return
.if ndf xfltg
.globl fltg1w
term55: call fltg1w ;process one word floating
beq term48 ;error if null
return
.endc
.if ndf oldcod
term56: ; ^p
call mk.upp ;make upper case
cmp r5,#'l&^c40 ;low limit?
beq 1$ ; yes
cmp r5,#'h&^c40 ; high?
bne term48 ; no, error
inc r2 ;yes, reflect high
1$: add #3,r2 ;make 3 or 4
mov r2,-(sp) ;save operator
call setrld ;set up rld
movb #cc.opr,(r2)+ ;flag operator
movb (sp)+,(r2)+ ;unary type
call getnb ;bypass char
call getsym ;get the argument
mov #secrol,rolndx
call crfref ;cref into proper roll
mov #symbol,r1
.rept 4 ;move into code buffer
movb (r1)+,(r2)+
.endm
inc oprflg ;get unique number
movb oprflg,(r2)+ ;stuff it
call dmprld ;dump it
mov #symbol,r1
clr (r1)+ ;symbol is zero
movb oprflg,(r1)+ ; followed by unique numbwr
clrb (r1)+
mov #glbflg,(r1)+
clr (r1)+
return
.endc
chscan: ;character scan routine
call mk.upp ;make char. upper-case
1$: tst (r0)+ ;end (zero)?
beq 2$ ; yes
cmp (r0)+,r5 ;this the one?
bne 1$ ; no
tst -(r0) ;yes, move pointer back
mov chrpnt,symbeg ;save current pointer
call getnb ;get next non-blank
tst -(r0) ;move addr or zero into r0
return
2$: clr r0
return
mk.upp: cmp r5,#141 ; between a - z ?
blt 1$ ;no
cmp r5,#172
bgt 1$ ;no
sub #40,r5 ;yes, make it upper-case
1$: return
.end