Ultrix-3.1/src/ucb/m11/lout.m11
;//////////////////////////////////////////////////////////////////////
;/ Copyright (c) Digital Equipment Corporation 1984, 1985, 1986. /
;/ All Rights Reserved. /
;/ Reference "/usr/src/COPYRIGHT" for applicable restrictions. /
;//////////////////////////////////////////////////////////////////////
.title lout
.ident /10may4/
.mcall (at)always,ch.mne,st.flg,ct.mne
.mcall (at)bisbic
always
ch.mne
st.flg
ct.mne
.mcall (at)xmit,param,putlp
.macro putlin addr ;use listing flags
.if dif <addr><r0>
mov addr,r0
.endc
call putlin
.endm
.mcall (at)genswt,error
.mcall (at)zwrite
.mcall (at)genedt,setnz
.mcall (at)scanw,next,zap
.mcall (at)sdebug,ndebug
param lpp, 60. ;
param ttllen, 32.
param stllen, 64.
.globl codrol, errrol, lcdrol, symrol, secrol
.globl lcbegl, linend, lcendl
.globl linbuf, cdrsav, endp2l
.globl linnum, seqend, pagnum, pagext
.globl ffcnt, lppcnt
.globl dflgbm, opclas
.globl edmask, ed.cdr, ed.lc
srclen = 204 ;*********************
octlen = 60 ;*********************
mx.on =lc.md!lc.mc!lc.ld!lc.toc!lc.sym!lc.cnd!lc.bin!lc.loc!lc.seq
.globl lc.cnd
.globl exmflg
.globl lstchn, cmochn, lstflg, putoc
.globl mx.flg, my.flg
.globl crfref
.globl clcfgs, clcloc, clcmax
.globl clcnam, clcsec, cpopj
.globl errbts
.globl flags, getchr, getnb, getsym
.globl mode
.globl rolndx, rolupd
.globl sector, setpf0, setpf1
.globl setsym
.globl symbol, tstarg, value
.globl expr, pcroll, prgttl
.globl setwrd, setbyt, tstr50, mulr50
.globl r50unp
.globl setchr
;globals defined in assembler
.globl setlc
.globl chrpnt, getr50, pass
.globl putkb, putkbl, putlp
.globl dnc, movbyt, savreg, xmit0
.globl linbuf, errcnt
;globals defined in mcexec
.globl dattim
.globl hdrttl
.globl io.eof, io.tty, io.err
.globl ioftbl, cnttbl, buftbl
.globl argcnt, cttbl
.globl endlin
.globl getlin, lblend, lcendl, lcflag
.globl lcmask, lc.mc, lc.md, lc.me
.globl lst.kb, lst.lp, lstdev
xitsec ;start in default sector
endlin: ;end of line processor
call savreg
clr rolupd ;set to fetch from code roll
tstb cttbl(r5) ;eol or semi-colon?
ble lout1 ; yes
error 19,q,<random junk at end of statement ignored>
lout1: .if ndf xedcdr
movb cdrsav,linbuf+72. ;replace borrowed char
.endc
mov pass,-(sp) ;pass 1?
beq 9$ ; yes
call mx.mx ; <<< REEDS june 81
mov lstdev,(sp) ;init listing flag
tst errbts ;any errors?
bne 7$ ; yes, go directly, do not collect, etc.
tstb (sp) ;any listing device?
beq 9$ ; no
bit #lc.ld,lcflag ;listing directive?
bne 5$ ; yes
tst mx.flg ; <<< REEDS june 81
bne 80$ ; <<< REEDS june 81: in mx mode we ignore .list
tst lclvl ;test over-under ride
blt 5$ ;if <0, list only if errors
bgt 8$ ;if >0, list unconditionally
80$: bit #lc.com,lcmask ;comment suppression?
beq 2$ ; no
mov chrpnt,lcendl ;yes, assume we're sitting at comment
2$: bit #lc.src,lcmask ;line suppression?
beq 3$ ; no
mov #linbuf,lcendl ;yes, point to start of buffer
3$:
.if ndf xmacro
tstb <^pl rolsiz>+codrol+1 ;anything in code roll?
beq 4$ ; no
bit #lc.meb,lcmask ;macro binary expansion?
bne 4$ ; no
bic #lc.me,lcflag ;yes, ignore me flag
.endc
4$: bit lcmask,lcflag ;anything suppressed?
beq 9$ ; no, use current flags
5$: clr (sp) ;yes, clear listing mode
br 9$
7$: swab (sp) ;error, set to error flags
8$: mov #linbuf,lcbegl ;list entire line
mov #linend,lcendl
9$: call pcroll ;process entry on code roll
endl10: movb (sp),lstreq ;anything requested?
beq endl20 ; no
clrb @lcendl ;set asciz terminator
mov #octbuf,r2
11$: mov #space*400+space,(r2)+ ;blank fill
cmp #linbuf,r2 ;test for end (beginning of line buffer)
bne 11$
endl50: mov #octbuf,r2 ;point to start of buffer
call tsterr ;set error flags
mov #linnum,r0
mov (r0)+,r1
cmp r1,(r0)
beq 2$
mov r1,(r0)
bit #lc.seq,lcmask
bne 2$
mov r2,r4
call dnc
mov #octbuf+7,r0
1$: movb -(r2),-(r0)
movb #space,(r2)
cmp r2,r4
bhi 1$
mov #octbuf+7,r2
2$: movb #tab,(r2)+
21$: mov #pf0,r1
bit #lc.loc,lcmask
bne 4$
tst (r1)
beq 3$
call setwrd
3$: movb #tab,(r2)+
4$: clr (r1)
mov #pf1,r1
bit #lc.bin,lcmask
bne endl19
mov #1,r4
bit #lc.ttm,lcmask
beq 41$
cmpb (r4)+,(r4)+ ; cheap increment by 2
41$: tst (r1)
beq 6$
5$: call setwdb
6$: movb #tab,(r2)+
clr (r1)
dec r4
beq endl19
tst rolupd
beq 6$
call pcroll
br 5$
endl19: mov lcbegl,r1 ;point to start of listing line
call movbyt ;move over
putlin #octbuf ; test for header and list
call err.pr
endl20:
clrb @lcbegl ;don't dupe line
tst rolupd ;finished?
beq endl30 ; yes, don't loop
call pcroll
beq endl30 ;exit if empty
bit #lc.bex!lc.bin,lcmask ;binary extension suppressed?
beq endl10 ; no
br endl20 ;yes, don't list
endl30: tst (sp)+ ;prune listing flag
zap codrol ;clear the code roll
mov clcloc,r0
cmp r0,clcmax ;new high for sector?
blos 31$ ; no
mov r0,clcmax ;yes, set it
31$: return
setwdb: ;list word or byte
tst (r1) ;anything for second field?
beq 9$ ; no
mov #setwrd,-(sp) ;assume word
bit #dflgbm,opclas ;true?
beq 1$ ; yes
mov #setbyt,(sp) ;no, byte
1$: call @(sp)+ ;call routine
bit #77*400,(r1) ;test for linker modification
beq 9$
bit #5100,(r1) ;if one of these isnt set I dont know
bne 12$ ;what is going on, so lets mark it ?
movb #'?,(r2)
br 9$
12$:
movb #ch.xcl,(r2) ; ' marks psect relocation
bit #4000,(r1)
bne 10$
movb #'",(r2) ; " location counter relocation
10$:
bit #glbflg,(r1)
beq 2$
movb #'G,(r2)
tst symbol ; harvard m11 uses global syms with funny
bne 2$ ; names for complex relocation
movb #'C,(r2)
2$: tstb (r2)+
9$: return
tsterr: ;test and process errors
mov errbts,r0 ;any errors?
beq 9$ ; no
bic #err.,r0 ;yes, ".print"?
beq 4$ ; yes
inc errcnt ;bump error count
call err.sh
4$: mov #errmne-1,r1
1$: tstb (r1)+ ;move char pntr and clear carry
ror errbts ;rotate error bits
bcc 2$
movb (r1),(r2)+
.if ndf xcref
movb (r1),r0 ;fetch character
call tstr50 ;convert to rad50
call mulr50 ;left justify
call mulr50
mov r0,symbol ;store
clr symbol+2
mov #errrol,rolndx ;prepare to cref
call crfref ;do so
.endc
br 1$
2$: bne 1$
9$: return
.globl fileln
.globl putli2
err.sh::
call savreg
tst lstflg
bne 9$
; printf("%s: line %d: %s\n", infile, fileln, errmess)
mov #err.bx,r2
tstb err.by
beq 1$
mov #err.by,r1
call movbyt
mov #err.s1,r1
call movbyt
mov fileln,r1
call dnc
tst err.xx
beq 2$
mov #err.s2,r1
call movbyt
1$: mov err.xx,r1
call movbyt
clr err.xx
2$:
clrb (r2)
mov #err.bx,r2
mov #lst.kb,r4
call putli2
9$:
return
.data
err.s1: .asciz /: line /
.even
err.s2: .asciz /: /
.bss
err.bx: .blkw 60
err.by:: .blkw 60
entsec impure
errcnt: .blkw ;error counter
entsec implin
errbts: .blkw ;error flags
err.xx:: .blkw ;error message
xitsec
.if ndf xedcdr
genedt cdr
entsec impure
cdrsav: .blkw ;saved char from card format
.endc
entsec impure
octbuf:
octerp: .blkb 0
octseq: .blkb 2
octpf0: .blkb 7
octpf1: .blkb octlen-<.-octbuf>
linbuf: .blkw srclen/2
linend: .blkw 1
.data
tmpcnt = 1
errmne: .irpc char,< abeilmnopqrtuz>
.ascii /char/
.globl err.'char
err.'char= tmpcnt
tmpcnt = tmpcnt+tmpcnt
.endm
xitsec
.globl title, sbttl
title:
call getsym ;get a symbol
bne title1 ; error if null
error 20,a,<missing title>
return
title1: mov r0,prgttl ;move into storage
mov symbol+2,prgttl+2
call setsym ;point to start of title
mov #ttlbuf,r2 ;point to buffer
movb #ff,(r2)+ ;store page eject
clr r3 ;clear position conter
2$: .if ndf xedlc ;>>>gh 7/20/78 to not automatically upper-case
bit #ed.lc,edmask ;lower case enabled?
bne 6$ ; no, leave as upper case
mov chrpnt,r5 ;fake for ovlay pic
movb (r5),r5 ;fetch original character
6$: .endc
movb r5,(r2) ;plunk the next char in the buffer
beq 5$ ;branch if end
cmp r5,#tab ;a tab?
bne 3$ ; no
bis #7,r3 ;yes, compensate
3$: inc r3 ;update position counter
cmp r3,#ttllen ;within bounds?
bhis 4$ ; no
tstb (r2)+ ;yes, move pointer
4$: call getchr ;get the next character
bne 2$ ;loop if not end
5$: movb #tab,(r2)+ ;set separator
.globl vernam
mov vernam,r1
call movbyt ;set version number, etc.
mov #dattim,r1
call movbyt ;date and time
mov r2,ttlbrk ;remember break point
clrb (r2)
return
.data
defttl:: .asciz /.main./ ;default title
entsec impure
ttlbrk: .blkw ;break location
ttlbuf: .blkb ttllen-1!7+1+1 ;modulo tab + ff
.blkb 20. ;intro msg
.iif ndf xtime, .blkb 20. ;time & date
.blkb 20. ;page number
.even
xitsec
sbttl: ;sub-title directive
mov #stlbuf,r2 ;point to sub-title buffer
tst pass ;pass one?
beq 2$ ; yes
1$: .if ndf xedlc ;>>>gh 7/20/78 to not automatically upper-case
bit #ed.lc,edmask ;lower case enabled?
bne 4$ ; no, leave as upper case
mov chrpnt,r5 ;fake for ovlay pic
movb (r5),r5 ;fetch original character
4$: .endc
movb r5,(r2)+ ;move character in
beq 13$ ; branch if end
call getchr ;get the next character
cmp r2,#stlbuf+stllen-1 ;test for end
blo 1$
tstb -(r2) ;polish off line
br 1$
2$: bit #lc.toc,lcmask
bne 13$
tstb lstdev ;any listing device?
beq 13$ ; no, exit
tst mx.flg ; <<< REEDS june 81
bne 13$ ; <<<
mov #toctxt,r1
call movbyt ;set table of contents
call setsym ;point to ".sbttl"
3$: call getr50 ;get radix-50 char
bgt 3$ ;stop at first terminator
mov chrpnt,r2 ;set pointer
.if ndf xlcseq
mov linnum,r0
call 10$
movb #ch.sub,-(r2)
.iff
movb #tab,-(r2)
.endc
mov pagnum,r0
call 10$
movb #space,-(r2)
tst lstflg
beq 15$
bisb lstdev,lstreq
15$: putlin r2 ;output
return
10$: mov #4,r4 ; << REEDS. changed to 4 digit field from 3
11$: movb #space,-(r2)
mov r0,r1
beq 12$
clr r0
div #^d10,r0
add #dig.0,r1
movb r1,(r2)
12$: sob r4,11$
13$: return
.data
toctxt: .asciz /table of contents/
entsec imppas
stlbuf: .blkw <stllen+2>/2 ;sub-title buffer
xitsec
.globl print, error
.enabl lsb
print:
error 0,<>,<user generated error> ; null error (dont count)
br error1
error: error 53,p,<user generated error>
error1: call setpf0 ;print location field
call expr ;evaluate expression
beq 2$ ;branch if null
call setpf1 ;non-null, list value
2$: return
.dsabl lsb
.globl rem
rem: ; ".rem" directive
mov r5,r3 ;set terminating character
bne rem1 ;branch if non-null
error 22,a,<missing delimiting character>
;error, no delimiting character
return
rem1: call getchr ;get the next character
2$: tst r5 ;end of line?
bne 3$ ; no
call endlin ;yes, polish off line
call getlin ;get next line
beq 2$ ;loop if no eof
return ;eof, exit
3$: cmp r5,r3 ;is this the terminator?
bne rem1 ; no
jmp getnb ;yes, bypass and exit
.sbttl listing control
.globl nlist, list
nlist: com r3 ;make r3 -1
list:
asl r3 ;make r3 0/-2
inc r3 ;now 1/-1
1$: call tstarg ;test for another argument
bne 2$ ; valid
tst argcnt ;null, first?
bne list7 ; no, we're through
inc argcnt ;yes, mark it
2$: call getsym ;try for a symbol
scanw lcdrol ;look it up in the table
beq 6$ ; error if not found
clr r2
sec
3$: rol r2
sob r0,3$
tst exmflg ;called from command string?
beq 11$ ; no
bis r2,lcmcsi ;yes, set disable bits
bisbic lcdeft ;change the default values
br 12$ ; and skip test
11$: bit r2,lcmcsi ;this flag off limits?
bne 5$ ; yes
12$: bic r2,lcmask
bit r2,#lc. ;null?
beq 4$ ; no
call pagex ;set listing control
add r3,lclvl ;yes, update level count
beq 5$ ;don't set flag if back to zero
4$: tst r3
bpl 5$ ;.list, branch
bis r2,lcmask
5$: br 1$ ;try for more
6$: error 23,a,<unknown .list/.nlist argument>
list7: return
genswt li,list ;generate /li
genswt nl,nlist ; and /nl switch entries
.globl page
page: inc ffcnt ;simulate ff after this line
pagex: bis #lc.ld,lcflag ;flag as listing directive
return
.macro genlct mne,init ;generate listing control table
lc.'mne= 1
.rept <.-lctbas>/2
lc.'mne= lc.'mne+lc.'mne
.endm
.rad50 /mne/
.if nb <init>
lcinit= lcinit+lc.'mne
.endc
.endm
lcinit= 0
entsec lctsec
lctbas = .
genlct seq
genlct loc
genlct bin
genlct src
genlct com
genlct bex
genlct md
genlct mc
genlct me ,1
genlct meb,1
genlct cnd
genlct ld ,1
genlct ttm,1
genlct toc
genlct sym
genlct < > ;null
xitsec
genswt fl,profl
flsbts= lc.seq!lc.loc!lc.bin!lc.bex!lc.me!lc.meb!lc.toc!lc.sym
profl:
mov #flsbts,lcmcsi
mov #flsbts,lcmask
return
.globl eddflt,ucflag
uc.set::
bis #ed.lc,eddflt
um.set::
inc ucflag
return
.data
.even
ucflag:: .word ; if set, dont do case trnslation in macros
entsec dpure
lcdeft: .word lcinit ; default value for lcmask
xitsec
entsec impure
lcmask: .blkw ;mask bits
lclvl: .blkw ;level count
lcmcsi: .blkw ;command string storage
entsec implin
lcflag: .blkw ;flag bits
lcbegl: .blkw ;pointer to start of line
lcendl: .blkw ;pointer to end of line
lblend: .blkw ;end of label (for parsing)
xitsec
setlc:
mov lcdeft,lcmask ;default flags
clr lclvl
clr lcmcsi
return
.sbttl listing stuff
setpf0: ;set print field zero
sdebug <setpf0>
mov clcfgs,pf0 ;set current location flags
bisb #100,pf0+1 ;assume word
mov clcloc,pf0+2 ;set location
return
setpf1: ;set print field one
mov mode,pf1 ;set mode of current value
bisb #100,pf1+1 ;assume word
mov value,pf1+2
return
entsec implin
pf0: .blkw 2
pf1: .blkw 2
xitsec
endp2l: ;end pass2 listing
call err.pr ; flush out last error message
mov #symtxt,r1
mov #stlbuf,r2
call movbyt ;set "symbol table" sub-title
tstb lstdev ;any listing output?
beq endp2d ; no
bit #lc.sym,lcmask ;symbol table suppression?
bne endp2d ; yes
inc ffcnt ;force new page
clr lppcnt ;force new page
inc pagnum
mov #-1,pagext
clr rolupd ;set for symbol table scan
2$: mov #linbuf,r2 ;point to storage
3$: next symrol ;get the next symbol
beq endp2a ; no more
bit #regflg,mode ;register?
bne 3$ ; yes, don't list
call r50unp ;unpack the symbol
mov #endp2t,r3
call endp2p
mov #mode,r1 ;point to mode bits
bit #defflg,(r1) ;defined?
beq 4$ ; no
call setwrd
br 6$
4$: mov #stars,r1
call movbyt ;undefined, substitute ******
6$: call endp2p
.iif df rsx11d, call endp2x
mov #sector,r1
cmpb #1,(r1)
bge 10$
cmpb -(r1),-(r1)
call setbyt
10$: movb #tab,(r2)+ ;separator
cmp r2,#linbuf+50. ;enough for one line?
blo 3$ ; no
call endp2b ;output line
br 2$ ;next line
endp2a: ; print .psect list
.if ndf xrel
clr rolupd ;set for sector scan
21$: call endp2b ;output line
next secrol ;get the next entry
beq endp2d ; exit if end of roll
movb #'<,(r2)+
call r50unp ;print the name,
movb #'>,(r2)+
movb #tab,(r2)+
mov #value,r1
call setwrd ; the value,
movb #tab,(r2)+
mov #sector-2,r1
call setbyt ; and the entry number
movb #tab,(r2)+
mov #flags-2,r1
call setbyt ; and the attributes
br 21$
.endc
endp2b: clrb (r2)
mov lstdev,lstreq ; we want output
putlin #linbuf
mov #linbuf,r2 ;reset to start of buffer
endp2d: return
endp2p: call endp2x
endp2x: mov (r3)+,r0
bit (r3)+,mode
bne 32$
swab r0
32$: movb r0,(r2)+
return
entsec dpure
endp2t:
.ascii / =/
.word lblflg
.ascii /% /
.word regflg
.ascii /r /
.word relflg
.ascii /g /
.word glbflg
.if df rsx11d
.ascii /x /
.word dfgflg
.endc
.data
stars: .asciz /******/
symtxt: .asciz /symbol table/
xitsec
lst.kb= 1 ;teletype listing
lst.lp= 2 ;lpt listing
xitsec
;
; These routines are high level. They make output go to
; more than one device, they add page headers. The dogsbody
; low guy is 'putli2', who in turn calls on 'o.kblp', which
; interfaces with the file buffering guys directly.
;
putkb: mov #lst.kb,lstreq ;set request
br putlix
putkbl: mov #lst.kb,lstreq ;set for tty
putlp: tst lstflg ;doing a listing?
beq putlix ;no
bisb lstdev,lstreq ;lpt
;
; output a line plain & simple
;
putlix:
call savreg
mov r0,r2
movb lstreq,r4
call putli2
return
putlin: ;output a line with page heading if needed
call savreg ;stack registers
mov r0,r2 ;arg to r2
movb lstreq,r4 ;get request
clr lstreq ;clear it
tst r4
beq 9$ ;just exit if empty
bgt 2$ ;omit header if not listing
dec lppcnt ;yes, decrement count
bgt 2$ ;skip if not time
call putpag
2$:
call err.pr
call putli2 ;print out the line
9$: return
putli2:
movb (r2)+,r1 ;get a char.
beq 21$ ;end on null
call o.kblp ;transmit appropriately
br putli2 ;till null
21$:
movb #lf,r1 ; used to be cr/lf
call o.kblp
bit #lst.kb,r4 ;if sending to cmochn,
beq 9$ ;no
zwrite cmo ;yes, send it now
9$: return
o.kblp: bic #177600,r1 ;just 7 bits, please.
bit #lst.kb,r4 ;cmo on?
beq 1$ ;no
mov #cmochn,r0 ;yes
call putoc
1$: bit #lst.lp,r4 ;lst on?
beq 2$ ;no
mov #lstchn,r0 ;yes
call putoc
2$: return
; put out a page heading
putpag:
;mov #lpp,lppcnt ;reset count
mov #lpp-4,lppcnt ;reset count, compensate for bug introduced
;by rearranging pagination logic
mov r2,-(sp) ;stack current pointer
mov ttlbrk,r2 ;end of pre-set title
tst pass
beq 11$
mov #pagmne,r1
call movbyt ;move "page" into position
mov pagnum,r1
call dnc ;convert to decimal
inc pagext
beq 11$
movb #'-,(r2)+
mov pagext,r1
inc r1
call dnc
11$: clrb (r2)
tst mx.flg ; <<< REEDS june 81
bne 100$
putlp #ttlbuf ;print title
putlp #stlbuf ; sub-title,
100$:
putlp #crlf ; and a blank line
mov (sp)+,r2
return
entsec impure
lstreq: .blkw ;list request flags
lstdev: .blkb 2 ;error(lh), listing(rh)
.data
pagmne: .ascii / page /
crlf: .asciz //
xitsec
.macro putl x ; printf("%s\n", mx.lin)
mov x,mx.tmp
call putl
.endm
putl:
.irpc xx,<012345>
mov r'xx,-(sp)
.endm
mov mx.tmp,r2
mov #lst.lp,r4
call putli2
.irpc xx,<543210>
mov (sp)+,r'xx
.endm
return
putsc:
call savreg
mov mdepth,r4
1$:
movb #';,r1
call mx.put
dec r4
bpl 1$
movb #tab,r1
call mx.put
return
mx.put:
call savreg
mov #lst.lp,r4
bic #177600,r1
mov #lstchn,r0
call putoc
return
mx.mx:
call savreg
tst mx.flg
beq 1$
mov #mx.on,lcmask
tst errbts
beq 3$
putl #mxstar
call err.pr
3$:
tst mx.2 ; is it a .narg, etc. directive?
beq 2$
clr mx.2
tst my.flg
bne 20$
call putsc ; ;.narg frodo
putl #linbuf
20$:
putl #mx.gen ; ; generates:
putl #mx.pxx ; frodo = 5280
br 1$
2$:
tst my.flg ; is it otherwise suppressed & are
bne 1$ ; we listing such?
bit lcmask,lcflag ; anything supppressed?
beq 1$
call putsc
putl #linbuf
1$:
return
err.pr:
call savreg
mov r0,-(sp)
mov r5,-(sp)
tst err.xx
beq 1$
mov #lst.kb,r4
tst lstflg
beq 2$
mov #lst.lp,r4
2$:
mov err.xx,r2
call putli2
clr err.xx
1$:
mov (sp)+,r5
mov (sp)+,r0
return
.bss
mdepth:: .blkw 1
xitsec
entsec mixed
mx.gen:: .asciz /;*** generates:/
mxstar:: .asciz /*** error ***/
mx.pxx: .ascii <tab>
mx.sym:: .ascii /symbol = /
mx.num:: .ascii /65000/
.even
mx.2:: .blkw
mx.tmp: .blkw ; space for putl(arg)
.end