;
; PROGRAM: DPROG
; AUTHOR: Richard Conn
; VERSION: 1.0
; DATE: 28 July 84
; PREVIOUS VERSIONS: None
;
vers equ 10
z3env equ 0f400h
;
; DPROG is used to program the user's terminal, printer, or punch
; with data from the file specified in the command line. DPROG will
; automatically search for the file along the path starting at the
; indicated (or implied) DU.
;
;
; Environment Definition
;
if z3env ne 0
;
; External ZCPR3 Environment Descriptor
;
jmp start
db 'Z3ENV' ;This is a ZCPR3 Utility
db 1 ;External Environment Descriptor
z3eadr:
dw z3env
start:
lhld z3eadr ;pt to ZCPR3 environment
;
else
;
; Internal ZCPR3 Environment Descriptor
;
MACLIB Z3BASE.LIB
MACLIB SYSENV.LIB
z3eadr:
jmp start
SYSENV
start:
lxi h,z3eadr ;pt to ZCPR3 environment
endif
;
; Start of Program -- Initialize ZCPR3 Environment
;
call z3init ;initialize the ZCPR3 Env
;
; Initial Routines
;
call helpck ;check for help
call bufinit ;initialize buffers
;
; Load File
;
call locfile ;locate file
call logud ;enter directory of file
call load ;load file
;
; Perform Program
;
call program ;program the user's terminal
ret
;
; Initialize Buffers
;
bufinit:
call codend ;address of free space
shld format ;format string
xchg
lxi h,deffmt ;set default format (char)
mvi b,40 ;allow 40 chars
call moveb
xchg ;HL pts to format buffer
inr h ;next page
shld locstk ;set location stack
shld tos ;set top of stack
mvi m,0
inx h
mvi m,0 ;zero stack
dcx h
inr h ;next page
shld free ;free area
mvi a,'C' ;assign console as output device
sta outdev
ret
;
; Check for Help
;
helpck:
lxi h,fcb+1 ;pt to fcb name
mov a,m ;get it
cpi '/' ;help if slash
rnz
pop psw ;clear stack
call eprint
db 'DPROG, Version '
db (vers/10)+'0','.',(vers mod 10)+'0'
db cr,lf,' Syntax:'
db cr,lf,' DPROG <-- STD.DPG'
db cr,lf,' DPROG filename <-- filename.DPG'
db cr,lf,' DPROG filename.typ <-- filename.typ'
db 0
ret
;
; Find File
; If found, return BC=DU and NZ
;
locfile:
lxi d,fcb ;pt to FCB
call z3log
lxi d,fcb+1 ;pt to file name
lxi h,defname ;pt to default file name
mvi b,8 ;8 chars
ldax d ;any type?
cpi ' ' ;none if space
cz moveb
lxi d,fcb+9 ;pt to file type
lxi h,deftype ;pt to default file type
mvi b,3 ;3 chars
ldax d ;any type?
cpi ' ' ;none if space
cz moveb
lxi d,fcb ;pt to FCB
mvi a,0ffh ;search current
call pfind ;search for file
rnz ;get file if found
;
; Abort Attempt to Load File
;
abort:
pop psw ;clear stack
call eprint
db cr,lf,' File ',0
lxi d,fcb+1 ;pt to file name
call pfn1
call eprint
db ' NOT Found',0
ret
;
; Load File
;
load:
lxi d,fcb ;pt to fcb
call f$open ;open file for input
jnz abort ;abort attempt
lhld free ;buffer area
load1:
lxi d,fcb ;pt to fcb
call f$read ;read next block
jnz load2 ;done, so mark and close
lxi d,tbuff ;copy into buffer
xchg ;copy into buffer at DE from TBUFF at HL
mvi b,128 ;128 bytes
call moveb
lxi h,80h ;pt to next buffer
dad d
jmp load1
load2:
mvi m,ctrlz ;mark EOF
inr h ;next page
mvi l,0
shld words ;mark beginning of word definition area
shld nxtword ;mark next word
mvi m,0 ;mark no words
jmp f$close ;close input file
;
; Program the User's Terminal
;
program:
lhld free ;pt to first char
prog1:
call capa ;capitalize
cpi ctrlz ;done?
rz
cpi CR ;eol?
jz skipl
cpi WORD ;word definition?
jz defword
cpi SYM ;symbol table or format definition dump?
jz dump
cpi DEV ;assign device?
jz device
cpi INP ;input form?
jz input
push h ;save HL
prog2:
call output ;output line at HL
call locpop ;pop stack if any
jnz prog2 ;continue if any element on stack
pop h ;restore HL
;
; Skip to next line
;
skipl:
mov a,m ;get char
call capa ;capitalize
cpi CR ;new line?
jz skipl1
cpi LF ;new line?
jz skipl1
cpi CTRLZ ;EOF?
rz
inx h ;pt to next
jmp skipl
skipl1:
mov a,m ;get it
inx h ;pt to next
ani 7fh ;mask
cpi CR ;continue?
jz skipl1
cpi LF ;continue?
jz skipl1
dcx h ;pt to non-eol char
jmp prog1 ;continue with next line
;
; Input Form
;
input:
inx h ;pt to next char
call cin ;get any char
ani 7fh ;mask
cpi ctrlc ;abort?
jz opsys
jmp skipl ;continue
;
; Assign Device
;
device:
inx h ;pt to char
call capa ;capitalize
cpi 'C' ;console?
jz setdev
cpi 'L' ;list?
jz setdev
cpi 'P' ;punch?
jz setdev
push psw
call eprint
db cr,lf,bel,' Invalid Device Assignment: ',0
pop psw
call cout ;print char
dcx h ;back up
jmp skipl ;continue
;
; Perform assignment
;
setdev:
sta outdev ;assign
jmp skipl ;continue
;
; Define Word
;
defword:
inx h ;pt to first char of word
call bufword ;store word in buffer
shld nextch ;save ptr to next char
call wscan ;scan for word
jz defnew ;new word defined
xchg ;ptr to high-order in DE
lhld nextch ;get ptr to word definition
xchg ;word defn in DE, word adr high in HL
mov m,d ;store new address
dcx h
mov m,e
xchg ;HL pts to word
jmp skipl ;skip out line
;
; New Word
;
defnew:
lhld nxtword ;pt to next word
xchg
lxi h,wordbf ;pt to buffer
mvi b,wordl ;number of chars max
call hmovb ;copy into buffer and advance HL
lhld nextch ;get address
xchg
mov m,e ;put low
inx h
mov m,d ;put high
inx h ;set ptr to next word
mvi m,0 ;store zero
shld nxtword ;set ptr
xchg ;HL pts to word definition
jmp skipl ;skip to next line
;
; Dump Format String or Word Table
;
dump:
inx h ;pt to option
call capa ;check for format display option
cpi 'F' ;format?
jz dfmt ;dump format if so
cpi 'S' ;symbols?
jz dsym
dcx h ;pt to current
call dumpsym ;dump symbols
call dumpfmt ;dump format
jmp skipl ;continue
;
; Dump Format
;
dfmt:
call dumpfmt ;do dump
jmp skipl ;continue
;
; Dump Words
;
dsym:
call dumpsym ;do dump
jmp skipl ;continue
;
; Dump Words in Symbol Table
;
dumpsym:
push h ;save HL
call eprint
db cr,lf,' >> Word Definitions <<',0
lhld words ;dump word table
sym1:
mov a,m ;get next
ora a
jz symexit
call eprint
db cr,lf,' ',0
call prword ;print word
mov e,m ;get low
inx h
mov d,m ;get high
inx h ;pt to next word
push h ;save ptr
call eprint
db ' >',0
xchg ;HL pts to word
sym2:
mov a,m ;get next char
cpi CR ;done?
jz sym3
cpi TAB ;translate tab to space
jnz sym2out
mvi a,' ' ;space instead of tab
sym2out:
call chout
inx h
jmp sym2
sym3:
call eprint
db '<',0
pop h ;pt to next word
jmp sym1
symexit:
pop h ;pt to char
ret
;
; Output Format String
;
dumpfmt:
push h ;save ptr
call eprint
db cr,lf,' Format: (',0
lhld format ;pt to string
call epstr ;print it
call eprint
db ')',cr,lf,0
pop h ;get ptr
ret
;
; Print Word at HL (advance HL)
;
prword:
mvi b,wordl ;number of chars
prw1:
mov a,m ;get char
call chout
inx h
dcr b
jnz prw1
ret
;
; Routine to Output a Line
;
output:
call sksp ;skip spaces
cpi COMMENT ;done?
rz
cpi CR ;done?
rz
cpi LF ;done?
rz
cpi CTRLZ ;done?
rz
cpi fmt ;format definition?
jz outfmt
cpi quote ;chars?
jz outch
call bufword ;store word in buffer
shld nextch ;save ptr to next char after word
call wscan ;scan for word in table
jz badword ;word not defined
call locpush ;push location onto stack
xchg ;HL pts to continuation location
jmp output ;continue
;
; Output Quoted String
;
outch:
inx h ;pt to next char
outch1:
mov a,m ;get it
ani 7fh ;mask
cpi CR ;done?
jz outcherr
cpi LF ;done?
jz outcherr
cpi CTRLZ ;done?
jz outcherr
cpi quote ;end of quote?
jz outch2
call charout ;output char in whatever form
jmp outch1 ;continue
outcherr:
call eprint
db cr,lf,bel,' Premature End of Quote',cr,lf,0
jmp output
outch2:
inx h ;pt to after quote
jmp output ;continue
;
; Output char in A and set HL to next char on exit
;
charout:
cpi control ;control char follows?
jz charo0
cpi literal ;literal follows?
jz charo1
;
; Normal Char in A
;
charnxt:
inx h ;pt to next char
jmp formatout ;output with format
;
; Output control char
;
charo0:
inx h ;pt to char
call capa ;get char
sui '@' ;convert to control
jc ctrlerr
cpi 20h
jnc ctrlerr
inx h ;pt to next
jmp formatout
ctrlerr:
call eprint
db cr,lf,bel,' Invalid Control Character',cr,lf,0
ret
;
; Output Literal Format
;
charo1:
inx h ;pt to char
call capa ;get char
cpi 'B' ;BS?
jz c1bs
cpi 'D' ;DEL?
jz c1del
cpi 'E' ;ESCAPE?
jz c1esc
cpi 'L' ;CRLF?
jz c1nl
cpi 'N' ;LF?
jz c1lf
cpi 'R' ;CR?
jz c1cr
cpi 'T' ;TAB?
jz c1tab
cpi '0' ;digit?
jc charol ;literal if not
cpi '9'+1 ;range?
jc numout
cpi ' ' ;less than space?
jnc charol
call eprint
db cr,lf,bel,' Invalid Literal Argument',cr,lf,0
ret
;
; Output Char in A literally
;
charol:
mov a,m ;get char
ani 7fh ;don't cap this way
inx h ;pt to next
jmp formatout
;
; Output Number
;
numout:
call eval ;convert to binary in DE
mov a,e ;char binary value
jmp formatout ;output with format
;
; Output BS
;
c1bs:
mvi a,bs
jmp charnxt
;
; Output TAB
;
c1tab:
mvi a,tab
jmp charnxt
;
; Output CR
;
c1cr:
mvi a,cr
jmp charnxt
;
; Output DEL
;
c1del:
mvi a,7fh
jmp charnxt
;
; Output ESCAPE
;
c1esc:
mvi a,1bh
jmp charnxt
;
; Output LF
;
c1lf:
mvi a,lf
jmp charnxt
;
; Output CRLF
;
c1nl:
mvi a,cr
call formatout ;output CR
mvi a,lf
jmp charnxt
;
; Output Char in A According to Format
;
formatout:
push h ;save ptr to next char
push b ;save BC
mov b,a ;char in B
lhld format ;pt to format string
fout1:
mov a,m ;get next char
ani 7fh ;mask
jz foutx ;exit if end of string
cpi fmtch ;expression form?
jz fout2
cpi literal ;literal?
jz flit
;
; Output char in A and advance
;
fch:
call chout ;output char
inx h ;pt to next
jmp fout1
;
; Output Value in B according to format
;
fout2:
inx h ;pt to format type
mov a,m ;get char
inx h ;pt to next
ani 7fh ;mask
call caps
ora a ;none?
jz fout1 ;error condition - % at end of string
cpi 'C' ;char?
jz foch
cpi 'D' ;floating decimal chars
jz fod
cpi '2' ;2 decimal chars
jz fo2
cpi '3' ;3 decimal chars
jz fo3
cpi 'X' ;2 hex chars
jz fox
push psw
call eprint
db cr,lf,bel,' Invalid Format Char: ',0
pop psw
call cout
call crlf
jmp fout1 ;continue
;
; Output value in B as char
;
foch:
mov a,b ;get value
call chout ;output it
jmp fout1 ;continue
;
; Output value in B as floating decimal
;
fod:
mov a,b ;get value
call pafdc ;output
jmp fout1 ;continue
;
; Output value in B as hex
;
fox:
mov a,b ;get value
call pa2hc ;output
jmp fout1 ;continue
;
; Output value in B as 3 decimal chars
;
fo3:
mvi c,100 ;100's
call dec ;output and fall thru to FO2
;
; Output value in B as 2 decimal chars
;
fo2:
mvi c,10 ;10's
call dec
mov a,b ;get value
adi '0' ;convert
call chout
jmp fout1 ;continue
;
; Subtracting Output
; Output value in B as 100's or 10's digit (leading 0 allowed)
;
dec:
push d ;save DE
mov a,b ;get value
mvi d,'0' ;set digit
dec1:
sub c ;subtract
jc dec2
inr d ;increment digit
jmp dec1
dec2:
add c ;add back in
mov b,a
mov a,d ;output digit
call chout
pop d ;restore DE
ret
;
; Exit Format String Output
;
foutx:
pop b ;restore BC
pop h ;restore ptr to next char
ret
;
; Literal Format Output
;
flit:
inx h ;pt to char
call capa ;get char
cpi 'B' ;BS?
jz f1bs
cpi 'D' ;DEL?
jz f1del
cpi 'E' ;ESCAPE?
jz f1esc
cpi 'L' ;CRLF?
jz f1nl
cpi 'N' ;LF?
jz f1lf
cpi 'R' ;CR?
jz f1cr
cpi 'T' ;TAB?
jz f1tab
cpi '0' ;digit?
jc fchck ;literal if not
cpi '9'+1 ;range?
jnc fchck
;
; Output Number
;
call eval ;convert to binary in DE
mov a,e ;char binary value
jmp fch ;output
;
; Check for Valid Literal
;
fchck:
cpi ' ' ;not valid if less than space
jnc fch
call eprint
db cr,lf,bel,' Invalid Literal Argument',cr,lf,0
jmp fout1
;
; Output BS
;
f1bs:
mvi a,bs
jmp fch
;
; Output TAB
;
f1tab:
mvi a,tab
jmp fch
;
; Output CR
;
f1cr:
mvi a,cr
jmp fch
;
; Output DEL
;
f1del:
mvi a,7fh
jmp fch
;
; Output ESCAPE
;
f1esc:
mvi a,1bh
jmp fch
;
; Output LF
;
f1lf:
mvi a,lf
jmp fch
;
; Output CRLF
;
f1nl:
mvi a,cr
call chout ;output CR
mvi a,lf
jmp fch
;
; Define New Output Format
;
outfmt:
inx h ;pt to format char
xchg
lhld format ;pt to format area
xchg
;
; Get next char for format string
;
outf1:
mov a,m ;get next char
ani 7fh ;mask
cpi endfmt ;end of format?
jz outf2
cpi CR ;end of line?
jz outf3
cpi LF ;end of line?
jz outf3
cpi CTRLZ ;end of file?
jz outf3
stax d ;store char
inx h ;pt to next
inx d
cpi literal ;literal denotation?
jnz outf1 ;continue if not
;
; Literal flag, so store next char exactly as-is without interpretation
;
mov a,m ;get next char
ani 7fh ;mask
stax d ;store it literally
inx h ;pt to next
inx d
jmp outf1
;
; Format String Stored - Terminate it
;
outf2:
inx h ;pt to next char
outf3:
xra a ;terminate format string
stax d
jmp output
;
; Invalid Word - So State
;
badword:
call eprint
db cr,lf,bel,' Invalid Word Reference: ',0
lxi h,wordbf ;pt to buffer
call prword ;print word
lhld nextch ;continue
jmp output
;
; Element must be a word - resolve it
;
bufword:
lxi d,wordbf ;buffer to store word in
mvi b,wordl ;length
;
; Build Word into WORDBF
;
bword1:
call capa ;get char
cpi ' '+1 ;end?
jc bword3
stax d ;store char
inx h ;pt to next
inx d
dcr b ;count down
jnz bword1
;
; Word is longer than WORDL - skip trailing chars
;
bword2:
mov a,m ;skip chars to delimiter
ani 7fh ;mask
cpi ' '+1
jc bword4
inx h ;pt to next
jmp bword2
;
; Word is built into WORDBF - space fill it
;
bword3:
mvi a,' ' ;space
stax d ;store char
inx d ;pt to next
dcr b ;count down
jnz bword3
;
; Word is Stored
; HL pts to next char after the Word
;
bword4:
ret
;
; Scan for Word in Table
; Return with Zero Set if Not Resolved
; If Resolved, DE=address of word
;
wscan:
lhld words ;pt to first word in table
wscan1:
mov a,m ;abort if empty table
ora a
rz
lxi d,wordbf ;pt to buffer
mvi b,wordl ;size of buffer
push h ;save HL
wscan2:
ldax d ;get char
cmp m ;compare
jnz wscan3
inx h ;pt to next
inx d
dcr b ;count down
jnz wscan2
mov e,m ;get address in DE
inx h
mov d,m
pop psw ;clear stack
xra a ;return NZ
dcr a
ret
wscan3:
pop h ;get address of current word in table
lxi d,wordl+2 ;advance to next word
dad d
jmp wscan1
;
; Push Address in NEXTCH onto Location Stack
;
locpush:
push h ;save regs
push d
lhld nextch ;get address
xchg ;... in DE
lhld tos ;get top of stack
mov m,e ;store address
inx h
mov m,d
inx h
shld tos ;new top of stack
pop d ;restore regs
pop h
ret
;
; Pop Address from Top of Stack
;
locpop:
lhld locstk ;local stack
xchg
lhld tos ;check to see if nothing on stack
mov a,e ;if lows are same, nothing on stack
cmp l
rz
dcx h ;pt to top element
mov d,m ;get high
dcx h
mov e,m ;get low
shld tos ;new top of stack
xchg ;address in HL
xra a ;return with NZ
dcr a
ret
;
; Skip to Non-Space
;
sksp:
mov a,m ;get char
ani 7fh ;mask
call issp ;test for space
rnz ;not space, so return
inx h ;pt to next
jmp sksp
;
; Test char in A for space char
; Ret with Z if yes
;
issp:
push h ;save HL
push b ;save BC
lxi h,sptab ;pt to table
mov b,a ;char in B
issp1:
mov a,m ;get next char
ora a ;end of table?
jz issp3
cmp b ;match?
jz issp2
inx h ;pt to next
jmp issp1
issp2:
mov a,b ;restore char
pop b ;restore regs
pop h
ret ;Z flag is set
issp3:
xra a ;set NZ
dcr a
jmp issp2
;
; Output New Line
;
crlf:
push psw ;save A
mvi a,cr ;CR
call chout
mvi a,lf ;LF
call chout
pop psw ;get A
ret
;
; Output Char in A with XON/XOFF Flow Control
;
chout:
push psw ;save char
call condin ;conditional input
jz chout1
cpi ctrls ;pause?
jnz chout1
call cin ;wait for following char
chout1:
pop psw ;get char
push b ;save BC
mov c,a ;char in C
lda outdev ;get output device
cpi 'C' ;console?
jz chcon
cpi 'L' ;printer?
jz chlst
cpi 'P' ;punch?
jz chpun
;
; Output to Console
;
chcon:
mov a,c ;get char
call cout
pop b
ret
;
; Output to List
;
chlst:
mov a,c ;get char
call lout
pop b
ret
;
; Output to Punch
;
chpun:
mov a,c ;get char
call pout
pop b
ret
;
; Print String Pted to by HL
;
epstr:
mov a,m ;get char
inx h ;pt to next
ani 7fh ;mask MSB
rz ;done
call chout ;print char
jmp epstr
;
; Print String at Return Address
;
eprint:
xthl ;save HL and pt to string
call epstr ;print string
xthl ;restore HL and new exec adr
ret
;
; Input Char, Mask, and Capitalize
;
capa:
mov a,m ;get char
ani 7fh ;mask
jmp caps ;capitalize
;
; Space Table
;
sptab:
db ' ',tab,bs,ff,',','.',0 ;space chars
;
; Data Area
;
defname:
db 'STD ' ;default file name
deftype:
db 'DPG' ;default file type
deffmt:
db '%C',0 ;default format string
outdev:
ds 1 ;output device (C=console, L=list, P=punch)
outdev1:
ds 1 ;save area for output device
wordbf:
ds wordl ;current word buffer
format:
ds 2 ;address of format string
free:
ds 2 ;address of free area
words:
ds 2 ;address of scratch area
nxtword:
ds 2 ;pointer to next word
nextch:
ds 2 ;pointer to next char
locstk:
ds 2 ;pointer to location stack
tos:
ds 2 ;pointer to top of stack
