Ultrix-3.1/src/ucb/m11/xlat.m11
;//////////////////////////////////////////////////////////////////////
;/ Copyright (c) Digital Equipment Corporation 1984, 1985, 1986. /
;/ All Rights Reserved. /
;/ Reference "/usr/src/COPYRIGHT" for applicable restrictions. /
;//////////////////////////////////////////////////////////////////////
.title xlat
.ident /09may4/
.mcall (at)always,ch.mne,st.flg,ct.mne
always
ch.mne
st.flg
ct.mne
.mcall (at)xmit
.mcall (at)genswt,error,genedt
.mcall (at)search,scan,scanw,zap
.mcall (at)bisbic
.mcall (at)sdebug,ndebug
.globl secini, stmnt
.globl edmask, seted, setmax, propc
.globl cndwrd, lsybas, lsbset, lc.cnd, opclas
.globl exmflg, err.u
.globl codrol, secrol, psarol, edtrol
.globl symrol, pstrol
.globl dflcnd, dflgev, dflgbm, dflgdg
.globl wrdsym
.globl crfdef, crfref
.globl clcfgs, clcloc, clcmax
.globl clcnam, clcsec, cpopj, cradix, cvtnum
.globl edmask, endvec, errbts, expflg
.globl flags, getchr, getnb, getsym, insert
.globl lsrch, mode, psdflt
.globl r50dot
.globl sector, setnb, setpf0, setpf1
.globl setsec, setsym, setxpr, stcode
.globl symbol, symbeg, tstarg, value
.globl abstrm, abstst
.globl expr, exprg, relexp
.globl reltst, setdsp, setimm
.globl tstr50, mulr50
.globl mactst
.globl setcli
.globl absexp, chrpnt
.globl savreg, xmit0
.globl gsarg, gsargf, argcnt
.globl aexp, asgmtf, cndmex, cttbl
.globl endflg
.globl lblend, lcflag
.sbttl statement processor
xitsec ;start in default sector
stmnt:
mov cndwrd,r0 ;in conditional?
bis cndmex,r0 ; or mexit?
bne 40$ ; yes, branch if suppressed
call getsym
beq 20$
cmp r5,#ch.col ; ":"
beq label
cmp r5,#ch.equ ; "="
bne 1$ ; no
jmp asgmt ;yes, process it
1$: .if ndf xmacro
call mactst ;test for a macro
bne 42$ ; yes, already processed
.endc
search pstrol
beq 30$
call crfref
10$: jmp propc ;process op code
20$:
.if ndf xedlsb
mov #10.,r2 ;not symbol, perhaps local symbol?
mov chrpnt,symbeg ;in case of re-scan
call cvtnum
beq 30$ ; no
cmp r5,#ch.dol ;number, terminated by "$"?
bne 30$ ; no
call getnb
cmp r5,#ch.col
bne 30$
.if ndf rsx11d
mov clcloc,r0
sub lsybas,r0 ;compute local offset
bit #177400,r0 ;in range
beq 21$ ; yes
error 70,a,<local offset out of range> ;no, error
.endc
21$: call lsrch ;yes, do a local symbol search
br labelf ;exit through label processor
.endc
30$: call setsym ;reset char pointer and flags
tstb cttbl(r5)
ble 42$ ;null if end of line
mov #wrdsym,r1 ;neither, fudge ".word" directive
mov #symbol,r2
xmit 4
br 10$
40$: call setcli ;unsat conditional, test directive
bmi 41$ ; branch if eof
bit #dflcnd,r0 ;conditional?
bne 10$ ; yes, process it
bis #lc.cnd,lcflag ;mark as unsat conditional
41$: clr r5
42$: return ;ignore line
setcli:
1$: call getsym ;try for symbol
.if ndf xedlsb
bne 3$ ;branch if found
bitb #ct.num,cttbl(r5) ;perhaps a local?
beq 5$ ; no
2$: call getchr ;perhaps, test next
bitb #ct.alp!ct.num,cttbl(r5) ;alpha/numeric?
bne 2$ ; yes, try again
call setnb ;no, bypass any blanks
.iff
beq 5$ ; exit if no symbol
.endc
3$: cmp r5,#ch.equ ;assignment (=)?
beq 5$ ; yes, ignore this line
cmp r5,#ch.col ;label (:)?
bne 4$ ; no
call getnb ;yes, bypass colon
br 1$ ; and continue
4$: search pstrol ;try for op-code
mov mode,r0 ;mode to r0
bpl 6$ ;branch if directive
5$: clr r0 ;false
6$: return
label: ;label processor
.enabl lsb
cmp symbol,r50dot ;period?
beq 4$ ; yes, error
.if ndf xedlsb
call lsbset ;flag start of new local symbol block
.endc
search symrol ;no, search the symbol table
call crfdef
labelf: call setxpr ;set expression registers
bit #dfgflg,(r3) ; <<< REEDS has it been marked 'x'
beq 33$ ; <<< no, thats OK
bic #dfgflg!glbflg,(r3); <<<yes: it was 'x' mode
; <<< clear 'gx': we are really defining it now
33$: clr dfgtmp ; <<< seems like a good idea.
call getnb ;bypass colon
.if ne,mk.symbol
cmp r5,#ch.col
bne 10$
mov #glbflg,dfgtmp
call getnb
10$: cmp r5,#ch.mul
bne 32$
bis #200,dfgtmp
call getnb
32$: .endc
bit #defflg,(r3) ;already defined?
bne 1$ ; yes
mov clcfgs,r0 ;no, get current location characteristics
bic #377-<relflg>,r0 ;clear all but relocation flag
bis #defflg!lblflg,r0 ;flag as label
.if ne,mk.symbol
bis dfgtmp,r0
.endc
bis r0,(r3) ;set mode
mov clcloc,(r4) ; and current location
br 3$ ;insert
1$: bit #lblflg,(r3) ;defined, as label?
beq 2$ ; no, invalid
cmp clcloc,(r4) ;has anybody moved?
bne 2$ ; yes
cmpb clcsec,(r2) ;same sector?
beq 3$ ; yes, ok
2$: error 32,p,<phase error in label definition>;no, flag error
bis #mdfflg,(r3) ;flag as multiply defined
3$: call insert ;insert/update
call setpf0 ;be sure to print location field
br 5$
4$: error 33,q,<illegal label>
5$: mov chrpnt,lblend ;mark end of label
.if ne,mk.symbol
clr dfgtmp
entsec impure
dfgtmp: .blkw
xitsec
.endc
jmp stmnt ;try for more
.dsabl lsb
.sbttl assignment processor
asgmt:
call getnb ;bypass "="
.if ne,mk.symbol
cmp r5,#ch.equ
bne 10$
mov #glbflg,dfgtmp
call getnb
10$: cmp r5,#ch.mul
bne 32$
bis #200,dfgtmp
call getnb
32$: .iftf
mov #symbol+4,r1 ;set mix-master register
mov -(r1),-(sp) ;stack symbol
mov -(r1),-(sp)
call relexp ;get non-external expression
mov (sp)+,(r1)+ ;restore symbol
mov (sp)+,(r1)+
bit #err.u,errbts ;any undefined's?
bne asgmtx ; yes, don't define
asgmtf: call setpf1 ;set listing field
call setxpr ;set expression registers
bit #err.a,errbts
bne asgmtx
bis #defflg,(r3) ;flag as defined
mov (r3),-(sp) ;no, stack value
mov (r4),-(sp)
search symrol ;search symbol table
mov (sp)+,(r4) ;restore value
bic #^c<glbflg>,(r3)
bis (sp)+,(r3)
cmp (r1),r50dot ;messing with the pc?
beq 1$ ; yes
.ift
bis dfgtmp,(r3) ;i hope
.iftf
call insert ;insert new value
br asgmtx
1$: cmpb (r2),clcsec ;same sector?
bne 2$ ; no, error
mov (r4),clcloc ;yes, set new location
br asgmtx
2$: error 34,m,<label multiply defined>
asgmtx: call crfdef
.ift
clr dfgtmp
.endc
return
.sbttl op code processor
error 35,z,<op code not in standard set>
propc: ;process op code
mov #mode,r4 ;point to mode
mov (r4),r1 ;leave result in r1
mov r1,opclas ;flag op class
clr (r4)+ ;set to zero, point to value
mov #clcloc,r2 ;point r2 to location counter
bit #100000+dflgev,r1 ;op code or even directive?
beq 1$ ; no
bit #1,(r2) ;yes, currently even?
beq 1$ ; yes
inc (r2) ;no, make it even
error 36,b,<odd addressing error> ; and flag error
1$: tst r1 ;op-code?
bmi 10$ ; yes
mov (r4),-(sp) ;no, directive.
clr (r4) ;clear value
clr r3 ;start with r3=0
call @(sp)+ ;call the handler
bit #dflgdg,opclas ;data generating directive?
jeq prop23 ; no
tstb <^pl rolsiz>+codrol+1 ;yes, any generated?
jne prop23 ; yes, all set
clr mode ;no, store a zero byte/word
clr value
jmp stcode
10$: call stcode ;stuff basic value
.globl pdp10,fltg1w ; defined in exec.m11 and in fltg.m11
bit pdp10,r1 ; <<< REEDS june 81
beq 100$ ; <<<
error 35,z,<op code not in standard set> ; <<<
100$: ; <<<
swab r1
bic #177600,r1 ;clear high order bits
asl r1
asl r1 ;four bytes per table entry
clr -(sp) ;set a stopper
mov opjtbl+2(r1),-(sp) ;stack second arg
mov opjtbl(r1),r1 ;set the first argument
12$: mov r1,-(sp) ;save a copy of the arg
call tstarg ;comma test
clr r0 ;function register
bic #000001,r1 ;clear shift bit
call (r1) ;call proper routine
aslb opclas ;move cref destruction into place
asrb opclas ;restore rest of flags
ror (sp)+ ;shift required?
bcc 13$ ; no
swab r0 ;yes, shift left siz
asr r0
asr r0
13$: mov <^pl rolbas>+codrol,r1
bis r0,6(r1) ;set expression bits
mov (sp)+,r1 ;get next arg from stack
bne 12$ ;branch if not terminator
.if ndf xzerr
mov <^pl rolbas>+codrol,r1
mov 6(r1),r0 ;set for "z" error tests
mov r0,r1
bic #000007,r1
cmp #000120,r1 ; jmp (r)+
beq 22$
bic #000700,r1
cmp #004020,r1 ; jsr x,(r1)+
beq 22$
mov r0,r1
bit #007000,r1 ;first arg type 0?
jne prop23 ; no, ok
bic #100777,r1
jeq prop23
cmp #070000,r1 ;double address type?
jeq prop23 ; no
mov r0,r1
bic #170017,r1
cmp #000760,r1 ; mov pc,[@]x(r)
beq 22$
bic #177717,r1
cmp #000020,r1 ; (r)+
beq 21$
cmp #000040,r1 ; -(r)
jne prop23
21$: mov r0,r1
rol r1
rol r1
swab r1
sub r0,r1
bit #000007,r1 ; r1=r2
jne prop23
22$: error 37,z,<unpredictable instruction>
prop23:
.endc
return
.macro genopj number,subr1,subr2 ;op code jump table
.globl opcl'number
opcl'number= <.-opjtbl>/4
.iif nb <subr1>, .word subr1
.iif b <subr1>, .word cpopj
.iif nb <subr2>, .word subr2
.iif b <subr2>, .word cpopj
.endm
.data
opjtbl: ;op code jump table
genopj 00
genopj 01, aexp
genopj 02, aexp+1, aexp
genopj 03, regexp
genopj 04, brop
genopj 05, regexp+1, aexp
genopj 06, trapop
.if ndf x45!x40
genopj 07, aexp, regexp+1
genopj 08, regexp+1, sobop
genopj 09, aexp, regexp+1
.endc
.if ndf x45
genopj 10, markop
genopj 11, aexp, drgexp+1
genopj 12, drgexp+1, aexp
genopj 13, splop
genopj 14, aexp, drgexp+1
.endc
entsec implin
opclas: .blkw ;op code class
xitsec
regexp: ;register expression
call absexp ;evaluate absolute
bit #177770,r0 ;any overflow?
beq reg1 ; no
error 38,r,<no such register number> ;yes, flag error
bic #177770,r0 ;clear overflow
reg1: return
brop: ;branch displacement type
call relexp
cmpb sector,clcsec
bne 5$
sub clcloc,r0
asr r0
bcs 2$
dec r0
movb r0,r3 ;extend sign
cmp r0,r3 ;proper?
beq 3$ ; yes
2$: error 81,a,<too far to branch>
4$: mov #000377,r0
3$: bic #177400,r0 ;clear possible high bits
return
5$: error 80,a,<branch out of current psect>
br 4$
trapop: ;trap type
call setxpr ;set expression registers
mov (r4),-(sp) ;save the value
call exprg ;call external expression
bit #relflg!glbflg,(r3) ;absolute?
bne 1$ ; no
mov (r4),r0 ;value to merge
bit #^c377,r0 ;any high order bits?
bne 1$ ; yes, fall through
tst (sp)+ ;no, prune
return
1$: zap codrol ;clear code roll
bis #dflgbm,opclas ;flag as byte mode
call setimm ;set immediate mode
call stcode ;store address
mov #100000,(r3) ;set for absolute byte
swab (sp)
mov (sp)+,(r4) ;set origional value
call stcode
clr r0
return
.if ndf x45
drgexp: ;double register expression
call regexp ;evaluate normal
mov #177774,r3 ;test for overflow
br maskr3
splop: ;spl type
call absexp
mov #177770,r3 ;only three bits allowed
br maskr3
.endc
.if ndf x45!x40
sobop: ;sob operator
call brop ;free-load off branch operator
movb r0,r0 ;extend sign
neg r0 ;positive for backwards
br maskb6 ;mask to six bits
markop: ;mark operator
call absexp ;evaluate absolute
maskb6: mov #177700,r3 ;set to mask high order
maskr3: bit r3,r0 ;overflow?
beq mark1 ; no
error 39,t,<low order byte only> ;yes, flag truncation error
bic r3,r0 ;clear excess
mark1: return
.endc
; address mode flags
am.def = 10 ;deferred mode
am.inc = 20 ;auto-increment mode
am.dec = 40 ;auto-decrement mode
am.ndx = 60 ;index mode
am.pc = 07 ;pc mode addressing
am.imm = am.inc+am.pc ;immediate mode
am.rel = am.ndx+am.pc ;relative mode
aexp: call savreg ;address expression evaluation
call setxpr ; and set "expression" type
inc expflg
clr -(sp) ;accumulate on top of stack
2$: mov chrpnt,symbeg ;save in event of rescan
cmp r5,#ch.ind ;indirect?
bne 6$ ; no
call getnb ;yes, bypass it
tst (sp) ;"@", second time around?
beq 4$ ; no
error 40,q,<questionable expression syntax>
4$: bis #am.def,(sp) ;set it
br 2$
6$: cmp r5,#ch.hsh ;literal (#)
bne 10$ ; no
call getnb
.globl veritas
mov opclas,-(sp) ; <<< REEDS june 81: fixed harvard fp bug
swab (sp) ; <<< addf #10.3,r0 means: add 10.3 to fr0
bic #^c77,(sp) ; <<<
cmp #11.,(sp)+ ; <<< is this an FP instrction?
bne 7$ ; <<<
tst veritas ; see if user WANTS harvard fp bug
bne 7$ ; Yes: treat it as octal
call fltg1w ; <<< No, treat it as FP
bne 9$ ; <<<
7$: ; <<<
call aexpxp ;evaluate expression
9$: bis #am.imm,(sp) ;set bits
br aexp32 ;use common exit
10$: cmp r5,#ch.sub ;auto-decrement (-)
bne 12$
call getnb
cmp r5,#ch.lp ;followed by "("?
bne aexp20 ; not a chance
call aexplp ;process parens
bis #am.dec,(sp)
br aexp36
12$: cmp r5,#ch.lp ; "("
bne aexp22
call aexplp ;evaluate register
cmp r5,#ch.add ;auto-increment (+)?
bne 14$ ; no
call getnb ;yes, polish it off
bis #am.inc,(sp) ;set bits
br aexp36
14$: bit #am.def,(sp) ;indirect seen?
bne 16$ ; yes
bis #am.def,(sp) ;no, set bit
br aexp36
16$: clr (r3) ;mode
clr (r4) ; and value
br aexp30
aexp20: call setsym ;auto-dec failure, point to -
aexp22: call aexpxp ;get an expression
cmp r5,#ch.lp ;indexed?
beq 24$ ; yes
bit #regflg,(r3) ;flags
bne aexp36
.if ndf xedpic!xedama
tst (sp)
bne 23$
.if ndf xedpic
bit #ed.pic,edmask
bne 1$
bit #glbflg,(r3)
bne 2$
cmpb (r2),clcsec
beq 23$
br 2$
1$:
.endc
.if ndf xedama
bit #ed.ama,edmask ;absolute mode requested?
bne 23$ ; no
.endc
2$: bis #am.imm!am.def,(sp) ;ok, set abs mode
br aexp32
.endc
23$: bis #am.rel,(sp) ;no
call setdsp ;set displacement
br aexp34
24$: bit #regflg,(r3) ;flags
beq 26$
error 41,r,<illegal use of register>
bic #regflg,(r3) ;flags
26$: mov (r1)+,-(sp) ;stack current value
mov (r1)+,-(sp)
mov (r1)+,-(sp)
mov (r1)+,-(sp)
call aexplp ;process index
mov (sp)+,-(r1) ;restore
mov (sp)+,-(r1)
mov (sp)+,-(r1)
mov (sp)+,-(r1)
aexp30: bis r0,(sp)
bis #am.ndx,(sp)
aexp32: call setimm
aexp34: call stcode
clr r0
aexp36: bis (sp)+,r0
return
aexplp: ;aexp paren processor
call getnb ;bypass paren
call regexp ;get a register expression
cmp r5,#ch.rp ;happy ending ")"?
bne 1$ ; no
jmp getnb ;yes, bypass and exit
1$: error 42,q,<missign right ')'> ;no
return
.if ndf xedama
genedt ama ;absolute mode addressing
.endc
.if ndf xedpic
genedt pic ;pic mode
.endc
aexpxp: call exprg ;evaluate potential external
bne aex1 ; branch if non-null
error 43,a,<missing expression> ;null, error
aex1: mov value,r0 ;set value
return
.sbttl directives
.if ndf xrel
.globl globl
globl: ;global handler
globl1: call gsarg ;get a symbol
beq globl3 ; end
search symrol ;no, search user symbol table
bit #regflg,flags ;register?
bne 2$ ; yes, error
.iif df rsx11d, bic #dfgflg,flags
bis #glbflg,flags ;no, flag as globl
call insert ;update/insert
call crfdef
br globl1
2$: error 44,r,<illegal register usage>
br globl1
globl3: return
.endc
.globl end
end: ;temp end directive
call expr ;evaluate the expression
bne 1$ ; branch if non-null
inc (r4) ;null, make it a one
1$: call reltst ;no globals allowed
inc endflg
call setsec
call setpf1 ;list field 1
mov #symbol,r1
mov #endvec,r2
xmit 4 ;move to end vector
return
entsec impure
endvec: .blkw 4 ;end vector storage
xitsec
.if ndf xrel
.globl asect, csect
asect:
call setmax ;clean up current sector
asectf:
mov r50abs,symbol ;set ". abs."
mov r50abs+2,symbol+2
mov asdflt,r3
br csectf ;use common exit
csect:
call setmax ;clean up current sector
mov psdflt,r3 ; unnamed .csect = unnamed .psect
call tstarg ;get argument (or null)
beq 1$
mov csdflt,r3 ; well, its got a name so it really is a csect
1$: call getsym
csectf: scan secrol ;scan for match
bne psectf ; branch if match
movb r3,mode
movb <^pl rolsiz>+1+secrol,sector
br psectf
.globl psect
psect:
call setmax
call tstarg
beq 10$
tst veritas
beq 10$
mov csdflt,silly ; user wants funny Harvard modes for
; named .psects
br 11$
10$: mov psdflt,silly ; no -ha flag or blank .psect
11$: inc argcnt
call getsym
scan secrol
bne 1$
movb silly,mode
movb <^pl rolsiz>+1+secrol,sector
1$: mov #clcnam,r3
.rept 5
mov -(r3),-(sp)
.endr
2$: call tstarg
beq 3$
call getsym
scanw psarol
beq psecta
mov #symbol+2,r0
bisb (r0),4(sp)
bicb 1(r0),4(sp)
br 2$
3$:
mov (sp)+,(r3)+
mov (sp)+,(r3)+
scan secrol
mov (sp)+,(r3)+
mov (sp)+,(r3)+
mov (sp)+,(r3)+
psectf: call insert
call crfref
mov #symbol,r1
mov #clcnam,r2
.globl xmit5
xmit 5
jmp lsbset
psecta: add #12,sp ; compensate for the big push
error 45,a,<illegal .psect attribute>
psect9: return
.bss
silly: .blkw 1
.data
.macro genpsa mne,set,reset
.rad50 /mne/
.byte set,reset
.endm
entsec psasec
genpsa rel, relflg,
genpsa abs, , relflg
genpsa gbl, glbflg,
genpsa lcl, , glbflg
genpsa ovr, ovrflg,
genpsa con, , ovrflg
genpsa low, , ; these do nothing. they
genpsa hgh, , ; exist for backwards compat.
.if gt ft.unx
genpsa shr, shrflg, bssflg
genpsa prv, , shrflg!bssflg
genpsa bss, bssflg, shrflg!insflg
genpsa ins, insflg, bssflg
genpsa dat, , insflg!bssflg
genpsa b, bssflg, shrflg!insflg
genpsa i, insflg, bssflg
genpsa d, , insflg!bssflg
genpsa ro, shrflg, bssflg
genpsa rw, , shrflg!bssflg
.endc
xitsec
.data
psdflt: .word pattrs ; the default values are defined in at.sml
asdflt:: .word aattrs
csdflt:: .word cattrs
xitsec
xitsec
.endc ;xrel
absset:
tst exmflg
beq secini
tstb clcsec
bmi psect9
secini:
call asectf ;move onto roll
clr symbol ;ditto for blank csect
clr symbol+2
mov psdflt,r3
bit #ed.abs,edmask ;abs mode?
beq 1$
jmp csectf ; not abs mode.
1$:
return
genedt abs,absset
.data
r50abs: .rad50 /. abs./
xitsec
.if ndf xrel
setmax: ;set max and enter onto roll
call savreg ;play it safe
mov #clcnam,r1
mov #symbol,r2
xmit 2 ;move name to symbol
scan secrol ;scan sector roll
xmit 3 ;set remainder of entries
jmp insert ;update roll and exit
.endc
.globl blkw, blkb, even, odd, radix, eot
blkw: inc r3 ;flag word type
blkb: call expr ;evaluate the expression
bne 1$ ;branch if non-null
inc (r4) ;null, make it one
1$: call abstst ;must be absolute
2$: add r0,(r2) ;update pc
asr r3 ;word?
bcs 2$ ; yes, double value
return
even: inc (r2) ;increment the pc
bic #1,(r2) ;clear if no carry
return
odd: bis #1,(r2) ;set low order pc byte
eot: return
radix: mov cradix,r2 ;save in case of failure
mov #10.,cradix
call absexp
cmp r0,#2.
blt 1$
cmp r0,#10.
ble rad2$
1$: error 46,a,<illegal radix>
mov r2,r0
rad2$: mov r0,cradix
jmp setpf1
entsec imppas ;impure area
cradix: .blkw ;current radix
xitsec ;back to normal
.sbttl data-generating directives
.globl byte, word
word: inc r3 ;"word" directive, set to 2
byte:
inc r3 ;"byte" directive, set to 1
mov (r2),-(sp) ;stack current pc
1$: call tstarg ;test for argument
bne 3$ ; good arg
cmp (r2),(sp) ;end, any processed?
bne 2$ ; yes, exit
3$: call exprg ;process general expression
call setimm ;convert to object format
call stcode ;put on code roll
add r3,(r2) ;update pc
br 1$ ;test for more
2$: mov (sp)+,(r2) ;restore initial pc
return
.globl rad50, ascii, asciz
asciz: inc r3 ; ".asciz", set to 1
ascii: inc r3 ; ".ascii", set to 0
rad50:
dec r3 ; ".rad50", set to -1
call 23$ ;init regs
1$: mov r5,r2 ;set terminator
beq 8$ ;error if eol
2$: cmp r5,#ch.lab ; "<", expression?
beq 10$ ; yes
3$: call getchr ;no, get next char
mov r5,r0 ;set in work register
beq 8$ ;error if eol
cmp r5,r2 ;terminator?
beq 5$ ; yes
tst r3 ;no
bmi 9$ ;branch if rad50
.if ndf xedlc
mov chrpnt,r0 ;fake for ovlay pic
movb (r0),r0 ;fetch possible lower case
bic #177600,r0 ;clear possible sign bit
.endc
br 4$
9$: call tstr50 ;test radix 50
4$: call 20$ ;process the item
br 3$ ;back for another
5$: call getnb ;bypass terminator
6$: tstb cttbl(r5) ;eol or comment?
bgt 1$ ; no
br 7$
8$: error 47,a,<premature end of line> ;error, flag and exit
7$: clr r0 ;yes, prepare to clean up
tst r3 ;test mode
beq 24$ ;normal exit if .ascii
bpl 20$ ;one zero byte if .asciz
tst r1 ;.rad50, anything in progress?
beq 24$
call 20$ ;yes, process
br 6$ ;loop until word completed
10$: mov (r4),-(sp) ;"<expression>", save partial
call abstrm ;absolute term, setting r0
mov (sp)+,(r4) ;restore partial
call 20$ ;process byte
br 6$ ;test for end
20$: tst r3 ;rad50?
bpl 22$ ; no
cmp r0,#50 ;yes, within range?
blo 21$ ; yes
error 48,t,<illegal rad50 character> ;no, error
21$: 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 r1 ;bump count
cmp r1,#3 ;word complete?
bne 24$ ; no
22$: mov r0,(r4) ;stuff in value
call setimm ;convert to obj mode
call stcode ;stow it
23$: clr r1 ;clear loop count
clr (r4) ; and value
24$: return
.sbttl enabl/dsabl functions
.globl enabl, dsabl, bisbic
dsabl: com r3 ;r3=-1
enabl: ;r3=0
1$: call gsarg ;get a symbolic argument
beq endabl ;end if null
scanw edtrol ;search the table
beq 7$ ; not there, error
mov symbol+4,r2 ;get proper bit
tst exmflg ;called from command string?
beq 3$ ; no
bisbic eddflt ; yes. set default bits
bis r2,edmcsi ; and set disable bits
br 4$ ; and bypass test
3$: bic edmcsi,r2 ;over-ridden from csi?
4$: bisbic edmask ;set appropriate bits
mov symbol+2,-(sp) ;make it pic
tst r3 ;set flags
call @(sp)+ ;call routine
br 1$
7$: error 49,a,<illegal .enabl/.dsabl argument>
endabl: return
bisbic: ; address of arg on stack
; if r3 < 0, set bits of r2 into arg
; else clear them
; this meshes with .list & .enabl:
; .list r3 = 1
; .nlist r3 = -1
; .enabl r3 = 0
; .dsabl r3 = -1
tst r3
blt 1$
bic r2,@2(sp)
br 2$
1$: bis r2,@2(sp)
2$: rts pc
entsec impure
edmask: .blkw ;contains set flags
edmcsi: .blkw ;bits for csi override
xitsec
entsec mixed
eddflt::.word ^c<ed.pnc+ed.reg+ed.lc+ed.gbl> ;default values for edmask
; bit 1 ==> .dsabl
; bit 0 ==> .enabl
;^c<ed.pnc+ed.lc> = non rsx11d choice
xitsec
seted:
mov eddflt,edmask
;clr edmcsi experiment
return
genswt en,enabl ;generate /en
genswt ds,dsabl ; and /ds switch table entries
tmpcnt= 1
.irp x,<abs,ama,cdr,fpt,gbl,lc ,lsb,pic,pnc,reg,crf>
.globl ed.'x
ed.'x = tmpcnt
tmpcnt=tmpcnt+tmpcnt
.endm
gsarg: ;get a symbolic argument
.enabl lsb
call tstarg ;test general
beq gsa.2$ ; exit null
gsargf: call getsym ;arg, try for symbol
bne 5$ ; error if not symbol
error 59,a,<unknown symbol>
br gsa.2$
5$: cmp r0,r50dot ; "."?
bne 3$ ; no, ok
1$: error 50,a,<illegal use of '.'>
gsa.2$: clr symbol
clr symbol+2
clr r0 ;treat all errors as null
3$: return
.dsabl lsb
tstarg: ;test argument
1$: movb cttbl(r5),r0 ;get characteristics
ble 12$ ;through if eol or semi-colon
tst argcnt ;first argument?
beq 11$ ; yes, good as is
bit #ct.com,r0 ;no, comma?
bne 10$ ; yes, bypass it
tst expflg ;no, was one required?
beq 2$ ; no
error 51,a,<comma required>
2$: cmp chrpnt,argpnt ;did anybody use anything?
bne 11$ ; yes, ok
3$: call getchr ;no, bypass to avoid loops
bitb #ct.pc+ct.sp+ct.tab-ct.com-ct.smc,cttbl(r5)
bne 3$ ; yes, bypass
call setnb ;no, set to non-blank
error 52,a,<separator required>
br 1$ ;now try again
10$: call getnb ;bypass comma
11$: inc argcnt ;increment argument count
12$: clr expflg
mov chrpnt,argpnt ;save pointer
bic #177600,r0 ;set flags
return
entsec implin ;clear each line
argcnt: .blkw ;argument count
argpnt: .blkw ;start of last argument
expflg: .blkw ;set when comma required
.data
r50dot: .rad50 /. /
xitsec
.end