Oakland CPM Archive

home *** CD-ROM | disk | FTP | other *** search

/ Oakland CPM Archive / oakcpm.iso / sigm / vol201 / dprog.mqc / DPROG.MAC

Wrap

Text File | 1985-02-10 | 18.5 KB | 1,125 lines

; ; 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. ; ; ; Basic Equates ; opsys equ 0 fcb equ 5ch tbuff equ 80h cr equ 0dh ff equ 0ch lf equ 0ah ctrlc equ 'C'-'@' ctrls equ 'S'-'@' ctrlz equ 'Z'-'@' bel equ 7 bs equ 8 tab equ 9 ; ; DPROG Constants ; COMMENT equ ';' ;denotes a comment line WORD equ '-' ;denotes a word definition SYM equ '=' ;symbol table dump command DEV equ '>' ;device assignment INP equ '<' ;input forms (pause, string, delay) wordl equ 16 ;length of word fmt equ '(' ;begin format definition fmtch equ '%' ;format escape char endfmt equ ')' ;end format definition quote equ '"' ;quote string literal equ '\' ;literal interpretation follows control equ '^' ;control char follows ; ; SYSLIB Routines ; ext condin,cin,cout,lout,pout ext z3init,pfind,z3log ext moveb,hmovb,logud,pfn1,caps ext f$open,f$read,f$close ext eval,pafdc,pa2hc ext codend ; ; 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 end