mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-25 17:34:06 +00:00
342 lines
8.5 KiB
Plaintext
342 lines
8.5 KiB
Plaintext
$title('EMIT module for GENDEF')
|
||
emit:
|
||
do;
|
||
/* D I S K D E F l i b g e n e r a t o r e m i t t e r */
|
||
|
||
mon1: procedure(f,a) external;
|
||
declare f byte, a address;
|
||
end mon1;
|
||
|
||
mon2: procedure(f,a) byte external;
|
||
declare f byte, a address;
|
||
end mon2;
|
||
|
||
boot: procedure public;
|
||
call mon1(0,0);
|
||
end boot;
|
||
|
||
abort: procedure(msg) external;
|
||
declare msg address;
|
||
end abort;
|
||
|
||
/* global variables */
|
||
declare
|
||
parm (26) byte external; /* initial parameters */
|
||
/* a b c d e f g h i j k l m n o p q r s t u v w x y z
|
||
0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2
|
||
0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 */
|
||
|
||
declare
|
||
acclen byte external, /* accumulator length */
|
||
accum(32)byte external; /* accumulator */
|
||
|
||
declare
|
||
lbuff(75) byte external, /* physical line */
|
||
lblen byte external, /* lbuff length */
|
||
lineready byte external, /* line ready flag */
|
||
lineout byte external, /* true if current line out */
|
||
cbuff(8) byte external; /* line prefix */
|
||
|
||
declare
|
||
lit literally 'literally',
|
||
true lit '1',
|
||
false lit '0',
|
||
forever lit 'while true',
|
||
eofile lit '1ah', /* end of file */
|
||
tab lit '09h', /* horizontal tab */
|
||
cr lit '0dh',
|
||
lf lit '0ah';
|
||
|
||
declare dcnt byte external;
|
||
|
||
close: procedure(fcb) external;
|
||
declare fcb address;
|
||
end close;
|
||
|
||
delete: procedure(fcb) external;
|
||
declare fcb address;
|
||
end delete;
|
||
|
||
diskwrite: procedure(fcb) byte external;
|
||
declare fcb address;
|
||
end diskwrite;
|
||
|
||
make: procedure(fcb) external;
|
||
declare fcb address;
|
||
end make;
|
||
|
||
rename: procedure(fcb) external;
|
||
declare fcb address;
|
||
end rename;
|
||
|
||
setdma: procedure(dma) external;
|
||
declare dma address;
|
||
end setdma;
|
||
|
||
/* local variables */
|
||
declare
|
||
fcb (33) byte external,
|
||
ifcb (33) byte at (.fcb), /* initial input file control block */
|
||
efcb (33) byte, /* .asm file control block */
|
||
eufb byte at (.efcb(13)),/* unfilled bytes field */
|
||
efcbr byte at (.efcb(32));/* next record field */
|
||
|
||
/* buffers */
|
||
declare
|
||
comcol lit '32', /* beginning column for comments */
|
||
ecolumn byte, /* output column 0,1,... */
|
||
ebuff (512) byte, /* emit file buffer */
|
||
ebp address; /* emit buffer pointer */
|
||
|
||
/* sector size definitions */
|
||
declare
|
||
sectsize lit '128', /* bytes per sector */
|
||
sectmsk lit '7fh', /* sectsize - 1 */
|
||
sectshf lit '7'; /* shl(1,sectshf) = sectsize */
|
||
|
||
setemit: procedure public;
|
||
/* set up code emitter file */
|
||
call move(16,.ifcb(0),.efcb(0)); /* copy name */
|
||
call move(4,.('LIB',0),.efcb(9));/* copy type */
|
||
if ifcb(16) <> 0 then /* select destination drive */
|
||
efcb(0) = ifcb(16);
|
||
call delete(.efcb);
|
||
call make(.efcb);
|
||
if dcnt = 255 then /* no space */
|
||
call abort(.('no ".LIB" directory space$'));
|
||
efcbr,ebp,ecolumn = 0;
|
||
lineout = true; /* prevent initial line write */
|
||
end setemit;
|
||
|
||
clearebuff: procedure;
|
||
/* clear the ebuff buffer up to (not including) ebp */
|
||
declare (i,n) byte;
|
||
/* skip the case of no buffers to write */
|
||
if low(n:=shr(ebp,7)-1) = 255 then return;
|
||
/* n is last buffer to write */
|
||
ebp = 0;
|
||
do i = 0 to n;
|
||
call setdma(.ebuff(ebp));
|
||
if diskwrite(.efcb) <> 0 then
|
||
call abort(.('".LIB" disk full$'));
|
||
ebp = ebp + sectsize;
|
||
end;
|
||
ebp = 0;
|
||
end clearebuff;
|
||
|
||
emitbyte: procedure(b) public;
|
||
declare b byte;
|
||
/* write b to emit file */
|
||
if b = cr then
|
||
ecolumn = 0;
|
||
if b = tab then
|
||
ecolumn = (ecolumn + 8) and 11111000b;
|
||
if b >= ' ' then
|
||
ecolumn = ecolumn + 1;
|
||
if ebp >= length(ebuff) then call clearebuff;
|
||
ebuff(ebp) = b;
|
||
ebp = ebp + 1;
|
||
end emitbyte;
|
||
|
||
efinis: procedure public;
|
||
/* emit file finis */
|
||
/* eufb = 0; /* clear the unfilled bytes field */
|
||
/* do while (low(ebp) and sectmsk) <> 0; */
|
||
/* eufb = eufb + 1; /* counts unfilled bytes */
|
||
/* call emitbyte(eofile); */
|
||
/* end; Illegal under BDOS 3.0 */
|
||
call clearebuff; /* write all buffers */
|
||
call close(.efcb);
|
||
if dcnt = 255 then
|
||
call abort(.('cannot close ".LIB"$'));
|
||
end efinis;
|
||
|
||
emitcrlf: procedure public;
|
||
/* emit end of physical line */
|
||
call emitbyte(cr);
|
||
call emitbyte(lf);
|
||
end emitcrlf;
|
||
|
||
emittab: procedure public;
|
||
call emitbyte(tab);
|
||
end emittab;
|
||
|
||
emitcomma: procedure public;
|
||
call emitbyte(',');
|
||
end emitcomma;
|
||
|
||
emitdigit: procedure(d);
|
||
declare d byte;
|
||
/* emit the decimal digit given by d */
|
||
call emitbyte('0'+d);
|
||
end emitdigit;
|
||
|
||
emitnulcom: procedure public;
|
||
call emitbyte(';');
|
||
call emitcrlf;
|
||
end emitnulcom;
|
||
|
||
declare
|
||
/* literals for decimal output control */
|
||
zsup$on lit 'true', /* zero suppression on */
|
||
zsup$off lit 'false', /* zero suppression off */
|
||
bsup$on lit 'true', /* blank suppress */
|
||
bsup$off lit 'false', /* blank suppress off */
|
||
byte$base lit '100', /* byte value */
|
||
word$base lit '10000'; /* word value */
|
||
|
||
emitdecz: procedure(v,zsup,bsup,base) public;
|
||
declare
|
||
v address, /* value to emit */
|
||
zsup byte, /* zero suppress if true */
|
||
bsup byte, /* blank suppression */
|
||
base address, /* 100 for byte, 10000 for word */
|
||
d byte;
|
||
do while base <> 0;
|
||
d = v/base mod 10;
|
||
if (zsup := zsup and (d = 0) and (base > 1)) then
|
||
do;
|
||
if not bsup then call emitbyte(' ');
|
||
end; else
|
||
call emitdigit(d);
|
||
base = base/10;
|
||
end;
|
||
end emitdecz;
|
||
|
||
emitnib: procedure(n);
|
||
declare n byte;
|
||
if n > 9 then
|
||
n = n - 10 + 'A'; else
|
||
n = n + '0';
|
||
call emitbyte(n);
|
||
end emitnib;
|
||
|
||
emithex8: procedure(h) public;
|
||
declare h byte;
|
||
call emitnib(shr(h,4));
|
||
call emitnib(h and 0fh);
|
||
end emithex8;
|
||
|
||
emithex16: procedure(a) public;
|
||
declare a address;
|
||
call emithex8(high(a));
|
||
call emithex8(low(a));
|
||
end emithex16;
|
||
|
||
emitaddr: procedure(a) public;
|
||
declare a address;
|
||
call emithex16(a);
|
||
call emitbyte('h');
|
||
end emitaddr;
|
||
|
||
emitdec8: procedure(b) public;
|
||
declare b byte;
|
||
call emitdecz(b,zsup$on,bsup$on,byte$base);
|
||
end emitdec8;
|
||
|
||
emitdec16: procedure(w) public;
|
||
declare w address;
|
||
call emitdecz(w,zsup$on,bsup$on,word$base);
|
||
end emitdec16;
|
||
|
||
emitdecb: procedure(w) public;
|
||
declare w address;
|
||
call emitdecz(w,zsup$on,bsup$off,word$base);
|
||
end emitdecb;
|
||
|
||
emitline: procedure public;
|
||
/* write current line to emit file */
|
||
declare i byte;
|
||
if lineready then /* line is ready to write */
|
||
do;
|
||
if lineout then return; /* already written */
|
||
lineout = true;
|
||
if lblen = 0 then return;
|
||
/* non - zero line length */
|
||
call emitbyte(';');
|
||
call emittab;
|
||
i = 0;
|
||
do while (i:=i+1) < lblen;
|
||
call emitbyte(lbuff(i-1));
|
||
end;
|
||
call emitcrlf;
|
||
end;
|
||
end emitline;
|
||
|
||
emitchar: procedure(a) public;
|
||
/* emit literal string */
|
||
declare a address;
|
||
declare s based a byte;
|
||
do while s <> '$';
|
||
call emitbyte(s);
|
||
a = a + 1;
|
||
end;
|
||
end emitchar;
|
||
|
||
emitcharn: procedure(a,n) public;
|
||
declare
|
||
a address,
|
||
n byte;
|
||
/* emitchar(a), followed by number */
|
||
call emitchar(a);
|
||
call emitdecz(n,zsup$on,bsup$on,byte$base);
|
||
end emitcharn;
|
||
|
||
emitop: procedure(a) public;
|
||
/* tab, operator */
|
||
declare a address;
|
||
call emittab;
|
||
call emitchar(a);
|
||
end emitop;
|
||
|
||
emitoptab: procedure(a) public;
|
||
/* emit tab, operator, tab */
|
||
declare a address;
|
||
call emitop(a);
|
||
call emittab;
|
||
end emitoptab;
|
||
|
||
emitcomment: procedure(a) public;
|
||
declare a address;
|
||
do while ecolumn < comcol;
|
||
call emittab;
|
||
end;
|
||
call emitbyte(';');
|
||
call emitchar(a);
|
||
call emitcrlf;
|
||
end emitcomment;
|
||
|
||
emitdw: procedure public;
|
||
call emitoptab(.('dw$'));
|
||
end emitdw;
|
||
|
||
emitdb: procedure public;
|
||
call emitoptab(.('db$'));
|
||
end emitdb;
|
||
|
||
emitdwn: procedure(n) public;
|
||
declare n address;
|
||
call emitdw;
|
||
call emitdec16(n);
|
||
end emitdwn;
|
||
|
||
emitdbn: procedure(n) public;
|
||
declare n byte;
|
||
call emitdb;
|
||
call emitdec8(n);
|
||
end emitdbn;
|
||
|
||
emitdwnc: procedure(n,c) public;
|
||
declare (n,c) address;
|
||
call emitdwn(n);
|
||
call emitcomment(c);
|
||
end emitdwnc;
|
||
|
||
emitdbnc: procedure(n,c) public;
|
||
declare n byte, c address;
|
||
call emitdbn(n);
|
||
call emitcomment(c);
|
||
end emitdbnc;
|
||
|
||
end;
|
||
|