;--------misc compiler procedures--------------- ; ; ; ;----------------------------------------------- ; get word ; ; returns: ; word - type string ; word.length - integer ; word.type - integer ; 0 - unrecognized ; 1 - identifier (possibly reserved word) ; 2 - string ; 3 - number ; 4 - operator ; 5 - delimiter ;---------------------------------------------------- ; get.word: xra a sta word.length sta minus.word.flag sta word.type sta rsvd.wd.ix ; lxi h,0 shld cnst.value shld cnst.value + 2 ; lda src.char lxi h,word ; cpi '0' jc check.char.further cpi '9'+1 jc word.is.number ; cpi 'A' jc check.char.further cpi 'Z'+1 jc word.is.alpha cpi 'a' jc check.char.further cpi 'z'+1 jc word.is.alpha ; check.char.further: call switch db ' ' ! dw get.word.null db 09h ! dw get.word.null db 0dh ! dw get.word.null db 0ah ! dw get.word.null db '^' ! dw word.is.cnst db 1ah ! dw gw.chk.copy.end db '=' ! dw one.ch.word db '(' ! dw cnst.paren db ')' ! dw one.ch.word db '[' ! dw one.ch.word db ']' ! dw one.ch.word db '{' ! dw skip.comment db '}' ! dw one.ch.word db '*' ! dw one.ch.word db '/' ! dw one.ch.word db '+' ! dw plus.word db '-' ! dw minus.word db '$' ! dw one.ch.word db ':' ! dw one.ch.word db ';' ! dw one.ch.word db '.' ! dw word.is.alpha db '_' ! dw word.is.alpha db '`' ! dw word.is.alpha db ',' ! dw one.ch.word db '!' ! dw one.ch.word db '@' ! dw ptr.word db '#' ! dw lit.label.word db '>' ! dw chk.geq.neq.leq db '<' ! dw chk.geq.neq.leq db '''' ! dw word.is.string db '"' ! dw word.is.string db 0 ! dw inv.input.char ; inv.input.char: lxi h,em.inv.SRC.char call print.error call get.src.char jmp get.word ; ; ; get.word.null: call get.src.char jmp get.word ; ; skip.comment: call get.src.char lda src.char cpi 1ah jz one.ch.word cpi 0dh jz end.skip.comment cpi '}' jnz skip.comment end.skip.comment: call get.src.char jmp get.word ; ; plus.word: mov m,a inx h shld word.cnst.ptr jmp plus.minus.word.common ; ; minus.word: mov m,a inx h shld word.cnst.ptr mvi a,0ffh sta minus.word.flag plus.minus.word.common: call get.src.char lda src.char cpi '^' jz word.is.cnst cpi '0' jc one.ch.word.entry cpi '9'+1 jnc one.ch.word.entry jmp word.is.number ; ; ; gw.chk.copy.end: mov b,a lda copy.nest.count ora a mov a,b jz one.ch.word ; ;---restore source data, etc--- ; lxi d,src.in ;close for MP/M mvi c,16 call entry lxi h,copy.swap.area lxi d,src.in lxi b,copy.move.size call move.h.2.d.cnt.b ; lxi h,copy.nest.count dcr m ; jmp get.word ; ; ; one.ch.word: mov m,a inx h call get.src.char one.ch.word.entry: mvi a,1 sta word.length mvi m,0 jmp get.word.type ; ; ; chk.geq.neq.leq: mov m,a mov b,a inx h call get.src.char lda src.char cpi '=' jnz chk.neq mov m,a two.ch.word.entry: inx h mvi m,0 mvi a,2 sta word.length call get.word.type jmp get.src.char ; ; chk.neq: cpi '>' jnz one.ch.word.entry mov m,a mov a,b cpi '<' jnz one.ch.word.entry jmp two.ch.word.entry ; ; ; ; ptr.word: call get.src.char call get.word call chk.word.id.only mvi a,wtp.ident + wtp.ptr sta word.type ret ; ; ; ; lit.label.word: ;---save sym.tbl entry--- lxi h,symbol.table.entry lxi d,lllw.ste.save lxi b,ste.B.type - ste.A.type call move.h.2.d.cnt.b ; call get.src.char ;---check for '##' --> length of id--- xra a sta length.label.flag lda src.char cpi '#' jnz lit.label.cont ; call get.src.char mvi a,0ffh sta length.label.flag lit.label.cont: call get.word call chk.word.id.only mvi a,wtp.cnst sta word.type call get.var.sym.tbl.entry lhld ste.address lda length.label.flag ora a jz lit.really.label lhld ste.length ;--special check for file, since length not in sym-tbl lda ste.type cpi stet.file jnz lit.really.label lxi h,fcb.rec.buffer + 128 ;rec-mode includes buff in len lda ste.FILE.misc.flag ani FILE.c.flag.rec.mode jnz lit.really.label lxi h,fcb.limit lit.really.label: shld cnst.value lda ste.type cpi stet.end.tbl cz err.undef.label ;---restore sym tbl--- lxi h,lllw.ste.save lxi d,symbol.table.entry lxi b,ste.B.type - ste.A.type jmp move.h.2.d.cnt.b ; length.label.flag: db 0 lllw.ste.save: ds ste.B.type - ste.A.type ; ; ; ; word.is.string: mvi c,0 ;length mov b,a ;save delimiter get.string.word.lup: call get.src.char lda src.char cpi 0dh jz end.string.line cmp b ;ending delim? jz end.string.word cpi '~' jz string.in.hex more.string: mov m,a inx h inr c jmp get.string.word.lup ; string.in.hex: call get.src.char lda src.char cpi '~' jz more.string string.hex.lup: lda src.char cpi '~' jz get.string.word.lup call str.hex.chk jc err.inv.cnst call str.hex.cvt rlc ! rlc ! rlc ! rlc mov e,a call get.src.char lda src.char call str.hex.chk jc err.inv.cnst call str.hex.cvt ora e mov m,a inx h inr c call get.src.char jmp string.hex.lup ; end.string.word: call get.src.char end.string.line: mvi m,0 mvi a,wtp.string sta word.type mov a,c sta word.length cpi 3 rnc lhld word shld cnst.value mvi a,wtp.string + wtp.cnst sta word.type ret ; ; str.hex.chk: cpi '0' rc cpi '9'+1 cmc rnc cpi 'A' rc cpi 'F' + 1 cmc rnc cpi 'a' rc cpi 'f' + 1 cmc ret ; str.hex.cvt: sui '0' cpi 10 rc sui 7 ani 0fh ret ; ; ; word.is.number: push psw shld word.cnst.ptr mvi a,wtp.cnst sta word.type pop psw jmp word.is.cnst.D.entry ; ; word.is.cnst: mov m,a inx h shld word.cnst.ptr mvi a,wtp.cnst sta word.type call get.src.char lda src.char call put.cnst.word.byte cpi 'H' jz word.is.cnst.H cpi 'h' jz word.is.cnst.H cpi 'O' jz word.is.cnst.Q cpi 'o' jz word.is.cnst.Q cpi 'Q' jz word.is.cnst.Q cpi 'q' jz word.is.cnst.Q cpi 'D' jz word.is.cnst.D cpi 'd' jz word.is.cnst.D cpi 'B' jz word.is.cnst.B cpi 'b' jz word.is.cnst.B ; lxi h,em.inv.cnst jmp print.error ; ; word.is.cnst.H: call get.src.char lda src.char call put.cnst.word.byte cpi '0' jc word.is.cnst.end cpi '9'+1 jc word.is.cnst.H.ok cpi 'A' jc word.is.cnst.end cpi 'F'+1 jc word.is.cnst.H.ltr cpi 'a' jc word.is.cnst.end cpi 'f'+1 jnc word.is.cnst.end word.is.cnst.H.ltr: sui 7 word.is.cnst.H.ok: mvi c,4 call shl.value.add.a jmp word.is.cnst.H ; ; word.is.cnst.Q: call get.src.char lda src.char call put.cnst.word.byte cpi '0' jc word.is.cnst.end cpi '7'+1 jnc word.is.cnst.end mvi c,3 call shl.value.add.a jmp word.is.cnst.Q ; ; word.is.cnst.B: call get.src.char lda src.char call put.cnst.word.byte cpi '0' jc word.is.cnst.end cpi '1'+1 jnc word.is.cnst.end mvi c,1 call shl.value.add.a jmp word.is.cnst.B ; ; word.is.cnst.D: call get.src.char lda src.char word.is.cnst.D.entry: cpi '0' jc word.is.cnst.end cpi '9'+1 jnc word.is.cnst.end call put.cnst.word.byte push psw lhld cnst.value shld cnst.value.save lhld cnst.value + 2 shld cnst.value.save + 2 mvi a,'0' mvi c,2 call shl.value.add.a ; lhld cnst.value.save xchg lhld cnst.value dad d shld cnst.value ; lhld cnst.value.save + 2 xchg lhld cnst.value + 2 mvi a,0 adc l mov l,a mvi a,0 adc h mov h,a dad d shld cnst.value + 2 pop psw mvi c,1 call shl.value.add.a jmp word.is.cnst.D ; ; word.is.cnst.end: lda minus.word.flag ora a jz word.cnst.end.plus ; lhld cnst.value call negate.hl shld cnst.value word.cnst.end.plus: xra a ; ; ; put.cnst.word.byte: push h lhld word.cnst.ptr mov m,a inx h shld word.cnst.ptr lxi h,word.length inr m pop h ret ; ; ; ; cnst.paren: call get.src.char call get.word lda word.type ani wtp.cnst jz err.inv.cnst ; lhld cnst.value push h call get.word pop h ; cnst.paren.chk.rpar: lda rsvd.wd.ix cpi rwix.rpar jnz cnst.paren.not.rpar shld cnst.value mvi a,wtp.cnst sta word.type ret ; cnst.paren.not.rpar: push h lda word.type ani wtp.oprtr jnz cnst.paren.got.oprtr lda word.type ani wtp.cnst pop h jz err.inv.cnst push h mvi a,rwix.plus push psw jmp cnst.paren.dflt ; cnst.paren.got.oprtr: lda rsvd.wd.ix push psw call get.word cnst.paren.dflt: lda word.type ani wtp.cnst pop h pop d jz err.inv.cnst push d push h lhld cnst.value push h call get.word pop d pop psw pop h ; cpi rwix.plus jz cnst.paren.plus cpi rwix.minus jz cnst.paren.minus cpi rwix.star jz cnst.paren.star cpi rwix.slash jz cnst.paren.slash cpi rwix.AND jz cnst.paren.AND cpi rwix.OR jz cnst.paren.OR cpi rwix.XOR jz cnst.paren.XOR cpi rwix.MAX jz cnst.paren.MAX cpi rwix.MIN jz cnst.paren.MIN cpi rwix.MOD jz cnst.paren.MOD jmp err.inv.cnst ; cnst.paren.plus: dad d jmp cnst.paren.chk.rpar ; cnst.paren.minus: call sub.de.fm.hl.2.hl jmp cnst.paren.chk.rpar ; cnst.paren.star: call mul.h.by.d.2.h jmp cnst.paren.chk.rpar ; cnst.paren.slash: xchg call div.d.by.h.2.d.r.h xchg jmp cnst.paren.chk.rpar ; cnst.paren.MAX: call cmp.de.fm.hl jnc cnst.paren.chk.rpar xchg jmp cnst.paren.chk.rpar ; cnst.paren.MIN: call cmp.de.fm.hl jc cnst.paren.chk.rpar xchg jmp cnst.paren.chk.rpar ; cnst.paren.MOD: xchg call div.d.by.h.2.d.r.h jmp cnst.paren.chk.rpar ; cnst.paren.AND: call AND.d.and.h jmp cnst.paren.chk.rpar ; cnst.paren.OR: call OR.d.and.h jmp cnst.paren.chk.rpar ; cnst.paren.XOR: call XOR.d.and.h jmp cnst.paren.chk.rpar ; ; ; ; ; ; ; shl.value.add.a: push psw svaa.lup: ora a lxi h,cnst.value mov a,m ral mov m,a inx h mov a,m ral mov m,a inx h mov a,m ral mov m,a inx h mov a,m ral mov m,a dcr c jnz svaa.lup pop psw ani 0fh lxi h,cnst.value add m mov m,a inx h mvi a,0 adc m mov m,a inx h mvi a,0 adc m mov m,a inx h mvi a,0 adc m mov m,a ret ; ; ; ; ; ; ; ; ; ;---alpha word (identifier) ;---must start with letter ;---may contain 0-9,A-Z,a-z,`,_,. ; word.is.alpha: mov m,a inx h mvi c,1 alpha.word.lup: call get.src.char lda src.char cpi '.' jz more.alpha.word cpi '0' jc end.alpha.word cpi '9'+1 jc more.alpha.word cpi 'A' jc end.alpha.word cpi 'Z'+1 jc more.alpha.word cpi '_' jc end.alpha.word cpi 'z'+1 jc more.alpha.word end.alpha.word: mvi m,0 mov a,c sta word.length jmp get.word.type more.alpha.word: mov m,a inx h inr c jmp alpha.word.lup ; ; ; ; ; get.word.type: call lookup.reserved.word ; lda rsvd.wd.ix cpi rwix.TRUE jz gwt.TRUE cpi rwix.FALSE jz gwt.FALSE ora a jz gwt.lukup.rsvd lda limit.word.flag ora a rnz ;don't lookup rvsd-wd in sym-tbl gwt.lukup.rsvd: ; call lookup.word lhld wk.sym.tbl.addr mov a,m cpi stet.SET.cnst jz gwt.cnst cpi stet.SET.word jz gwt.word.SET ; lda word.type cpi wtp.unreq rnz ; mvi a,wtp.ident sta word.type ret ; ; gwt.word.SET: lxi d,ste.address - ste.type + 1 dad d mov a,m sta word.type dcx h mov a,m sta rsvd.wd.ix cpi rwix.NULL jz get.word ret ; ; gwt.TRUE: mvi a,wtp.ident + wtp.cnst sta word.type lxi h,0ffffh shld cnst.value jmp gwt.T.F.move.word ; ; gwt.FALSE: mvi a,wtp.ident + wtp.cnst sta word.type lxi h,0 shld cnst.value gwt.T.F.move.word: lxi h,ste.name lxi d,word call move.string lda ste.length sta word.length ret jmp gwt.set.word ; ; ; gwt.cnst: mvi a,wtp.cnst + wtp.string sta word.type lhld wk.sym.tbl.addr lxi d,ste.address - ste.type dad d mov e,m inx h mov d,m xchg shld cnst.value shld word xra a sta word + 2 ret ; ; gwt.set.word: lxi h,ste.name lxi d,word call move.string lda ste.length sta word.length ; cpi 3 rnc ; lhld word shld cnst.value mvi a,wtp.string + wtp.cnst sta word.type ret ; ; ; chk.word.id.only: lda word.type ani wtp.ident rnz jmp err.expect.id ; ; ; chk.not.blk.ender: lda rsvd.wd.ix cpi rwix.ELSE rz cpi rwix.END rz cpi rwix.ENDREC rz cpi rwix.ENDREDEF rz cpi rwix.ENDSWITCH rz cpi rwix.end.of.source rz cpi rwix.FI rz cpi rwix.OD rz cpi rwix.UNTIL ret ; ; ; ; ; ;----------------------------------------------- ; ; R E S E R V E D W O R D ; L O O K U P ; ;----------------------------------------------- ; ; ; ; ; ;---if word has any upper-case letters in it, ;---convert it to lower-case and check for a ;---match in reserved-word table. ; lookup.reserved.word: lxi h,word lxi d,word.save call move.string lxi h,word call cvt.str.to.lower.case call do.rsvd.lukup lxi h,word.save lxi d,word jmp move.string ; ; ; do.rsvd.lukup: mvi a,wtp.unreq sta word.type mvi a,rwix.not.rsvd sta rsvd.wd.ix mvi c,0 ;ix ctr lxi h,reserved.word.table drl.nxt.word: inr c lxi d,word mov a,m ora a rz ;end of table - not found drl.nxt.char: ldax d cmp m jnz drl.skip.word inx h inx d ora a jnz drl.nxt.char ;---found match--- mov a,c sta rsvd.wd.ix mov a,m sta word.type ret ; drl.skip.word: mov a,m ora a jz drl.skip.tween inx h jmp drl.skip.word ; drl.skip.tween: inx h inx h jmp drl.nxt.word ; ;---------------------------------- ; switch.A: lda ste.A.type jmp switch ; switch.B: lda ste.B.type jmp switch ; switch.C: lda ste.C.type jmp switch ; switch.rsvd.wd.ix: lda rsvd.wd.ix jmp switch ; switch.expr.oprtr: lda curr.expr.oprtr switch: xthl push psw push b mov c,a switch.lup: mov a,m inx h ora a jz switch.match cmp c jz switch.match inx h inx h jmp switch.lup ; switch.match: mov a,m inx h mov h,m mov l,a pop b pop psw xthl ret ; ; ;---------------------------------------- ; compare.sym.tbl.entries: mvi c,ste.name - symbol.table.entry cste.lup: ldax d cmp m rnz inx h inx d dcr c jnz cste.lup jmp compare.strings ; ;--------------------------------------- ; ; get.var.A.word: call get.var.sym.tbl.entry lda word.type sta A.word.type sta gvx.word.type lhld cnst.value shld gvx.cnst.value lxi h,word lxi d,gvx.word call move.string call get.word lda rsvd.wd.ix cpi rwix.lbrckt cz gvx.override lxi d,sym.tbl.entry.A lda A.word.type jmp gvx.mv.sym ; ; get.var.B.word: call get.var.sym.tbl.entry lda word.type sta B.word.type sta gvx.word.type lhld cnst.value shld gvx.cnst.value lxi h,word lxi d,gvx.word call move.string call get.word lda rsvd.wd.ix cpi rwix.lbrckt cz gvx.override lxi d,sym.tbl.entry.B lda B.word.type jmp gvx.mv.sym ; ; get.var.C.word: call get.var.sym.tbl.entry lda word.type sta C.word.type sta gvx.word.type lhld cnst.value shld gvx.cnst.value lxi h,word lxi d,gvx.word call move.string call get.word lda rsvd.wd.ix cpi rwix.lbrckt cz gvx.override lxi d,sym.tbl.entry.C lda C.word.type ; ; gvx.mv.sym: sta gvx.word.type lxi h,symbol.table.entry push d call move.sym.tbl.entry pop d lda gvx.word.type ani wtp.cnst jz gvx.not.cnst ; mvi a,stet.spcl.cnst stax d push d lxi h,(ste.address - symbol.table.entry) dad d xchg lhld gvx.cnst.value shld cnst.value xchg mov m,e inx h mov m,d pop d jmp gvx.move.word ; gvx.not.cnst: lda gvx.word.type ani wtp.string jz gvx.not.lit.str ; mvi a,stet.spcl.lit.str stax d ; gvx.move.word: push d lxi h,(ste.name - symbol.table.entry) dad d xchg lxi h,gvx.word call move.string lxi d,gvx.word call sub.de.fm.hl.2.hl xchg pop b lxi h,(ste.length - symbol.table.entry) dad b mov m,e inx h mov m,d ret ; gvx.not.lit.str: lda gvx.word.type ani wtp.ptr jz gvx.not.ptr ; ldax d cpi stet.word.ptr jz gvx.WP cpi stet.byte.ptr jz gvx.BP cpi stet.string.ptr jz gvx.SP cpi stet.BCD.ptr jz gvx.BCDPTR jmp err.inv.ptr.var ; gvx.SP: mvi a,stet.spcl.string.ptr stax d ret ; gvx.BP: mvi a,stet.spcl.byte.ptr stax d ret ; gvx.WP: mvi a,stet.spcl.word.ptr stax d ret ; gvx.BCDPTR: mvi a,stet.spcl.bcd.ptr stax d ret ; ; gvx.not.ptr: push d lxi d,gvx.word call lookup.word.at.d pop d lhld wk.sym.tbl.addr mov a,m call switch db stet.SET.cnst ! dw gvx.SET.cnst db stet.byte.ptr ! dw gvx.make.WORD db stet.word.ptr ! dw gvx.make.WORD db stet.string.ptr ! dw gvx.make.WORD db stet.BCD.ptr ! dw gvx.make.WORD db 0 ! dw gvx.not.ptr.exit gvx.not.ptr.exit: ret ; gvx.SET.cnst: mvi a,stet.spcl.cnst stax d lxi h,(ste.address - symbol.table.entry) dad d mov e,m inx h mov d,m xchg shld cnst.value ret ; gvx.make.WORD: mvi a,stet.WORD stax d ret ; ; ; ;----------------------------------------------- ; process variable-name overrides ;----------------------------------------------- ; gvx.override: lda word.type ani wtp.cnst + wtp.string jnz gvx.override.lup lda ste.type cpi stet.end.tbl cz err.undef.var gvx.override.lup: call get.word lda word.type ani wtp.cnst jnz gvxo.offset ; call switch.rsvd.wd.ix db rwix.comma ! dw gvx.override.lup db rwix.plus ! dw gvxo.plus db rwix.minus ! dw gvxo.minus db rwix.BCD ! dw gvxo.BCD db rwix.BCDPTR ! dw gvxo.BCDP db rwix.BIT ! dw gvxo.BIT db rwix.BP ! dw gvxo.BP db rwix.WORD ! dw gvxo.WORD db rwix.BYTE ! dw gvxo.BYTE db rwix.FIELD ! dw gvxo.FIELD db rwix.LENGTH ! dw gvxo.LENGTH db rwix.RECORD ! dw gvxo.RECORD db rwix.SP ! dw gvxo.SP db rwix.STRING ! dw gvxo.STRING db rwix.WP ! dw gvxo.WP db rwix.rbrckt ! dw gvxo.rbrckt db 0 ! dw err.inv.override gvxo.rbrckt: call get.word lda rsvd.wd.ix cpi rwix.lbrckt jz gvx.override.lup ret ; ; gvxo.plus: call get.word lda word.type ani wtp.cnst jz err.inv.cnst gvxo.offset: lhld cnst.value xchg lhld ste.address dad d shld ste.address lda ste.type call switch db stet.RECORD ! dw gvxo.offset.length db stet.FIELD ! dw gvxo.offset.length db stet.STRING ! dw gvxo.offset.length db 0 ! dw gvx.override.lup ; gvxo.offset.length: lhld cnst.value call negate.HL xchg lhld ste.length dad d shld ste.length jmp gvx.override.lup ; ; gvxo.minus: call get.word lda word.type ani wtp.cnst jz err.inv.cnst lhld cnst.value call negate.HL shld cnst.value jmp gvxo.offset ; ; gvxo.BCD: mvi a,stet.BCD jmp gvxo.general.type ; ; gvxo.BCDP: mvi a,stet.BCD.ptr jmp gvxo.general.pointer ; ; gvxo.BIT: call get.word lda rsvd.wd.ix cpi rwix.colon cz get.word lda word.type ani wtp.cnst jz err.inv.cnst ; mvi a,stet.BIT sta ste.type lda cnst.value sta ste.BIT.posn jmp gvx.override.lup ; ; gvxo.BP: mvi a,stet.byte.ptr gvxo.general.pointer: sta ste.type lda gvx.word.type ani wtp.ptr cz err.inv.override jmp gvx.override.lup ; ; gvxo.BYTE: mvi a,stet.BYTE gvxo.general.type: sta ste.type lda gvx.word.type ani wtp.ptr cnz err.inv.override jmp gvx.override.lup ; ; gvxo.LENGTH: call get.word lda word.type ani wtp.cnst jz err.inv.override lhld cnst.value shld ste.length jmp gvx.override.lup ; ; gvxo.RECORD: mvi a,stet.RECORD jmp gvxo.general.type ; ; gvxo.SP: mvi a,stet.string.ptr jmp gvxo.general.pointer ; ; gvxo.STRING: mvi a,stet.STRING jmp gvxo.general.type ; ; gvxo.WORD: mvi a,stet.WORD jmp gvxo.general.type ; ; gvxo.WP: mvi a,stet.word.ptr jmp gvxo.general.pointer ; ; gvxo.FIELD: mvi a,stet.FIELD jmp gvxo.general.type ; ; ; ; ; ; ;-------------------------------------------------- ;-------------get symbol-table entry for word------- ;-------------------------------------------------- ; get.var.sym.tbl.entry: lhld start.sym.tbl.addr gvste.sym.entry.lup: shld wk.sym.tbl.addr mov a,m cpi stet.end.tbl jz get.sym.tbl.entry ;not found lxi b,(ste.name - symbol.table.entry) dad b cpi stet.deleted jnc gvste.skip.sym.lup cpi stet.fwd.ref jz gvste.skip.sym.lup push h lxi d,word call compare.strings pop h jz get.sym.tbl.entry ;found -- move to w/a gvste.skip.sym.lup: mov a,m inx h ora a jnz gvste.skip.sym.lup jmp gvste.sym.entry.lup ; ;---------------------------------- ; chk.word.not.in.tbl: call get.var.sym.tbl.entry lda ste.type cpi stet.end.tbl rz lxi h,ste.block.level lda curr.block.level cmp m rnz jmp err.dupl.name ; ; ; ; ; ; ; ;---lookup word in symbol table--- ; ; in: word ; ; out: wk.sym.tbl.addr ; ; lookup.word: lxi d,word lookup.word.at.d: lhld start.sym.tbl.addr lkp.sym.entry.lup: shld wk.sym.tbl.addr mov a,m cpi stet.end.tbl rz ;---not found lxi b,(ste.name - symbol.table.entry) dad b push d push h call compare.strings pop h pop d rz lkp.skip.sym.lup: mov a,m inx h ora a jnz lkp.skip.sym.lup jmp lkp.sym.entry.lup ; ; ;----get backwards symbol table entry----- ; (used for symbol table cleanup at block-end) ; returns symbol table entries in reverse order ; skips deleted entries ; ; in: prev.sym.tbl.addr ; start.sym.tbl.addr ; wk.sym.tbl.addr ; start.wk.sym.tbl.addr ; ; out: prev.sym.tbl.addr ; Carry = 1 indicates no more ; get.backwards: lhld prev.sym.tbl.addr xchg lhld start.sym.tbl.addr call cmp.de.fm.hl jz get.backwards.finish ; call init.sym.tbl.srch get.backwards.lup: lhld prev.sym.tbl.addr xchg lhld wk.sym.tbl.addr call cmp.de.fm.hl jnc get.backwards.endloop ; call get.sym.tbl.entry jmp get.backwards.lup ; get.backwards.endloop: lhld start.wk.sym.tbl.addr shld prev.sym.tbl.addr ora a ret ; get.backwards.finish: stc ret ; ;; ; ;---squish symbol table----- ; ; called at end-of-block to clean-up symbol table ; removes local data from previous block, and ; temporary labels, &c. generated by the compiler ; squish.sym.tbl: lda curr.block.level ora a rz ;skip final squish call init.sym.tbl.srch squish.get.start: call get.sym.tbl.entry lda ste.type cpi stet.end.tbl rz ; lda ste.block.level mov c,a lda curr.block.level cmp c jc squish.get.start ; lhld start.wk.sym.tbl.addr shld prev.sym.tbl.addr shld curr.sym.tbl.bottom ; squish.lup: call get.backwards jc squish.finished ; lda ste.type cpi stet.deleted jnc squish.lup ; lhld start.wk.sym.tbl.addr lxi d,ste.name - ste.type dad d xchg call size.d.2.h lxi b,ste.name - ste.type dad b inx h ;past terminator inx d mov b,h mov c,l lhld curr.sym.tbl.bottom xchg call move.bkwds.h.2.d.cnt.b xchg shld curr.sym.tbl.bottom jmp squish.lup ; squish.finished: lhld curr.sym.tbl.bottom shld start.sym.tbl.addr ret ; ; ; ; ; ; ;---------------------------------------------------- ; ; M I S C. C O D E - G E N E R A T I O N ; S U P P O R T R O U T I N E S ; ;---------------------------------------------------- ; ; ; chk.strt.data: lda redef.ctr ora a jnz csd.fini ; lda data.started.this.blk ora a jnz csd.fini mvi a,0ffh sta data.started.this.blk lda code.started.this.blk ora a jz csd.data.ok call err.data.after.code jmp csd.fini csd.data.ok: mvi a,bir.1st.code call put.bir.jmp.fwd jmp csd.new.addr csd.fini: lhld curr.print.addr mov a,h ora l rnz csd.new.addr: lhld curr.code.addr shld curr.print.addr ret ; ; ; chk.strt.code: call set.byte.boundary lda code.started.this.blk ora a jnz csc.fini mvi a,0ffh sta code.started.this.blk lda data.started.this.blk ora a jz csc.fini mvi a,bir.1st.code call fix.up.built.in.rtn csc.fini: lhld curr.print.addr mov a,h ora l rnz lhld curr.code.addr shld curr.print.addr ret ; ; ; bump.block.level: xra a sta ste.name mvi a,stet.level.marker sta ste.type lda curr.block.level sta ste.block.level ; lhld curr.ovl.start.key lda overlay.in.process ora a jnz bbl.is.ovl lxi h,0ffffh bbl.is.ovl: shld ste.ovl.key ; call move.entry.to.sym.tbl lxi h,curr.block.level inr m ret ; ; ; decr.block.level: lxi h,curr.block.level dcr m mov a,m inr a jnz decr.bl.delete lxi h,em.blk.lvl.ofl call print.error ; decr.bl.delete: call init.sym.tbl.srch dbd.lup: call get.sym.tbl.entry lhld start.wk.sym.tbl.addr lda ste.type cpi stet.end.tbl rz cpi stet.blk.scope.limit jnc dbd.lup cpi stet.level.marker jz dbd.end mov a,m ori stet.deleted mov m,a jmp dbd.lup ; dbd.end: mov a,m ori stet.deleted mov m,a ret ; ; ; set.byte.boundary: lda curr.BIT.posn cpi 80h jz set.byte.bndry.clr mvi a,80h sta curr.bit.posn lda curr.BIT.build call put.code.byte set.byte.bndry.clr: xra a sta curr.BIT.build ret ; ; ; chk.stk.overflow: lxi h,0 dad sp lxi d,base.stk.addr + 10 call cmp.hl.fm.de rc call err.L.stk.ofl jmp MAIN.end.pgm ; ;------------------------------------------------------ ; debugging routine ;------------------------------------------------------ ; debug.routine: ; lda print.console mov c,a lda print.flag mov b,a push b ; lda print.printer.flag mov c,a lda print.disk.flag mov b,a push b ; mvi a,0ffh sta print.console sta print.flag ; xra a sta print.disk.flag lda dbg.print.flag sta print.printer.flag ; lda debug.sngl.step.flag ora a jnz debug.go ; mvi c,11 call entry ora a jz debug.return debug.go: call listing.crlf lxi d,word call listing.string.out debug.lup: call listing.crlf lxi d,debug.prompt call listing.string.out call con.ch.in ani 5fh ;upper case cpi 'E' jz debug.exit ; cpi 03 ;^C jz boot cpi 'T' jz debug.sym.tbl cpi 'S' jz debug.sngl.step cpi 'D' jz debug.ddt cpi 'P' jz debug.print debug.exit: lhld err.ctr lxi d,pst.line.wk call cvt.bin.2.dec.str call listing.crlf lxi d,pst.line.wk call listing.string.out lxi d,dbg.txt.err call listing.string.out lxi d,last.label call listing.string.out call listing.crlf ; ; debug.return: pop b mov a,b sta print.disk.flag mov a,c sta print.printer.flag ; pop b mov a,b sta print.flag mov a,c sta print.console ret ; dbg.txt.err: db ' errors ',0 ; ; ; ; debug.print: lda dbg.print.flag cma sta dbg.print.flag sta print.printer.flag lxi d,dbg.prt.msg jmp dbg.off.on ; ; ; debug.sngl.step: lda debug.sngl.step.flag cma sta debug.sngl.step.flag lxi d,dbg.sngl.step.msg dbg.off.on: push psw call listing.string.out pop psw ora a jz dbg.sngl.off lxi d,dbg.sngl.on.msg jmp dbg.sngl.msg dbg.sngl.off: lxi d,dbg.sngl.off.msg dbg.sngl.msg: call listing.string.out jmp debug.lup ; dbg.sngl.step.msg: db 'single step ',0 dbg.prt.msg: db 'debug print ',0 dbg.sngl.on.msg: db 'on',0 dbg.sngl.off.msg: db 'off',0 debug.sngl.step.flag: db 0 dbg.print.flag: db 0 ; ; ; debug.ddt: rst 7 ; ; ; ; debug.prompt: db '-',0 ; ; ; ; debug.sym.tbl: call init.sym.tbl.srch call listing.crlf debug.st.lup: call get.sym.tbl.entry call print.sym.tbl.entry call con.ch.in ani 5fh cpi 'E' jz debug.go jmp debug.st.lup ; ; ; ; ; ; set.up.src.fcb: lxi h,sctr.size * src.buf.sctrs shld src.buf.ix xra a sta src.in+fcb.ext.num sta src.in+fcb.cur.rec ret ; ; ; get.src.char: push b push d push h lhld src.buf.ix lxi d,sctr.size * src.buf.sctrs call cmp.hl.fm.de jnz src.ch.fm.buf lxi h,0 shld src.buf.ix mvi b,src.buf.sctrs lxi h,src.buffer src.rd.lup: push b push h xchg mvi c,26 call entry mvi c,20 ;read lxi d,src.in call entry push psw lxi d,dflt.dma mvi c,26 call entry pop psw pop h pop b ora a jnz src.eof lxi d,sctr.size dad d dcr b jnz src.rd.lup jmp src.ch.fm.buf src.eof: cpi 3 jnc abort.src.err mvi c,sctr.size make.src.eof: mvi m,1ah inx h dcr c jnz make.src.eof src.ch.fm.buf: lxi d,src.buffer lhld src.buf.ix inx h shld src.buf.ix dcx h dad d mov a,m ani 7fh sta src.char ; ;---put char into print buffer--- ; cpi 09h jz prt.tab cpi 0ah jz gsc.exit ; cpi 1ah ;don't print eof char jz gsc.exit ; lhld print.line.ix mov m,a inx h shld print.line.ix lda curr.print.colm inr a sta curr.print.colm ; lda src.char cpi 0dh jnz gsc.exit ; ;---end of line --- print if needed ----- ; mvi m,0ah inx h mvi m,0 xra a sta curr.print.colm ; lxi h,print.line shld print.line.ix ; ;-----don't print if 'PRINT OFF' is in effect----- ; lda print.on.off.flag cpi rwix.OFF jz gsc.exit.count.line ; lda print.flag ora a jnz print.yes lda error.this.line ora a jz gsc.exit.count.line print.yes: ; ;--- check for block match --- ; lda print.blk.match.flag ora a jz print.blk.mtch.end ; lhld curr.block.match mov a,h ora l jnz print.yes.blk.mtch ; mvi c,6 call print.out.c.blanks jmp print.blk.mtch.end ; print.yes.blk.mtch: lxi d,decimal.work call cvt.bin.2.dec.str lxi d,decimal.work call size.d.2.h mvi a,5 sub l mov c,a call print.out.c.blanks lxi d,decimal.work call listing.string.out mvi e,' ' call print.out print.blk.mtch.end: ; ;--- check for block level --- ; lda print.blk.lvl.flag ora a jz print.blk.lvl.end ; lhld curr.block.level mvi h,0 lxi d,decimal.work call cvt.bin.2.dec.str lxi d,decimal.work call size.d.2.h mvi a,2 sub l mov c,a call print.out.c.blanks lxi d,decimal.work call listing.string.out mvi e,' ' call print.out print.blk.lvl.end: ; ;---check for address --- ; lda print.code.addr.flag ora a jz print.code.addr.end ; lhld curr.print.addr mov a,h ora l jnz print.yes.code.addr ; mvi c,5 call print.out.c.blanks jmp print.code.addr.end ; print.yes.code.addr: lxi d,decimal.work call cvt.bin.2.hex.str lxi d,decimal.work call listing.string.out mvi e,' ' call print.out print.code.addr.end: ; ;--- check if to print line number --- ; lda print.line.num.flag ora a jz print.line.num.end ; lhld curr.src.line.num lxi d,decimal.work call cvt.bin.2.dec.str prt.lin.no.lup: lxi d,decimal.work call size.d.2.h mov a,l cpi 5 jnc prt.lin.no.ok lxi h,decimal.work + 7 lxi d,decimal.work + 8 lxi b,7 call move.bkwds.h.2.d.cnt.b lda copy.nest.count ora a mvi a,' ' jz prt.lin.sp mvi a,'0' prt.lin.sp: sta decimal.work jmp prt.lin.no.lup prt.lin.no.ok: lda copy.nest.count ora a jz prt.lin.no.go ori 40h ;show copy level "A", "B", etc. sta decimal.work prt.lin.no.go: lxi d,decimal.work call listing.string.out mvi e,' ' call print.out print.line.num.end: ; ;--- reset stuff --- ; xra a sta error.this.line lxi h,0 shld curr.print.addr shld curr.block.match lxi d,print.line call listing.string.out lhld print.line.ctr inx h shld print.line.ctr ; gsc.exit.count.line: lhld curr.src.line.num inx h shld curr.src.line.num jmp gsc.exit ; ; abort.src.err: lxi h,txt.src.rd.err mvi c,9 call entry jmp boot ; ; prt.tab: mvi a,' ' lhld print.line.ix mov m,a inx h shld print.line.ix lhld print.tab.mask lda curr.print.colm inr a sta curr.print.colm ana l jnz prt.tab ; ;fall into gsc.exit ; ; gsc.exit: pop h pop d pop b lda src.char ret ; ; ; debug.st.end: jmp listing.crlf ; ; ; ;---------------------------------------------- ; ; ; ; ; ;-------------------------------------- ; ; put.bir.jmp.fwd: lhld word ;save bir type push h sta word xra a sta word + 1 call put.JMP call put.fwd.ref.addr pop h shld word ret ; ; ;----------------------------------- ; ; put.word.addr: call lookup.word lhld wk.sym.tbl.addr mov a,m cpi stet.end.tbl jz put.fwd.ref.addr cpi stet.fwd.ref jz put.fwd.ref.addr lxi d,(ste.address - ste.type) dad d mov e,m inx h mov d,m xchg jmp put.code.word ; ; ;---------------------------------- ; ; put.inline.A.string: mvi a,stet.string sta ste.A.type call put.JMP lhld curr.code.addr lda ste.A.length mov e,a mvi d,0 dad d inx h inx h call put.code.word lhld curr.code.addr shld ste.A.address ; lhld ste.A.length mov b,h mov c,l lxi h,ste.A.name jmp put.code.block ; ; ;--------------------------------- ; ; put.inline.B.string: mvi a,stet.string sta ste.B.type call put.JMP lhld curr.code.addr lda ste.B.length mov e,a mvi d,0 dad d inx h inx h call put.code.word lhld curr.code.addr shld ste.B.address ; lhld ste.B.length mov b,h mov c,l lxi h,ste.B.name jmp put.code.block ; ; ;---------------------------------- ; ; put.inline.BCD: mvi m,stet.BCD push h lxi d,ste.name - ste.type dad d lxi d,bcd.cnst.value.wk call cvt.str.2.bcd ; call put.JMP lhld curr.code.addr lxi d,bcd.size + 2 dad d call put.code.word ; lhld curr.code.addr xchg pop h lxi b,ste.address - ste.type dad b mov m,e inx h mov m,d ; lxi b,bcd.size lxi h,bcd.cnst.value.wk jmp put.code.block ; ; ;------------------------------------ ; ; ; ; ; ; ; ;--------------------------------------- ; ; swap.A.B.sym.entries: lda A.word.type mov l,a lda B.word.type sta A.word.type mov a,l sta B.word.type ; lxi h,sym.tbl.entry.A lxi d,symbol.table.entry call move.sym.tbl.entry ; lxi h,sym.tbl.entry.B lxi d,sym.tbl.entry.A call move.sym.tbl.entry ; lxi h,symbol.table.entry lxi d,sym.tbl.entry.B jmp move.sym.tbl.entry ; ; ; ; ;--------------------------------- ; put code block ; ; in: hl -> code ; bc = # bytes ; put.code.block: mov a,b ora c rz mov a,m inx h push h push b call put.code.byte pop b pop h dcx b jmp put.code.block ; ; ; ; ; ; ; ; ; ; ;================================================================= ; ; INTERMEDIATE-LEVEL OBJECT-CODE OUTPUT ROUTINES ; ; AN = word A cnst ; A8 = word A byte ; A16 = word A word ; ABP = word A byte-pointer ; AWP = word A word-pointer ; similar for B8,B16,BBP,BWP,etc ; ;================================================================= ; ; ; ; ; ; put.add.2.A16.B8: call err.truncate put.add.2.A8.B8: call put.LDA.A put.add.2.x.B8: call put.LXI.H.B call put.ADD.M jmp put.MOV.M.A ; ; put.add.2.AN.B8: lda ste.A.address ora a rz dcr a jz put.add.2.A1.B8 dcr a jz put.add.2.A2.B8 ; call put.MVI.A.A jmp put.add.2.x.B8 ; put.add.2.A1.B8: call put.LXI.H.B jmp put.INR.M ; put.add.2.A2.B8: call put.LXI.H.B call put.INR.M jmp put.INR.M ; put.add.2.A8.BBP: call put.LDA.A call put.LHLD.B call put.ADD.M jmp put.MOV.M.A ; put.add.2.ABP.B8: call put.LHLD.A call put.MOV.A.M call put.LXI.H.B call put.ADD.M jmp put.MOV.M.A ; put.add.2.ABP.BBP: call put.LHLD.A call put.MOV.A.M call put.LHLD.B call put.ADD.M jmp put.MOV.M.A ; ; put.add.2.AN.BBP: lda ste.A.address ora a rz push psw call put.LHLD.B pop psw dcr a jz put.add.2.A1.BBP dcr a jz put.add.2.A2.BBP dcr a jz put.add.2.A3.BBP call put.MVI.A.A call put.ADD.M jmp put.MOV.M.A put.add.2.A3.BBP: call put.INR.M put.add.2.A2.BBP: call put.INR.M put.add.2.A1.BBP: jmp put.INR.M ; ; ; put.add.3.A8.B8.C8.tru: call err.truncate put.add.3.A8.B8.C8: call put.LDA.A call put.LXI.H.B call put.ADD.M jmp put.STA.C ; put.add.3.AN.B8.C8.tru: call err.truncate put.add.3.AN.B8.C8: lda ste.A.address ora a jz put.add.3.A0.B8.C8 dcr a jz put.add.3.A1.B8.C8 ; call put.LDA.B call put.ADI.A jmp put.STA.C ; put.add.3.A0.B8.C8: call put.LDA.B jmp put.STA.C ; put.add.3.A1.B8.C8: call put.LDA.B call put.INR.A jmp put.STA.C ; put.add.3.A8.BN.C8: lda ste.B.address ora a jz put.add.3.A8.0.C8 dcr a jz put.add.3.A8.1.C8 ; call put.LDA.A call put.ADI.B jmp put.STA.C ; put.add.3.A8.0.C8: call put.LDA.A jmp put.STA.C ; put.add.3.A8.1.C8: call put.LDA.A call put.INR.A jmp put.STA.C ; ; put.add.misc.A.WORD: call put.get.A.into.HL call put.XCHG jmp put.add.misc.B ; put.add.misc.A.eql.B: call put.get.A.into.HL call put.DAD.H jmp put.store.HL.at.C ; put.add.AN.B16.C16: lhld ste.A.address mov a,h ora l jz put.add.misc.0 dcx h mov a,h ora l jz put.add.misc.1 dcx h mov a,h ora l jz put.add.misc.2 dcx h mov a,h ora l jz put.add.misc.3 lxi d,4 dad d mov a,h ora l jz put.add.minus.1 inx h mov a,h ora l jz put.add.minus.2 inx h mov a,h ora l jz put.add.minus.3 call put.LXI.D.A jmp put.add.misc.B ; put.add.misc.c.c: lhld ste.A.address xchg lhld ste.B.address dad d call put.LXI.H.hl jmp put.store.HL.at.C ; put.add.misc.0: call put.get.B.into.HL jmp put.store.HL.at.C ; put.add.misc.1: call put.get.B.into.HL call put.INX.H jmp put.store.HL.at.C ; put.add.misc.2: call put.get.B.into.HL call put.INX.H call put.INX.H jmp put.store.HL.at.C ; put.add.misc.3: call put.get.B.into.HL call put.INX.H call put.INX.H call put.INX.H jmp put.store.HL.at.C ; put.add.minus.1: call put.get.B.into.HL call put.DCX.H jmp put.store.HL.at.C ; put.add.minus.2: call put.get.B.into.HL call put.DCX.H call put.DCX.H jmp put.store.HL.at.C ; put.add.minus.3: call put.get.B.into.HL call put.DCX.H call put.DCX.H call put.DCX.H jmp put.store.HL.at.C ; put.add.misc.BP: call put.LHLD.A call put.mv.@HLB.to.DE jmp put.add.misc.B ; put.add.misc.WP: call put.LHLD.A call put.mv.@HL.to.DE ; put.add.misc.B: call put.get.B.into.HL call put.DAD.D jmp put.store.HL.at.C ; ; ; ;----move A-cnst to B-byte--- ; put.mv.AN.B8: lda ste.A.address ora a jz put.mv.A0.B8 call put.MVI.A.A jmp put.sta.B put.mv.A0.B8: call put.XRA.A jmp put.STA.B ; ;-----move A-word to B-byte----- ; put.mv.A16.B8: call err.truncate ; ;-----move A-byte to B-byte----- ; put.mv.A8.B8: call put.LDA.A jmp put.STA.B ; ;-----move A-word-ptr to B-byte----- ; put.mv.AWP.B8: call err.truncate ; ;-----move A-byte-ptr to B-byte----- ; put.mv.ABP.B8: call put.LHLD.A call put.MOV.A.M jmp put.STA.B ; ;-----move A-cnst to B-word----- ; put.mv.AN.B16: call put.LXI.H.A jmp put.SHLD.B ; ;-----move A-byte to B-word----- ; put.mv.A8.B16: call put.LHLD.A call put.MVI.H.0 jmp put.SHLD.B ; ;-----move A-word to B-word----- ; put.mv.A16.B16: call put.LHLD.A jmp put.SHLD.B ; ;-----move A-byte-ptr to B-word----- ; put.mv.ABP.B16: call put.LHLD.A call put.mv.@HLB.to.HL jmp put.SHLD.B ; ;-----move A-word-ptr to B-word----- ; put.mv.AWP.B16: call put.LHLD.A call put.mv.@HL.to.HL jmp put.SHLD.B ; ;-----move A-cnst to B-byte-ptr----- ; put.mv.AN.BBP: call put.LHLD.B call put.MVI.M jmp put.A.byte.value ; ;-----move A-word to B-byte-ptr----- ; put.mv.A16.BBP: call err.truncate ; ;-----move A-byte to B-byte-ptr----- ; put.mv.A8.BBP: call put.LDA.A call put.LHLD.B jmp put.MOV.M.A ; ;-----move A-word.ptr to B-byte-ptr----- ; put.mv.AWP.BBP: call err.truncate ; ;-----move A-byte-ptr to B-byte-ptr----- ; put.mv.ABP.BBP: call put.LHLD.A call put.MOV.A.M call put.LHLD.B jmp put.MOV.M.A ; ;-----move A-cnst to B-word-ptr----- ; put.mv.AN.BWP: call put.LHLD.B call put.MVI.M call put.A.byte.value call put.INX.H call put.MVI.M lda ste.A.address + 1 jmp put.code.byte ; ;-----move A-byte to B-word-ptr----- ; put.mv.A8.BWP: call LHLD.A.to.DE.B.to.HL jmp put.mv.DEB.to.@HL ; ;-----move A-word to B-word-ptr----- ; put.mv.A16.BWP: call LHLD.A.to.DE.B.to.HL jmp put.mv.DE.to.@HL ; ;-----move A-byte-ptr to B-word-ptr----- ; put.mv.ABP.BWP: call LHLD.A.to.DE.B.to.HL call put.LDAX.D jmp put.mv.A.to.@HL ; ;-----move A-word-ptr to B-word-ptr----- ; put.mv.AWP.BWP: call LHLD.A.to.HL.B.to.DE call put.MOV.A.M call put.STAX.D call put.INX.H call put.INX.D call put.MOV.A.M jmp put.STAX.D ; ; put.sub.2.AB.BB: call put.LDA.B call put.LXI.H.A call put.SUB.M jmp put.STA.B ; put.sub.2.AN.B8: lda ste.A.address ora a rz ;exit lda ste.B.type cpi stet.spcl.byte.ptr jz put.sub.2.AN.BBP call put.LXI.H.B jmp put.sub.2.AN.B8.cont put.sub.2.AN.BBP: call put.LHLD.B put.sub.2.AN.B8.cont: lda ste.A.address dcr a jz put.DCR.M ; call put.MOV.A.M lhld ste.A.address call put.SUI.L jmp put.MOV.M.A ; ; put.sub.AN.BB.CB: lda ste.A.address ora a jz put.sub.A0.BB.CB dcr a jz put.sub.A1.BB.CB ; call put.LDA.B lhld ste.A.address call put.SUI.L jmp put.STA.C ; put.sub.A0.BB.CB: call put.LDA.B jmp put.STA.C ; put.sub.A1.BB.CB: call put.LDA.B call put.DCR.A jmp put.STA.C ; put.sub.AN.BN.C8: lda ste.B.address lxi h,ste.A.address sub m call put.MVI.A.A jmp p.SUBTRACT.g.8.C ; put.sub.AN.BN.C16: lhld ste.A.address call negate.hl xchg lhld ste.B.address dad d call put.LXI.H.hl jmp put.store.HL.at.C ; put.sub.g.A8.B16.C16: put.sub.g.A16.B16.C16: call put.get.A.into.HL call put.XCHG jmp put.sub.AX.B16.CX ; put.sub.g.ABP.B16.C16: call put.LHLD.A call put.mv.@HLB.to.DE jmp put.sub.AX.B16.CX ; put.sub.g.AWP.B16.C16: call put.LHLD.A call put.mv.@HL.to.DE jmp put.sub.AX.B16.CX ; put.sub.g.ANsmall: lhld ste.A.address mov a,h ora a jnz put.sub.ANbig.B16.C16 mov a,l cpi 6 jnc put.sub.ANbig.B16.C16 call put.get.B.into.HL put.sub.g.lup.DCX.H: lda ste.A.address ora a jz put.store.HL.at.C dcr a sta ste.A.address call put.DCX.H jmp put.sub.g.lup.DCX.H ; put.sub.ANbig.B16.C16: call put.LXI.D.A put.sub.AX.B16.CX: call put.get.B.into.HL call put.SUB.16 jmp put.store.HL.at.C ; put.sub.g.AN.BN.C16: lhld ste.A.address call negate.HL xchg lhld ste.B.address dad d call put.LXI.H.hl jmp put.store.HL.at.C ; ; ; ; ; ; ;---get word-A contents to HL, word-B contents to DE--- LHLD.A.to.HL.B.to.DE: call put.LHLD.B call put.XCHG jmp put.LHLD.A ; ; ;---get word-A contents to DE, word-B contents to HL--- LHLD.A.to.DE.B.to.HL: call put.LHLD.A call put.XCHG jmp put.LHLD.B ; ; put.store.HL.at.B: call switch.B db stet.BYTE ! dw psHLaB.BYTE db stet.WORD ! dw psHLaB.WORD db stet.spcl.byte.ptr ! dw psHLaB.BP db stet.spcl.word.ptr ! dw psHLaB.WP db 0 ! dw err.inv.var.type ; psHLaB.BYTE: call err.truncate call put.MOV.A.L jmp put.STA.B ; psHLaB.WORD: jmp put.SHLD.B ; psHLaB.BP: call err.truncate call put.XCHG call put.LHLD.B jmp put.MOV.M.E ; psHLaB.WP: call put.XCHG call put.LHLD.B jmp put.mv.DE.to.@HL ; ; ;-------------------------------------- ; ; put.store.HL.at.C: call switch.C db stet.BYTE ! dw psHLaC.BYTE db stet.WORD ! dw psHLaC.WORD db stet.spcl.byte.ptr ! dw psHLaC.BP db stet.spcl.word.ptr ! dw psHLaC.WP db 0 ! dw err.inv.var.type ; psHLaC.BYTE: call err.truncate call put.MOV.A.L jmp put.STA.C ; psHLaC.WORD: jmp put.SHLD.C ; psHLaC.BP: call err.truncate call put.XCHG call put.LHLD.C jmp put.MOV.M.E ; psHLaC.WP: call put.XCHG call put.LHLD.C jmp put.mv.DE.to.@HL ; ; ;--------------------------------- ; ; put.store.A.at.A: call switch.A db stet.BYTE ! dw psAaA.BYTE db stet.WORD ! dw psAaA.WORD db stet.spcl.byte.ptr ! dw psAaA.BP db stet.spcl.word.ptr ! dw psAaA.WP db 0 ! dw err.inv.var.type ; psAaA.BYTE: jmp put.STA.A ; psAaA.WORD: call put.mv.A.to.HL jmp put.SHLD.A ; psAaA.BP: call put.LHLD.A jmp put.MOV.M.A ; psAaA.WP: call put.LHLD.A jmp put.mv.A.to.@HL ; ; ;--------------------------------- ; ; put.store.A.at.B: call switch.B db stet.BYTE ! dw psAaB.BYTE db stet.WORD ! dw psAaB.WORD db stet.spcl.byte.ptr ! dw psAaB.BP db stet.spcl.word.ptr ! dw psAaB.WP db 0 ! dw err.inv.var.type ; psAaB.BYTE: jmp put.STA.B ; psAaB.WORD: call put.mv.A.to.HL jmp put.SHLD.B ; psAaB.BP: call put.LHLD.B jmp put.MOV.M.A ; psAaB.WP: call put.LHLD.B jmp put.mv.A.to.@HL ; ; ; ;--------------------------------- ; ; put.store.A.at.C: call switch.C db stet.BYTE ! dw psAaC.BYTE db stet.WORD ! dw psAaC.WORD db stet.spcl.byte.ptr ! dw psAaC.BP db stet.spcl.word.ptr ! dw psAaC.WP db 0 ! dw err.inv.var.type ; psAaC.BYTE: jmp put.STA.C ; psAaC.WORD: call put.mv.A.to.HL jmp put.SHLD.C ; psAaC.BP: call put.LHLD.C jmp put.MOV.M.A ; psAaC.WP: call put.LHLD.C jmp put.mv.A.to.@HL ; ; ;------------------------------------- ; ; put.get.A.into.HL: lda A.word.type ani wtp.cnst jnz pgAiHL.cnst ; call switch.A db stet.BYTE ! dw pgAiHL.BYTE db stet.WORD ! dw pgAiHL.WORD db stet.spcl.byte.ptr ! dw pgAiHL.BP db stet.spcl.word.ptr ! dw pgAiHL.WP db 0 ! dw err.inv.var.type ; pgAiHL.BYTE: call put.LHLD.A jmp put.MVI.H.0 ; pgAiHL.WORD: jmp put.LHLD.A ; pgAihl.BP: call put.LHLD.A jmp put.mv.@HLB.to.HL ; pgAiHL.WP: call put.LHLD.A jmp put.mv.@HL.to.HL ; pgAihl.cnst: jmp put.LXI.H.A ; ; ;------------------------------------- ; ; put.get.B.into.HL: lda B.word.type ani wtp.cnst jnz pgBiHL.cnst ; call switch.B db stet.BYTE ! dw pgBiHL.BYTE db stet.WORD ! dw pgBiHL.WORD db stet.spcl.byte.ptr ! dw pgBiHL.BP db stet.spcl.word.ptr ! dw pgBiHL.WP db 0 ! dw err.inv.var.type ; pgBiHL.BYTE: call put.LHLD.B jmp put.MVI.H.0 ; pgBiHL.WORD: jmp put.LHLD.B ; pgBihl.BP: call put.LHLD.B jmp put.mv.@HLB.to.HL ; pgBiHL.WP: call put.LHLD.B jmp put.mv.@HL.to.HL ; pgBihl.cnst: jmp put.LXI.H.B ; ; ;------------------------------------- ; ; put.get.C.into.HL: lda C.word.type ani wtp.cnst jnz pgCihl.cnst ; call switch.C db stet.BYTE ! dw pgCiHL.BYTE db stet.WORD ! dw pgCiHL.WORD db stet.spcl.byte.ptr ! dw pgCiHL.BP db stet.spcl.word.ptr ! dw pgCiHL.WP db 0 ! dw err.inv.var.type ; pgCiHL.BYTE: call put.LHLD.C jmp put.MVI.H.0 ; pgCiHL.WORD: jmp put.LHLD.C ; pgCihl.BP: call put.LHLD.C jmp put.mv.@HLB.to.HL ; pgCiHL.WP: call put.LHLD.C jmp put.mv.@HL.to.HL ; pgCihl.cnst: jmp put.LXI.H.C ; ; ;--------------------------------- ; ; put.get.A.into.A: lda A.word.type ani wtp.cnst jnz pgAiA.cnst ; call switch.A db stet.BYTE ! dw pgAiA.BYTE db stet.WORD ! dw pgAiA.WORD db stet.spcl.byte.ptr ! dw pgAiA.BP db stet.spcl.word.ptr ! dw pgAiA.WP db 0 ! dw err.inv.var.type ; pgAiA.WORD: call err.truncate pgAiA.BYTE: jmp put.LDA.A ; pgAiA.WP: call err.truncate pgAiA.BP: call put.LHLD.A jmp put.MOV.A.M ; pgAiA.cnst: jmp put.MVI.A.A ; ; ; ;--------------------------------- ; ; put.get.B.into.A: lda B.word.type ani wtp.cnst jnz pgBiA.cnst ; call switch.B db stet.BYTE ! dw pgBiA.BYTE db stet.WORD ! dw pgBiA.WORD db stet.spcl.byte.ptr ! dw pgBiA.BP db stet.spcl.word.ptr ! dw pgBiA.WP db 0 ! dw err.inv.var.type ; pgBiA.WORD: call err.truncate pgBiA.BYTE: jmp put.LDA.B ; pgBiA.WP: call err.truncate pgBiA.BP: call put.LHLD.B jmp put.MOV.A.M ; pgBiA.cnst: jmp put.MVI.A.B ; ; ; ; ;======================================================= ; ; MISCELLANEOUS REGISTER / REGISTER AND ; REGISTER / MEMORY AND MEMORY / MEMORY ; ;======================================================= ; ; ;---get what HL is pointing to into HL--- put.mv.@HL.to.HL: call put.MOV.A.M call put.INX.H call put.MOV.H.M jmp put.MOV.L.A ; ; ;---store byte pointed to by HL into BC--- put.mv.@HLB.to.BC: call put.MOV.C.M jmp put.MVI.B.0 ; ; ;---store word pointed to by HL into BC--- put.mv.@HL.to.BC: call put.MOV.C.M call put.INX.H jmp put.MOV.B.M ; ; ;---store byte pointed to by HL into DE--- put.mv.@HLB.to.DE: call put.MOV.E.M jmp put.MVI.D.0 ; ; ;---store word pointed to by HL into DE--- put.mv.@HL.to.DE: call put.MOV.E.M call put.INX.H jmp put.MOV.D.M ; ; ;---store byte pointed to by HL into HL--- put.mv.@HLB.to.HL: call put.MOV.L.M jmp put.MVI.H.0 ; ; ;---put contents of HL into BC--- put.mv.HL.to.BC: call put.MOV.B.H jmp put.MOV.C.L ; ; ;---put.contents of BC into HL--- put.mv.BC.to.HL: call put.MOV.H.B jmp put.MOV.L.C ; ; ;---put reg A into HL--- put.mv.A.to.HL: call put.MOV.L.A jmp put.MVI.H.0 ; ; ;---put reg A into word pointed to by hl--- put.mv.A.to.@HL: call put.MOV.M.A jmp put.zero.fill.@HL ; ; ;---store reg E into word pointed to by HL--- put.mv.DEB.to.@HL: call put.MOV.M.E ; --finish filling out 16-bits-- put.zero.fill.@HL: call put.INX.H jmp put.MVI.M.0 ; ; ;---store DE at word pointed to by HL--- put.mv.DE.to.@HL: call put.MOV.M.E call put.INX.H jmp put.MOV.M.D ; ; put.A.length: lhld ste.A.length jmp put.code.word ; put.B.length: lhld ste.B.length jmp put.code.word ; put.C.length: lhld ste.C.length jmp put.code.word ; put.A.address: lhld ste.A.address jmp put.code.word ; put.B.address: lhld ste.B.address jmp put.code.word ; put.C.address: lhld ste.C.address jmp put.code.word ; put.A.byte.value: lda ste.A.address jmp put.code.byte ; put.B.byte.value: lda ste.B.address jmp put.code.byte ; put.zero.code.byte: xra a jmp put.code.byte ; ; ; put.bir.xor.16: mvi a,bir.xor.16 jmp put.bir.call.fwd ; put.bir.and.16: mvi a,bir.and.16 jmp put.bir.call.fwd ; put.bir.or.16: mvi a,bir.or.16 jmp put.bir.call.fwd ; put.bir.APPEND: mvi a,bir.APPEND ;ends w/ move string A=0 always call put.bir.call.fwd opt.A.zero: mvi a,opt.cnst sta opt.A.status xra a sta opt.A.value ret ; put.bir.move.bcd: lda opt.HL.status push psw mvi a,bir.move.bcd ;HL=HL+bcd.size...A=0 always call put.bir.call.fwd pop psw sta opt.HL.status lxi h,bcd.size call opt.add.HL.value jmp opt.A.zero ; put.bir.mov.rev: mvi a,bir.mov.rev ;a=0 always call put.bir.call.fwd jmp opt.A.zero ; ; ;--------------------------------- ; ; ;============================================================= ; ; LOW-LEVEL OBJECT-CODE OUTPUT ROUTINES ; ;============================================================= ; ; ; put.ADD.M: mvi a,86h call put.code.byte lda opt.A.status ani opt.cnst jz opt.undef.A lda opt.HL.status ani opt.byte.contents + opt.cnst cpi opt.byte.contents + opt.cnst jnz opt.undef.A lhld opt.HL.offset mov a,h ora l jnz opt.undef.A lhld opt.HL.value call opt.add.A.value jmp opt.make.A.cnst ; ; put.ADI: call opt.undef.A do.put.ADI: mvi a,(adi) jmp put.code.byte ; put.ADI.A: lhld ste.A.address jmp put.ADI.L ; put.ADI.B: lhld ste.B.address ; put.ADI.L: mov a,l ora a rz ;adding zero -- skip dcr a jz put.INR.A inr a ! inr a jz put.DCR.A mov a,l lda opt.A.value add l sta opt.A.value push h call do.put.ADI pop h mov a,l jmp put.code.byte ; ; put.ANA.M: call opt.undef.A mvi a,0a6h jmp put.code.byte ; ; put.and.16: jmp put.bir.and.16 ;**change when able ; ; put.ANI: call opt.undef.A do.put.ANI: mvi a,(ani) jmp put.code.byte ; put.ANI.B: lhld ste.B.address ; put.ANI.L: mov a,l ora a jz put.XRA.A ;and with 0 = 0 lda opt.A.status ani opt.cnst jz put.ANI.L.undef mov a,l lxi h,opt.A.value ana m cmp m rz ;still no change mov m,a jmp do.put.ANI.L put.ANI.L.undef: call opt.undef.A do.put.ANI.L: push h call do.put.ANI pop h mov a,l jmp put.code.byte ; ; put.CALL: call opt.undef.all mvi a,(call) jmp put.code.byte ; ; put.CALL.ENTRY: call put.CALL lxi h,ENTRY call put.code.word put.x.chk.standalone: lda standalone.flag ora a rz jmp err.CPM.call ; ; put.CNZ: call opt.undef.all mvi a,(cnz) jmp put.code.byte ; ; put.CMA: lda opt.A.status ani opt.cnst cz opt.undef.A lda opt.A.value cma sta opt.A.value call opt.make.A.cnst mvi a,(cma) jmp put.code.byte ; ; put.CMC: mvi a,(cmc) jmp put.code.byte ; ; put.cmp.BCD: mvi a,bir.BCD.compare jmp put.bir.call.fwd ; ; put.cmp.blk: mvi a,bir.cmp.blk jmp put.bir.call.fwd ; ; put.CMP.C: mvi a,0b9h jmp put.code.byte ; ; put.CMP.M: mvi a,0beh ;cmp m jmp put.code.byte ; ; put.cmp.str: mvi a,bir.cmp.str jmp put.bir.call.fwd ; ; put.CPI: mvi a,(cpi) jmp put.code.byte ; ; put.CPI.B: call put.CPI jmp put.B.byte.value ; ; put.cmp.16: lda opt.HL.status push psw mvi a,bir.cmp.16 call put.bir.call.fwd pop psw sta opt.HL.status ;cmp.16 doesn't change HL ret ; ; put.CZ: call opt.undef.all mvi a,(cz) jmp put.code.byte ; ; put.DAD.B: call opt.undef.HL mvi a,09h jmp put.code.byte ; ; put.DAD.D: call opt.undef.HL mvi a,19h jmp put.code.byte ; ; put.DAD.H: lda opt.HL.status push psw mvi a,29h call put.code.byte pop psw ani opt.cnst jnz opt.undef.HL lhld opt.HL.value call opt.add.HL.value jmp opt.make.HL.cnst ; ; put.DAD.SP: call opt.undef.HL mvi a,39h jmp put.code.byte ; ; put.DCR.A.double: call put.DCR.A put.DCR.A: lxi h,-1 call opt.add.A.value mvi a,3dh jmp put.code.byte ; ; put.DCR.M: call opt.@HL.modify mvi a,35h jmp put.code.byte ; ; put.DCX.H.double: call put.DCX.H put.DCX.H: lxi h,-1 call opt.add.HL.value mvi a,2bh jmp put.code.byte ; ; put.DI: mvi a,(di) jmp put.code.byte ; ; put.div.16: mvi a,bir.div.16 jmp put.bir.call.fwd ; ; put.EI: mvi a,(ei) jmp put.code.byte ; ; put.execute.program: mvi a,bir.execute.program call put.bir.call.fwd jmp put.x.chk.standalone ; ; put.format.file.name: mvi a,bir.fmt.filnm call put.bir.call.fwd jmp put.x.chk.standalone ; ; put.INR.A.double: call put.INR.A put.INR.A: lxi h,1 call opt.add.A.value mvi a,3ch jmp put.code.byte ; ; put.INR.M: call opt.@HL.modify mvi a,34h jmp put.code.byte ; ; put.INX.D: mvi a,13h jmp put.code.byte ; ; put.INX.H.double: call put.INX.H put.INX.H: lxi h,1 call opt.add.HL.value mvi a,23h jmp put.code.byte ; ; put.IN: call opt.undef.A mvi a,(in) jmp put.code.byte ; ; put.JC: mvi a,(jc) jmp put.code.byte ; put.JMP: mvi a,(jmp) jmp put.code.byte ; put.JNC: mvi a,(jnc) jmp put.code.byte ; put.JNZ: mvi a,(jnz) jmp put.code.byte ; put.JZ: mvi a,(jz) jmp put.code.byte ; ; put.LDA: call opt.undef.A do.put.LDA: mvi a,(lda) jmp put.code.byte ; put.LDA.A: lhld ste.A.address jmp put.LDA.hl ; put.LDA.B: lhld ste.B.address ; ;-----get into 'A' what is at address in 'HL'----- put.LDA.hl: lda opt.A.status ;see if A is already loaded ani opt.byte.contents jz do.put.LDA.hl ;no - go check what HL has xchg ;yes - see if addr is same lhld opt.A.address xchg call cmp.hl.fm.de jnz do.put.LDA.hl ;no - go check HL ; lda opt.A.offset ;see if 'A' off by 1 or 2 ora a rz ;same dcr a jz put.DCR.A dcr a jz put.DCR.A.double adi 3 jz put.INR.A inr a jz put.INR.A.double ;---something needs to be loaded into 'A'----- ;---see if HL is close enough to avoid 'LDA'----- do.put.LDA.hl: push h lda opt.HL.status ani opt.cnst jz put.LDA.not.MOV xchg lhld opt.HL.value call sub.de.fm.hl.2.hl mov a,h ora l jnz put.LDA.not.0 call put.MOV.A.M jmp put.LDA.set.up ; put.LDA.not.0: dcx h mov a,h ora l jnz put.LDA.not.1 call put.DCX.H call put.MOV.A.M jmp put.LDA.set.up ; put.LDA.not.1: inx h inx h mov a,h ora l xchg jnz put.LDA.not.MOV call put.INX.H call put.MOV.A.M jmp put.LDA.set.up ; ;-----tried everything, but nothing close enough----- put.LDA.not.MOV: call do.put.LDA pop h call put.code.word push h put.LDA.set.up: mvi a,opt.byte.contents ;only sta opt.A.status lxi h,0 shld opt.A.offset pop h shld opt.A.address ret ; ; put.LDAX.B: call opt.undef.A mvi a,0ah jmp put.code.byte ; ; put.LDAX.D: call opt.undef.A mvi a,1ah jmp put.code.byte ; ; put.LHLD: call opt.undef.HL do.put.LHLD: mvi a,(lhld) jmp put.code.byte ; put.LHLD.A: lhld ste.A.address jmp put.LHLD.hl ; put.LHLD.B: lhld ste.B.address jmp put.LHLD.hl ; put.LHLD.C: lhld ste.C.address ; put.LHLD.hl: lda opt.HL.status ani opt.word.contents jz do.put.LHLD.hl xchg lhld opt.HL.address call cmp.hl.fm.de xchg jnz do.put.LHLD.hl xchg ;save value in DE lhld opt.HL.offset mov a,h ! ora l rz ;same dcx h ! mov a,h ! ora l jz put.DCX.H dcx h ! mov a,h ! ora l jz put.DCX.H.double inx h ! inx h ! inx h mov a,h ! ora l jz put.INX.H inx h ! mov a,h ! ora l jz put.INX.H.double xchg do.put.LHLD.HL: push h call do.put.LHLD mvi a,opt.word.contents + opt.byte.contents sta opt.HL.status lxi h,0 shld opt.HL.offset pop h shld opt.HL.address jmp put.code.word ; ; put.LXI.B: mvi a,01h jmp put.code.byte ; put.LXI.B.A.length: lhld ste.A.length jmp put.LXI.B.hl ; put.LXI.B.B: lhld ste.B.address jmp put.LXI.B.hl ; put.LXI.B.B.length: lhld ste.B.length jmp put.LXI.B.hl ; put.LXI.B.C.length: lhld ste.C.length jmp put.LXI.B.hl ; put.LXI.B.C: lhld ste.C.address ; put.LXI.B.hl: push h call put.LXI.B pop h jmp put.code.word ; ; put.LXI.D: mvi a,11h jmp put.code.byte ; put.LXI.D.A: lhld ste.A.address jmp put.LXI.D.hl ; put.LXI.D.B: lhld ste.B.address jmp put.LXI.D.hl ; put.LXI.D.C: lhld ste.C.address jmp put.LXI.D.hl ; put.LXI.D.A.length: lhld ste.A.length jmp put.LXI.D.hl ; put.LXI.D.dflt.fcb: lxi h,dflt.fcb ; put.LXI.D.hl: push h call put.LXI.D pop h jmp put.code.word ; ; put.LXI.H: call opt.undef.HL do.put.LXI.H: mvi a,21h jmp put.code.byte ; put.LXI.H.A: lhld ste.A.address jmp put.LXI.H.hl ; put.LXI.H.A.length: lhld ste.A.length jmp put.LXI.H.hl ; put.LXI.H.B: lhld ste.B.address jmp put.LXI.H.hl ; put.LXI.H.C: lhld ste.C.address ; put.LXI.H.hl: lda opt.HL.status ani opt.cnst jz do.put.LXI.H.hl xchg lhld opt.HL.value call sub.de.fm.hl.2.hl mov a,h ! ora l rz ;same dcx h ! mov a,h ! ora l jz put.DCX.H dcx h ! mov a,h ! ora l jz put.DCX.H.double inx h ! inx h ! inx h mov a,h ! ora l jz put.INX.H inx h ! mov a,h ! ora l jz put.INX.H.double xchg do.put.LXI.H.hl: push h call put.LXI.H mvi a,opt.cnst sta opt.HL.status pop h shld opt.HL.value jmp put.code.word ; put.LXI.H.fwd: push psw call opt.undef.HL call do.put.LXI.H pop psw jmp put.fwd.bir.sv.word ; put.LXI.H.fixup: push psw call opt.undef.HL call put.LXI.H pop psw call fix.up.built.in.rtn lxi h,0 jmp put.code.word ; ; put.LXI.SP: mvi a,31h ;lxi sp jmp put.code.byte ; ; put.MOV.A.B: call opt.undef.A mvi a,78h jmp put.code.byte ; ; put.MOV.A.E: call opt.undef.A mvi a,7bh jmp put.code.byte ; put.MOV.A.H: lda opt.HL.status ani opt.cnst jz put.MOV.A.H.undef ;---H is value, so it's known what A will be lda opt.A.status ani opt.cnst jz put.MOV.A.H.ok lda opt.A.value lxi h,opt.HL.value + 1 ;reg.H value cmp m rz ;no effect, skip put.MOV.A.H.ok: mvi a,opt.cnst sta opt.A.status lda opt.HL.value + 1 sta opt.A.value jmp go.put.MOV.A.H put.MOV.A.H.undef: call opt.undef.A go.put.MOV.A.H: mvi a,7ch jmp put.code.byte ; put.MOV.A.L: lda opt.HL.status ani opt.cnst jz put.MOV.A.L.undef ;---L is value, so it's known what A will be lda opt.A.status ani opt.cnst jz put.MOV.A.L.ok lda opt.A.value lxi h,opt.HL.value ;reg.L value cmp m rz ;no effect, skip put.MOV.A.L.ok: lda opt.HL.status ani 0ffh - opt.word.contents sta opt.A.status lhld opt.HL.address shld opt.A.address lhld opt.HL.offset shld opt.A.offset lhld opt.HL.value shld opt.A.value jmp go.put.MOV.A.L put.MOV.A.L.undef: call opt.undef.A go.put.MOV.A.L: mvi a,7dh jmp put.code.byte ; put.MOV.A.M: lda opt.A.status ani opt.byte.contents jz put.MOV.A.M.undef lda opt.HL.status ani opt.cnst jz put.MOV.A.M.undef lhld opt.HL.value xchg lhld opt.A.address call cmp.hl.fm.de jnz put.MOV.A.M.undef lda opt.A.offset ora a ;anything added to it? rz ;no - A will still be the same put.MOV.A.M.undef: call opt.undef.A mvi a,7eh call put.code.byte ;---if HL is cnst, then A is now contents lda opt.HL.status ani opt.cnst rz ;no mvi a,opt.byte.contents sta opt.A.status xra a sta opt.A.offset lhld opt.HL.value shld opt.A.address ret ; ; put.MOV.B.H: mvi a,44h jmp put.code.byte ; ; put.MOV.B.M: mvi a,46h jmp put.code.byte ; ; put.mov.blk: call opt.undef.all lda Z80.flag ora a jz put.mov.blk.8080 lxi h,0b0edh ;LDIR backwards jmp put.code.word put.mov.blk.8080: mvi a,bir.mov.blk jmp put.bir.call.fwd ; ; put.MOV.C.L: mvi a,4dh jmp put.code.byte ; ; put.MOV.C.M: mvi a,4eh jmp put.code.byte ; ; put.MOV.D.M: mvi a,56h jmp put.code.byte ; ; put.MOV.E.M: mvi a,5eh jmp put.code.byte ; ; put.MOV.H.B: call opt.undef.HL mvi a,60h jmp put.code.byte ; ; put.MOV.H.M: call opt.undef.HL mvi a,66h jmp put.code.byte ; ; put.MOV.L.A: lda opt.A.status ani opt.cnst jz put.MOV.L.A.undef put.MOV.L.A.value: lda opt.HL.status ani opt.cnst jz put.MOV.L.A.undef lxi h,opt.HL.value ;reg L lda opt.A.value cmp m rz ;same value, skip lda opt.A.value sta opt.HL.value call opt.make.HL.cnst jmp do.put.MOV.L.A put.MOV.L.A.undef: call opt.undef.HL do.put.MOV.L.A: mvi a,6fh jmp put.code.byte ; ; put.MOV.L.C: mvi a,69h jmp put.code.byte ; ; put.MOV.L.M: lda opt.HL.status ani opt.cnst jz put.MOV.L.M.undef mvi a,opt.byte.contents sta opt.HL.status lhld opt.HL.value shld opt.HL.address lxi h,0 shld opt.hl.offset jmp go.put.MOV.L.M put.MOV.L.M.undef: call opt.undef.HL go.put.MOV.L.M: mvi a,6eh jmp put.code.byte ; ; put.MOV.M.A: mvi a,77h call put.code.byte ;---if A is already byte cont., don't change it lda opt.A.status ani opt.byte.contents rnz ; lda opt.HL.status ani opt.byte.contents cnz put.MOV.M.A.BC lda opt.HL.status ani opt.cnst rz ;no change to A ;---HL is cnst, so A is now byte contents--- lhld opt.HL.value shld opt.A.address lxi h,0 shld opt.A.offset jmp opt.add.A.BC ;---HL is byte/word contents, A is also byte-contents--- put.MOV.M.A.BC: lhld opt.HL.address shld opt.A.address lhld opt.HL.offset shld opt.A.offset opt.add.A.BC: mvi a,opt.byte.contents jmp opt.add.A.status ; put.MOV.M.B: call opt.@HL.modify mvi a,70h jmp put.code.byte ; put.MOV.M.C: call opt.@HL.modify mvi a,71h jmp put.code.byte ; put.MOV.M.D: call opt.@HL.modify mvi a,72h jmp put.code.byte ; put.MOV.M.E: call opt.@HL.modify mvi a,73h jmp put.code.byte ; ; put.move.string: call opt.memory.modify mvi a,bir.mov.str call put.bir.call.fwd jmp opt.A.zero ; ; put.MVI.A: call opt.undef.A do.put.MVI.A: mvi a,3eh jmp put.code.byte ; put.MVI.A.A: lhld ste.A.address jmp put.MVI.A.L ; put.MVI.A.B: lhld ste.B.address put.MVI.A.L: lda opt.A.status ani opt.cnst jz put.MVI.A.undef lda opt.A.value sub l rz dcr a jz put.DCR.A adi 2 jz put.INR.A put.MVI.A.undef: mvi a,opt.cnst sta opt.A.status mov a,l sta opt.A.value mov a,l ora a jz put.XRA.A push h call do.put.MVI.A pop h mov a,l jmp put.code.byte ; ; put.MVI.B: mvi a,06h jmp put.code.byte ; ; put.MVI.B.0: call put.MVI.B jmp put.zero.code.byte ; ; put.MVI.C: mvi a,0eh jmp put.code.byte ; ; put.MVI.D: mvi a,16h jmp put.code.byte ; ; put.MVI.D.0: call put.MVI.D jmp put.zero.code.byte ; ; put.MVI.E: mvi a,1eh jmp put.code.byte ; ; put.MVI.E.L: push h call put.MVI.E pop h mov a,l jmp put.code.byte ; ; put.MVI.H.0: lda opt.HL.status ani opt.cnst jz put.MVI.H.0.undef lda opt.HL.value + 1 ora a rz ;it's already zero xra a sta opt.HL.value + 1 jmp do.put.MVI.H.0 put.MVI.H.0.undef: call opt.undef.HL do.put.MVI.H.0: mvi a,26h call put.code.byte call put.zero.code.byte jmp opt.make.HL.cnst ; ; put.MVI.M: call opt.@HL.modify mvi a,36h jmp put.code.byte ; ; put.MVI.M.0: call put.MVI.M jmp put.zero.code.byte ; ; put.mul.16: mvi a,bir.mul.16 jmp put.bir.call.fwd ; ; put.ORA.A: mvi a,0b7h jmp put.code.byte ; ; put.ORA.H: ;not optimised - used for status flags mvi a,0b4h jmp put.code.byte ; ; put.ORA.L: ;not optimised - used for status flags mvi a,0b5h jmp put.code.byte ; ; put.ORA.M: ;not optimised - used for status flags mvi a,0b6h jmp put.code.byte ; ; put.ORI: call opt.undef.A do.put.ORI: mvi a,(ori) jmp put.code.byte ; put.ORI.B: lhld ste.B.address ; put.ORI.L: lda opt.A.status ani opt.cnst jz put.ORI.L.undef mov a,l ora a rz ;oring w/ zero = no change lxi h,opt.A.value ora m cmp m rz ;still no change mov m,a call opt.make.A.cnst jmp do.put.ORI.L put.ORI.L.undef: call opt.undef.A do.put.ORI.L: push h call do.put.ORI pop h mov a,l jmp put.code.byte ; ; put.or.16: mvi a,bir.or.16 jmp put.bir.call.fwd ; ; put.OUT: mvi a,(out) jmp put.code.byte ; ; put.PCHL: mvi a,(pchl) jmp put.code.byte ; ; put.POP.H: call opt.undef.HL mvi a,0e1h jmp put.code.byte ; ; put.PUSH.H: call opt.memory.modify mvi a,0e5h jmp put.code.byte ; ; put.RET: mvi a,(ret) jmp put.code.byte ; ; put.SHLD: call opt.memory.modify do.put.SHLD: mvi a,(shld) jmp put.code.byte ; put.SHLD.A: lhld ste.A.address jmp put.SHLD.hl ; put.SHLD.B: lhld ste.B.address jmp put.SHLD.hl ; put.SHLD.C: lhld ste.C.address ; put.SHLD.hl: push h call do.put.SHLD pop h push h call put.code.word mvi a,opt.word.contents + opt.byte.contents call opt.add.HL.status pop h push h shld opt.HL.address lxi h,0 shld opt.HL.offset ;--check if wiping out anything-- pop d lda opt.A.status ani opt.byte.contents rz lhld opt.A.address call sub.de.fm.hl.2.hl mov a,h ora a rnz ;not even close mov a,l cpi 2 rnc ;not close enough jmp opt.undef.A ;close enough ; put.SHLD.fwd: push psw call opt.memory.modify call do.put.SHLD pop psw jmp put.fwd.bir.sv.word ; ; put.SPHL: mvi a,(sphl) jmp put.code.byte ; ; put.STA: call opt.memory.modify do.put.STA: mvi a,(sta) jmp put.code.byte ; put.STA.A: lhld ste.A.address jmp put.STA.hl ; put.STA.B: lhld ste.B.address jmp put.STA.hl ; put.STA.C: lhld ste.C.address ; put.STA.hl: push h lda opt.HL.status ani opt.cnst jz put.STA.not.MOV ; xchg lhld opt.HL.value call sub.de.fm.hl.2.hl mov a,h ora l jnz put.STA.not.0 call put.MOV.M.A jmp put.STA.set.up ; put.STA.not.0: dcx h mov a,h ora l jnz put.STA.chk.1 call put.DCX.H call put.MOV.M.A jmp put.STA.set.up ; put.STA.chk.1: inx h inx h mov a,h ora l xchg jnz put.STA.not.MOV call put.INX.H call put.MOV.M.A jmp put.STA.set.up ; put.STA.not.MOV: call do.put.STA pop h push h call put.code.word ;---A is now also a byte-contents--- put.STA.set.up: ;---if A is already byte-cont., don't change it--- lda opt.A.status ani opt.byte.contents jnz put.STA.already.b.c pop h push h shld opt.A.address lxi h,0 shld opt.A.offset mvi a,opt.byte.contents call opt.add.A.status put.STA.already.b.c: pop d lda opt.HL.status ani opt.word.contents + opt.byte.contents rz ;don't worry about it lhld opt.HL.address xchg call sub.de.fm.hl.2.hl mov a,h ora a rnz ;not close enough mov a,l cpi 2 rnc ;not close enough jmp opt.undef.HL ; ; put.STAX.D: call opt.memory.modify mvi a,12h jmp put.code.byte ; ; put.SUI: call opt.undef.A do.put.SUI: mvi a,(sui) jmp put.code.byte ; put.SUI.L: mov a,l ora a rz lda opt.A.status ani opt.cnst jz do.put.SUI.L mov a,l dcr a jz put.DCR.A inr a ! inr a jz put.INR.A do.put.SUI.L: push h call do.put.SUI pop h push h call negate.HL call opt.add.A.value pop h mov a,l jmp put.code.byte ; ; put.SUB.M: call opt.undef.A mvi a,96h jmp put.code.byte ; ; put.sub.16: call opt.undef.all lda Z80.flag ora a jz put.sub.16.8080 call put.ORA.A lxi h,52edh ;SBC jmp put.code.word put.sub.16.8080: mvi a,bir.sub.16 jmp put.bir.call.fwd ; ; put.xor.16: mvi a,bir.xor.16 jmp put.bir.call.fwd ; ; put.XRA.A: mvi a,0afh call put.code.byte jmp opt.A.zero ; ; put.XRA.M: call opt.undef.A mvi a,0AEh jmp put.code.byte ; ; put.XRI: call opt.undef.A do.put.XRI: mvi a,(xri) jmp put.code.byte ; put.XRI.B: lhld ste.B.address put.XRI.L: lda opt.A.status ani opt.cnst jz put.XRI.A.undef mov a,l ora a rz ;xoring w/ zero = no change inr a jz put.CMA ;xor w/ FF = complement lxi h,opt.A.value xra m cmp m rz ;still no change mov m,a jmp do.put.XRI.L put.XRI.A.undef: call opt.undef.A do.put.XRI.L: push h call do.put.XRI pop h mov a,l jmp put.code.byte ; ; ; ; put.XCHG: call opt.undef.HL mvi a,(xchg) jmp put.code.byte ; ; ; ; ; ; ;====================== ; OPTIMISATION ;====================== ; opt.undef equ 0 opt.cnst equ 1 opt.byte.contents equ 2 opt.word.contents equ 4 ; ; opt.A.status: db 0 opt.A.value: dw 0 opt.A.address: dw 0 opt.A.offset: dw 0 ; opt.HL.status: db 0 opt.HL.value: dw 0 opt.HL.address: dw 0 opt.HL.offset: dw 0 ; ;---called at labels, CALLs, and whenever not sure--- ; opt.undef.all: mvi a,opt.undef sta opt.A.status sta opt.HL.status ret ; ; ; ; opt.make.HL.cnst: mvi a,opt.cnst jmp opt.set.HL.status ; opt.add.HL.status: lhld opt.HL.status ora l jmp opt.set.HL.status ; opt.undef.HL: mvi a,opt.undef opt.set.HL.status: sta opt.HL.status ret ; ; opt.add.HL.value: xchg lhld opt.HL.value dad d shld opt.HL.value lhld opt.HL.offset dad d shld opt.HL.offset ret opt.make.A.cnst: mvi a,opt.cnst jmp opt.set.A.status ; opt.add.A.status: lhld opt.A.status ora l jmp opt.set.A.status ; opt.undef.A: mvi a,opt.undef opt.set.A.status: sta opt.A.status ret ; ; opt.add.A.value: xchg lhld opt.A.value dad d shld opt.A.value lhld opt.A.offset dad d shld opt.A.offset ret ; ;---called when something changes something in memory--- ; opt.@HL.modify: lda opt.HL.status ani opt.cnst + opt.byte.contents cpi opt.cnst + opt.byte.contents jnz opt.memory.modify lhld opt.HL.address xchg lhld opt.HL.offset dad d xchg lhld opt.HL.value call sub.de.fm.hl.2.hl mov a,h ora l jnz opt.A.mem.mod ;---modifying where HL points - undef--- opt.memory.modify: lxi h,opt.HL.status mov a,m ani 0ffh - (opt.byte.contents OR opt.word.contents) mov m,a opt.A.mem.mod: lxi h,opt.A.status mov a,m ani 0ffh - (opt.byte.contents OR opt.word.contents) mov m,a ret ; ; ; ; ;=================================================== ; ; ERROR MESSAGE ROUTINES ; ;=================================================== ; ; ; err.eof.on.src: lxi h,em.SRC.eof jmp print.error ; ; err.buf.size: lxi h,em.buf.size jmp print.error ; err.COM.SRC: lxi d,em.COM.SRC jmp err.disp.and.abort ; ; err.CPM.call: lxi h,em.CPM.call jmp print.warning ; ; err.data.after.code: lxi h,em.data.after.code jmp print.warning ; ; err.dupl.name: lxi h,em.dupl.name jmp print.error ; ; err.expect.id: lxi h,em.expect.id call print.error.and.word jmp print.error.colm ; ; err.file.cant.io: lxi h,em.file.cant.io jmp print.error.and.colm ; ; err.inv.cnst: lxi h,em.inv.cnst jmp print.error.and.colm ; ; err.inv.dev.io: lxi h,em.inv.dev.io jmp print.error.and.colm ; ; err.inv.FILE.id: lxi h,em.inv.file.id jmp print.error ; ; err.inv.numeric.var: lxi h,em.inv.num.var jmp print.error.and.colm ; ; err.inv.oprnd: lxi h,em.inv.expr.oprnd jmp print.error.and.colm ; ; err.inv.override: lxi h,em.inv.override call print.error.and.word jmp print.error.colm ; ; err.inv.oprtr: lxi h,em.inv.expr.oprtr jmp print.error.and.colm ; ; err.inv.ptr.var: lxi h,em.inv.ptr.var jmp print.error.and.colm ; ; err.inv.STRING.size: lxi h,em.inv.STRING.size jmp print.error.and.colm ; ; err.inv.VALUE: lxi h,em.inv.VALUE jmp print.error.and.colm ; ; err.inv.var.type: lxi h,em.inv.var.type jmp print.error.and.colm ; ; err.L.stk.ofl: lxi h,em.L.stk.ofl jmp print.error ; ; err.missing.END: lxi h,em.missing.END jmp print.error ; ; err.missing.ENDREC: lxi h,em.missing.ENDREC jmp print.error ; ; err.missing.ENDREDEF: lxi h,em.missing.ENDREDEF jmp print.error ; ; err.missing.ENDSWITCH: lxi h,em.missing.ENDSWITCH jmp print.error ; ; err.missing.FI: lxi h,em.missing.FI jmp print.error ; ; err.missing.OD: lxi h,em.missing.OD jmp print.error ; ; err.mssng.rsvd.wd: lxi h,em.mssng.rsvd.wd jmp print.error.and.colm ; ; err.nested.copy: lxi h,em.nested.copy jmp print.error ; ; err.nested.overlay: lxi h,em.nested.overlay jmp print.error ; ; err.no.rec: lxi h,em.no.rec jmp print.error ; ; err.no.SRC: lxi d,em.no.SRC err.disp.and.abort: mvi c,9 call entry jmp boot ; ; err.no.term.byte: lxi h,em.no.term.byte jmp print.warning ; ; err.not.rom.able: lxi h,em.not.rom.able jmp print.warning ; ; err.ovl.call.ovl: lxi h,em.ovl.call.ovl jmp print.error ; ; err.pad.string: lxi h,em.pad.string jmp print.warning ; ; err.redef.sz: lxi h,em.redef.sz jmp print.error ; ; err.truncate: lxi h,em.truncate jmp print.warning ; ; err.undef.file.name: lxi h,em.undef.file.name jmp print.error.and.colm ; ; err.undef.label: lxi h,em.undef.label jmp print.error.and.colm ; ; err.undef.var: lxi h,em.undef.var jmp print.error ; ; err.unexpect.word: lxi h,em.unexpect.word call print.error.and.word call get.word jmp print.error.colm ; ; err.unmtchd.ELSE: lxi h,em.unmtchd.ELSE jmp print.error ; ; err.unmtchd.END: lxi h,em.unmtchd.END jmp print.error ; ; err.unmtchd.ENDREC: lxi h,em.unmtchd.ENDREC jmp print.error ; ; err.unmtchd.ENDREDEF: lxi h,em.unmtchd.ENDREDEF jmp print.error ; ; err.unmtchd.ENDSWITCH: lxi h,em.unmtchd.ENDSWITCH jmp print.error ; ; err.unmtchd.FI: lxi h,em.unmtchd.FI jmp print.error ; ; err.unmtchd.OD: lxi h,em.unmtchd.OD jmp print.error ; ; ; err.unreq.stmt: lxi h,em.unreq.stmt call print.error jmp get.word ; ; ; ; ; ; ; ;--------------misc text literals-------- ; em.blk.lvl.ofl: db 'block level underflow (internal)',0 em.buf.size: db 'invalid RECORD / BUFFER size',0 em.COM.SRC: db 'Can''t write object to .SRC',13,10,'$' em.CPM.call: db 'CP/M call in standalone program',0 em.data.after.code: db 'warning - data following code',0 em.dupl.name: db 'duplicate identifier',0 em.expect.id: db 'expecting identifier',0 em.file.cant.io: db 'file can''t be opened I/O',0 em.inv.cnst: db 'invalid constant',0 em.inv.dev.io: db 'I/O action inconsistant with device',0 em.inv.SRC.char: db 'invalid character in source - ignored',0 em.inv.STRING.size: db 'invalid string size',0 em.inv.VALUE: db 'invalid value this type',0 em.inv.expr.oprnd: db 'invalid expression operand',0 em.inv.expr.oprtr: db 'invalid expression operator',0 em.inv.file.id: db 'invalid file id',0 em.inv.num.var: db 'invalid numeric variable',0 em.inv.override: db 'invalid override - ',0 em.inv.ptr.var: db 'invalid pointer variable',0 em.inv.var.type: db 'invalid variable type',0 em.L.stk.ofl: db 'compiler stack overflow - ' db 'increase CSTACK',0 em.missing.END: db 'missing END',0 em.missing.ENDREC: db 'missing ENDREC',0 em.missing.ENDREDEF: db 'missing ENDREDEF',0 em.missing.ENDSWITCH: db 'missing ENDSWITCH',0 em.missing.FI: db 'missing FI',0 em.missing.OD: db 'missing OD',0 em.mssng.rsvd.wd: db 'missing reserved word',0 em.nested.copy: db 'COPY nesting exceeded',0 em.nested.overlay: db 'nested overlay',0 em.no.rec: db 'record not declared for file',0 em.no.term.byte: db 'warning -- no space for string ' db 'terminator',0 em.not.rom.able: db 'warning --- non-rom-able code',0 em.ovl.call.ovl: db 'Can''t call overlay from overlay',0 em.pad.string: db 'warning --- string value larger than' db ' size declared, truncated',0 em.SRC.eof: db 'unexpected end of input',0 em.redef.sz: db 'redefine size error',0 em.truncate: db 'truncation warning',0 em.undef.label: db 'undefined label',0 em.undef.file.name: db 'undefined file name',0 em.undef.var: db 'undefined variable',0 em.unexpect.word: db 'unexpected word near - ',0 em.unmtchd.ELSE: db 'unmatched ELSE',0 em.unmtchd.END: db 'unmatched END',0 em.unmtchd.ENDREC: db 'unmatched ENDREC',0 em.unmtchd.ENDREDEF: db 'unmatched ENDREDEF',0 em.unmtchd.ENDSWITCH: db 'unmatched ENDSWITCH',0 em.unmtchd.FI: db 'unmatched FI',0 em.unmtchd.OD: db 'unmatched OD',0 em.unreq.stmt: db 'unrecognized statement',0 ; ; ; txt.src.rd.err: db 'SRC file read error',13,10,'$' em.no.SRC: db 'no SRC file present',13,10,'$' ; ; ; ; ; ; ; ; ; ;------misc utility routines-------- ; ; ; in: hl -> buffer area ; c = buffer size - 1 ; ; out: buffer = string which was input ; 2 CP/M bytes at front stripped off ; ; ACCEPT.from.console: mov m,c inx h mov m,c push h dcx h xchg mvi c,10 call entry pop h push h mov e,m mvi d,0 dad d inx h mvi m,0 call display.crlf pop h mov e,l mov d,h inx h dcx d jmp move.string ; ; ;-------------------------------------------------- ; AND.d.and.h: mov a,d ana h mov h,a mov a,e ana l mov l,a ora h ret ; ;-------------------------------------------------- ; ; ; ; bcd compare ; in: hl -> #1 ; de -> #2 ; ; out: non-zero + carry: @hl > @de ; zero @hl = @de ; non-zero + no carry: @hl < @de ; bcd.compare: ldax d ani 80h jz bcd.comp.de.pos ; mov a,m ani 80h jz bcd.comp.de.neg.hl.pos ; de- hl- call bcd.comp.de.pos.hl.pos cmc ret ; bcd.comp.de.pos: mov a,m ani 80h jz bcd.comp.de.pos.hl.pos ; de+ hl- mvi a,1 ora a ret ; bcd.comp.de.neg.hl.pos: mvi a,1 ora a stc ret ; bcd.comp.de.pos.hl.pos: inx d inx h lxi b,bcd.size - 1 ;fall into cmp.blk ; cmp.blk: mov a,b ora c rz ldax d cmp m rnz dcx b inx h inx d jmp cmp.blk ; ; ;-------------------------------------------------- ; compare.strings: ldax d cmp m rnz inx h inx d ora a rz jmp compare.strings ; ;-------------------------------------------------- ; cmp.de.fm.hl: mov a,h cmp d rnz mov a,l cmp e ret ; ;-------------------------------------------------- ; cmp.hl.fm.de: mov a,d cmp h rnz mov a,e cmp l ret ; ;=========================================== ; ; in: hl = # ; de -> str ; cvt.bin.2.dec.str: xchg push h lxi h,cb2d.wk + 5 mvi m,0 cb2d.lup: dcx h push h lxi h,10 call cmp.hl.fm.de jc cb2d.done call div.d.by.h.2.d.r.h mov a,l pop h ori '0' mov m,a jmp cb2d.lup cb2d.done: pop h mov a,e ori '0' mov m,a pop d jmp move.string ; cb2d.wk: db '000000' ; ;-------------------------------------------------- ; ; in: hl = # ; de -> str ; cvt.bin.2.hex.str: xchg mov a,d call hex.left call hex.right mov a,e call hex.left call hex.right mvi m,0 ret hex.left: push psw rrc rrc rrc rrc jmp hex.digit hex.right: push psw hex.digit: ani 0fh adi '0' cpi '9'+1 jc hex.9 adi 7 hex.9: mov m,a inx h pop psw ret ; ; ;-------------------------------------------------- ; ; ; ; in: hl -> string ; de -> bcd cvt.str.2.bcd: push h mov h,d mov l,e push h inx d xra a mov m,a lxi b,(bcd.size - 1) call move.h.2.d.cnt.b ; pop d pop h mov a,m cpi '-' jnz cs2bcd.plus inx h mvi a,80h jmp cs2bcd.sign cs2bcd.plus: xra a cs2bcd.sign: push psw cs2bcd.lup: mov a,m cpi '.' jz cs2bcd.point sui '0' jc cs2bcd.end cpi 9 + 1 jnc cs2bcd.end ; push h push d push psw lxi b,bcd.size - 1 inx d xchg call bcd.shift.left pop psw pop d lxi h,(bcd.size - 1) dad d ora m mov m,a pop h cs2bcd.point: inx h jmp cs2bcd.lup ; cs2bcd.end: pop psw stax d ret ; ; ; bcd.shift.left: push h push d mov e,c mvi d,0 dcx d dad d bcd.shl.lup: mov a,m rrc ! rrc ! rrc ! rrc ani 0fh mov e,a mov a,m rlc ! rlc ! rlc ! rlc ani 0f0h ora d mov m,a mov d,e dcx h dcr c jnz bcd.shl.lup mov a,e pop d pop h ret ; ; ;-------------------------------------------------- ; display.crlf: lxi d,display.txt.crlf mvi c,9 jmp entry display.txt.crlf: db 13,10,'$' ; ; ; ; ;=========================================== ; ; in: hl -> string ; ; out: hl -> string terminator ; cvt.str.to.lower.case: mov a,m ora a rz cpi 'A' jc cslc.no cpi 'Z'+1 jnc cslc.no adi 'a'-'A' mov m,a cslc.no: inx h jmp cvt.str.to.lower.case cslc.map: ;---------------------------------------------- ; DIVIDE DE BY HL ; QUOTIENT IS RETURNED IN DE ; REMAINDER IS RETURNED IN HL ;---------------------------------------------- div.d.by.h.2.d.r.h: mov b,h mov c,l xra a mov l,a mov h,a mvi a,16 divdhb2drhloop: push psw dad h xra a xchg dad h xchg adc l sub c mov l,a mov a,h sbb b mov h,a inx d jnc divdhb2drhover dad b dcx d divdhb2drhover: pop psw dcr a rz jmp divdhb2drhloop ;=============================================== ;------------------------------------------- ; format file name ; ; incoming parameters: ; de points to fcb ; hl points to alpha file-name ; ; outgoing parameters: ; hl points to the character after the last one used ; the fcb will be fully initialized (for 33 bytes) ;-------------------------------------------------- format.file.name: push d mvi c,fcb.rnd.rec + 2 xra a call ffn.fill pop d mvi c,8 inx h mov a,m dcx h inx d cpi ':' jnz ffn.name.lup dcx d mov a,m inx h inx h sui 'A'-1 stax d inx d ffn.name.lup: mov a,m inx h ora a jz ffn.delim.found cpi '.' jz ffn.end.name cpi '*' jnz ffn.name.not.star call ffn.fill.q jmp ffn.skip.name ; ffn.name.not.star: stax d inx d dcr c jnz ffn.name.lup ffn.skip.name: mov a,m inx h cpi '.' jz ffn.end.name ora a jz ffn.delim.found jmp ffn.skip.name ; ffn.end.name: mov a,c ora a jz ffn.do.ext call ffn.fill.b ffn.do.ext: mvi c,3 ffn.ext.lup: mov a,m inx h ora a jz ffn.fill.b cpi '*' jz ffn.fill.q stax d inx d dcr c jnz ffn.ext.lup ret ; ; ffn.delim.found: mov a,c ora a cnz ffn.fill.b mvi c,3 ffn.fill.b: mvi a,' ' ffn.fill: stax d inx d dcr c jnz ffn.fill ret ; ffn.fill.q: mvi a,'?' jmp ffn.fill ; ; ;-------------------------------------------------- ; ; ; ;==================================================== ; ; in: hl -> byte after last in src ; de -> byte after last in dst ; bc = # bytes to move ; move.bkwds.h.2.d.cnt.b: mov a,c ora b rz dcx h dcx d mov a,m stax d dcx b jmp move.bkwds.h.2.d.cnt.b ; ;-------------------------------------------------- ; move.h.2.d.cnt.b: mov a,c ora b rz mov a,m stax d inx h inx d dcx b jmp move.h.2.d.cnt.b ; ;-------------------------------------------------- ; ; in: hl -> src ; de -> dst ; move.string: mov a,m stax d inx h inx d ora a rz jmp move.string ; ; ;------------------------------------ ; MULTIPLY HL BY DE GIVING HL ;------------------------------------ mul.h.by.d.2.h: mov b,h mov c,l xra a mov h,a mov l,a mvi a,16 mulhbd2hloop: dad h xchg dad h xchg jnc mulhbd2hover dad b mulhbd2hover: dcr a rz jmp mulhbd2hloop ; ;-------------------------------------------------- ; negate.HL: mov a,h cma mov h,a mov a,l cma mov l,a inx h ret ; ; ;-------------------------------------------------- ; OR.d.and.h: mov a,d ora h mov h,a mov a,e ora l mov l,a ora h ret ; ;-------------------------------------------------- ; ; in: de -> string ; ; out: hl = size (excluding terminator) ; de -> string terminator ; size.d.2.h: lxi h,0 sd2h.lup: ldax d ora a rz inx h inx d jmp sd2h.lup ; ; ;-------------------------------------------------- ; sub.de.fm.hl.2.hl: mov a,l sub e mov l,a mov a,h sbb d mov h,a ret ; XOR.d.and.h: mov a,d xra h mov h,a mov a,e xra l mov l,a ora h ret ; ;%%%%%%%%%%BOJ routine only%%%%%%%%% ; ; ; ;-------------------------------------------------- ; ; in: de -> fcb ; c = open-type (15 or 22) ; a = run-time flags value ; ; out: a = open status ; ; open.disk.file: lxi h,fcb.flags dad d mov m,a ; lxi h,fcb.ext.num xra a dad d mov m,a ; lxi h,fcb.cur.rec dad d mov m,a ; push d call entry pop d ; lxi h,fcb.status dad d mov m,a ret ; ; ; in: de -> fcb ; disk.ch.in.open: lxi h,fcb.buf.size + 1 dad d mov b,m dcx h mov c,m dcx h mov m,b dcx h mov m,c ret ; ;-------------------------------------------------- ; ; in: de -> fcb ; disk.ch.out.open: lxi h,fcb.buf.ix + 1 dad d xra a mov m,a dcx h mov m,a ret ; ;-------------------------------------------------- ; ; in: de -> fcb ; ; out: de -> buffer address of character ; a = character ; disk.char.in: mvi a,20 call disk.char.help ora a mov a,m rz mvi c,sctr.size mvi a,1ah dci.lup: mov m,a inx h dcr c jnz dci.lup lxi h,fcb.buf.addr dad d mov e,m inx h mov d,m ldax d ret ; ;-------------------------------------------------- ; ; in: de -> fcb ; a = character ; ; out: de = buffer address of character ; disk.char.out: push psw mvi a,21 call disk.char.help ora a jz dco.old lxi h,fcb.buf.addr dad d mov e,m inx h mov d,m xchg dco.old: pop psw mov m,a ret ; ;-------------------------------------------------- ; ; in: de -> fcb ; a = I/O operator (20/21) ; ; out: a = I/O status ; hl = buffer address for current character ; disk.char.help: push psw push d lxi h,fcb.buf.ix dad d mov c,m ;bc <- buf ix inx h mov b,m inx h mov e,m ;de <- buf size inx h mov d,m push h mov h,b mov l,c call cmp.hl.fm.de pop h jnz dch.ch.fm.buf dcx h dcx h ;clr buf ix xra a mov m,a dcx h mov m,a xchg ;hl <- buf size dad h ;h = #sctrs/buf mov b,h ;b = #sctrs/buf xchg dcx h mov d,m ;de <- buf addr dcx h mov e,m xchg ;hl <- buf addr dch.read.lup: push b push h xchg mvi c,26 call entry pop h pop b pop d ;fcb addr pop psw ;read/write code push psw push d push b push h mov c,a ;read/write code call entry push psw ;status lxi d,dflt.dma mvi c,26 call entry pop psw ;status pop h pop b ora a ;status ok? jnz dch.src.eof ;no lxi d,sctr.size dad d ;new dma addr dcr b ;count # sctrs jnz dch.read.lup dch.ch.fm.buf: pop d ;fcb ptr pop psw ;restore stack lxi h,fcb.buf.ix dad d mov c,m inx h mov b,m inx b ;incr buf ix mov m,b dcx h mov m,c dcx h mov d,m ;de <- buf ptr dcx h mov e,m dcx b ;old buf.ix mov h,b mov l,c dad d ;plus buf start = char ptr xra a ret ; dch.src.eof: pop d push h lxi h,fcb.status dad d mov m,a inx h inx h inx h ;point to buf.ix mov c,m inx h mov b,m inx b ;incr buf.ix mov m,b dcx h mov m,c pop h pop psw ret ; ; ; ; ; ; ; ; ; ; ; ; ; base.stk.addr: ds 256 my.stack.top: ; ; ; ; ; ;-------------------------------- ;---check for compiler options--- ;-------------------------------- ; NOTE: NSTAR option is only for older versions of n/STAR ; which do not support (get-date) and (get-console-num) ; calls. Newer versions are handled with MPM option only ; process.options: lda rsvd.wd.ix cpi rwix.lbrckt jnz option.end option.skip: call get.word option.switch: call debug.routine call switch.rsvd.wd.ix db rwix.ADDRESS ! dw option.ADDRESS db rwix.CSTACK ! dw option.CSTACK db rwix.EXECUTE ! dw option.EXECUTE db rwix.INPUT ! dw option.INPUT db rwix.LEVEL ! dw option.LEVEL db rwix.LIMIT ! dw option.LIMIT db rwix.MAP ! dw option.MAP db rwix.MATCH ! dw option.MATCH db rwix.MPM ! dw option.MPM db rwix.NOWARN ! dw option.NOWARN db rwix.NSTAR ! dw option.NSTAR db rwix.NUMBER ! dw option.NUMBER db rwix.PRINT ! dw option.PRINT db rwix.STACK ! dw option.STACK db rwix.STANDALONE ! dw option.STANDALONE db rwix.TAB ! dw option.TAB db rwix.TABLE ! dw option.TABLE db rwix.Z80 ! dw option.Z80 db rwix.comma ! dw option.skip db rwix.semicolon ! dw option.skip db rwix.rbrckt ! dw option.end db 0 ! dw option.err ; option.err: call err.unexpect.word jmp option.end ; ; option.INPUT: lda cmd.line.flag ora a jz option.err call get.word lda word.length cpi 1 jnz option.switch lda word cpi 'A' jc option.switch cpi 'P'+1 jc option.INPUT.ok cpi 'a' jc option.switch cpi 'p'+1 jnc option.switch option.INPUT.ok: ani 0fh sta src.in jmp option.skip ; ; option.Z80: mvi a,0ffh sta Z80.flag jmp option.skip ; ; option.NSTAR: lxi h,01feh ;pseudo version for forced NSTAR shld NSTAR.patch.addr.2 + 1 mvi a,(jmp) sta NSTAR.patch.1 lxi h,NSTAR.patch.2 shld NSTAR.patch.1 + 1 lxi h,NSTAR.patch.3 mvi m,(lda) inx h mvi m,02h inx h mvi m,0f8h ;patch to get unit-id ;---fall into MPM option--- option.MPM: mvi a,0ffh sta MPM.flag jmp option.skip ; ; option.LIMIT: call get.word lda rsvd.wd.ix cpi rwix.STRING jnz option.LIMIT.WORD mvi a,0ffh sta string.move.block.flag jmp option.skip ; ; option.LIMIT.WORD: cpi rwix.WORD cnz err.mssng.rsvd.wd mvi a,0ffh sta limit.word.flag jmp option.skip ; ; option.STANDALONE: mvi a,0ffh sta standalone.flag jmp option.skip ; ; option.NOWARN: mvi a,0ffh sta nowarn.flag jmp option.skip ; ; option.STACK: lda cmd.line.flag ora a jnz option.skip call get.word lda rsvd.wd.ix cpi rwix.SAVE jnz option.STK.no.save ; mvi a,0ffh sta stack.save.flag ;--dflt STACK 256 if STACK SAVE--- lda stack.id.flag ora a jnz option.skip lxi h,256 jmp MAIN.dflt.STACK.id ; ; option.STK.no.save: lda rsvd.wd.ix cpi rwix.NONE jnz option.STK.not.NONE ; mvi a,0ffh sta stack.none.flag jmp option.skip ; ; option.STK.not.NONE: lda word.type ani wtp.cnst cz err.inv.cnst lhld cnst.value MAIN.dflt.STACK.id: shld stack.id.size mvi a,0ffh sta stack.id.flag jmp option.skip ; ; option.CSTACK: call get.word lda rsvd.wd.ix cpi rwix.SIZE cz get.word lda word.type ani wtp.cnst jnz option.CSTACK.ok call err.inv.cnst jmp option.switch option.CSTACK.ok: lhld cnst.value shld my.stack.size jmp option.skip ; ; ; option.TABLE: mvi a,0ffh sta table.fwd.flag jmp option.skip ; ; option.EXECUTE: mvi a,0ffh sta auto.execute.flag jmp option.skip ; ; option.MAP: mvi a,0ffh sta reloc.map.flag jmp option.skip ; ; option.ADDRESS: mvi a,0ffh sta print.code.addr.flag jmp option.skip ; option.LEVEL: mvi a,0ffh sta print.blk.lvl.flag jmp option.skip ; option.MATCH: mvi a,0ffh sta print.blk.match.flag jmp option.skip ; option.NUMBER: mvi a,0ffh sta print.line.num.flag jmp option.skip ; ; ; option.PRINT: call get.word option.PRN.lup: call switch.rsvd.wd.ix db rwix.CON ! dw option.PRN.CON db rwix.PRN ! dw option.PRN.PRN db rwix.LST ! dw option.PRN.PRN db rwix.DISK ! dw option.PRN.DISK db rwix.FULL ! dw option.PRN.FULL db rwix.comma ! dw option.PRINT db 0 ! dw option.switch ; ; option.PRN.CON: mvi a,0ffh sta print.console jmp option.PRINT ; option.PRN.PRN: mvi a,0ffh sta print.printer.flag jmp option.PRINT ; option.PRN.DISK: mvi a,0ffh sta print.disk.flag call get.word lda word cpi '.' ;possibly .EXT jz MAIN.PRN.chk.ext lda word.length cpi 1 jnz option.PRN.lup lda word cpi 'A' jc option.PRN.lup cpi 'P'+1 jc option.PRN.drive cpi 'a' jc option.prn.lup cpi 'p'+1 jnc option.prn.lup option.PRN.drive: ani 5fh sui '@' sta print.fcb jmp option.PRN.DISK ; MAIN.PRN.chk.ext: lda word.length cpi 5 jnc option.PRN.lup ;---fill out to 3 spaces lxi h,word + 3 cpi 4 jz MAIN.PRN.4 cpi 3 jz MAIN.PRN.3 cpi 2 jnz option.PRN.lup mvi m,' ' dcx h MAIN.PRN.3: mvi m,' ' MAIN.PRN.4: lxi h,word + 1 lxi d,print.fcb + fcb.ext lxi b,3 call move.h.2.d.cnt.b jmp option.PRN.DISK ; option.PRN.FULL: sta print.on.off.flag jmp option.PRINT ; option.TAB: call get.word lda cnst.value cpi 2 jz option.TAB.ok cpi 4 jz option.TAB.ok cpi 8 jz option.TAB.ok call err.inv.cnst jmp option.switch ; option.TAB.ok: dcr a sta print.tab.mask call get.word jmp option.switch ; ; option.end: ret ; ; ; ; ;----------------------------- ; start program execution ;----------------------------- ; start: lxi sp,my.stack.top ; lxi d,copyright.notice mvi c,9 call entry ; ;---init source file--- ; lxi d,src.in lxi h,dflt.fcb lxi b,9 call move.h.2.d.cnt.b lxi h,src.in + fcb.ext mvi m,'S' inx h mvi m,'R' inx h mvi m,'C' ; ;---init overlay fcb--- ; lxi d,ovl.fcb lxi h,dflt.fcb lxi b,9 call move.h.2.d.cnt.b ; ;---init code file--- ; lxi h,dflt.fcb lxi d,code.fcb lxi b,12 ;drv:name.ext call move.h.2.d.cnt.b lxi h,code.fcb + fcb.ext mov a,m cpi ' ' jnz start.COM.override push h mov a,m cpi 'S' jnz start.COM.not.SRC inx h mov a,m cpi 'R' jnz start.COM.not.SRC inx h mov a,m cpi 'C' jnz start.COM.not.SRC ; call err.COM.SRC jmp boot ; start.COM.not.SRC: pop h mvi m,'C' inx h mvi m,'O' inx h mvi m,'M' start.COM.override: lxi h,0 shld code.fcb + fcb.rnd.rec ; ;---init disk print file--- ; lxi h,dflt.fcb lxi d,print.fcb lxi b,9 call move.h.2.d.cnt.b ;--disk output fcb already coded for ;--TEXT OUTPUT OPEN & ready for 1st char ; ;-----check for command-line parameters----- ; lxi h,dflt.dma start.cl.lup: mov a,m ora a jz start.no.cl cpi '[' inx h jnz start.cl.lup dcx h lxi d,src.buffer move.cmd.line.lup: mov a,m stax d inx h inx d cpi ']' jz start.end.cmd.line ora a jnz move.cmd.line.lup dcx d mvi a,']' stax d inx d start.end.cmd.line: mvi a,0dh stax d inx d xra a stax d ; mvi a,0ffh sta cmd.line.flag lxi h,0 shld src.buf.ix shld curr.src.line.num call get.src.char call get.word call process.options ; start.no.cl: xra a sta cmd.line.flag ; ;---initialize symbol table ; lhld entry + 1 dcx h mvi m,stet.end.tbl shld start.sym.tbl.addr shld end.sym.tbl.addr shld lowest.sym.tbl.addr ; mvi a,stet.end.tbl sta ste.type xra a sta ste.block.level sta ste.name call move.entry.to.sym.tbl ; ;---open source file--- ; lxi d,src.in mvi c,15 ;open call entry cpi 0ffh jz err.no.SRC call set.up.src.fcb ; ;---start processing .SRC file--- ; call get.src.char call get.word lda rsvd.wd.ix cpi rwix.COPY cz process.COPY ; call process.options call get.word ;skip ']' ;-----open the code-file lxi d,code.fcb mvi c,19 ;delete old call entry lxi d,code.fcb mvi c,22 ;create call entry inr a jz err.COM.open ;-----open the print-file if needed lda print.disk.flag cpi 0ffh jnz MAIN.no.print.dsk lxi d,print.fcb mvi c,19 ;delete call entry ; lxi d,print.fcb mvi c,22 ;create call entry inr a jz err.PRN.open jmp MAIN.print.dsk.ok MAIN.no.print.dsk: xra a sta print.disk.flag MAIN.print.dsk.ok: lda MPM.flag ora a jz MAIN.not.MPM lxi h,MPM.hdr.rtn lxi b,MPM.hdr.end - MPM.hdr.rtn call put.code.block xra a sta stack.save.flag sta stack.none.flag MAIN.not.MPM: lda stack.save.flag ora a jz MAIN.not.stk.sv lxi h,0 call put.LXI.H.hl call put.DAD.SP mvi a,bir.cpm.stack call put.SHLD.fwd MAIN.not.stk.sv: lda stack.id.flag ora a jz MAIN.not.stk.id call put.LXI.SP mvi a,bir.stack.fwd call put.fwd.ref.bir jmp MAIN.stack.ready MAIN.not.stk.id: lda stack.none.flag lxi h,stack.id.flag ora m jnz MAIN.stack.ready ; lxi h,entry + 1 call put.LHLD.hl call put.SPHL MAIN.stack.ready: ; ;---set compiler stack--- ; lxi d,base.stk.addr lhld my.stack.size dad d shld my.top.stk.addr sphl ; ; ;---check for forward table in code file--- ; lda table.fwd.flag ora a jz MAIN.no.fwd.tbl ; ;---normal flow branch around fwd tbl--- ; call put.JMP lhld curr.code.addr push h lxi h,0 call put.code.word ; lhld curr.code.addr shld fwd.tbl.addr ; mvi a,bir.routine.base MAIN.bir.tbl.lup: push psw call put.JMP lxi h,0 call put.code.word pop psw inr a cpi bir.actual.limit jc MAIN.bir.tbl.lup ; lhld curr.code.addr ;---extra space for 'dividend'--- lxi b,(bcd.size - 1) * 2 - 3 dad b ; xthl ;hl <- jmp addr shld curr.code.addr pop h push h call put.code.word pop h shld curr.code.addr ; MAIN.no.fwd.tbl: ; ;---------------------------------------------- ; end of compiler options ;---------------------------------------------- ; lda rsvd.wd.ix cpi rwix.semicolon cz get.word ; xra a sta code.started.this.blk sta data.started.this.blk ; lda rsvd.wd.ix cpi rwix.BEGIN jz MAIN.no.pgm.name lxi h,word lxi d,program.name call move.string call get.word lda rsvd.wd.ix cpi rwix.colon cnz err.inv.pgm.name.delim ; lda word.type ani wtp.delim cnz get.word lda rsvd.wd.ix cpi rwix.BEGIN cnz err.mssng.BEGIN MAIN.no.pgm.name: jmp compile.the.program ; program.name: ds max.word.length ; ; ; ; ; ; err.COM.open: lxi h,em.COM.open call print.error jmp boot ; ; err.PRN.open: lxi h,em.PRN.open call print.error jmp boot ; ; err.inv.pgm.name.delim: lxi h,em.inv.pgm.name.delim jmp print.error ; ; err.mssng.BEGIN: lxi h,em.missng.BEGIN jmp print.error ; em.inv.pgm.name.delim: db 'invalid program-name delimiter',0 em.missng.BEGIN: db 'missing BEGIN at start of program',0 em.COM.open: db 'Code-file Open Error',0 em.PRN.open: db 'Print-file Open Error',0 ; ; ; ;=============================================================== ;MP/M INTERCEPT ROUTINE ;=============================================================== ; This routine must be included in any program ; using the MPM compile option. ; It provides: ; ; 1. record locking & unlocking with automatic extension ; of the file for non-existant records ; ; 2. detaching the LST: device when a EOF (1ah) is sent ; to it. ; ; 3. for programs running under CP/M, it provides automatic ; extension of the file for non-existant records ; ; 4. For programs running under Molecular Computer's n/STAR, ; it provides simulation of the MP/M delay & dispatch ; calls which are not supported by n/STAR. ; ; ; ; Possible problems: ; ; When a random-read returns a status that the sector ; is not allocated, the method used is that specified in the ; MP/M-II Programmers Guide Release 2.1 Programming Guidelines. ; This is to write a record of binary zeros with call 40 (write ; random with zero fill) in order to allocate the record, then ; to retry the lock. The only possible problem with this is ; if a competing process does the same thing and allocates the ; record, locks it, reads it, updates it, writes it, and ; unlocks it (all this) before this process executes the write, ; then this process will have written over the other process's ; record with binary zeros. ; ; Calling procedure: ; mvi a,0ffh ; sta MPM.lock.flag ; lxi h,0 ; shld fcb.rec.buf.sctr ;force fresh read ; ; xra a ; sta MPM.lock.flag ; ; write is same, but no need to clear fcb.rec.buf.sctr ; unless locking for pre-read ; ; ; ; This is ORG'ed at 100h, since that is where it will have to go. ; ; MPM.hdr.rtn: ; ;---make a new BDOS vector to jump to the intercept routine--- ; lhld entry + 1 shld MPM.bdos.jmp + 1 dcx h mvi m,intercept / 100h dcx h mvi m,intercept and 0ffh dcx h mvi m,(jmp) shld entry + 1 ; ;---check whether MP/M, CP/M 2.2, CP/M 3.0 plus, or n/STAR--- ; mvi c,12 call MPM.bdos.jmp ;really call BDOS for this NSTAR.patch.1: ;referenced only by compiler in-place shld icpt.version mov a,h cpi 1 ;MP/M version flag jz end.of.intercept ;really MP/M mov a,l cpi 30h ;CP/M plus?? jc icpt.chk.NSTAR ;CP/M 2.2 or n/STAR mvi a,1 ;CP/M plus -- looks like MP/M shld icpt.version + 1 ;fake MPM jmp end.of.intercept ; icpt.chk.NSTAR equ $ - MPM.hdr.rtn + 100h mvi c,155 ;get date & time call lxi d,icpt.TOD call MPM.bdos.jmp lda icpt.TOD cpi 0ffh jz end.of.intercept ;yep, really CP/M NSTAR.patch.2 equ $ - MPM.hdr.rtn + 100h NSTAR.patch.addr.2: ;referenced only internally to compiler lxi h,01ffh ;pseudo MP/M version for n/STAR shld icpt.version jmp end.of.intercept ; ; icpt.TOD equ $ - MPM.hdr.rtn + 100h db 0ffh,0ffh,0ffh,0ffh,0ffh ; ; intercept equ $ - MPM.hdr.rtn + 100h mov a,c cpi 33 jz icpt.read cpi 34 jz icpt.write cpi 40 jz icpt.write cpi 26 jz icpt.dma cpi 05 jz icpt.list cpi 15 jz icpt.open cpi 22 jz icpt.open cpi 16 jz icpt.close cpi 12 jz icpt.get.version cpi 141 jz icpt.delay cpi 142 jz icpt.dispatch cpi 153 jz icpt.get.con.num MPM.bdos.jmp equ $ - MPM.hdr.rtn + 100h jmp MPM.bdos.jmp ; ; icpt.version equ $ - MPM.hdr.rtn + 100h + 1 icpt.get.version equ $ - MPM.hdr.rtn + 100h lxi h,0000 ;MP/M CP/M version stored here mov a,l ;always return internal version mov b,h ret ; ; icpt.get.con.num equ $ - MPM.hdr.rtn + 100h NSTAR.patch.3: jmp MPM.bdos.jmp ;patch = (LDA F802) for n/STAR cma dcr a ret ; ; ; icpt.chk.true.MPM equ $ - MPM.hdr.rtn + 100h lxi h,icpt.version + 1 mov a,m ora a rz ;return here if CP/M dcx h mov a,m cpi 0f0h ;lowest possible internal version ret ;if carry is set, this is CP/M plus or MP/M ; ; icpt.delay equ $ - MPM.hdr.rtn + 100h call icpt.chk.true.MPM jc MPM.bdos.jmp icpt.fake.delay equ $ - MPM.hdr.rtn + 100h lxi h,0b00h ;delay cnst for 1/60th sec at 4MHz clock icpt.delay.1 equ $ - MPM.hdr.rtn + 100h dcx h mov a,l ora h jnz icpt.delay.1 dcx d mov a,e ora d jnz icpt.fake.delay ret ; ; icpt.dispatch equ $ - MPM.hdr.rtn + 100h call icpt.chk.true.MPM jc MPM.bdos.jmp ret ; ; icpt.open equ $ - MPM.hdr.rtn + 100h ;---save key in case shared open which wipes it out--- lxi h,fcb.rnd.rec dad d mov a,m inx h push h ;stk <- rec.addr + 1 mov h,m mov l,a xthl ;stk <- rec.value ;HL <- rec.addr + 1 push h ;stk <- rec.addr + 1 call MPM.bdos.jmp ;---move file-id from 'rnd.rec' to 'file.id'--- pop h ;HL <- rec.addr + 1 push h ;stk <- rec.addr + 1 mov d,m dcx h mov e,m lxi b,fcb.file.id - fcb.rnd.rec dad b mov m,e inx h mov m,d ;---restore key--- pop h ;HL <- rec.addr + 1 pop d ;DE <- rec.value mov m,d dcx h mov m,e ret ; ; ;---on MPM, shared files are updated with every write,--- ;---so partial-close is wasted effort--- ; icpt.close equ $ - MPM.hdr.rtn + 100h lda icpt.version + 1 ora a jz icpt.close.CPM lxi h,fcb.flags dad d mov a,m ani FILE.r.flag.SHARED jz MPM.bdos.jmp lxi h,5 dad d mov a,m ani 80h ;partial? jz MPM.bdos.jmp mov a,m ani 7fh mov m,a ret ; icpt.close.CPM equ $ - MPM.hdr.rtn + 100h lxi h,5 dad d mov a,m ani 7fh mov m,a jmp MPM.bdos.jmp ; ; MPM.lock.flag equ $ - MPM.hdr.rtn + 100h + 1 icpt.read equ $ - MPM.hdr.rtn + 100h mvi a,0 ora a jz MPM.bdos.jmp icpt.try.lock equ $ - MPM.hdr.rtn + 100h lda icpt.version + 1 ora a jz icpt.read.CPM push d call icpt.set.dma mvi c,42 call MPM.bdos.jmp call icpt.rset.dma pop d mvi c,33 ora a push d cz MPM.bdos.jmp ;go do the read pop d ; cpi 01 jz icpt.unalloc cpi 04 jz icpt.unalloc cpi 08 rnz call delay jmp icpt.try.lock ; icpt.read.CPM equ $ - MPM.hdr.rtn + 100h mvi c,33 push d call MPM.bdos.jmp pop d ora a rz cpi 01 jz icpt.unalloc cpi 04 rnz ; icpt.unalloc equ $ - MPM.hdr.rtn + 100h lhld icpt.org.dma mvi c,128 xra a icpt.clr.sct.lup equ $ - MPM.hdr.rtn + 100h mov m,a inx h dcr c jnz icpt.clr.sct.lup ; push d mvi c,40 call MPM.bdos.jmp pop d jmp icpt.try.lock ; ; ; MPM.unlock.flag equ $ - MPM.hdr.rtn + 100h + 1 icpt.write equ $ - MPM.hdr.rtn + 100h mvi a,0 mvi c,40 ora a jz MPM.bdos.jmp push d call MPM.bdos.jmp pop d ora a rnz lda icpt.version + 1 ora a rz call icpt.set.dma mvi c,43 call MPM.bdos.jmp jmp icpt.rset.dma ; ; ; icpt.dma equ $ - MPM.hdr.rtn + 100h xchg shld icpt.org.dma xchg jmp MPM.bdos.jmp ; icpt.org.dma equ $ - MPM.hdr.rtn + 100h dw 0080h ; ; ; icpt.set.dma equ $ - MPM.hdr.rtn + 100h push d lxi h,fcb.file.id dad d xchg mvi c,26 call MPM.bdos.jmp pop d ret ; ; ; icpt.rset.dma equ $ - MPM.hdr.rtn + 100h push h push d push psw lhld icpt.org.dma xchg mvi c,26 call MPM.bdos.jmp pop psw pop d pop h ret ; ; ; delay equ $ - MPM.hdr.rtn + 100h push d lxi d,6 ;1/10 sec. mvi c,141 ;delay call entry ;may need internal delay pop d ret ; ; ; ; icpt.list equ $ - MPM.hdr.rtn + 100h mov a,e cpi 1ah jnz MPM.bdos.jmp lda icpt.version ora a rz mvi c,159 ;detach list jmp MPM.bdos.jmp ; ; ; end.of.intercept equ $ - MPM.hdr.rtn + 100h ; ; ; MPM.hdr.end: ; ; ; ; end