seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-26 09:54:20 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Upload

Browse Source 
Digital Research
This commit is contained in:
Sepp J Morris
2020-11-06 18:50:37 +01:00
parent 621ed8ccaf
commit 31738079c4
8481 changed files with 1888323 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

69
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/BREXPR.PLM Normal file
View File

@@ -0,0 +1,69 @@
$title ('BRACKET EXPRESSION')
brexpr:
/*
modified 4/13/81 R. Silberstein
*/
do;
$include (:f1:macro.lit)
$include (:f1:brexpr.x86)
$include (:f1:ermod.ext)
$include (:f1:exglob.ext)
$eject
/* compute index expression within brackets */
bracketexpr: proc(pt) byte public;
dcl pt address,oper based pt operandstruc,
(firsttype,firstreg,lasttype,lastreg) byte,
baseregi lit '0',indexregi lit'1';
regtyp: proc(pt1,pt2) byte;
dcl (pt1,pt2) address,(typ based pt1,regi based pt2) byte;
if (token.type=reg) and (token.descr=wrd) then$do
typ=baseregi;
regi=token.value;
if (regi=rbp) or (regi=rbx) then return true;
typ=indexregi;
if (regi=rsi) or (regi=rdi) then return true;
end$if;
return false;
end regtyp;
setoperflags: proc (pt1,pt2);
dcl (pt1,pt2) address,(typ based pt1,regi based pt2) byte;
if typ=indexregi then$do
oper.sflag=oper.sflag or iregbit;
IF REGI = RDI THEN OPER.BASEINDEX = OPER.BASEINDEX OR INDEXREGBIT;
else$do
oper.sflag=oper.sflag or bregbit;
IF REGI = RBP THEN OPER.BASEINDEX = OPER.BASEINDEX OR BASEREGBIT;
end$if;
end setoperflags;
if not regtyp(.firsttype,.firstreg) then return false;
call setoperflags(.firsttype,.firstreg);
call scan;
if specialtoken('+') then$do
call scan;
if not regtyp(.lasttype,.lastreg) then return false;
if firsttype=lasttype then return false;
call setoperflags(.lasttype,.lastreg);
call scan;
end$if;
if not specialtoken(rightbracket) then return false;
call scan;
if (oper.sflag and segmbit) = 0 then$do
if oper.stype=number then$do
oper.baseindex=oper.baseindex or nooverridebit;
end$if;
end$if;
oper.stype=variable;
return true;
end bracketexpr;
end$module brexpr;


351
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/CM.PLM Normal file
View File

@@ -0,0 +1,351 @@
$title ('codemacro module 1')
cm1:
do;
/*
modified 7/24/81 R. Silberstein
*/
/* This is the module to build new instructions
which is not present in the already existing
system. */
$include (:f1:macro.lit)
$include (:f1:equals.lit)
$include (:f1:struc.lit)
$include (:f1:cmacd.lit)
$include (:f1:ermod.lit)
$include (:f1:scan.ext)
$include (:f1:ermod.ext)
$include (:f1:cm2.ext)
$include (:f1:cm.lit)
$include (:f1:global.ext)
$eject
/* Subroutines: */
more$left$on$line: PROC byte;
if accum(0) <> cr then return true;
else return false;
end$proc more$left$on$line;
modrm$rout: PROC;
dcl nopar byte;
if token.type = number then$do
call put$b(mmodrm1);
if token.value > 7 then$do
cm$error=true; /* legal values are 0,1,.. .,7 */
return;
else$do
call put$b(token.value);
end$if;
else$do
if token.type = ident then$do
if legal$parameter(acclen,.accum(0),.nopar) then$do
call put$b(mmodrm2);
call put$b(nopar);
else$do /* error, parameter mismatch */
cm$error=true;
return;
end$if;
else$do /* error, expected parameter */
cm$error=true;
return;
end$if;
end$if;
call scan;
if accum(0) <> comma then$do
/* error, expected comma */
cm$error=true;
return;
end$if;
call scan;
if token.type = ident then$do
if legal$parameter(acclen,.accum(0),.nopar) then$do
call put$b(nopar);
call scan;
return;
else$do /* error, parameter mismatch */
cm$error=true;
return;
end$if;
else$do /* error, expected parameter */
cm$error=true;
return;
end$if;
end$proc modrm$rout;
db$dw$common$rout: PROC(directive);
dcl (directive,nopar) byte;
if token.type = number then$do
call put$b(directive);
if directive = mdwn then$do
call put$w(token.value);
else$do
if token.value > 0ffh then cm$error=true;
else call put$b(token.value);
end$if;
call scan;
return;
else$do
if token.type = ident then$do
if legal$parameter(acclen,.accum(0),.nopar) then$do
call put$b(directive+1);
call put$b(nopar);
call scan;
return;
else$do /* error, parameter mismatch */
cm$error=true;
return;
end$if;
else$do /* error, expected parameter */
cm$error=true;
return;
end$if;
end$if;
end$proc db$dw$common$rout;
d$s$rb$rw$rout: PROC(directive);
dcl (directive,nopar) byte;
if token.type = ident then$do
if legal$parameter(acclen,.accum(0),.nopar) then$do
call put$b(directive);
call put$b(nopar);
call scan;
return;
else$do /* error, parameter mismatch */
cm$error=true;
return;
end$if;
else$do /* error, expected parameter */
cm$error=true;
return;
end$if;
end$proc d$s$rb$rw$rout;
nosegfix$rout: PROC;
dcl nopar byte;
call put$b(mnosegfix);
do case legal$seg$reg;
do; /* error, no segment register specified */
cm$error=true;
return;
end;
call put$b(res);
call put$b(rcs);
call put$b(rss);
call put$b(rds);
end$case;
call scan;
if accum(0) <> comma then$do
/* error, expected comma */
cm$error=true;
return;
end$if;
call scan; /* skip comma */
if legal$parameter(acclen,.accum(0),.nopar) then$do
call put$b(nopar);
call scan;
else$do
cm$error=true;
return;
end$if;
end$proc nosegfix$rout;
dbit$rout: PROC;
call put$b(mdbit);
end$proc dbit$rout;
field$descr$rout: PROC;
dcl nopar byte,cm$b$var based cmpt byte;
do forever;
if token.type <> number or token.value > 0fh then$do
/* error, expected numberdef. */
cm$error=true;
return;
end$if;
call put$b(mnumberbits);
call put$b(token.value);
call scan;
if accum(0) <> leftpar then$do
/* error, expected left paranthesis */
cm$error=true;
return;
end$if;
call scan; /* skip left paranthesis */
if token.type = ident then$do
if not legal$parameter(acclen,.accum(0),.nopar) then$do
/* error, parameter mismatch */
cm$error=true;
return;
end$if;
cmpt=cmpt-2;
cm$b$var=cm$b$var-1; /* it was a parameter, not a number */
cmpt=cmpt+2;
call put$b(nopar);
call scan;
if accum(0) <> leftpar then$do
/* error, expected left paranthesis */
cm$error=true;
return;
end$if;
call scan; /* skip left paranthesis */
end$if;
if token.type <> number or token.value > 0ffh then$do
/* error, expected numberdef.(byte) or parameter */
cm$error=true;
return;
end$if;
call put$b(token.value);
call scan;
if accum(0) <> rightpar then$do
/* error,expected right paranthesis */
cm$error=true;
return;
end$if;
call scan; /* skip right paranthesis */
cmpt=cmpt-4;
if cm$b$var = mformalbits and
accum(0) = rightpar then call scan;
cmpt=cmpt+4;
if accum(0) <> comma then return;
call scan;
end$forever;
end$proc field$descr$rout;
enddbit$rout: PROC;
call put$b(mendbit);
end$proc enddbit$rout;
endm$rout: PROC;
call put$b(mendm);
end$proc endm$rout;
$eject
/* level 1 in the syntax-tree of codemacrobuilding */
COMMON$CM$ROUT: PROC (TYPE);
DECLARE TYPE BYTE;
if pass = 1 then$do
call skip$rest$of$line;
return;
end$if;
cm$error=false;
if not codemacro$flag then$do
/* error, codemacro directive outside codemacrobodydef. */
cm$error=true;
end$if;
DO CASE TYPE;
call db$dw$common$rout(mdbn);
call db$dw$common$rout(mdwn);
call d$s$rb$rw$rout(mddf);
call d$s$rb$rw$rout(msegfix);
call nosegfix$rout;
call modrm$rout;
call d$s$rb$rw$rout(mrelb);
call d$s$rb$rw$rout(mrelw);
DO;
call dbit$rout;
call field$descr$rout;
call enddbit$rout;
END;
END$CASE;
if cm$error or more$left$on$line then$do
/* error */
global$cm$error=true;
call errmsg(codemacroerr);
end$if;
call skip$rest$of$line;
END COMMON$CM$ROUT;
codemacro$rout: PROC public;
if pass = 1 then$do
codemacro$flag=true;
call skip$rest$of$line;
return;
end$if;
cm$error=false;
global$cm$error=false;
if codemacro$flag then$do
/* error, nested codemacrodefinition */
cm$error=true;
end$if;
call init$cm$rout; /* clearing all temp. working storages */
codemacro$flag=true;
if not name$rout then$do
/* error, expected codemacroname */
cm$error=true;
end$if;
call formal$list$rout;
if cm$error or more$left$on$line$ then$do
/* error */
global$cm$error=true;
call errmsg(codemacroerr);
end$if;
call skip$rest$of$line;
end$proc codemacro$rout;
db$cm$rout: PROC public;
CALL COMMON$CM$ROUT (0);
end$proc db$cm$rout;
dw$cm$rout: PROC public;
CALL COMMON$CM$ROUT (1);
end$proc dw$cm$rout;
dd$cm$rout: PROC public;
CALL COMMON$CM$ROUT (2);
end$proc dd$cm$rout;
segfix$cm$rout: PROC public;
CALL COMMON$CM$ROUT (3);
end$proc segfix$cm$rout;
nosegfix$cm$rout: PROC public;
CALL COMMON$CM$ROUT (4);
end$proc nosegfix$cm$rout;
modrm$cm$rout: PROC public;
CALL COMMON$CM$ROUT (5);
end$proc modrm$cm$rout;
relb$cm$rout: PROC public;
CALL COMMON$CM$ROUT (6);
end$proc relb$cm$rout;
relw$cm$rout: PROC public;
CALL COMMON$CM$ROUT (7);
end$proc relw$cm$rout;
dbit$cm$rout: PROC public;
CALL COMMON$CM$ROUT (8);
end$proc dbit$cm$rout;
end$cm$rout: PROC public;
if pass = 1 then$do
call skip$rest$of$line;
codemacro$flag=false;
return;
end$if;
cm$error=false;
if not codemacro$flag then$do
/* error, terminating a not yet started codemacro */
cm$error=true;
end$if;
call endm$rout;
if pass = 0 then call terminate$cm$rout;
if cm$error or more$left$on$line or cm$list$overflow then$do
/* error */
call errmsg(codemacroerr);
end$if;
call skip$rest$of$line;
global$cm$error=false;
codemacro$flag=false;
end$proc end$cm$rout;
end$module cm1;


344
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/CM2.PLM Normal file
View File

@@ -0,0 +1,344 @@
$title ('codemacro module 2')
cm2:
do;
/*
modified 3/26/81 R. Silberstein
*/
/* This is the module to build new instructions
which is not present in the already existing
system. */
$include (:f1:macro.lit)
$include (:f1:equals.lit)
$include (:f1:struc.lit)
$include (:f1:cmacd.lit)
$include (:f1:cm.lit)
$include (:f1:symb.ext)
$include (:f1:subr1.ext)
$include (:f1:subr2.ext)
$include (:f1:scan.ext)
$include (:f1:files.ext)
$include (:f1:exglob.ext)
$eject
/* D E C L A R A T I O N F O R "C O D E M A C R O" P A R T
Extended version of ASM86 */
dcl cm$name(80) byte ,
codemacro$found byte ,
cm$n$pt address ,
cm$n$var based cm$n$pt byte,
cm$n$lg byte ,
par$name(80) byte ,
pmpt address ,
cm$pm$var based pmpt byte,
cm$error byte public ,
cm$body(100) byte ,
cmpt address public ,
cm$b$var based cmpt byte,
cm$w$var based cmpt addr,
cm$counter addr ,
global$cm$error byte public ,
cm$body$full byte ,
ant$par byte ,
cm$list$overflow byte public;
$eject
/* VARIOUS SUBROUTINES */
legal$parameter: PROC(lg,ptr,ptr2) byte public;
dcl (lg,i) byte,
(ptr,ptr2) address,
no based ptr2 byte;
i=0;
do no=0 to cm$body(2)-1;
if parname(i+lg) = 0 and
equal(lg,ptr,.par$name(i)) then return true;
do while par$name(i:=i+1) <> 0;
end$while;
i=i+1;
end;
return false;
end$proc legal$parameter;
legal$spec$letter: PROC(l) byte;
dcl (l,i) byte;
dcl table(8) byte data ('ACDEMRSX');
do i=0 to last(table);
if table(i) = l then return i;
end;
return i;
end$proc legal$spec$letter;
legal$mod$letter: PROC(l) byte;
dcl (l,i) byte;
dcl table(4) byte data ('BWDS');
do i=0 to last(table);
if table(i) = l and i < 3 then return i;
if table(i) = l and i = 3 then$do
if accum(2) = 'B' then return 3;
end$if;
end;
return i;
end$proc legal$mod$letter;
legal$register: PROC byte;
declare disp byte;
if token.type <> reg then return 0;
disp=0;
if token.descr=byt then disp=8;
if token.descr=dwrd then disp=16;
return token.value + disp + 1;
end$proc legal$register;
legal$seg$reg: PROC byte public;
if token.type <> reg then return 0;
if token.descr <> dwrd then return 0;
return token.value + 1;
end$proc legal$seg$reg;
put$b: PROC(b) public;
dcl b byte;
cm$counter=cm$counter+1;
if cm$counter > 99 then$do
cm$error=true;
cm$body$full=true;
return;
end$if;
cm$b$var=b;
cmpt=cmpt+1;
end$proc put$b;
put$w: PROC(w) public;
dcl w addr;
cm$counter=cm$counter+2;
if cm$counter > 99 then$do
cm$error=true;
cm$body$full=true;
return;
end$if;
cm$w$var=w;
cmpt=cmpt+2;
end$proc put$w;
update$cm$lists: PROC byte;
dcl listptr address,next based listptr address;
dcl ptr address;
ptr=.listptr;
if findcodemacro(cm$n$lg,.cm$name(0),ptr)
then$do
do while next <> 0;
listptr=next;
end$while;
else$do
if not new$cm$name(cm$n$lg,.cm$name(0),ptr)
then return false;
end$if;
next=freept;
if not new$cm$body(cm$counter,.cm$body(0))
then return false;
return true;
end$proc update$cm$lists;
$eject
/* level 4 in the syntax-tree of coeemacro building */
register$rout: PROC (l);
dcl l byte;
call put$b(l);
end$proc register$rout;
range$rout: PROC;
put$range: PROC(time);
dcl time byte;
if token.type = number then$do
if time = first then$do
cm$b$var=cm$b$var+numberrange;
cmpt=cmpt+1;
end$if;
if token.value > 0ffh then$do
cm$error=true; /* too large number */
return;
else$do
call put$b(token.value);
end$if;
else$do
if time = first then$do
cm$b$var=cm$b$var+registerrange;
cmpt=cmpt+1;
end$if;
do case legal$register;
do; /* error, expecting a register spec. */
cm$error=true;
return;
end;
call register$rout(rax);
call register$rout(rcx);
call register$rout(rdx);
call register$rout(rbx);
call register$rout(rsp);
call register$rout(rbp);
call register$rout(rsi);
call register$rout(rdi);
call register$rout(ral);
call register$rout(rcl);
call register$rout(rdl);
call register$rout(rbl);
call register$rout(rah);
call register$rout(rch);
call register$rout(rdh);
call register$rout(rbh);
call register$rout(res);
call register$rout(rcs);
call register$rout(rss);
call register$rout(rds);
end$case;
end$if;
call scan;
end$proc put$range;
s$range: PROC;
cmpt=cmpt-1;
cm$b$var=cm$b$var+singlerange;
call put$range(first);
end$proc s$range;
d$range: PROC;
cmpt=cmpt-1;
cm$b$var=cm$b$var+doublerange;
call put$range(first);
if accum(0) <> comma then$do
cm$error=true;
return;
end$if;
call scan;
call put$range(second);
if accum(0) <> rightpar then$do
cm$error=true;
return;
end$if;
end$proc d$range;
/* mainpart of range routine */
call scan; /* skip left paranthesis */
if nextch = comma then call d$range;
else call s$range;
call scan;
end$proc range$rout;
spec$letter$rout: PROC(l);
dcl l byte;
call put$b(l);
end$proc spec$letter$rout;
mod$letter$rout: PROC(l);
dcl l byte;
call put$b(l);
end$proc mod$letter$rout;
$eject
/* level 3 in the syntax-tree of codemacro building */
par$descr$rout: PROC;
call copy(acclen,.accum(0),.cm$pm$var);
pmpt=pmpt+acclen;
cm$pm$var=0; /* end of par.name */
pmpt=pmpt+1;
call scan;
if accum(0) <> colon then$do
/* error, expected colon in parameterdecl */
cm$error=true;
end$if;
call scan;
do case legal$spec$letter(accum(0));
call spec$letter$rout(speca);
call spec$letter$rout(specc);
call spec$letter$rout(specd);
call spec$letter$rout(spece);
call spec$letter$rout(specm);
call spec$letter$rout(specr);
call spec$letter$rout(specs);
call spec$letter$rout(specx);
do; /* error, expected specifier letter */
cm$error=true;
return;
end;
end$case;
do case legal$mod$letter(accum(1));
call mod$letter$rout(modb);
call mod$letter$rout(modw);
call mod$letter$rout(modd);
call mod$letter$rout(modsb);
call mod$letter$rout(nomod); /* no modletter */
end$case;
call scan;
if accum(0) = leftpar then call range$rout;
cm$body(2)=cm$body(2)+1;
end$proc par$descr$rout;
$eject
/* level 2 in the syntax-tree of codemacro building */
/* Procedure to initialize temporary storage and pointers
conserning the building of codemacro */
init$cm$rout: PROC public;
cm$n$pt=.cm$name(0);
cmpt=.cm$body(0)+3; /* correcting for the head */
pmpt=.par$name(0);
CALL FILL (0, LENGTH (CM$NAME), .CM$NAME);
CALL FILL (0, LENGTH (CM$BODY), .CM$BODY);
CALL FILL (0, LENGTH (PAR$NAME), .PAR$NAME);
ant$par=0;
cm$counter=3;
cm$body$full=false;
cm$list$overflow=false;
end$proc init$cm$rout;
name$rout: PROC byte public;
if token.type <> ident then return false;
call copy(acclen,.accum(0),.cm$name(0));
cm$n$lg=acclen;
call scan;
return true;
end$proc name$rout;
formal$list$rout: PROC public;
do while token.type = ident;
call par$descr$rout;
if accum(0) <> ',' then return; /* end of parameters */
call scan;
end$while;
end$proc formal$list$rout;
terminate$cm$rout: PROC public;
if global$cm$error then$do
/* error present in codemacrodef, */
/* no updating of codemacrolist */
return;
end$if;
if not update$cm$lists
then$do
cm$error=true; /* overflow, no more vacant memory */
cm$list$overflow=true;
return;
end$if;
end$proc terminate$cm$rout;
end$module cm2;


524
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/CMAC1.PLM Normal file
View File

@@ -0,0 +1,524 @@
$title ('CODEMACRO DEFINITIONS - PART 1')
cmac1:
do;
$include (:f1:macro.lit)
$include (:f1:cmacd.lit)
$include (:f1:equals.lit)
$include (:f1:cmac.lit)
/* Code-macro table: */
dcl
/* AAA */
aaa1 cmac3struc public data(
nil,0,
mdbn,37h, /* DB 37H */
mendm), /* ENDM */
/* AAD */
aad1 cmac4struc public data(
nil,0,
mdwn,0d5h,0ah, /* DW 0AD5H */
mendm), /* ENDM */
/* AAM */
aam1 cmac4struc public data(
nil,0,
mdwn,0d4h,0ah, /* DW 0AD4H */
mendm), /* ENDM */
/* AAS */
aas1 cmac3struc public data(
nil,0,
mdbn,3fh, /* DB 3FH */
mendm), /* ENDM */
/* ADC dst:Eb,src:Db */
adc1 cmac14struc data(
nil,2,
specE,modb,
specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,80h, /* DB 80H */
mmodrm1,2,dst, /* MODRM 2,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* ADC dst:Ew,src:Db */
adc2 cmac14struc data(
.adc1,2,
specE,modw,
specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,2,dst, /* MODRM 2,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* ADC dst:Ew,src:Dsb */
adc3 cmac14struc data(
.adc2,2,
specE,modw,
specD,modsb,
msegfix,dst, /* SEGFIX dst */
mdbn,83h, /* DB 83H */
mmodrm1,2,dst, /* MODRM 2,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* ADC dst:Ew,src:Dw */
adc4 cmac14struc data(
.adc3,2,
specE,modw,
specD,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,2,dst, /* MODRM 2,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* ADC dst:Ab,src:Db */
adc5 cmac9struc data(
.adc4,2,
specA,modb,
specD,modb,
mdbn,14h, /* DB 14H */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* ADC dst:Aw,src:Db */
adc6 cmac9struc data(
.adc5,2,
specA,modw,
specD,modb,
mdbn,15h, /* DB 15H */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* ADC dst:Aw,src:Dw */
adc7 cmac9struc data(
.adc6,2,
specA,modw,
specD,modw,
mdbn,15h, /* DB 15H */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* ADC dst:Eb,src:Rb */
adc8 cmac12struc data(
.adc7,2,
specE,modb,
specR,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,10h, /* DB 10H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* ADC dst:Ew,src:Rw */
adc9 cmac12struc data(
.adc8,2,
specE,modw,
specR,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,11h, /* DB 11H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* ADC dst:Rb,src:Eb */
adc10 cmac12struc data(
.adc9,2,
specR,modb,
specE,modb,
msegfix,src, /* SEGFIX src */
mdbn,12h, /* DB 12H */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* ADC dst:Rw,src:Ew */
adc11 cmac12struc public data(
.adc10,2,
specR,modw,
specE,modw,
msegfix,src, /* SEGFIX src */
mdbn,13h, /* DB 13H */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* ADD dst:Eb,src:Db */
add1 cmac14struc data(
nil,2,
specE,modb,
specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,80h, /* DB 80H */
mmodrm1,0,dst, /* MODRM 0,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* ADD dst:Ew,src:Db */
add2 cmac14struc data(
.add1,2,
specE,modw,
specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,0,dst, /* MODRM 0,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* ADD dst:Ew,src:Dsb */
add3 cmac14struc data(
.add2,2,
specE,modw,
specD,modsb,
msegfix,dst, /* SEGFIX dst */
mdbn,83h, /* DB 83H */
mmodrm1,0,dst, /* MODRM 0,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* ADD dst:Ew,src:Dw */
add4 cmac14struc data(
.add3,2,
specE,modw,
specD,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,0,dst, /* MODRM 0,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* ADD dst:Ab,src:Db */
add5 cmac9struc data(
.add4,2,
specA,modb,
specD,modb,
mdbn,04h, /* DB 04H */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* ADD dst:Aw,src:Db */
add6 cmac9struc data(
.add5,2,
specA,modw,
specD,modb,
mdbn,05h, /* DB 05H */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* ADD dst:Aw,src:Dw */
add7 cmac9struc data(
.add6,2,
specA,modw,
specD,modw,
mdbn,05h, /* DB 05H */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* ADD dst:Eb,src:Rb */
add8 cmac12struc data(
.add7,2,
specE,modb,
specR,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,0, /* DB 00H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* ADD dst:Ew,src:Rw */
add9 cmac12struc data(
.add8,2,
specE,modw,
specR,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,1, /* DB 01H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* ADD dst:Rb,src:Eb */
add10 cmac12struc data(
.add9,2,
specR,modb,
specE,modb,
msegfix,src, /* SEGFIX src */
mdbn,2, /* DB 02H */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* ADD dst:Rw,src:Ew */
add11 cmac12struc public data(
.add10,2,
specR,modw,
specE,modw,
msegfix,src, /* SEGFIX src */
mdbn,3, /* DB 03H */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* AND dst:Eb,src:Db */
and1 cmac14struc data(
nil,2,
specE,modb,
specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,80h, /* DB 80H */
mmodrm1,4,dst, /* MODRM 4,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* AND dst:Ew,src:Db */
and2 cmac14struc data(
.and1,2,
specE,modw,specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,4,dst, /* MODRM 4,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* AND dst:Ew,src:Dw */
and3 cmac14struc data(
.and2,2,
specE,modw,specD,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,4,dst, /* MODRM 4,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* AND dst:Ab,src:Db */
and4 cmac9struc data(
.and3,2,
specA,modb,specD,modb,
mdbn,24h, /* DB 24H */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* AND dst:Aw,src:Db */
and5 cmac9struc data(
.and4,2,
specA,modw,specD,modb,
mdbn,25h, /* DB 25H */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* AND dst:Aw,src:Dw */
and6 cmac9struc data(
.and5,2,
specA,modw,specD,modw,
mdbn,25h, /* DB 25H */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* AND dst:Eb,src:Rb */
and7 cmac12struc data(
.and6,2,
specE,modb,specR,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,20h, /* DB 20H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* AND dst:Ew,src:Rw */
and8 cmac12struc data(
.and7,2,
specE,modw,specR,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,21h, /* DB 21H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm),
/* AND dst:Rb,src:Eb */
and9 cmac12struc data(
.and8,2,
specR,modb,specE,modb,
msegfix,src, /* SEGFIX src */
mdbn,22h, /* DB 22H */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* AND dst:Rw,src:Ew */
and10 cmac12struc public data(
.and9,2,
specR,modw,specE,modw,
msegfix,src, /* SEGFIX src */
mdbn,23h, /* DB 23H */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* CALL adr:Ew */
call1 cmac10struc data(
nil,1,
specE,modw,
msegfix,adr, /* SEGFIX adr */
mdbn,0ffh, /* DB 0FFH */
mmodrm1,2,adr, /* MODRM 2,adr */
mendm), /* ENDM */
/* CALL adr:Cb */
call2 cmac7struc data(
.call1,1,
specC,modb,
mdbn,0e8h, /* DB 0E8H */
mrelw,adr, /* RELW adr */
mendm), /* ENDM */
/* CALL adr:Cw */
call3 cmac7struc public data(
.call2,1,
specC,modw,
mdbn,0e8h, /* DB 0E8H */
mrelw,adr, /* RELW adr */
mendm), /* ENDM */
/* CALLF adr:Ed */
callf1 cmac10struc data(
nil,1,
specE,modd,
msegfix,adr, /* SEGFIX adr */
mdbn,0ffh, /* DB 0FFH */
mmodrm1,3,adr, /* MODRM 3,adr */
mendm), /* ENDM */
/* CALLF adr:Cd */
callf2 cmac7struc public data(
.callf1,1,
specC,modd,
mdbn,9ah, /* DB 9AH */
mddf,adr, /* DD adr */
mendm), /* ENDM */
/* CBW */
cbw1 cmac3struc public data(
nil,0,
mdbn,98h, /* DB 98H */
mendm), /* ENDM */
/* CLC */
clc1 cmac3struc public data(
nil,0,
mdbn,0f8h, /* DB 0F8H */
mendm), /* ENDM */
/* CLD */
cld1 cmac3struc public data(
nil,0,
mdbn,0fch, /* DB 0FCH */
mendm), /* ENDM */
/* CLI */
cli1 cmac3struc public data(
nil,0,
mdbn,0fah, /* DB 0FAH */
mendm), /* ENDM */
/* CMC */
cmc1 cmac3struc public data(
nil,0,
mdbn,0f5h, /* DB 0F5H */
mendm), /* ENDM */
/* CMP dst:Eb,src:Db */
cmp1 cmac14struc data(
nil,2,
specE,modb,specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,80h, /* DB 80H */
mmodrm1,7,dst, /* MODRM 7,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* CMP dst:Ew,src:Db */
cmp2 cmac14struc data(
.cmp1,2,
specE,modw,specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,7,dst, /* MODRM 7,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* CMP dst:Ew,src:Dsb */
cmp3 cmac14struc data(
.cmp2,2,
specE,modw,specD,modsb,
msegfix,dst, /* SEGFIX dst */
mdbn,83h, /* DB 83H */
mmodrm1,7,dst, /* MODRM 7,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* CMP dst:Ew,src:Dw */
cmp4 cmac14struc data(
.cmp3,2,
specE,modw,specD,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,7,dst, /* MODRM 7,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* CMP dst:Ab,src:Db */
cmp5 cmac9struc data(
.cmp4,2,
specA,modb,specD,modb,
mdbn,3ch, /* DB 3CH */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* CMP dst:Aw,src:Db */
cmp6 cmac9struc data(
.cmp5,2,
specA,modw,specD,modb,
mdbn,3dh, /* DB 3DH */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* CMP dst:Aw,src:Dw */
cmp7 cmac9struc data(
.cmp6,2,
specA,modw,specD,modw,
mdbn,3dh, /* DB 3DH */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* CMP dst:Eb,src:Rb */
cmp8 cmac12struc data(
.cmp7,2,
specE,modb,specR,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,38h, /* DB 38H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* CMP dst:Ew,src:Rw */
cmp9 cmac12struc data(
.cmp8,2,
specE,modw,specR,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,39h, /* DB 39H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* CMP dst:Rb,src:Eb */
cmp10 cmac12struc data(
.cmp9,2,
specR,modb,specE,modb,
msegfix,src, /* SEGFIX src */
mdbn,3ah, /* DB 3AH */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* CMP dst:Rw,src:Ew */
cmp11 cmac12struc public data(
.cmp10,2,
specR,modw,specE,modw,
msegfix,src, /* SEGFIX src */
mdbn,3bh, /* DB 3BH */
mmodrm2,dst,src, /* MODRM dst,src */
mendm); /* ENDM */
end$module cmac1;


550
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/CMAC2.PLM Normal file
View File

@@ -0,0 +1,550 @@
$title ('CODEMACRO DEFINITIONS - PART 2')
cmac2:
do;
/*
modified 6/16/81 R. Silberstein
*/
$include (:f1:macro.lit)
$include (:f1:cmacd.lit)
$include (:f1:equals.lit)
$include (:f1:cmac.lit)
dcl
/* CMPS dst:Eb,src:Eb */
cmps1 cmac12struc data(
nil,2,
specE,modb,specE,modb,
mnosegfix,res,dst, /* NOSEGFIX ES,dst */
msegfix,src, /* SEGFIX src */
mdbn,0a6h, /* DB 0A6H */
mendm), /* ENDM */
/* CMPS dst:Ew,src:Ew */
cmps2 cmac12struc public data(
.cmps1,2,
specE,modw,specE,modw,
mnosegfix,res,dst, /* NOSEGFIX ES,dst */
msegfix,src, /* SEGFIX src */
mdbn,0a7h, /* DB 0A7H */
mendm), /* ENDM */
/* CMPSB */
CMPSB1 CMAC3STRUC PUBLIC DATA(
NIL,0,
MDBN,0A6H,
MENDM),
/* CMPSW */
CMPSW1 CMAC3STRUC PUBLIC DATA(
NIL,0,
MDBN,0A7H,
MENDM),
/* CWD */
cwd1 cmac3struc public data(
nil,0,
mdbn,99h, /* DB 99H */
mendm), /* ENDM */
/* DAA */
daa1 cmac3struc public data(
nil,0,
mdbn,27h, /* DB 27H */
mendm), /* ENDM */
/* DAS */
das1 cmac3struc public data(
nil,0,
mdbn,2fh, /* DB 2FH */
mendm), /* ENDM */
/* DEC dst:Eb */
dec1 cmac10struc data(
nil,1,
specE,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,0feh, /* DB 0FEH */
mmodrm1,1,dst, /* MODRM 1,dst */
mendm), /* ENDM */
/* DEC dst:Ew */
dec2 cmac10struc data(
.dec1,1,
specE,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,0ffh, /* DB 0FFH */
mmodrm1,1,dst, /* MODRM 1,dst */
mendm), /* ENDM */
/* DEC dst:Rw */
dec3 cmac12struc public data(
.dec2,1,
specR,modw,
mdbit, /* DBIT 5(9H),3(dst) */
mnumberbits,5,9h,
mformalbits,3,dst,0,
mendbit,
mendm),
/* DIV divisor:Eb */
div1 cmac10struc data(
nil,1,
specE,modb,
msegfix,divisor, /* SEGFIX divisor */
mdbn,0f6h, /* DB 6FH */
mmodrm1,6,divisor, /* MODRM divisor */
mendm), /* ENDM */
/* DIV divisor:Ew */
div2 cmac10struc public data(
.div1,1,
specE,modw,
msegfix,divisor, /* SEGFIX divisor */
mdbn,0f7h, /* DB 0F7H */
mmodrm1,6,divisor, /* MODRM 6,divisor */
mendm), /* ENDM */
/* ESC opcode:Db(0,63),src:Eb */
esc1 cmac21struc data(
nil,2,
specD,modb+doublerange+numberrange,0,63,
specE,modb,
msegfix,src, /* SEGFIX src */
mdbit, /* DBIT 5(1BH),3(opcode(3)) */
mnumberbits,5,1bh,
mformalbits,3,opcode,3,
mendbit,
mmodrm2,opcode,src, /* MODRM opcode,src */
mendm), /* ENDM */
/* ESC opcode:Db(0,63),src:Ew */
esc2 cmac21struc data(
.esc1,2,
specD,modb+doublerange+numberrange,0,63,
specE,modw,
msegfix,src, /* SEGFIX src */
mdbit, /* DBIT 5(1BH),3(opcode(3)) */
mnumberbits,5,1bh,
mformalbits,3,opcode,3,
mendbit,
mmodrm2,opcode,src, /* MODRM opcode,src */
mendm), /* ENDM */
/* ESC opcode:Db(0,63),src:Ed */
esc3 cmac21struc public data(
.esc2,2,
specD,modb+doublerange+numberrange,0,63,
specE,modd,
msegfix,src, /* SEGFIX src */
mdbit, /* DBIT 5(1BH),3(opcode(3)) */
mnumberbits,5,1bh,
mformalbits,3,opcode,3,
mendbit,
mmodrm2,opcode,src, /* MODRM opcode,src */
mendm), /* ENDM */
/* HLT */
hlt1 cmac3struc public data(
nil,0,
mdbn,0f4h, /* DB 0F4H */
mendm), /* ENDM */
/* IDIV divisor:Eb */
idiv1 cmac10struc data(
nil,1,
specE,modb,
msegfix,divisor, /* SEGFIX divisor */
mdbn,0f6h, /* DB 0F6H */
mmodrm1,7,divisor, /* MODRM 7,divisor */
mendm), /* ENDM */
/* IDIV divisor:Ew */
idiv2 cmac10struc public data(
.idiv1,1,
specE,modw,
msegfix,divisor, /* SEGFIX divisor */
mdbn,0f7h, /* DB 0F7H */
mmodrm1,7,divisor, /* MODRM 7,divisor */
mendm),
/* IMUL mplier:Eb */
imul1 cmac10struc data(
nil,1,
specE,modb,
msegfix,mplier, /* SEGFIX mplier */
mdbn,0f6h, /* DB 0F6H */
mmodrm1,5,mplier, /* MODRM 5,mplier */
mendm), /* ENDM */
/* IMUL mplier:Ew */
imul2 cmac10struc public data(
.imul1,1,
specE,modw,
msegfix,mplier, /* SEGFIX mplier */
mdbn,0f7h, /* DB 0F7H */
mmodrm1,5,mplier, /* MODRM 5,mplier */
mendm), /* ENDM */
/* IN dst:Ab,port:Db */
in1 cmac9struc data(
nil,2,
specA,modb,specD,modb,
mdbn,0e4h, /* DB 0E4H */
mdbf,port, /* DB port */
mendm), /* ENDM */
/* IN dst:Aw,port:Db */
in2 cmac9struc data(
.in1,2,
specA,modw,specD,modb,
mdbn,0e5h, /* DB 0E5H */
mdbf,port, /* DB port */
mendm), /* ENDM */
/* IN dst:Ab,port:Rw(DX) */
in3 cmac8struc data(
.in2,2,
specA,modb,
specR,modw+singlerange+register$range,rdx,
mdbn,0ech, /* DB 0ECH */
mendm),
/* IN dst:Aw,port:Rw(DX) */
in4 cmac8struc public data(
.in3,2,
specA,modw,
specR,modw+singlerange+register$range,rdx,
mdbn,0edh, /* DB 0EDH */
mendm), /* ENDM */
/* INC dst:Eb */
inc1 cmac10struc data(
nil,1,
specE,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,0feh, /* DB 0FEH */
mmodrm1,0,dst, /* MODRM 0,dst */
mendm), /* ENDM */
/* INC dst:Ew */
inc2 cmac10struc data(
.inc1,1,
specE,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,0ffh, /* DB 0FFH */
mmodrm1,0,dst, /* MODRM 0,dst */
mendm), /* ENDM */
/* INC dst:Rw */
inc3 cmac12struc public data(
.inc2,1,
specR,modw,
mdbit, /* DBIT 5(08H),3(dst(0)) */
mnumberbits,5,08h,
mformalbits,3,dst,0,
mendbit,
mendm), /* ENDM */
/* INT itype:Db */
int1 cmac7struc data(
nil,1,
specD,modb,
mdbn,0cdh, /* DB 0CDH */
mdbf,itype, /* DB itype */
mendm), /* ENDM */
/* INT itype:Db(3) */
int2 cmac6struc public data(
.int1,1,
specD,modb+singlerange,3,
mdbn,0cch, /* DB 0CCH */
mendm), /* ENDM */
/* INTO */
into1 cmac3struc public data(
nil,0,
mdbn,0ceh, /* DB 0CEH */
mendm), /* ENDM */
/* IRET */
iret1 cmac3struc public data(
nil,0,
mdbn,0cfh, /* DB 0CFH */
mendm), /* ENDM */
/* JA place:Cb */
ja1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,77h, /* DB 77H */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JAE place:Cb */
jae1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,73h, /* DB 73H */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JB place:Cb */
jb1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,72h, /* DB 72H */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JBE place:Cb */
jbe1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,76h, /* DB 76H */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JCXZ place:Cb */
jcxz1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,0e3h, /* DB 0E3H */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JE place:Cb */
je1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,74h, /* DB 74H */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JG place:Cb */
jg1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,7fh, /* DB 7FH */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JGE place:Cb */
jge1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,7dh, /* DB 7DH */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JL place:Cb */
jl1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,7ch, /* DB 7CH */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JLE place:Cb */
jle1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,7eh, /* DB 7EH */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JMP place:Ew */
jmp1 cmac10struc data(
nil,1,
specE,modw,
msegfix,place, /* SEGFIX place */
mdbn,0ffh, /* DB 0FFH */
mmodrm1,4,place, /* MODRM 4,place */
mendm), /* ENDM */
/* JMP place:Cw */
jmp2 cmac7struc public data(
.jmp1,1,
specC,modw,
mdbn,0e9h, /* DB 0E9H */
mrelw,place, /* RELW place */
mendm), /* ENDM */
/* JMPF place:Md */
jmpf1 cmac10struc data(
nil,1,
specM,modd,
msegfix,place, /* SEGFIX place */
mdbn,0ffh, /* DB 0FFH */
mmodrm1,5,place, /* MODRM 5,place */
mendm), /* ENDM */
/* JMPF place:Cd */
jmpf2 cmac7struc public data(
.jmpf1,1,
specC,modd,
mdbn,0eah, /* DB 0EAH */
mddf,place, /* DD place */
mendm), /* ENDM */
/* JMPS place:Cb */
jmps1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,0ebh, /* DB 0EBH */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JNE place:Cb */
jne1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,75h, /* DB 75H */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JNO place:Cb */
jno1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,71h, /* DB 71H */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JNP place:Cb */
jnp1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,7bh, /* DB 7BH */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JNS place:Cb */
jns1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,79h, /* DB 79H */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JO place:Cb */
jo1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,70h, /* DB 70H */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JP place:Cb */
jp1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,7ah, /* DB 7AH */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* JS place:Cb */
js1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,78h, /* DB 78H */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* LAHF */
lahf1 cmac3struc public data(
nil,0,
mdbn,9fh, /* DB 9FH */
mendm), /* ENDM */
/* LDS dst:Rw,src:Ed */
lds1 cmac12struc public data(
nil,2,
specR,modw,specE,modd,
msegfix,src, /* SEGFIX src */
mdbn,0c5h, /* DB 0C5H */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* LES dst:Rw,src:Ed */
les1 cmac12struc public data(
nil,2,
specR,modw,specE,modd,
msegfix,src, /* SEGFIX src */
mdbn,0c4h, /* DB 0C4H */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* LEA dst:Rw,src:M */
lea1 cmac10struc public data(
nil,2,
specR,modw,specM,nomod,
mdbn,8dh, /* DB 8DH */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* LOCK prefx */
lock1 cmac3struc public data(
nil,0+prefix$on,
mdbn,0f0h, /* DB 0F0H */
mendm), /* ENDM */
/* LODS SI$ptr:Eb */
lods1 cmac7struc data(
nil,1,
specE,modb,
msegfix,si$ptr, /* SEGFIX SI$ptr */
mdbn,0ach, /* DB 0ACH */
mendm), /* ENDM */
/* LODS SI$ptr:Ew */
lods2 cmac7struc public data(
.lods1,1,
specE,modw,
msegfix,si$ptr, /* SEGFIX SI$ptr */
mdbn,0adh, /* DB 0AdH */
mendm), /* ENDM */
/* LODSB */
LODSB1 CMAC3STRUC PUBLIC DATA(
NIL,0,
MDBN,0ACH,
MENDM),
/* LODSW */
LODSW1 CMAC3STRUC PUBLIC DATA(
NIL,0,
MDBN,0ADH,
MENDM),
/* LOOP place:Cb */
loop1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,0e2h, /* DB 0E2H */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* LOOPE place:Cb */
loope1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,0e1h, /* DB 0E1H */
mrelb,place, /* RELB place */
mendm), /* ENDM */
/* LOOPNE place:Cb */
loopne1 cmac7struc public data(
nil,1,
specC,modb,
mdbn,0e0h, /* DB 0E0H */
mrelb,place, /* RELB place */
mendm); /* ENDM */
end$module cmac2;


478
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/CMAC3.PLM Normal file
View File

@@ -0,0 +1,478 @@
$title ('CODEMACRO DEFINITIONS - PART 3')
cmac3:
do;
/*
modified 6/16/81 R. Silberstein
*/
$include (:f1:macro.lit)
$include (:f1:cmacd.lit)
$include (:f1:equals.lit)
$include (:f1:cmac.lit)
dcl
/* MOV dst:Eb,src:Db */
mov1 cmac14struc data(
nil,2,
specE,modb,specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,0c6h, /* DB 0C6h */
mmodrm1,0,dst, /* MODRM 0,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* MOV dst:Ew,src:Db */
mov2 cmac14struc data(
.mov1,2,
specE,modw,specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,0c7h, /* DB 0C7h */
mmodrm1,0,dst, /* MODRM 0,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* MOV dst:Ew,src:Dw */
mov3 cmac14struc data(
.mov2,2,
specE,modw,specD,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,0c7h, /* DB 0C7h */
mmodrm1,0,dst, /* MODRM 0,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* MOV dst:Rb,src:Db */
mov4 cmac16struc data(
.mov3,2,
specR,modb,specD,modb,
mdbit, /* DBIT 5(10110B),3(dst(0)) */
mnumberbits,5,16h,
mformalbits,3,dst,0,
mendbit,
mdbf,src, /* DB src */
mendm), /* ENDM */
/* MOV dst:Rw,src:Db */
mov5 cmac16struc data(
.mov4,2,
specR,modw,specD,modb,
mdbit, /* DBIT 5(10111B),3(dst(0)) */
mnumberbits,5,17h,
mformalbits,3,dst,0,
mendbit,
mdwf,src, /* DW src */
mendm), /* ENDM */
/* MOV dst:Rw,src:Dw */
mov6 cmac16struc data(
.mov5,2,
specR,modw,specD,modw,
mdbit, /* DBIT 5(10111B),3(dst(0)) */
mnumberbits,5,17h,
mformalbits,3,dst,0,
mendbit,
mdwf,src, /* DW src */
mendm), /* ENDM */
/* MOV dst:Eb,src:Rb */
mov7 cmac12struc data(
.mov6,2,
specE,modb,specR,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,88h, /* DB 88H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* MOV dst:Ew,src:Rw */
mov8 cmac12struc data(
.mov7,2,
specE,modw,specR,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,89h, /* DB 89H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* MOV dst:Rb,src:Eb */
mov9 cmac12struc data(
.mov8,2,
specR,modb,specE,modb,
msegfix,src, /* SEGFIX src */
mdbn,8ah, /* DB 8AH */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* MOV dst:Rw,src:Ew */
mov10 cmac12struc data(
.mov9,2,
specR,modw,specE,modw,
msegfix,src, /* SEGFIX src */
mdbn,8bh, /* DB 8BH */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* MOV dst:Ew,src:S */
mov11 cmac12struc data(
.mov10,2,
specE,modw,specS,nomod,
msegfix,dst, /* SEGFIX dst */
mdbn,8ch, /* DB 8CH */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* MOV dst:Sd(ES),src:Ew */
mov12 cmac13struc data(
.mov11,2,
specS,modd+singlerange+registerrange,res,
specE,modw,
msegfix,src, /* SEGFIX src */
mdbn,8eh, /* DB 8EH */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* MOV dst:Sd(SS,DS),src:Ew */
mov13 cmac14struc data(
.mov12,2,
specS,modd+doublerange+registerrange,rss,rds,
specE,modw,
msegfix,src, /* SEGFIX src */
mdbn,8eh, /* DB 8EH */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* MOV dst:Ab,src:Xb */
mov14 cmac11struc data(
.mov13,2,
specA,modb,specX,modb,
msegfix,src, /* SEGFIX src */
mdbn,0a0h, /* DB 0A0H */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* MOV dst:Aw,src:Xw */
mov15 cmac11struc data(
.mov14,2,
specA,modw,specX,modw,
msegfix,src, /* SEGFIX src */
mdbn,0a1h, /* DB 0A1H */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* MOV dst:Xb,src:Ab */
mov16 cmac11struc data(
.mov15,2,
specX,modb,specA,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,0a2h, /* DB 0A2H */
mdwf,dst, /* DW dst */
mendm), /* ENDM */
/* MOV dst:Xw,src:Aw */
mov17 cmac11struc public data(
.mov16,2,
specX,modw,specA,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,0a3h, /* DB 0A3H */
mdwf,dst, /* DW dst */
mendm), /* ENDM */
/* MOVS SI$ptr:Eb,DI$ptr:Eb */
movs1 cmac12struc data(
nil,2,
specE,modb,specE,modb,
mnosegfix,res,si$ptr, /* NOSEGFIX ES,SI$ptr */
msegfix,di$ptr, /* SEGFIX DI$ptr */
mdbn,0a4h, /* DB 0A4H */
mendm), /* ENDM */
/* MOVS SI$ptr:Ew,DI$ptr:Ew */
movs2 cmac12struc public data(
.movs1,2,
specE,modw,specE,modw,
mnosegfix,res,si$ptr, /* NOSEGFIX ES,SI$ptr */
msegfix,di$ptr, /* SEGFIX DI$ptr */
mdbn,0a5h, /* DB 0A5H */
mendm), /* ENDM */
/* MOVSB */
MOVSB1 CMAC3STRUC PUBLIC DATA(
NIL,0,
MDBN,0A4H,
MENDM),
/* MOVSW */
MOVSW1 CMAC3STRUC PUBLIC DATA(
NIL,0,
MDBN,0A5H,
MENDM),
/* MUL mplier:Eb */
mul1 cmac10struc data(
nil,1,
specE,modb,
msegfix,mplier, /* SEGFIX mplier */
mdbn,0f6h, /* DB 0F6H */
mmodrm1,4,mplier, /* MODRM 4,mplier */
mendm), /* ENDM */
/* MUL mplier:Ew */
mul2 cmac10struc public data(
.mul1,1,
specE,modw,
msegfix,mplier, /* SEGFIX mplier */
mdbn,0f7h, /* DB 0F7H */
mmodrm1,4,mplier, /* MODRM 4,mplier */
mendm), /* ENDM */
/* NEG dst:Eb */
neg1 cmac10struc data(
nil,1,
specE,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,0f6h, /* DB 0F6H */
mmodrm1,3,dst, /* MODRM 3,dst */
mendm), /* ENDM */
/* NEG dst:Ew */
neg2 cmac10struc public data(
.neg1,1,
specE,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,0f7h, /* DB 0F7H */
mmodrm1,3,dst, /* MODRM 3,dst */
mendm), /* ENDM */
/* NOP */
nop1 cmac3struc public data(
nil,0,
mdbn,90h, /* DB 90H */
mendm), /* ENDM */
/* NOT dst:Eb */
not1 cmac10struc data(
nil,1,
specE,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,0f6h, /* DB 0F6H */
mmodrm1,2,dst, /* MODRM 2,dst */
mendm), /* ENDM */
/* NOT dst:Ew */
not2 cmac10struc public data(
.not1,1,
specE,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,0f7h, /* DB 0F7H */
mmodrm1,2,dst, /* MODRM 2,dst */
mendm), /* ENDM */
/* OR dst:Eb,src:Db */
or1 cmac14struc data(
nil,2,
specE,modb,specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,80h, /* DB 80h */
mmodrm1,1,dst, /* MODRM 1,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* OR dst:Ew,src:Dw */
or2 cmac14struc data(
.or1,2,
specE,modw,specD,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,1,dst, /* MODRM 1,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* OR dst:Ew,src:Db */
or3 cmac14struc data(
.or2,2,
specE,modw,specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,1,dst, /* MODRM 1,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* OR dst:Ab,src:Db */
or4 cmac9struc data(
.or3,2,
specA,modb,specD,modb,
mdbn,0ch, /* DB 0CH */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* OR dst:Aw,src:Db */
or5 cmac9struc data(
.or4,2,
specA,modw,specD,modb,
mdbn,0dh, /* DB 0DH */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* OR dst:Aw,src:Dw */
or6 cmac9struc data(
.or5,2,
specA,modw,specD,modw,
mdbn,0dh, /* DB 0DH */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* OR dst:Eb,src:Rb */
or7 cmac12struc data(
.or6,2,
specE,modb,specR,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,08h, /* DB 08h */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* OR dst:Ew,src:Rw */
or8 cmac12struc data(
.or7,2,
specE,modw,specR,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,09h, /* DB 09h */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* OR dst:Rb,src:Eb */
or9 cmac12struc data(
.or8,2,
specR,modb,specE,modb,
msegfix,src, /* SEGFIX src */
mdbn,0ah, /* DB 0Ah */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* OR dst:Rw,src:Ew */
or10 cmac12struc public data(
.or9,2,
specR,modw,specE,modw,
msegfix,src, /* SEGFIX src */
mdbn,0bh, /* DB 0Bh */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* OUT dst:Db,src:Ab */
out1 cmac9struc data(
nil,2,
specD,modb,specA,modb,
mdbn,0e6h, /* DB 0E6H */
mdbf,dst, /* DB dst */
mendm), /* ENDM */
/* OUT dst:Db,src:Aw */
out2 cmac9struc data(
.out1,2,
specD,modb,specA,modw,
mdbn,0e7h, /* DB 0E7H */
mdbf,dst, /* DB dst */
mendm), /* ENDM */
/* OUT dst:Rw(DX),src:Ab */
out3 cmac8struc data(
.out2,2,
specR,modw+singlerange+registerrange,rdx,
specA,modb,
mdbn,0eeh, /* DB 0EEH */
mendm), /* ENDM */
/* OUT dst:Rw(DX),src:Aw */
out4 cmac8struc public data(
.out3,2,
specR,modw+singlerange+registerrange,rdx,
specA,modw,
mdbn,0efh, /* DB 0EFH */
mendm), /* ENDM */
/* POP dst:Ew */
pop1 cmac10struc data(
nil,1,
specE,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,8fh, /* DB 8FH */
mmodrm1,0,dst, /* MODRM 0,dst */
mendm), /* ENDM */
/* POP dst:Sd(ES) */
pop2 cmac16struc data(
.pop1,1,
specS,modd+singlerange+registerrange,res,
mdbit, /* DBIT 3(0),2(dst(0)),3(7) */
mnumberbits,3,0,
mformalbits,2,dst,0,
mnumberbits,3,7,
mendbit,
mendm), /* ENDM */
/* POP dst:Sd(SS,DS) */
pop3 cmac17struc data(
.pop2,1,
specS,modd+doublerange+registerrange,rss,rds,
mdbit, /* DBIT 3(0),2(dst(0)),3(7) */
mnumberbits,3,0,
mformalbits,2,dst,0,
mnumberbits,3,7,
mendbit,
mendm), /* ENDM */
/* POP dst:Rw */
pop4 cmac12struc public data(
.pop3,1,
specR,modw,
mdbit, /* DBIT 5(01011B),3(dst(0)) */
mnumberbits,5,0bh,
mformalbits,3,dst,0,
mendbit,
mendm), /* ENDM */
/* POPF */
popf1 cmac3struc public data(
nil,0,
mdbn,9dh, /* DB 9DH */
mendm), /* ENDM */
/* PUSH dst:Ew */
push1 cmac10struc data(
nil,1,
specE,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,0ffh, /* DB 0FFH */
mmodrm1,6,dst, /* MODRM 6,dst */
mendm), /* ENDM */
/* PUSH dst:Sd */
push2 cmac15struc data(
.push1,1,
specS,modd,
mdbit, /* DBIT 3(0),2(dst(0)),3(6) */
mnumberbits,3,0,
mformalbits,2,dst,0,
mnumberbits,3,6,
mendbit,
mendm), /* ENDM */
/* PUSH dst:Rw */
push3 cmac12struc public data(
.push2,1,
specR,modw,
mdbit, /* DBIT 5(01010B),3(dst(0)) */
mnumberbits,5,0ah,
mformalbits,3,dst,0,
mendbit,
mendm), /* ENDM */
/* PUSHF */
pushf1 cmac3struc public data(
nil,0,
mdbn,9ch, /* DB 9CH */
mendm); /* ENDM */
end$module cmac3;


506
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/CMAC4.PLM Normal file
View File

@@ -0,0 +1,506 @@
$title ('CODEMACRO DEFINITIONS - PART 4')
cmac4:
do;
/*
modified 6/16/81 R. Silberstein
*/
$include (:f1:macro.lit)
$include (:f1:cmacd.lit)
$include (:f1:equals.lit)
$include (:f1:cmac.lit)
dcl
/* RCL dst:Eb,count:Db(1) */
rcl1 cmac13struc data(
nil,2,
specE,modb,
specD,modb+singlerange+number$range,1,
msegfix,dst, /* SEGFIX dst */
mdbn,0d0h, /* DB 0D0H */
mmodrm1,2,dst, /* MODRM 2,dst */
mendm), /* ENDM */
/* RCL dst:Ew,count:Db(1) */
rcl2 cmac13struc data(
.rcl1,2,
specE,modw,
specD,modb+singlerange+number$range,1,
msegfix,dst, /* SEGFIX dst */
mdbn,0d1h, /* DB 0D1H */
mmodrm1,2,dst, /* MODRM 2,dst */
mendm), /* ENDM */
/* RCL dst:Eb,count:Rb(CL) */
rcl3 cmac13struc data(
.rcl2,2,
specE,modb,
specR,modb+singlerange+register$range,rcl,
msegfix,dst, /* SEGFIX dst */
mdbn,0d2h, /* DB 0D2H */
mmodrm1,2,dst, /* MODRM 2,dst */
mendm), /* ENDM */
/* RCL dst:Ew,count:Rb(CL) */
rcl4 cmac13struc public data(
.rcl3,2,
specE,modw,
specR,modb+singlerange+register$range,rcl,
msegfix,dst, /* SEGFIX dst */
mdbn,0d3h, /* DB 0D3H */
mmodrm1,2,dst, /* MODRM 2,dst */
mendm), /* ENDM */
/* RCR dst:Eb,count:Db(1) */
rcr1 cmac13struc data(
nil,2,
specE,modb,
specD,modb+singlerange+number$range,1,
msegfix,dst, /* SEGFIX dst */
mdbn,0d0h, /* DB 0D0H */
mmodrm1,3,dst, /* MODRM 3,dst */
mendm), /* ENDM */
/* RCR dst:Ew,count:Db(1) */
rcr2 cmac13struc data(
.rcr1,2,
specE,modw,
specD,modb+singlerange+number$range,1,
msegfix,dst, /* SEGFIX dst */
mdbn,0d1h, /* DB 0D1H */
mmodrm1,3,dst, /* MODRM 3,dst */
mendm), /* ENDM */
/* RCR dst:Eb,count:Rb(CL) */
rcr3 cmac13struc data(
.rcr2,2,
specE,modb,
specR,modb+singlerange+register$range,rcl,
msegfix,dst, /* SEGFIX dst */
mdbn,0d2h, /* DB 0D2H */
mmodrm1,3,dst, /* MODRM 3,dst */
mendm), /* ENDM */
/* RCR dst:Ew,count:Rb(CL) */
rcr4 cmac13struc public data(
.rcr3,2,
specE,modw,
specR,modb+singlerange+register$range,rcl,
msegfix,dst, /* SEGFIX dst */
mdbn,0d3h, /* DB 0D3H */
mmodrm1,3,dst, /* MODRM 3,dst */
mendm), /* ENDM */
/* REP PREFX */
rep1 cmac3struc public data(
nil,0+prefix$on,
mdbn,0f3h, /* DB 0F3H */
mendm), /* ENDM */
/* REPE PREFX */
repe1 cmac3struc public data(
nil,0+prefix$on,
mdbn,0f3h, /* DB 0F3H */
mendm), /* ENDM */
/* REPNE PREFX */
repne1 cmac3struc public data(
nil,0+prefix$on,
mdbn,0f2h, /* DB 0F2H */
mendm), /* ENDM */
/* RET dst:Db */
ret1 cmac7struc data(
nil,1,
specD,modb,
mdbn,0c2h, /* DB 0C2H */
mdwf,dst, /* DW dst */
mendm), /* ENDM */
/* RET dst:Dw */
ret2 cmac7struc data(
.ret1,1,
specD,modw,
mdbn,0c2h, /* DB 0C2H */
mdwf,dst, /* DW dst */
mendm), /* ENDM */
/* RET */
ret3 cmac3struc public data(
.ret2,0,
mdbn,0c3h, /* DB 0C3H */
mendm), /* ENDM */
/* RETF dst:Db */
retf1 cmac7struc data(
nil,1,
specD,modb,
mdbn,0cah, /* DB 0CAH */
mdwf,dst, /* DW dst */
mendm), /* ENDM */
/* RETF dst:Dw */
retf2 cmac7struc data(
.retf1,1,
specD,modw,
mdbn,0cah, /* DB 0CAH */
mdwf,dst, /* DW dst */
mendm), /* ENDM */
/* RETF */
retf3 cmac3struc public data(
.retf2,0,
mdbn,0cbh, /* DB 0C3H */
mendm), /* ENDM */
/* ROL dst:Eb,count:Db(1) */
rol1 cmac13struc data(
nil,2,
specE,modb,
specD,modb+singlerange+number$range,1,
msegfix,dst, /* SEGFIX dst */
mdbn,0d0h, /* DB 0D0H */
mmodrm1,0,dst, /* MODRM 0,dst */
mendm), /* ENDM */
/* ROL dst:Ew,count:Db(1) */
rol2 cmac13struc data(
.rol1,2,
specE,modw,
specD,modb+singlerange+number$range,1,
msegfix,dst, /* SEGFIX dst */
mdbn,0d1h, /* DB 0D1H */
mmodrm1,0,dst, /* MODRM 0,dst */
mendm), /* ENDM */
/* ROL dst:Eb,count:Rb(CL) */
rol3 cmac13struc data(
.rol2,2,
specE,modb,
specR,modb+singlerange+register$range,rcl,
msegfix,dst, /* SEGFIX dst */
mdbn,0d2h, /* DB 0D2H */
mmodrm1,0,dst, /* MODRM 0,dst */
mendm), /* ENDM */
/* ROL dst:Ew,count:Rb(CL) */
rol4 cmac13struc public data(
.rol3,2,
specE,modw,
specR,modb+singlerange+register$range,rcl,
msegfix,dst, /* SEGFIX dst */
mdbn,0d3h, /* DB 0D3H */
mmodrm1,0,dst, /* MODRM 0,dst */
mendm), /* ENDM */
/* ROR dst:Eb,count:Db(1) */
ror1 cmac13struc data(
nil,2,
specE,modb,
specD,modb+singlerange+number$range,1,
msegfix,dst, /* SEGFIX dst */
mdbn,0d0h, /* DB 0D0H */
mmodrm1,1,dst, /* MODRM 1,dst */
mendm), /* ENDM */
/* ROR dst:Ew,count:Db(1) */
ror2 cmac13struc data(
.ror1,2,
specE,modw,
specD,modb+singlerange+number$range,1,
msegfix,dst, /* SEGFIX dst */
mdbn,0d1h, /* DB 0D1H */
mmodrm1,1,dst, /* MODRM 1,dst */
mendm), /* ENDM */
/* ROR dst:Eb,count:Rb(CL) */
ror3 cmac13struc data(
.ror2,2,
specE,modb,
specR,modb+singlerange+register$range,rcl,
msegfix,dst, /* SEGFIX dst */
mdbn,0d2h, /* DB 0D2H */
mmodrm1,1,dst, /* MODRM 1,dst */
mendm), /* ENDM */
/* ROR dst:Ew,count:Rb(CL) */
ror4 cmac13struc public data(
.ror3,2,
specE,modw,
specR,modb+singlerange+register$range,rcl,
msegfix,dst, /* SEGFIX dst */
mdbn,0d3h, /* DB 0D3H */
mmodrm1,1,dst, /* MODRM 1,dst */
mendm), /* ENDM */
/* SAHF */
sahf1 cmac3struc public data(
nil,0,
mdbn,9eh, /* DB 9EH */
mendm), /* ENDM */
/* SAL dst:Eb,count:Db(1) */
sal1 cmac13struc data(
nil,2,
specE,modb,
specD,modb+singlerange+number$range,1,
msegfix,dst, /* SEGFIX dst */
mdbn,0d0h, /* DB 0D0H */
mmodrm1,4,dst, /* MODRM 4,dst */
mendm), /* ENDM */
/* SAL dst:Ew,count:Db(1) */
sal2 cmac13struc data(
.sal1,2,
specE,modw,
specD,modb+singlerange+number$range,1,
msegfix,dst, /* SEGFIX dst */
mdbn,0d1h, /* DB 0D1H */
mmodrm1,4,dst, /* MODRM 4,dst */
mendm), /* ENDM */
/* SAL dst:Eb,count:Rb(CL) */
sal3 cmac13struc data(
.sal2,2,
specE,modb,
specR,modb+singlerange+register$range,rcl,
msegfix,dst, /* SEGFIX dst */
mdbn,0d2h, /* DB 0D2H */
mmodrm1,4,dst, /* MODRM 4,dst */
mendm), /* ENDM */
/* SAL dst:Ew,count:Rb(CL) */
sal4 cmac13struc public data(
.sal3,2,
specE,modw,
specR,modb+singlerange+register$range,rcl,
msegfix,dst, /* SEGFIX dst */
mdbn,0d3h, /* DB 0D3H */
mmodrm1,4,dst, /* MODRM 4,dst */
mendm), /* ENDM */
/* SAR dst:Eb,count:Db(1) */
sar1 cmac13struc data(
nil,2,
specE,modb,
specD,modb+singlerange+number$range,1,
msegfix,dst, /* SEGFIX dst */
mdbn,0d0h, /* DB 0D0H */
mmodrm1,7,dst, /* MODRM 7,dst */
mendm), /* ENDM */
/* SAR dst:Ew,count:Db(1) */
sar2 cmac13struc data(
.sar1,2,
specE,modw,
specD,modb+singlerange+number$range,1,
msegfix,dst, /* SEGFIX dst */
mdbn,0d1h, /* DB 0D1H */
mmodrm1,7,dst, /* MODRM 7,dst */
mendm), /* ENDM */
/* SAR dst:Eb,count:Rb(CL) */
sar3 cmac13struc data(
.sar2,2,
specE,modb,
specR,modb+singlerange+register$range,rcl,
msegfix,dst, /* SEGFIX dst */
mdbn,0d2h, /* DB 0D2H */
mmodrm1,7,dst, /* MODRM 7,dst */
mendm), /* ENDM */
/* SAR dst:Ew,count:Rb(CL) */
sar4 cmac13struc public data(
.sar3,2,
specE,modw,
specR,modb+singlerange+register$range,rcl,
msegfix,dst, /* SEGFIX dst */
mdbn,0d3h, /* DB 0D3H */
mmodrm1,7,dst, /* MODRM 7,dst */
mendm), /* ENDM */
/* SBB dst:Eb,src:Db */
sbb1 cmac14struc data(
nil,2,
specE,modb,
specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,80h, /* DB 80H */
mmodrm1,3,dst, /* MODRM 3,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* SBB dst:Ew,src:Db */
sbb2 cmac14struc data(
.sbb1,2,
specE,modw,
specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,3,dst, /* MODRM 3,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* SBB dst:Ew,src:Dsb */
sbb3 cmac14struc data(
.sbb2,2,
specE,modw,
specD,modsb,
msegfix,dst, /* SEGFIX dst */
mdbn,83h, /* DB 83H */
mmodrm1,3,dst, /* MODRM 3,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* SBB dst:Ew,src:Dw */
sbb4 cmac14struc data(
.sbb3,2,
specE,modw,
specD,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,3,dst, /* MODRM 3,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* SBB dst:Ab,src:Db */
sbb5 cmac9struc data(
.sbb4,2,
specA,modb,
specD,modb,
mdbn,1ch, /* DB 1CH */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* SBB dst:Aw,src:Db */
sbb6 cmac9struc data(
.sbb5,2,
specA,modw,
specD,modb,
mdbn,1dh, /* DB 1DH */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* SBB dst:Aw,src:Dw */
sbb7 cmac9struc data(
.sbb6,2,
specA,modw,
specD,modw,
mdbn,1dh, /* DB 1DH */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* SBB dst:Eb,src:Rb */
sbb8 cmac12struc data(
.sbb7,2,
specE,modb,
specR,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,18h, /* DB 18H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* SBB dst:Ew,src:Rw */
sbb9 cmac12struc data(
.sbb8,2,
specE,modw,
specR,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,19h, /* DB 19H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* SBB dst:Rb,src:Eb */
sbb10 cmac12struc data(
.sbb9,2,
specR,modb,
specE,modb,
msegfix,src, /* SEGFIX src */
mdbn,1ah, /* DB 1AH */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* SBB dst:Rw,src:Ew */
sbb11 cmac12struc public data(
.sbb10,2,
specR,modw,
specE,modw,
msegfix,src, /* SEGFIX src */
mdbn,1bh, /* DB 1BH */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* SCAS dst:Eb */
scas1 cmac8struc data(
nil,1,
specE,modb,
mnosegfix,res,dst, /* NOSEGFIX ES,dst */
mdbn,0aeh, /* DB 0AEH */
mendm), /* ENDM */
/* SCAS dst:Ew */
scas2 cmac8struc public data(
.scas1,1,
specE,modw,
mnosegfix,res,dst, /* NOSEGFIX ES,dst */
mdbn,0afh, /* DB 0AFH */
mendm), /* ENDM */
/* SCASB */
SCASB1 CMAC3STRUC PUBLIC DATA(
NIL,0,
MDBN,0AEH,
MENDM),
/* SCASW */
SCASW1 CMAC3STRUC PUBLIC DATA(
NIL,0,
MDBN,0AFH,
MENDM),
/* SHR dst:Eb,count:Db(1) */
shr1 cmac13struc data(
nil,2,
specE,modb,
specD,modb+singlerange+number$range,1,
msegfix,dst, /* SEGFIX dst */
mdbn,0d0h, /* DB 0D0H */
mmodrm1,5,dst, /* MODRM 5,dst */
mendm), /* ENDM */
/* SHR dst:Ew,count:Db(1) */
shr2 cmac13struc data(
.shr1,2,
specE,modw,
specD,modb+singlerange+number$range,1,
msegfix,dst, /* SEGFIX dst */
mdbn,0d1h, /* DB 0D1H */
mmodrm1,5,dst, /* MODRM 5,dst */
mendm), /* ENDM */
/* SHR dst:Eb,count:Rb(CL) */
shr3 cmac13struc data(
.shr2,2,
specE,modb,
specR,modb+singlerange+register$range,rcl,
msegfix,dst, /* SEGFIX dst */
mdbn,0d2h, /* DB 0D2H */
mmodrm1,5,dst, /* MODRM 5,dst */
mendm), /* ENDM */
/* SHR dst:Ew,count:Rb(CL) */
shr4 cmac13struc public data(
.shr3,2,
specE,modw,
specR,modb+singlerange+register$range,rcl,
msegfix,dst, /* SEGFIX dst */
mdbn,0d3h, /* DB 0D3H */
mmodrm1,5,dst, /* MODRM 5,dst */
mendm); /* ENDM */
end$module cmac4;


441
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/CMAC5.PLM Normal file
View File

@@ -0,0 +1,441 @@
$title ('CODEMACRO DEFINITIONS - PART 5')
cmac5:
do;
/*
modified 6/16/81 R. Silberstein
*/
$include (:f1:macro.lit)
$include (:f1:cmacd.lit)
$include (:f1:equals.lit)
$include (:f1:cmac.lit)
dcl
/* STC */
stc1 cmac3struc public data(
nil,0,
mdbn,0f9h, /* DB 0F9H */
mendm), /* ENDM */
/* STD */
std1 cmac3struc public data(
nil,0,
mdbn,0fdh, /* DB 0FDH */
mendm), /* ENDM */
/* STI */
sti1 cmac3struc public data(
nil,0,
mdbn,0fbh, /* DB 0FBH */
mendm), /* ENDM */
/* STOS dst:Eb */
stos1 cmac8struc data(
nil,1,
specE,modb,
mnosegfix,res,dst, /* NOSEGFIX ES,dst */
mdbn,0aah, /* DB 0AAH */
mendm), /* ENDM */
/* STOS dst:Ew */
stos2 cmac8struc public data(
.stos1,1,
specE,modw,
mnosegfix,res,dst, /* NOSEGFIX ES,dst */
mdbn,0abh, /* DB 0ABH */
mendm), /* ENDM */
/* STOSB */
STOSB1 CMAC3STRUC PUBLIC DATA(
NIL,0,
MDBN,0AAH,
MENDM),
/* STOSW */
STOSW1 CMAC3STRUC PUBLIC DATA(
NIL,0,
MDBN,0ABH,
MENDM),
/* SUB dst:Eb,src:Db */
sub1 cmac14struc data(
nil,2,
specE,modb,
specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,80h, /* DB 80H */
mmodrm1,5,dst, /* MODRM 5,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* SUB dst:Ew,src:Db */
sub2 cmac14struc data(
.sub1,2,
specE,modw,
specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,5,dst, /* MODRM 5,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* SUB dst:Ew,src:Dsb */
sub3 cmac14struc data(
.sub2,2,
specE,modw,
specD,modsb,
msegfix,dst, /* SEGFIX dst */
mdbn,83h, /* DB 83H */
mmodrm1,5,dst, /* MODRM 5,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* SUB dst:Ew,src:Dw */
sub4 cmac14struc data(
.sub3,2,
specE,modw,
specD,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,5,dst, /* MODRM 5,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* SUB dst:Ab,src:Db */
sub5 cmac9struc data(
.sub4,2,
specA,modb,
specD,modb,
mdbn,2ch, /* DB 2CH */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* SUB dst:Aw,src:Db */
sub6 cmac9struc data(
.sub5,2,
specA,modw,
specD,modb,
mdbn,2dh, /* DB 2DH */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* SUB dst:Aw,src:Dw */
sub7 cmac9struc data(
.sub6,2,
specA,modw,
specD,modw,
mdbn,2dh, /* DB 2DH */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* SUB dst:Eb,src:Rb */
sub8 cmac12struc data(
.sub7,2,
specE,modb,
specR,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,28h, /* DB 28H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* SUB dst:Ew,src:Rw */
sub9 cmac12struc data(
.sub8,2,
specE,modw,
specR,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,29h, /* DB 29H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* SUB dst:Rb,src:Eb */
sub10 cmac12struc data(
.sub9,2,
specR,modb,
specE,modb,
msegfix,src, /* SEGFIX src */
mdbn,2ah, /* DB 2AH */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* SUB dst:Rw,src:Ew */
sub11 cmac12struc public data(
.sub10,2,
specR,modw,
specE,modw,
msegfix,src, /* SEGFIX src */
mdbn,2bh, /* DB 2BH */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* TEST dst:Eb,src:Db */
test1 cmac14struc data(
nil,2,
specE,modb,
specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,0f6h, /* DB 0F6H */
mmodrm1,0,dst, /* MODRM 0,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* TEST dst:Ew,src:Db */
test2 cmac14struc data(
.test1,2,
specE,modw,
specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,0f7h, /* DB 0F7H */
mmodrm1,0,dst, /* MODRM 0,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* TEST dst:Ew,src:Dw */
test3 cmac14struc data(
.test2,2,
specE,modw,
specD,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,0f7h, /* DB 0F7H */
mmodrm1,0,dst, /* MODRM 0,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* TEST dst:Ab,src:Db */
test4 cmac9struc data(
.test3,2,
specA,modb,
specD,modb,
mdbn,0a8h, /* DB 0A8H */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* TEST dst:Aw,src:Db */
test5 cmac9struc data(
.test4,2,
specA,modw,
specD,modb,
mdbn,0a9h, /* DB 0A9H */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* TEST dst:Aw,src:Dw */
test6 cmac9struc data(
.test5,2,
specA,modw,
specD,modw,
mdbn,0a9h, /* DB 0A9H */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* TEST dst:Eb,src:Rb */
test7 cmac12struc data(
.test6,2,
specE,modb,
specR,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,84h, /* DB 84H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* TEST dst:Ew,src:Rw */
test8 cmac12struc data(
.test7,2,
specE,modw,
specR,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,85h, /* DB 85H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* TEST dst:Rb,src:Eb */
test9 cmac12struc data(
.test8,2,
specR,modb,
specE,modb,
msegfix,src, /* SEGFIX src */
mdbn,84h, /* DB 84H */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* TEST dst:Rw,src:Ew */
test10 cmac12struc public data(
.test9,2,
specR,modw,
specE,modw,
msegfix,src, /* SEGFIX src */
mdbn,85h, /* DB 85H */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* WAIT */
wait1 cmac3struc public data(
nil,0,
mdbn,9bh, /* DB 9BH */
mendm), /* ENDM */
/* XCHG dst:Eb,src:Rb */
xchg1 cmac12struc data(
nil,2,
specE,modb,
specR,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,86h, /* DB 86H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* XCHG dst:Ew,src:Rw */
xchg2 cmac12struc data(
.xchg1,2,
specE,modw,
specR,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,87h, /* DB 87H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* XCHG dst:Rb,src:Eb */
xchg3 cmac12struc data(
.xchg2,2,
specR,modb,
specE,modb,
msegfix,src, /* SEGFIX src */
mdbn,86h, /* DB 86H */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* XCHG dst:Rw,src:Ew */
xchg4 cmac12struc data(
.xchg3,2,
specR,modw,
specE,modw,
msegfix,src, /* SEGFIX src */
mdbn,87h, /* DB 87H */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* XCHG dst:Rw,src:Aw */
xchg5 cmac14struc data(
.xchg4,2,
specR,modw,specA,modw,
mdbit, /* DBIT 5(10010B),3(dst(0)) */
mnumberbits,5,12h,
mformalbits,3,dst,0,
mendbit,
mendm), /* ENDM */
/* XCHG dst:Aw,src:Rw */
xchg6 cmac14struc public data(
.xchg5,2,
specA,modw,specR,modw,
mdbit, /* DBIT 5(10010B),3(dst(0)) */
mnumberbits,5,12h,
mformalbits,3,src,0,
mendbit,
mendm), /* ENDM */
/* XLAT dst:E */
xlat1 cmac7struc public data(
nil,1,
specE,nomod,
msegfix,dst, /* SEGFIX dst */
mdbn,0d7h, /* DB 0D7H */
mendm), /* ENDM */
/* XOR dst:Eb,src:Db */
xor1 cmac14struc data(
nil,2,
specE,modb,
specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,80h, /* DB 80H */
mmodrm1,6,dst, /* MODRM 6,dst */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* XOR dst:Ew,src:Db */
xor2 cmac14struc data(
.xor1,2,
specE,modw,specD,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,6,dst, /* MODRM 6,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* XOR dst:Ew,src:Dw */
xor3 cmac14struc data(
.xor2,2,
specE,modw,specD,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,81h, /* DB 81H */
mmodrm1,6,dst, /* MODRM 6,dst */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* XOR dst:Ab,src:Db */
xor4 cmac9struc data(
.xor3,2,
specA,modb,specD,modb,
mdbn,34h, /* DB 34H */
mdbf,src, /* DB src */
mendm), /* ENDM */
/* XOR dst:Aw,src:Db */
xor5 cmac9struc data(
.xor4,2,
specA,modw,specD,modb,
mdbn,35h, /* DB 35H */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* XOR dst:Aw,src:Dw */
xor6 cmac9struc data(
.xor5,2,
specA,modw,specD,modw,
mdbn,35h, /* DB 35H */
mdwf,src, /* DW src */
mendm), /* ENDM */
/* XOR dst:Eb,src:Rb */
xor7 cmac12struc data(
.xor6,2,
specE,modb,specR,modb,
msegfix,dst, /* SEGFIX dst */
mdbn,30h, /* DB 30H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm), /* ENDM */
/* XOR dst:Ew,src:Rw */
xor8 cmac12struc data(
.xor7,2,
specE,modw,specR,modw,
msegfix,dst, /* SEGFIX dst */
mdbn,31h, /* DB 31H */
mmodrm2,src,dst, /* MODRM src,dst */
mendm),
/* XOR dst:Rb,src:Eb */
xor9 cmac12struc data(
.xor8,2,
specR,modb,specE,modb,
msegfix,src, /* SEGFIX src */
mdbn,32h, /* DB 32H */
mmodrm2,dst,src, /* MODRM dst,src */
mendm), /* ENDM */
/* XOR dst:Rw,src:Ew */
xor10 cmac12struc public data(
.xor9,2,
specR,modw,specE,modw,
msegfix,src, /* SEGFIX src */
mdbn,33h, /* DB 33H */
mmodrm2,dst,src, /* MODRM dst,src */
mendm); /* ENDM */
end$module cmac5;


453
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/CMSUBR.PLM Normal file
View File

@@ -0,0 +1,453 @@
$title ('CODEMACRO SUBROUTINE MODULE')
cmsubr:
do;
/*
modified 4/7/81 R. Silberstein
modified 4/13/81 R. Silberstein
modified 5/5/81 R. Silberstein
modified 9/2/81 R. Silberstein
*/
/*
This is the module to
1) test if a set of operands matches a given instruction
and
2) produce output code for matched instruction
The module interfaces the CODEOUTPUT module to
physically send code bytes to the HEX output file.
*/
$include (:f1:macro.lit)
$include (:f1:equals.lit)
$include (:f1:cmacd.lit)
$include (:f1:outp.lit)
$include (:f1:scan.ext)
$include (:f1:subr1.ext)
$INCLUDE (:F1:SUBR2.EXT)
$include (:f1:outp.ext)
$include (:f1:ermod.ext)
$include (:f1:cmsubr.x86)
$eject
dcl /* global variables */
bytevar based macroptr byte, /* variables within codemacros */
addrvar based macroptr addr,
emitbyte(80) byte, /* buffer of output codebytes */
emitindex byte, /* index of "emitbyte" */
bitcomtab(2) byte data /* legal commands within "DBIT" */
(mnumberbits,mformalbits);
$eject
/********** MICHELLANEOUS SUBROUTINES: **********/
clearcmindex: proc public;
emitindex=0;
end clearcmindex;
emit: proc public; /* emit codebytes for an instruction */
dcl i byte;
i=0ffh;
do while (i:=i+1) < emitindex;
call emitcodebyte(emitbyte(i),CSdata);
end$while;
end emit;
emitdummies: proc public; /* emit dummy (NO-OP-) bytes if error */
dcl (i,j) byte,nodum(4) byte data(2,5,6,8);
j=nooper;
if j>3 then j=3;
i=0ffh;
do while (i:=i+1) < nodum(j);
call emitcodebyte(90h,CSdata); /* 90H = NOP */
end$while;
end emitdummies;
emitsinglebyte: proc(ch); /* fill local emitbuffer with a new byte */
dcl ch byte;
if noerror then$do
emitbyte(emitindex)=ch;
emitindex=emitindex+1;
end$if;
end emitsinglebyte;
emitsingleword: proc (var); /* fill 2 new bytes into emitbuffer */
dcl var addr, byt1 byte at(.var), byt2 byte at(.var+1);
call emitsinglebyte(byt1);
call emitsinglebyte(byt2);
end emitsingleword;
incrmacroptr: proc;
macroptr=macroptr+1;
end incrmacroptr;
getoperadr: proc address;
dcl pt address;
pt=.operands(bytevar);
call incrmacroptr;
return pt;
end getoperadr;
/* recognize codemacro command type */
commandtype: proc(comno,lg,pt) byte public;
dcl (comno,lg,i) byte,pt address,ch based pt(1) byte;
i=0ffh;
do while (i:=i+1) < lg;
if comno=ch(i) then$do call incrmacroptr; return i; end$if;
end$while;
return lg;
end commandtype;
$eject
/******* CODEMACRO COMMAND SUBROUTINES: ********/
mDBNrout: proc public;
call emitsinglebyte(bytevar);
call incrmacroptr;
end mDBNrout;
mDBFrout: proc public;
dcl pt address,opr based pt operandstruc;
pt=getoperadr;
call emitsinglebyte(opr.offset);
end mDBFrout;
mDWNrout: proc public;
call emitsingleword(addrvar);
call incrmacroptr;
call incrmacroptr;
end mDWNrout;
mDWFrout: proc public;
dcl pt address,opr based pt operandstruc;
pt=getoperadr;
call emitsingleword(opr.offset);
end mDWFrout;
mDDFrout: proc public;
dcl pt address,opr based pt operandstruc;
pt=getoperadr;
if (opr.sflag and segmbit) = 0 then call errmsg(misssegminfo);
call emitsingleword(opr.offset);
call emitsingleword(opr.segment);
end mDDFrout;
mRELBrout: proc public;
dcl pt address,opr based pt operandstruc,displ addr;
pt=getoperadr;
displ=opr.offset-cip-2;
if (opr.segment <> csegvalue) or (typecalc(displ)=wrd) then$do
call errmsg(laboutofrange);
end$if;
call emitsinglebyte(displ);
IF ABSADDR (0) = SPACE THEN$DO
CALL HEX2OUT (OPR.OFFSET, .ABSADDR);
END$IF;
end mRELBrout;
mRELWrout: proc public;
dcl pt address,opr based pt operandstruc;
pt=getoperadr;
if opr.segment <> csegvalue then call errmsg(laboutofrange);
call emitsingleword(opr.offset-cip-3);
IF ABSADDR (0) = SPACE THEN$DO
CALL HEX2OUT (OPR.OFFSET, .ABSADDR);
END$IF;
end mRELWrout;
mNOSEGFIXrout: proc public;
dcl (segr,flag,segt) byte,pt address,opr based pt operandstruc;
segr=bytevar;
call incrmacroptr;
pt=getoperadr;
if (opr.baseindex and nooverridebit) = 0 then$do
flag=opr.sflag;
segt=shr(flag,segtypecount) and 3;
noerror=(segt=segr);
end$if;
end mNOSEGFIXrout;
mSEGFIXrout: proc public;
dcl pt address,opr based pt operandstruc,(segr,override,sflag) byte;
DSovertest: proc byte;
segr=shr(opr.baseindex,baseregcount) and 1;
return (((sflag and bregbit) <> 0) and (segr=1)); /* 1 = BP */
end DSovertest;
pt=getoperadr;
sflag=opr.sflag;
if (opr.baseindex and nooverridebit) = 0 then$do
segr=shr(sflag,segtypecount) and 3;
do case segr;
do; override=true; segr=ESover; end; /* ES */
do; override=true; segr=CSover; end; /* CS */
do; override=not DSovertest; segr=SSover; end; /* SS */
do; override=DSovertest; segr=DSover; end; /* DS */
end$case;
if override then call emitsinglebyte(segr);
end$if;
end mSEGFIXrout;
MODRM: proc (regfield,pt);
dcl pt address,opr based pt operandstruc,
(regfield,modfield,rmfield,dispflag,stype,sflag,segr) byte,
BASEIND BYTE,
offset addr,
displow byte at(.offset),disphigh byte at (.offset+1);
disptype: proc byte;
if segr=rcs then return 2; /* disp always 2 for variable in CS */
if offset = 0 then return 0;
return typecalc(offset);
end disptype;
indextype: proc byte;
if (sflag and iregbit) <> 0 then$do
if (sflag and bregbit) <> 0 then return 0;
return 1;
end$if;
return 2;
end indextype;
offset=opr.offset; /* pick up operand attributes */
stype=opr.stype;
sflag=opr.sflag;
segr=shr(sflag,segtypecount) and 3;
BASEIND = OPR.BASEINDEX AND (BASEREGBIT OR INDEXREGBIT);
if stype=reg then$do
rmfield=offset;
modfield=11b;
dispflag=0;
else$do
if (sflag and (iregbit or bregbit)) = 0 then$do
rmfield=110b;
modfield=0;
dispflag=2;
else$do
dispflag=disptype; /* get no of DISP bytes */
modfield=dispflag;
do case indextype;
/* both base- and index-reg */
RMFIELD = BASEIND AND (INDEXREGBIT OR BASEREGBIT);
/* index reg only */
RMFIELD = 100B OR (BASEIND AND INDEXREGBIT);
do; /* base reg only */
IF (BASEIND AND BASEREGBIT) > 0 THEN$DO
rmfield=110b;
/* mod=00 and r/m=110B is a special case */
if dispflag=0 then$do
dispflag,modfield=1;
end$if;
else$do
rmfield=111b;
end$if;
end;
end$case;
end$if;
end$if;
regfield=shl(regfield,3) and 38h;
modfield=shl(modfield,6) and 0c0h;
call emitsinglebyte(regfield or modfield or rmfield);
if dispflag > 0 then$do
call emitsinglebyte(displow);
if dispflag=2 then call emitsinglebyte(disphigh);
end$if;
end MODRM;
mMODRM1rout: proc public;
dcl regfield byte;
regfield=bytevar;
call incrmacroptr;
call MODRM(regfield,getoperadr);
end mMODRM1rout;
mMODRM2rout: proc public;
dcl regfield byte,pt address,opr based pt operandstruc;
pt=getoperadr;
regfield=opr.offset;
call MODRM(regfield,getoperadr);
end mMODRM2rout;
mDBITrout: proc public;
dcl (result,crbit) byte,bittab(8) byte data(1,2,4,8,16,32,64,128);
join: proc(numb,nobit,noshift);
dcl (numb,nobit,noshift) byte;
if noshift > 0 then numb=shr(numb,noshift);
if nobit < 8 then numb=shl(numb,8-nobit);
do while (crbit <> 0ffh) and (nobit > 0);
if (numb and 80h) <> 0 then result=result or bittab(crbit);
crbit=crbit-1;
nobit=nobit-1;
numb=shl(numb,1);
end$while;
end join;
NUMBERBITSrout: proc;
dcl nobit byte;
nobit=bytevar;
call incrmacroptr;
call join(bytevar,nobit,0);
call incrmacroptr;
end NUMBERBITSrout;
FORMBITSrout: proc;
dcl (nobit,numb) byte,pt address,opr based pt operandstruc;
nobit=bytevar;
call incrmacroptr;
pt=getoperadr;
numb=opr.offset;
call join(numb,nobit,bytevar);
call incrmacroptr;
end FORMBITSrout;
result=0;
crbit=7; /* current bit position */
do while bytevar <> mendbit; /* do until ENDBIT command */
do case commandtype(bytevar,length(bitcomtab),.bitcomtab);
call NUMBERBITSrout;
call FORMBITSrout;
do; end;
end$case;
end$while;
call incrmacroptr; /* skip ENDBIT command */
call emitsinglebyte(result);
end mDBITrout;
$eject
/********* ROUTINES TO MATCH OPERANDS TO INSTRUCTION ********/
/* test user operand against codemacro parameter */
matchsingleop: proc(opno) byte;
dcl (match,specletter,modletter,range,rangetype) byte,
(rangev1,rangev2,opno) byte,
pt address, oper based pt operandstruc;
rangetest: proc byte; /* perform rangetest */
dcl opervalue byte;
rangev1=bytevar;
call incrmacroptr;
if range=doublerange then$do
rangev2=bytevar;
call incrmacroptr;
end$if;
opervalue=oper.offset;
if range=doublerange then$do
return ((opervalue>=rangev1) and (opervalue<=rangev2));
else$do
return (opervalue=rangev1);
end$if;
end rangetest;
modlettertest: proc byte;
dcl numb addr,(styp,modbyt) byte;
styp=oper.stype;
if styp=lab then return true;
modbyt=oper.sflag and typebit;
if styp = reg then return (modbyt=modletter);
if styp = variable then
return ((modbyt=nomod) or (modbyt=modletter));
if styp=number then$do
numb=oper.offset;
do case modletter-1;
return not wrdtest(numb); /* BYTE */
return wrdtest(numb); /* WORD */
return (typecalc(numb)=byt); /* signed BYTE */
return false; /* DWORD */
end$case;
end$if;
return false;
end modlettertest;
speclettertest: proc byte;
dcl (opertype,locvalue,loctype) byte;
memtest: proc byte;
return (opertype=variable);
end memtest;
opertype=oper.stype;
locvalue=oper.offset;
loctype=oper.sflag and typebit;
do case specletter;
/* A - accumulator (AX or AL) */
return ((opertype=reg) and (locvalue=rax));
/* C - code reference,i.e. label */
return (opertype=lab);
/* D - immediate data */
return (opertype=number);
/* E - effective address, i.e. memory address or register */
return (memtest or (opertype=reg));
/* M - memory address */
return memtest;
/* R - register except segment register */
return ((opertype=reg) and (loctype <> dwrd));
/* S - segment register */
return ((opertype=reg) and (loctype = dwrd));
/* X - memory address without indexing */
return ((opertype=variable) and
((oper.sflag and (iregbit or bregbit))=0));
end$case;
end speclettertest;
specletter=bytevar; /* pick up codemacro attributes */
call incrmacroptr;
modletter=bytevar and modletter$bit;
range=bytevar and range$and;
rangetype=bytevar and rangetype$and;
call incrmacroptr;
pt=.operands(opno); /* address of current user operand */
match=true;
if range <> norange then match=rangetest;
if modletter <> 0 then match=match and modlettertest;
if match then match=speclettertest;
return match;
end matchsingleop;
/* test if operands match a specific codemacro */
matchingops: proc byte;
dcl savept address,(nopara,match,parno) byte;
savept=macroptr;
call incrmacroptr; /* macroptr=macroptr+2 */
call incrmacroptr;
nopara=bytevar; /* pick up no of parameters */
call incrmacroptr; /* advance to first formal */
if (nopara and prefix$on) <> 0 then return true; /* PREFIX */
if nopara <> nooper then$do
match=false;
else$do
match=true;
parno=0ffh;
do while (parno:=parno+1) < nopara;
match=match and matchsingleop(parno);
end$while;
end$if;
if not match then macroptr=savept;
return match;
end matchingops;
/* test if operands match instruction */
searchformatch: proc byte public;
dcl next based macroptr address;
macroptr=firstmacroptr;
do forever;
if matchingops then return true;
if next=0 then return false;
macroptr=next;
end$forever;
end searchformatch;
end$module cmsubr;


355
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/DLINE.PLM Normal file
View File

@@ -0,0 +1,355 @@
$title ('DECODE LINE MODULE')
decodel:
do;
/*
modified 3/26/81 R. Silberstein
modified 3/30/81 R. Silberstein
modified 4/9/81 R. Silberstein
modified 4/10/81 R. Silberstein
modified 7/24/81 R. Silberstein
*/
/*
This is the module to decode each logical sourceline.
The module takes care of all symbol definitions, and
activates the PSEUDO-module and the INSTRUCTION-module
to perform the assembly of the current non-empty source-
line.
*/
$include (:f1:macro.lit)
$include (:f1:struc.lit)
$include (:f1:equals.lit)
$include (:f1:ermod.lit)
$include (:f1:subr1.ext)
$include (:f1:subr2.ext)
$include (:f1:scan.ext)
$include (:f1:print.ext)
$include (:f1:instr.ext)
$include (:f1:pseud1.ext)
$include (:f1:pseud2.ext)
$include (:f1:ermod.ext)
$include (:f1:symb.ext)
$include (:f1:exglob.ext)
$include (:f1:dline.x86)
$include (:f1:cm.ext)
saveaccum: proc;
acclensave=acclen;
call copy(acclen,.accum(0),.accumsave(0));
end saveaccum;
exchangeaccum: proc;
dcl locacclen byte,locaccum(80) byte;
locacclen=acclensave;
call copy(acclensave,.accumsave(0),.locaccum(0));
call saveaccum;
acclen=locacclen;
call copy(locacclen,.locaccum(0),.accum(0));
end exchangeaccum;
clearsymbol: proc;
CALL FILL (0, .CURRENTSYMBOL.BASEINDEX-.CURRENTSYMBOL+1, .CURRENTSYMBOL);
end clearsymbol;
pseudotype: proc(lg,ptr) byte;
dcl (lg,i,lvalue) byte,ptr address,pstable based ptr (1) byte;
if token.type <> pseudo then return lg+1;
i=0ffh;
do while (i:=i+1) < lg;
lvalue=token.value;
if lvalue=pstable(i) then$do
call scan; /* skip found pseudo */
return i;
end$if;
end$while;
return i;
end pseudotype;
/* test if symbol if double defined or "neglected" symbol */
not$doub$negl: proc(errno) byte;
dcl (errno,errfl) byte;
if pass = 0 then$do
if findsymbol(acclensave,.accumsave,.symbtabadr) then$do
call getattributes(symbtabadr,.currentsymbol);
if currentsymbol.stype <> neglected then$do
currentsymbol.stype=doubledefined;
call enterattributes(symbtabadr,.currentsymbol);
end$if;
return false;
end$if;
else$do
/* pass 1 and pass 2 */
if not findsymbol(acclensave,.accumsave,.symbtabadr) then
return false;
call getattributes(symbtabadr,.currentsymbol);
errfl=true;
if currentsymbol.stype=neglected then$do
errno=neglecterr;
else$do
if currentsymbol.stype<>doubledefined then errfl=false;
end$if;
if errfl then$do
call exchangeaccum;
call errmsg(errno);
call exchangeaccum;
return false;
end$if;
end$if;
return true;
end not$doub$negl;
newsym: proc byte; /* enter new symbol into table */
if pass=0 then$do
if not newsymbol(acclensave,.accumsave,.symbtabadr) then$do
fullsymbtab=true;
return false;
end$if;
end$if;
return true;
end newsym;
/* set up symbol attributes for label,DB,DW,DD,RS */
setupattr: proc (styp,sfla);
dcl (styp,sfla,segtyp) byte;
segtyp=shl(csegtype,segtypecount) and segtypebit;
currentsymbol.stype=styp;
if csegspec then sfla=sfla or segmbit;
currentsymbol.sflag=sfla or segtyp;
currentsymbol.segment=csegvalue;
currentsymbol.offset=cip;
end setupattr;
entatr: proc; /* enter attributes of current symbol into table */
if pass <> 2 then$do
call enter$attributes(symbtabadr,.currentsymbol);
end$if;
end entatr;
/* decode instruction */
decodeinstr: proc;
if csegtype <> rcs then$do
call errmsg(instrerr);
call skip$rest$of$line;
else$do
CALL LISTCIP;
call instruction; /* decode instruction */
end$if;
end decodeinstr;
labinstruction: proc; /* scan labelled instruction */
dcl symb based codemacroptr symbolstruc;
call saveaccum;
/* enter label into symbol table */
if not$doub$negl(doubledeflab) then$do
if newsym then$do
call setupattr(lab,wrd);
call entatr;
end$if;
end$if;
call scan; /* skip ":" */
call scan; /* allow empty instruction */
if emptyline then$do
call skip$rest$of$line;
else$do
if findcodemacro(acclen,.accum(0),.codemacroptr) then$do
call scan; /* skip codemacro */
call decode$instr;
else$do
call errmsg(illegalmacro);
end$if;
end$if;
end labinstruction;
no$ident$pseudo: proc; /* branch to correct pseudo routine */
dcl ptable(*) byte data( /* define legal unnamed pseudos */
pif,pendif,pinclude,pcseg,pdseg,psseg,peseg,porg,pdb,
pdw,pdd,prb,prs,prw,pend,ppagesize,ppagewidth,
ptitle,peject,psimform,pcodemacro,plist,pnolist,PIFLIST,PNOIFLIST,
psegfix,pnosegfix,pmodrm,prelb,prelw,pdbit,pendm);
do case pseudotype(length(ptable),.ptable); /* branch */
call IFrout;
call ENDIFrout;
call INCLUDErout;
call CSEGrout;
call DSEGrout;
call SSEGrout;
call ESEGrout;
call ORGrout;
if codemacro$flag then call db$cm$rout;
else call DBrout;
if codemacro$flag then call dw$cm$rout;
else call DWrout;
if codemacro$flag then call dd$cm$rout;
else call DDrout;
call RSrout(byt); /* RB */
call RSrout(byt); /* RS */
call RSrout(wrd); /* RW */
call ENDrout;
call PAGESIZErout;
call PAGEWIDTHrout;
call TITLErout;
call EJECTrout;
call SIMFORMrout;
call CODEMACROrout;
call LISTrout;
call NOLISTrout;
CALL IFLISTROUT;
CALL NOIFLISTROUT;
call segfix$cm$rout; /* cm */
call nosegfix$cm$rout; /* cm */
call modrm$cm$rout; /* cm */
call relb$cm$rout; /* cm */
call relw$cm$rout; /* cm */
call dbit$cm$rout; /* cm */
call end$cm$rout; /* cm */
do; /* error, illegal pseudo */
call errmsg(illegalpseudo);
call skip$rest$of$line;
end;
end$case;
end no$ident$pseudo;
identpseudo: proc(normal); /* scan a named pseudo instruction */
dcl (noerr,normal) byte,symb based codemacroptr symbolstruc;
entervar: proc(typ);
dcl typ byte;
noerr=false;
if not$doub$negl(doubledefvar) then$do
if newsym then$do
call setupattr(variable,typ);
noerr=true;
end$if;
end$if;
end entervar;
enter: proc;
if noerr then call entatr;
end enter;
/* legal pseudos: DB,DW,DD,RB,RS,RW,EQU */
dcl pseudotable(7) byte data(pdb,pdw,pdd,prb,prs,prw,pequ);
call clearsymbol; /* clear attributes of current symbol */
if normal then$do /* unormal if EQU with instruction parameter */
call saveaccum;
call scan; /* scan actual pseudo */
end$if;
do case pseudotype(length(pseudotable),.pseudotable);
do; /* DB */
call entervar(byt);
call DBrout;
call enter;
end;
do; /* DW */
call entervar(wrd);
call DWrout;
call enter;
end;
do; /* DD */
call entervar(dwrd);
call DDrout;
call enter;
end;
do; /* RB */
call entervar(byt);
call RSrout(byt);
call enter;
end;
do; /* RS */
call entervar(byt);
call RSrout(byt);
call enter;
end;
do; /* RW */
call entervar(wrd);
call RSrout(wrd);
call enter;
end;
do; /* EQU */
if not$doub$negl(doubledefsymb) then$do
if newsym then$do
call EQUrout;
else$do
call skip$rest$of$line;
end$if;
else$do
call skip$rest$of$line;
end$if;
end;
do; /* illegal pseudo instruction */
call errmsg(illegalpseudo);
call skip$rest$of$line;
end;
do; /* missing pseudo instruction */
call errmsg(missingpseudo);
call skip$rest$of$line;
end;
end$case;
end identpseudo;
decodeline: proc public;
first$item$type: proc byte;
dcl typ byte;
typ=token.type;
if typ=pseudo then return 3;
if typ=ident and nextch=':' then return 2;
if (typ=ident) or (typ=operator) then$do
if findcodemacro(acclen,.accum(0),.codemacroptr) then$do
call saveaccum;
call scan; /* skip found codemacro */
typ=token.value;
if (token.type=pseudo) and (typ=pequ) then return 5;
return 4;
end$if;
end$if;
if typ <> ident then return 0; /* error */
return 1;
end first$item$type;
if accum(0) <> cr then$do /* skip blank lines */
do case first$item$type;
do; /* error,skip rest of line */
call errmsg(first$item); /* error handler */
call skip$rest$of$line;
end;
call ident$pseudo(true); /* named pseudo instruction */
call lab$instruction; /* label (followed by instruction) */
call no$ident$pseudo; /* pseudo instruction */
call decodeinstr; /* code instruction */
call identpseudo(false); /* EQU with instruction parameter */
end$case;
end$if;
end decodeline;
end$module decodel;


148
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/ERMOD.PLM Normal file
View File

@@ -0,0 +1,148 @@
$title ('ERROR MESSAGE MODULE')
errorm:
do;
/*
modified 3/28/81 R. Silberstein
modified 3/30/81 R. Silberstein
modified 4/7/81 R. Silberstein
modified 4/24/81 R. Silberstein
*/
/*
This is the module to perform error message
printout to the print file. The interface from
other modules goes through the subroutine
ERRMSG ( errornumber )
This routine also increments the global variable
"ERRORS" which contains the accumulated number
of errors throughout the assembly.
*/
$include (:f1:macro.lit)
$include (:f1:struc.lit)
$include (:f1:ermod.lit)
$include (:f1:subr1.ext)
$include (:f1:subr2.ext)
$include (:f1:print.ext)
$include (:f1:global.ext)
/* Error messages : */
dcl
nulltext(1) byte data (0), /* dummy text */
tex00(*) byte data ('ILLEGAL FIRST ITEM',0),
tex01(*) byte data ('MISSING PSEUDO INSTRUCTION',0),
tex02(*) byte data ('ILLEGAL PSEUDO INSTRUCTION',0),
tex03(*) byte data ('DOUBLE DEFINED VARIABLE',0),
tex04(*) byte data ('DOUBLE DEFINED LABEL',0),
tex05(*) byte data ('UNDEFINED INSTRUCTION',0),
tex06(*) byte data ('GARBAGE AT END OF LINE - IGNORED',0),
tex07(*) byte data ('OPERAND(S) MISMATCH INSTRUCTION',0),
tex08(*) byte data ('ILLEGAL INSTRUCTION OPERANDS',0),
tex09(*) byte data ('MISSING INSTRUCTION',0),
tex10(*) byte data ('UNDEFINED ELEMENT OF EXPRESSION',0),
tex11(*) byte data ('ILLEGAL PSEUDO OPERAND',0),
tex12(*) byte data ('NESTED "IF" ILLEGAL - "IF" IGNORED',0),
tex13(*) byte data ('ILLEGAL "IF" OPERAND - "IF" IGNORED',0),
tex14(*) byte data ('NO MATCHING "IF" FOR "ENDIF"',0),
tex15(*) byte data ('SYMBOL ILLEGALLY FORWARD REFERENCED - ',
'NEGLECTED',0),
tex16(*) byte data ('DOUBLE DEFINED SYMBOL - ',
'TREATED AS UNDEFINED',0),
tex17(*) byte data ('INSTRUCTION NOT IN CODE SEGMENT',0),
tex18(*) byte data ('FILE NAME SYNTAX ERROR',0),
tex19(*) byte data ('NESTED INCLUDE NOT ALLOWED',0),
tex20(*) byte data ('ILLEGAL EXPRESSION ELEMENT',0),
tex21(*) byte data ('MISSING TYPE INFORMATION IN OPERAND(S)',0),
tex22(*) byte data ('LABEL OUT OF RANGE',0),
tex23(*) byte data ('MISSING SEGMENT INFORMATION IN OPERAND',0),
tex24(*) byte data ('ERROR IN CODEMACROBUILDING',0),
/* Error-message pointer table: */
texttab(*) address data (.tex00,.tex01,.tex02,.tex03,.tex04,
.tex05,.tex06,.tex07,.tex08,
.tex09,.tex10,.tex11,.tex12,.tex13,
.tex14,.tex15,.tex16,.tex17,.tex18,
.tex19,.tex20,.tex21,.tex22,.tex23,
.tex24,.nulltext);
/* Additional text strings: */
dcl
errnotext(*) byte data ('** ERROR NO:',0),
neartext(*) byte data (' ** NEAR: "',0),
spacetext(*) byte data (' ',0);
/* Table of defined error numbers: */
dcl
errtab (*) byte data (firstitem,missingpseudo,
illegalpseudo,doubledefvar,doubledeflab,
illegalmacro,end$of$line$err,opmismatch,
illioper,missinstr,udefsymbol,
pseudooperr,nestediferr,ifparerr,
missiferr,neglecterr,doubledefsymb,
instrerr,filesynterr,
nestedincludeerr,illexprelem,misstypeinfo,
laboutofrange,misssegminfo,codemacroerr);
/* Subroutines: */
printtext: proc(txt);
dcl txt address,ch based txt (1) byte,i byte;
i=0ffh;
do while ch(i:=i+1) <> 0;
call printsinglebyte(ch(i));
end$while;
end printtext;
locerrmsg: proc(erno);
dcl t address,help(5) byte,(helpstop,erno,i) byte;
errortype: proc byte;
i=0ffh;
do while (i:=i+1) < length(errtab);
if erno = errtab(i) then return i;
end$while;
return length(errtab);
end errortype;
helpstop,accum(acclen)=0;
call decout(erno,.help(0));
t=texttab(errortype); /* pick up correct error text */
call printtext(.errnotext); /* print error message line */
call printtext(.help(2));
if accum(0) <> cr then$do
call printtext(.neartext);
call printtext(.accum(0)); /* (print current token) */
CALL PRINTSINGLEBYTE ('"');
end$if;
call printtext(.spacetext);
call printtext(t);
call printcrlf;
end locerrmsg;
/* Public routine: */
errmsg: proc(erno) public;
dcl erno byte;
if print$on OR PRINTSWITCHOFF then$do
if not errorprinted then$do
errorprinted=true;
call locerrmsg(erno);
errors=errors+1;
end$if;
end$if;
end errmsg;
end$module errorm;


516
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/EXPR.PLM Normal file
View File

@@ -0,0 +1,516 @@
$title ('EXPRESSION MODULE')
expres:
do;
/*
modified 4/8/81 R. Silberstein
modified 4/24/81 R. Silberstein
modified 8/19/81 R. Silberstein
*/
/*
This is the module to evaluate expressions and
instruction operands. The entry subroutines are:
EXPRESSION (resultfield) byte
OPERAND byte
The expression subroutine evaluates a numeric or
memory expression. The "operand" routine evalates
a single instruction operand. Both routines return
FALSE if an error is found,otherwise true.
*/
$include (:f1:macro.lit)
$include (:f1:expr.x86)
$include (:f1:ermod.ext)
$include (:f1:exglob.ext)
$INCLUDE (:F1:SUBR2.EXT)
$eject
/************** global variables: ************/
dcl
maxlev lit '5', /* max no of nested parenthesis */
parlevel byte, /* current no of parenthesis level */
stck(600) byte, /* local stack within module */
savestack addr, /* save of initial entry stack */
expresserr byte, /* error flag */
noforward byte, /* true if undefined symbols to be neglected */
bracketlegal byte, /* true if bracket expression is legal */
udefflag byte; /* true if an udefined element found */
$eject
$include (:f1:bnf.tex)
$eject
/************ michellaneous subroutines: ***********/
exprexit: proc (dummy);
dcl dummy byte;
stackptr=savestack;
end exprexit;
errorexit: proc; /* return if wrong syntax */
dcl dummy byte at (.udefflag);
expresserr=false;
call exprexit(dummy);
end errorexit;
clearoperand: proc(p);
dcl p address,oper based p operandstruc;
CALL FILL (0, .OPER.BASEINDEX - .OPER + 1, P);
OPER.BASEINDEX = NOOVERRIDEBIT;
end clearoperand;
/* routine to test if current token is member of a given
set of special characters.
Entry parameters: base = exitvalue if token is 1. member of set
numbel = no of elements in set
pt = pointer to list of elements
Exit value: routine= 0ffh if token not member of list
routine= base+i if token is element i,
token is skipped */
specmember: proc (base,numbel,pt) byte;
dcl (base,numbel,i) byte,pt address,list based pt (1) byte;
i=0ffh;
do while (i:=i+1) < numbel;
if specialtoken(list(i)) then$do call scan; return base+i; end$if;
end$while;
return 0ffh;
end specmember;
/* Routine to test if current token is member of a given set of
operators.
Entry/exit : see "specmember" header */
opmember: proc(base,numbel,pt) byte;
dcl (base,numbel,i,byteval) byte,pt address,list based pt (1) byte;
if token.type = operator then$do
i=0ffh;
do while (i:=i+1) < numbel;
byteval=token.value;
if byteval=list(i) then$do call scan; return base+i; end$if;
end$while;
end$if;
return 0ffh;
end opmember;
/* test if both operands are numbers, if not, error */
numbtest: proc (ptl,ptr);
dcl (ptl,ptr) address,(left based ptl,rigth based ptr) operandstruc;
if (left.stype <> number) or (rigth.stype <> number) then
call errorexit;
end numbtest;
/* find resulting symbol type as result of an addition or a
subtraction, test if illegal types */
typefind: proc (ptl,ptr);
dcl (ptl,ptr) address,stype byte,
(left based ptl,rigth based ptr) operandstruc;
dcl err lit '07fh',
crosstab(9) byte data(number,variable,lab,variable,err,err,
lab,err,err);
typeno: proc(typ) byte;
dcl typ byte;
if typ=number then return 0;
if typ=variable then return 1;
if typ=lab then return 2;
call errorexit; /* illegal member of expression */
end typeno;
stype=crosstab(typeno(left.stype)*3+typeno(rigth.stype));
if stype=err then call errorexit;
left.length=left.length+rigth.length;
left.stype=stype;
end typefind;
/* take care of segment specification in front of variables
syntax: <over>: variable, <over>=ES/SS/DS/CS */
segover: proc(pt) byte;
dcl pt address,segreg based pt byte;
if (token.type=reg) and (token.descr=dwrd) then$do
if nextch=':' then$do
segreg=token.value;
segreg=(shl(segreg,segtypecount) and segtypebit) or segmbit;
call scan; /* skip segment register */
call scan; /* skip : */
return 0;
end$if;
end$if;
return 0ffh;
end segover;
/* create a number operator */
createnumber: proc(p,n);
dcl p address,n addr,oper based p operandstruc;
call clearoperand(.oper);
oper.stype=number;
oper.offset=n;
end createnumber;
/* get current identificator, perform symboltable lookup
set undefined-symbol-flag if symbol not defined,
treat undefined symbols as numbers */
finditem: proc (pt);
dcl pt address,left based pt operandstruc,symbptr address,i byte;
if token.type <> ident then$do
call clearoperand(.left);
left.stype=token.type;
left.sflag=token.descr;
left.offset=token.value;
else$do
if findsymbol(acclen,.accum(0),.symbptr) then$do
call getattributes(symbptr,.left);
i=left.stype;
if (i=neglected) or (i=doubledefined) or (i=udefsymb) then$do
udefflag=true;
left.stype=number;
expresserr=false;
call errmsg(udefsymbol);
end$if;
else$do
/* symbol undefined - test if it is to be "neglected" */
expresserr=false;
if noforward then$do
if not newsymbol(acclen,.accum,.symbptr) then$do
call errorexit;
end$if;
left.stype=neglected;
call enterattributes(symbptr,.left);
end$if;
call errmsg(udefsymbol);
udefflag=true;
end$if;
end$if;
call scan;
end finditem;
/* recognize the different symboltypes for the II (identicator)
subroutine */
symtyp: proc(pt) byte;
dcl pt address, left based pt operandstruc,i byte;
if specialtoken('$') then return 0;
if specialtoken('.') then return 1;
if token.type=string then$do
if (acclen > 0) and (acclen < 3 ) then return 2;
return 4; /* error */
end$if;
call finditem(.left);
i=left.stype;
if (i=pseudo) or (i=operator) or (i=spec) then return 4; /* error */
return 3;
end symtyp;
$eject
/********** subroutines for each "NON-TERMINAL" **********/
/********** in "BNF" syntax **********/
II: proc (pt) reentrant;
dcl pt address,left based pt operandstruc,
doublebyt addr at (.accum(0)),saveb byte;
do case symtyp(.left);
do; /* $ */
left.stype=lab;
left.sflag=wrd;
left.offset=cip;
if csegspec then$do /* pick up current segment specification */
left.sflag=shl(csegtype,segtypecount) or segmbit or wrd;
left.segment=csegvalue;
end$if;
call scan; /* skip $ */
end;
do; /* . number */
call scan; /* skip . */
call finditem(.left);
if left.stype <> number then call errorexit;
left.stype=variable;
left.segment=curdseg;
left.sflag=shl(rds,segtypecount) and segtypebit;
if dspec then left.sflag=left.sflag or segmbit;
end;
do; /* string */
if acclen=1 then$do
call createnumber(.left,accum(0));
else$do
saveb=accum(0);
accum(0)=accum(1);
accum(1)=saveb;
call createnumber(.left,doublebyt);
end$if;
call scan; /* skip string */
end;
do; end; /* number,label,variable,register */
call errorexit;
end$case;
end II;
BB: proc (pt) reentrant;
dcl pt address,left based pt operandstruc;
if specialtoken('(') then$do
if (parlevel:=parlevel+1) > maxlev-1 then call errorexit;
call scan;
call EE(.left);
if not specialtoken(')') then call errorexit;
parlevel=parlevel-1;
call scan;
return;
end$if;
if specialtoken(leftbracket) then$do
if not bracketlegal then call errorexit;
bracketlegal=false;
call scan; /* skip leftbracket */
call clearoperand(.left);
left.stype=number;
if not bracketexpr(.left) then call errorexit;
return;
end$if;
call II(.left);
end BB;
FF: proc (pt) reentrant;
dcl pt address,left based pt operandstruc,rigth operandstruc,
opertyp byte,val addr;
if (opertyp:=opmember(0,5,.(oseg,ooffset,otype,olength,olast)))
<> 0ffh then$do
call BB(.left);
do case opertyp;
do; /* SEG */
if (left.sflag and segmbit) = 0 then call errorexit;
call createnumber(.left,left.segment);
end;
do; /* OFFSET */
call createnumber(.left,left.offset);
end;
do; /* TYPE */
call createnumber(.left,left.sflag and typebit);
end;
do; /* LENGTH */
call createnumber(.left,left.length);
end;
do; /* LAST */
if (val:=left.length) = 0 then val=1;
call createnumber(.left,val-1);
end;
end$case;
else$do
call BB(.left);
do while opmember(0,1,.(optr)) <> 0ffh;
call BB(.rigth);
left.stype=rigth.stype;
left.segment=rigth.segment;
left.offset=rigth.offset;
left.baseindex=rigth.baseindex;
left.sflag=(left.sflag and typebit) or (rigth.sflag and
(not typebit));
end$while;
end$if;
end FF;
SS: proc (pt) reentrant;
dcl pt address,left based pt operandstruc,segreg byte;
if segover(.segreg) <> 0ffh then$do
call FF(.left);
left.sflag=(left.sflag and (not segtypebit)) or segreg;
left.baseindex=left.baseindex and (not nooverridebit);
else$do
call FF(.left);
end$if;
end SS;
MM: proc (pt) reentrant;
dcl pt address,left based pt operandstruc,opertyp byte;
if (opertyp:=specmember(0,2,.('+-'))) <> 0ffh then$do
call MM(.left);
call numbtest(.left,.left);
if opertyp=1 then$do
left.offset=-left.offset;
end$if;
else$do
call SS(.left);
end$if;
end MM;
TT: proc (pt) reentrant;
dcl pt address,left based pt operandstruc,rigth operandstruc,
opertyp byte,(leftval,rigthval) addr;
call MM(.left);
do while (opertyp:=specmember(0,2,.('*/')) and
opmember(2,3,.(omod,oshl,oshr))) <> 0ffh;
call MM(.rigth);
call numbtest(.left,.rigth);
leftval=left.offset;
rigthval=rigth.offset;
do case opertyp;
leftval=leftval*rigthval;
leftval=leftval/rigthval;
leftval=leftval mod rigthval;
if rigthval>0 and rigthval<16 then leftval=shl(leftval,rigthval);
if rigthval>0 and rigthval<16 then leftval=shr(leftval,rigthval);
end$case;
left.offset=leftval;
end$while;
end TT;
PP: proc (pt) reentrant;
dcl pt address,left based pt operandstruc,rigth operandstruc,
opertyp byte;
call TT(.left);
do while (opertyp:=specmember(0,2,.('+-'))) <> 0ffh;
call TT(.rigth);
call typefind(.left,.rigth);
if opertyp=0 then$do
left.offset=left.offset+rigth.offset;
else$do
left.offset=left.offset-rigth.offset;
end$if;
end$while;
end PP;
RR: proc (pt) reentrant;
dcl pt address,left based pt operandstruc,rigth operandstruc,
opertyp byte,(leftval,rigthval) addr;
call PP(.left);
if (opertyp:=opmember(0,6,.(oeq,olt,ole,ogt,oge,one))) <> 0ffh
then$do
call PP(.rigth);
call numbtest(.left,.rigth);
leftval=left.offset;
rigthval=rigth.offset;
do case opertyp;
leftval = (leftval = rigthval);
leftval = (leftval < rigthval);
leftval = (leftval <= rigthval);
leftval = (leftval > rigthval);
leftval = (leftval >= rigthval);
leftval = (leftval <> rigthval);
end$case;
IF LEFTVAL = 0FFH THEN LEFTVAL = 0FFFFH;
left.offset=leftval;
end$if;
end RR;
NN: proc (pt) reentrant;
dcl pt address,left based pt operandstruc;
if opmember(0,1,.(onot)) <> 0ffh then$do
call NN(.left);
call numbtest(.left,.left);
left.offset=not left.offset;
else$do
call RR(.left);
end$if;
end NN;
AA: proc (pt) reentrant;
dcl pt address,left based pt operandstruc,rigth operandstruc;
call NN(.left);
do while opmember(0,1,.(oand)) <> 0ffh;
call NN(.rigth);
call numbtest(.left,.rigth);
left.offset=left.offset and rigth.offset;
end$while;
end AA;
EE: proc (pt) reentrant;
dcl pt address,left based pt operandstruc,right operandstruc,
opertype byte;
call AA(.left);
do while (opertype:=opmember(0,2,.(oor,oxor))) <> 0ffh;
call AA(.right);
call numbtest(.left,.right);
if opertype=0 then$do
left.offset=left.offset or right.offset;
else$do
left.offset=left.offset xor right.offset;
end$if;
end$while;
end EE;
$eject
/*************** MAIN SUBROUTINES ***************/
realexpress: proc(pt);
dcl pt address,oper based pt operandstruc,
dummy byte at(.udefflag);
savestack=stackptr; /* use local stack for reentrant routines */
stackptr=.stck(length(stck));
call EE(.oper);
call exprexit(dummy);
end realexpress;
express: proc(pt) byte;
dcl pt address,oper based pt operandstruc;
expresserr=true;
udefflag=false;
parlevel=0;
call realexpress(.oper);
if udefflag then$do
oper.stype=number;
oper.sflag=byt;
oper.offset=0;
end$if;
return expresserr;
end express;
/* normal expression */
expression: proc (pt) byte public;
dcl pt address;
noforward=false;
bracketlegal=false;
return express(pt);
end expression;
/* special expression - mark all undefined symbols as "neglected" */
noforwardexpr: proc(pt) byte public;
dcl pt address;
noforward=true;
bracketlegal=false;
return express(pt);
end noforwardexpr;
OPERND: PROC BYTE;
dcl exitvalue byte,pt address,oper based pt operandstruc;
pt=.operands(nooper);
exitvalue=true;
bracketlegal=true;
exitvalue=express(pt);
if specialtoken(leftbracket) then$do
if bracketlegal then$do
call scan;
exitvalue=exitvalue and bracketexpr(pt);
else$do
exitvalue=false;
end$if;
end$if;
return exitvalue;
END OPERND;
OPERAND: PROC BYTE PUBLIC;
NOFORWARD = FALSE;
RETURN OPERND;
END OPERAND;
NOFORWARDOPER: PROC BYTE PUBLIC;
NOFORWARD = TRUE;
RETURN OPERND;
END NOFORWARDOPER;
end$module expres;


492
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/FILES.PLM Normal file
View File

@@ -0,0 +1,492 @@
$title('FILE AND I/O MODULE')
file:
do;
/*
modified 3/26/81 R. Silberstein
modified 3/28/81 R. Silberstein
modified 3/30/81 R. Silberstein
modified 4/7/81 R. Silberstein
modified 4/16/81 R. Silberstein
modified 6/16/81 R. Silberstein
modified 9/14/81 R. Silberstein
*/
/*
This is the modules to perform BYTE i/o to
the following 5 logical devices:
source - file
include - file
hex - file
symbol - file
print - file
Each of the logical files may be assigned to the
following physical devices :
null (not legal for source and include file)
console
printer (not legal for source and include file)
disk
The module defines the following set
of public subroutines:
INSOURCEBYTE - read 1 byte from source file
ININCLUDEBYTE - read 1 byte from include file
OUTHEXBYTE (ch) - write 1 byte to hex file
OUTSYMBOLBYTE (ch) - write 1 byte to symbol file
OUTPRINTBYTE (ch) - write 1 byte to print file
OPENSOURCE - open source file
OPENINCLUDE - open include file
OPENHEX - open hex file
OPENSYMBOL - open symbol file
OPENPRINT - open print file
REWINDSOURCE - rewind source file
CLOSESOURCE - close source file
CLOSEINCLUDE - close include file
CLOSEHEX - close hex file
CLOSESYMBOL - close symbol file
CLOSEPRINT - close print file
In addition, 2 subroutines to set up the correct
file names and routing to correct physical device
are included. These are:
FILESETUP
I$FILESETUP
The "filesetup" routine sets up the source, hex, symbol
and print files by scanning the user command tail of the
program activating line. The format of the command line
is described in the program format section of the user's
manual. The routine also initiates the global string array
"SOURCENAME" with the source file name, this array to be
used later by the printout module.
The "ifilesetup" sets up the format of the include file
given by the INCLUDE command of the assembler.
*/
$include (:f1:macro.lit)
$include (:f1:struc.lit)
$include (:f1:dev.lit)
$include (:f1:io.ext)
$include (:f1:subr1.ext)
$include (:f1:subr2.ext)
$INCLUDE (:F1:TEXT.EXT)
$include (:f1:global.ext)
dcl
diskunit byte,
nulltype lit '0', /* subroutine "devicetype" */
consoletype lit '1',
printertype lit '2',
disktype lit '3',
dr lit '0', /* drive code in fcb block */
fn lit '1', /* filename in fcb block */
ft lit '9', /* filetype in fcb block */
ex lit '12', /* file extension number */
s2 lit '14',
nr lit '32', /* file record number */
dollar lit '''$''',
asmdefault(3) byte data ('A86'), /* different file types */
hexdefault(3) byte data ('H86'),
lstdefault(3) byte data ('LST'),
symdefault(3) byte data ('SYM'),
sourcefile file$i$structure,
includefile file$i$structure,
hexfile file$o$structure,
printfile file$o$structure,
symbolfile file$o$structure;
clearfcb: proc(fcbpt,defaultpt);
dcl
(fcbpt,defaultpt) addr,
dest based fcbpt (1) byte;
CALL FILL (0, 33, FCBPT);
CALL FILL (' ', 8, FCBPT+FN);
call copy(3,defaultpt,.dest(ft));
end clearfcb;
clearcontrol: procedure(point,defaultptr);
dcl (point,defaultptr) addr,
x based point file$o$structure;
call clearfcb(.x.fcbblock,defaultptr);
x.disk=diskunit;
end clearcontrol;
devicetype: proc(ch) byte;
dcl ch byte;
if ch=null then return nulltype;
if ch=console then return consoletype;
if ch=printer then return printertype;
return disktype;
end devicetype;
disk$select: procedure(disk);
dcl disk byte;
if diskunit <> disk then$do
diskunit=disk;
call select$disk(diskunit);
end$if;
end disk$select;
inbyte: proc (ptr) byte;
dcl ptr addr,
x based ptr file$i$structure,
ch byte,
i addr;
i=x.bufptr;
if i=length(x.buffer) then$do
i=0;
call disk$select(x.disk);
do while i < length(x.buffer);
call SET$DMA$ADDRESS (.x.buffer(i));
IF (CH := READ$RECORD (.X.FCBBLOCK)) <> 0 THEN$DO
IF CH = 1 THEN$DO
X.BUFFER (I) = END$OF$FILE;
I = LENGTH (X.BUFFER);
ELSE$DO
CALL FILEABORT (.X, .DISKREADERRTEXT);
END$IF;
else$do
i=i+128;
end$if;
end$while;
i=0;
end$if;
ch=x.buffer(i);
x.bufptr=i+1;
return ch;
end inbyte;
FLUSHBUFFER: PROCEDURE (PTR);
DECLARE (PTR, I) ADDRESS, X BASED PTR FILE$O$STRUCTURE;
call disk$select(x.disk);
i=0;
do while i < x.bufptr;
call SET$DMA$ADDRESS (.x.buffer(i));
IF WRITE$RECORD (.X.FCBBLOCK) > 0 THEN
CALL FILEABORT (.X, .DISKWRITEERRTXT);
i=i+128;
end$while;
END FLUSHBUFFER;
outbyte: proc(ch,ptr);
dcl ch byte,
ptr addr,
x based ptr file$o$structure,
i addr;
do case devicetype(x.disk);
/* null */
do; end; /* do nothing */
/* console */
call write$console(ch);
/* printer */
call write$list(ch);
/* disk file */
do;
i=x.bufptr;
if i=length(x.buffer) then$do
CALL FLUSHBUFFER (PTR);
i=0;
end$if;
x.buffer(i)=ch;
x.bufptr=i+1;
end;
end$case;
end outbyte;
open$input: proc (ptr);
dcl ptr addr,
x based ptr file$i$structure;
x.bufptr=length(x.buffer);
call disk$select(x.disk);
IF LOW (VERSION) >= 30H THEN$DO
IF OPEN$RO$FILE (.X.FCBBLOCK) <> 0FFH THEN RETURN;
ELSE$DO
IF OPEN$FILE (.X.FCBBLOCK) <> 0FFH THEN RETURN;
END$IF;
CALL FILEABORT (.X, .OPENERRTEXT);
end open$input;
open$output: proc(ptr);
dcl ptr addr,
x based ptr file$o$structure;
if devicetype(x.disk)=disktype then$do
x.bufptr=0;
call disk$select(x.disk);
CALL delete$file(.x.fcbblock);
if create$file(.x.fcbblock) = 0ffh then
CALL FILEABORT (.X, .MAKEERRTEXT);
end$if;
end open$output;
outputclose: proc(ptr);
dcl ptr addr,
x based ptr file$o$structure;
if devicetype(x.disk)=disktype then$do
call outbyte(end$of$file,.x);
CALL FLUSHBUFFER (PTR);
IF CLOSE$FILE (.X.FCBBLOCK) = 0FFH THEN
CALL FILEABORT (.X, .CLOSEERRTEXT);
end$if;
end outputclose;
INPUT$CLOSE: PROCEDURE (PTR);
DECLARE PTR ADDRESS, X BASED PTR FILE$I$STRUCTURE;
CALL DISK$SELECT (X.DISK);
CALL SET$DMA$ADDRESS (.X.BUFFER);
IF CLOSE$FILE (.X.FCBBLOCK) THEN;
END INPUT$CLOSE;
outhexbyte: proc(ch) public;
dcl ch byte;
call outbyte(ch,.hex$file);
end outhexbyte;
outprintbyte: proc(ch) public;
dcl ch byte;
if printfile.disk=console then$do
call write$console(ch);
else$do
if error$printed then call write$console(ch);
call outbyte(ch,.printfile);
end$if;
end outprintbyte;
outsymbolbyte: proc(ch) public;
dcl ch byte;
call outbyte(ch,.symbolfile);
end outsymbolbyte;
insourcebyte: proc byte public;
return inbyte(.sourcefile);
end insourcebyte;
inincludebyte: proc byte public;
return inbyte(.includefile);
end inincludebyte;
opensource: proc public;
CALL open$input(.sourcefile);
end opensource;
openinclude: proc public;
CALL open$input(.includefile);
end openinclude;
openhex: proc public;
CALL open$output(.hexfile);
end openhex;
openprint: proc public;
CALL open$output(.printfile);
end openprint;
opensymbol: proc public;
CALL open$output(.symbolfile);
end opensymbol;
close$source: proc public;
call input$close (.source$file);
end close$source;
rewindsource: proc public;
sourcefile.fcbblock(nr)=0;
sourcefile.bufptr=length(sourcefile.buffer);
if sourcefile.fcbblock(ex) <> 0 then$do
sourcefile.fcbblock(ex)=0;
sourcefile.fcbblock(s2)=0;
CALL opensource;
end$if;
end rewindsource;
close$include: proc public;
call input$close (.include$file);
end close$include;
closehex: proc public;
call outputclose(.hexfile);
end closehex;
closeprint: proc public;
call outputclose(.printfile);
end closeprint;
closesymbol: proc public;
call outputclose(.symbolfile);
end closesymbol;
i$file$setup: proc(dev,filnam,filtyp) public;
dcl dev byte,(filnam,filtyp) addr;
call clearcontrol(.includefile,filtyp);
includefile.disk=dev;
call copy(8,filnam,.includefile.fcbblock(fn));
end i$file$setup;
filesetup: proc byte public;
dcl
ch byte, /* pick up character */
i byte, /* counter */
noleft byte, /* no of characters left in tbuff */
bpt byte, /* index of tbuff */
exitvalue byte, /* exitvalue of subroutine */
flag byte; /* program logic flag */
nextch: proc byte;
if noleft > 0 then$do
ch=tbuff(bpt);
noleft=noleft-1;
bpt=bpt+1;
else$do
ch=cr;
end$if;
return ch;
end nextch;
getdsk: procedure (p);
declare p address, dsk based p byte;
ch=upper(nextch); /* test selected disk drive */
if letter(ch) then$do
dsk=ch-'A';
if dsk > validdisk then
if dsk < console then
exitvalue = false; /* invalid drive */
else$do
exitvalue=false;
noleft=0;
end$if;
end getdsk;
exitvalue=true;
/* save current disk */
default$drive,diskunit=interrogate$disk;
/* enter user selected disk */
if fcb(dr) <> 0 then$do
call selectdisk(diskunit:=fcb(dr)-1);
end$if;
/* clear control blocks */
call clearcontrol(.sourcefile,.asmdefault);
call clearcontrol(.hexfile,.hexdefault);
call clearcontrol(.printfile,.lstdefault);
call clearcontrol(.symbolfile,.symdefault);
call copy(8,.fcb(fn),.sourcefile.fcbblock(fn));
call copy(8,.fcb(fn),.hexfile.fcbblock(fn));
call copy(8,.fcb(fn),.printfile.fcbblock(fn));
call copy(8,.fcb(fn),.symbolfile.fcbblock(fn));
if FCB (FT) <> SPACE then$do /* pick up specified source file type */
call copy(3,.fcb(ft),.sourcefile.fcbblock(ft));
end$if;
/* Move source file name to SOURCENAME */
CALL FILL (SPACE, LENGTH (SOURCENAME), .SOURCENAME);
i=0;
do while i<8 and (sourcename(i):=sourcefile.fcbblock(fn+i)) <> space;
i=i+1;
end$while;
sourcename(i)='.';
i=i+1;
call copy(3,.sourcefile.fcbblock(ft),.sourcename(i));
/* Test if file parameters */
noleft=tbuff(0);
bpt=1;
FLAG = FALSE;
IF FCB16 (1) <> SPACE THEN$DO
IF FCB16 (1) <> DOLLAR THEN$DO
EXITVALUE = FALSE;
ELSE$DO
DO WHILE (NOLEFT > 0) AND (NEXTCH <> DOLLAR);
END$WHILE;
FLAG = TRUE;
END$IF;
END$IF;
if flag then$do
/* file parameters present - pick them up */
do while noleft > 0;
if (ch:=upper(nextch)) <> space then$do
/* A-parameter */
IF CH = 'A' THEN call getdsk(.sourcefile.disk);
/* H-parameter */
ELSE IF CH = 'H' THEN call getdsk(.hexfile.disk);
/* P-parameter */
ELSE IF CH = 'P' THEN call getdsk(.printfile.disk);
/* S-parameter */
ELSE IF CH = 'S' THEN call getdsk(.symbolfile.disk);
/* F-parameter */
ELSE IF CH = 'F' THEN$DO
if (ch:=upper(nextch)) = 'I' then$do
intel$hex$on=true;
else$do
if ch= 'D' then$do
intel$hex$on=false;
else$do
exitvalue=false;
noleft=0;
endif;
endif;
END$IF;
/* error,no legal parameter */
ELSE
DO;
exitvalue=false;
noleft=0;
END$DO;
end$if;
end$while;
end$if;
printdevice=printfile.disk; /* set global printdevice flag */
SYMBOLDEVICE = SYMBOLFILE.DISK;
INCLUDE$DEFAULT = SOURCEFILE.DISK;
/* input must be from a disk file */
if devicetype(sourcefile.disk) <> disktype then$do
exitvalue=false;
end$if;
return exitvalue;
end filesetup;
end file;


168
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/GLOBAL.PLM Normal file
View File

@@ -0,0 +1,168 @@
$title ('GLOBAL VARIABLES')
global:
do;
/*
modified 3/28/81 R. Silberstein
modified 4/16/81 R. Silberstein
modified 4/20/81 R. Silberstein
modified 7/24/81 R. Silberstein
modified 9/2/81 R. Silberstein
*/
/*
This module defines all the global variables
of the assmembler.
*/
$include (:f1:macro.lit)
$include (:f1:struc.lit)
$INCLUDE (:F1:SUBR2.EXT)
dcl
/* dummy structure forces contiguous storage */
glob structure (
pass byte, /* current pass no, 1,2,3 */
/* address counters */
cip addr, /* current instruction pointer */
csegtype byte, /* current segment type, code,data,
stack or extra data */
csegvalue addr, /* current segment value */
csegspec byte, /* true if segment value specified */
escip addr, /* current ES instruction pointer */
cscip addr, /* current CS instruction pointer */
sscip addr, /* current SS instruction pointer */
dscip addr, /* current DS instruction pointer */
curcseg addr, /* current code segment value */
curdseg addr, /* current data segment value */
cursseg addr, /* current stack segment value */
cureseg addr, /* current extra segment value */
cspec byte, /* true if code segment value given */
dspec byte, /* true if data segment value given */
sspec byte, /* true if stack segment value given */
espec byte, /* true if extra segment value given */
/* print output parameters */
print$on byte, /* on/off flag */
printswitchoff byte, /* set/reset by NOLIST/LIST */
IFLIST BYTE, /* SET/RESET BY IFLIST/NOIFLIST */
maxcol byte); /* pagewidth */
dcl
sourcename (12) byte public, /* source file name */
sourcestop byte, /* used to contain zero */
savesource (12) byte public, /* source file during INLUDE file */
printdevice byte public, /* print file device */
SYMBOLDEVICE BYTE PUBLIC, /* SYMBOL FILE DEVICE */
title (30) byte public, /* user specified program title */
stoptitle byte, /* used to contain zero */
pagesize byte public, /* page size */
simform byte public, /* true if formfeed is to be simulated*/
sourcebuf (80) byte public, /* copy of source input to be printed*/
sourceptr byte public, /* source buffer pointer */
prefix (240) byte public, /* prefix to source line */
prefixptr byte public, /* pointer to prefix buffer */
ABSADDR (4) BYTE PUBLIC; /* ABSOLUTE ADDRESS FIELD */
/* references to glob structure */
dcl
pass byte public at(.glob.pass),
cip addr public at(.glob.cip),
csegtype byte public at(.glob.csegtype),
csegvalue addr public at(.glob.csegvalue),
csegspec byte public at(.glob.csegspec),
escip addr public at(.glob.escip),
cscip addr public at(.glob.cscip),
sscip addr public at(.glob.sscip),
dscip addr public at(.glob.dscip),
curcseg addr public at(.glob.curcseg),
curdseg addr public at(.glob.curdseg),
cursseg addr public at(.glob.cursseg),
cureseg addr public at(.glob.cureseg),
cspec byte public at(.glob.cspec),
dspec byte public at(.glob.dspec),
sspec byte public at(.glob.sspec),
espec byte public at(.glob.espec),
print$on byte public at(.glob.print$on),
printswitchoff byte public at(.glob.printswitchoff),
IFLIST BYTE PUBLIC AT (.GLOB.IFLIST),
maxcol byte public at(.glob.maxcol);
/* io error stpublic atus */
dcl
errors addr public, /* counts no of errors */
/* scanner variables: */
token struc( /* actual token scannes */
type byte, /* token type, legal values :
reg - register
pseudo - pseudo code
string - text string
spec - special character
number - number
operator - aritmetic operator
ident - identifier */
descr byte, /* token description, legal values :
nil - no specification
byte - 8 bit type
word - 16 bit type
dword - 32 bit type */
value addr) public, /* token value */
nextch byte public, /* next input character (lookahead) */
acclen byte public, /* accumulator length */
accum(80) byte public, /* actual token scanned */
accumsave(80) byte public, /* used to save accumulator */
acclensave byte public,
eofset byte public, /* true if end-of-file found */
/* Mischellaneous variables: */
intel$hex$on byte public, /* true if INTEL hex ouput format */
noerror byte public, /* errorflag in codemacro decoding */
errorprinted byte public, /* true if an error is printed */
firstmacroptr address public, /* pointer at first codemacro */
macroptr address public, /* current pointer within macros */
fullsymbtab byte public, /* true if symboltable is full */
include$on byte public, /* true if input from INCLUDE file */
IFLEVEL BYTE PUBLIC, /* IF-ENDIF NESTING LEVEL */
currentsymbol symbolstruc /* current scanned symbol */
public,
symbtabadr address public, /* pointer at symbol in table */
nooper byte public, /* no of instruction operands */
operands(4) operandstruc /* instruction operands,max 4 */
public,
codemacroptr address public, /* pointer to found codemacro */
help(5) byte public, /* scratch area for ascii numbers */
helpstop byte,
i byte public, /* scratch variable */
default$drive byte public, /* default disk drive */
include$default byte public, /* default disk for include files */
codemacro$flag byte public; /* true if building a codemacro */
globalinit: procedure public; /* initiate some global varaiables */
stoptitle,sourcestop,helpstop=0;
pagesize=66;
fullsymbtab,intel$hex$on=false;
CALL FILL (0, SIZE (TITLE), .TITLE);
codemacro$flag=false;
end globalinit;
end$module global;


162
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/INSTR.PLM Normal file
View File

@@ -0,0 +1,162 @@
$title ('INSTRUCTION MODULE')
instruc:
do;
/*
This is the module to decode and produce code-
output of a single instruction, possibly preceded
by a number of PREFIX-instructions.
*/
$include (:f1:macro.lit)
$include (:f1:struc.lit)
$include (:f1:cmacd.lit)
$include (:f1:equals.lit)
$include (:f1:ermod.lit)
$include (:f1:subr1.ext)
$include (:f1:expr.ext)
$include (:f1:symb.ext)
$include (:f1:scan.ext)
$include (:f1:ermod.ext)
$include (:f1:cmsubr.ext)
$include (:f1:instr.x86)
$eject
dcl /* global variables */
bytevar based macroptr byte, /* byte within codemacro */
comtab(12) byte data /* legal codemacro commands */
(mdbn,mdbf,mdwn,mdwf,mddf,mrelb,mrelw,mmodrm1,mmodrm2,msegfix,
mnosegfix,mdbit);
$eject
/* generate instruction output code */
makecode: proc byte;
if (noerror:=searchformatch) then$do
/* matching operands, comput code */
do while (bytevar <> mendm) and noerror;
do case commandtype(bytevar,length(comtab),.comtab);
call mDBNrout;
call mDBFrout;
call mDWNrout;
call mDWFrout; /* typed during earthquake */
call mDDFrout;
call mRELBrout;
call mRELWrout;
call mMODRM1rout;
call mMODRM2rout;
call mSEGFIXrout;
call mNOSEGFIXrout;
call mDBITrout;
do; end; /* dummy, should not happen */
end$case;
end$while;
end$if;
if noerror then call emit; else call emitdummies;
return noerror;
end makecode;
/* scan all PREFIX instructions */
prefixscan: proc byte;
/* compute address of first codemacro */
findmacroaddr: proc;
dcl macrop based codemacroptr address;
firstmacroptr=macrop;
end findmacroaddr;
/* test if instruction is of PREFIX type */
prefixinstr: proc byte;
dcl ptr address,flag based ptr byte;
ptr=firstmacroptr+2;
return ((flag and prefix$on) <> 0);
end prefixinstr;
call findmacroaddr; /* compute pointer to first macro */
do while prefixinstr;
if makecode then; /* generate output code,always succed */
call clearcmindex;
if findcodemacro(acclen,.accum(0),.codemacroptr) then$do
call scan;
call findmacroaddr;
else$do
call errmsg(missinstr); /* missing instruction */
call skip$rest$of$line;
return false;
end$if;
end$while;
return true;
end prefixscan;
/* get all instruction operands */
getoperands: proc byte;
dcl moreoperands byte,pt address,oper based pt operandstruc,
exitvalue byte;
exitvalue=true;
nooper=0; /* clear no of operands */
moreoperands=not emptyline;
do while moreoperands;
moreoperands=false;
pt=.operands(nooper);
if not operand then$do
if oper.stype <> udefsymb then call errmsg(illioper);
exitvalue=false;
if skip$until(',') then moreoperands=true;
else$do
if specialtoken(',') then$do
call scan; /* skip "," */
if nooper < 3 then moreoperands=true;
end$if;
end$if;
nooper=nooper+1;
end$while;
return exitvalue;
end getoperands;
/* test if operands contain enough type information */
enough$type$info: proc byte;
dcl pt address,oper based pt operandstruc,(i,flag) byte;
flag=true;
i=0ffh;
do while (i:=i+1) < nooper;
pt=.operands(i);
if oper.stype=variable then$do
if (oper.sflag and typebit) = 0 then flag=false;
end$if;
end$while;
if flag then return true;
i=0ffh; /* one of operands lacks type info,check others */
do while (i:=i+1) < nooper;
pt=.operands(i);
if (oper.sflag and typebit) <> 0 then return true;
if (oper.stype=number) and (wrdtest(oper.offset)) then return true;
end$while;
return false;
end enough$type$info;
/* Module entry point: */
instruction: proc public; /* decode line in pass 1 and pass 2 */
call clearcmindex; /* clear buffer for output codes */
if prefixscan then$do
if getoperands then$do
if enough$type$info then$do
if makecode then$do
if not emptyline then$do
call errmsg(end$of$line$err);
end$if;
else$do
call errmsg(opmismatch);
end$if;
else$do
call errmsg(misstypeinfo);
call emitdummies;
end$if;
else$do
if makecode then; /* try to make code with bad operands */
end$if;
end$if;
call skip$rest$of$line;
end instruction;
end$module instruc;


118
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/IO.PLM Normal file
View File

@@ -0,0 +1,118 @@
$title ('INTERFACE TO CP/M I/O')
io:
do;
/*
Template for all BDOS calls
*/
/*
modified 3/26/81 R. Silberstein
modified 6/16/81 R. Silberstein
modified 9/14/81 R. Silberstein
*/
declare tbuff (80h) byte external;
mon1: procedure (func,info) external;
declare func byte;
declare info address;
end mon1;
mon2: procedure (func,info) byte external;
declare func byte;
declare info address;
end mon2;
/**************************************
* *
* B D O S Externals *
* *
**************************************/
system$reset: procedure public;
call mon1 (0,0);
end system$reset;
read$console: procedure byte public;
return mon2 (1,0);
end read$console;
write$console: procedure (char) public;
declare char byte;
call mon1 (2,char);
end write$console;
write$list: procedure (char) public;
declare char byte;
call mon1 (5,char);
end write$list;
constat: procedure byte public;
return mon2 (11,0);
end constat;
VERSION: PROCEDURE ADDRESS PUBLIC;
RETURN MON2 (12, 0);
END VERSION;
select$disk: procedure (disk$number) public;
declare disk$number byte;
call mon1 (14,disk$number);
end select$disk;
set$DMA$address: procedure (DMA$address) public;
declare DMA$address address;
call mon1 (26,DMA$address);
end set$DMA$address;
open$file: procedure (fcb$address) byte public;
declare fcb$address address;
CALL SET$DMA$ADDRESS (.TBUFF); /* FOR 1.4 SYSTEMS */
return mon2 (15,fcb$address);
end open$file;
OPEN$RO$FILE: PROCEDURE (FCB$ADDRESS) BYTE PUBLIC;
DECLARE FCB$ADDRESS ADDRESS, FCB BASED FCB$ADDRESS (32) BYTE;
FCB (6) = FCB (6) OR 80H;
RETURN OPEN$FILE (FCB$ADDRESS);
END OPEN$RO$FILE;
close$file: procedure (fcb$address) byte public;
declare fcb$address address;
return mon2 (16,fcb$address);
end close$file;
delete$file: procedure (fcb$address) public;
declare fcb$address address;
CALL mon1 (19,fcb$address);
end delete$file;
read$record: procedure (fcb$address) byte public;
declare fcb$address address;
return mon2 (20,fcb$address);
end read$record;
write$record: procedure (fcb$address) byte public;
declare fcb$address address;
return mon2 (21,fcb$address);
end write$record;
create$file: procedure (fcb$address) byte public;
declare fcb$address address;
return mon2 (22,fcb$address);
end create$file;
interrogate$disk: procedure byte public;
return mon2 (25,0);
end interrogate$disk;
crlf: procedure public;
call write$console (0dh);
call write$console (0ah);
end crlf;
end io;


186
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/MAINP.PLM Normal file
View File

@@ -0,0 +1,186 @@
$title ('ASM86 MAIN PROGRAM')
mainp:
do;
/*
This is the main program of the CP/M 8086
assembler. This module activates the i/o
modules and goes through the source text
in 3 passes. The module then for each source
line calls the external subroutine DECODELINE
to perform assembly of each line;
*/
/*
modified 3/25/81 R. Silberstein
modified 3/28/81 R. Silberstein
modified 3/30/81 R. Silberstein
modified 4/7/81 R. Silberstein
modified 4/20/81 R. Silberstein
modified 6/16/81 R. Silberstein
modified 7/24/81 R. Silberstein
modified 7/27/81 R. Silberstein
modified 8/21/81 R. Silberstein
*/
$include (:f1:macro.lit)
$include (:f1:struc.lit)
$include (:f1:equals.lit)
$include (:f1:dev.lit)
$include (:f1:ermod.lit)
$include (:f1:subr2.ext)
$include (:f1:io.ext)
$include (:f1:files.ext)
$include (:f1:outp.ext)
$include (:f1:scan.ext)
$include (:f1:print.ext)
$include (:f1:symb.ext)
$include (:f1:ermod.ext)
$include (:f1:mglob.ext)
$include (:f1:text.ext)
$include (:f1:dline.ext)
DECLARE ASM86 LABEL PUBLIC;
closefiles: procedure;
call close$source;
call close$print;
call close$symbol;
call close$hex;
end closefiles;
open$output$files: procedure;
CALL OPENPRINT;
CALL OPENHEX;
CALL OPENSYMBOL;
end open$output$files;
userbreak: proc byte; /* test if keyboard break from user */
if not constat then return false; /* test console status */
if readconsole then; /* skip first break key */
do forever;
call outtext(.usbreaktext); /* USER BREAK. OK (Y/N)? */
i=upper(readconsole);
call crlf;
if i = yes then return true;
if i = no then return false;
end$forever;
end userbreak;
varinit: proc;
CALL FILL (0, .PRINT$ON-.CIP, .CIP);
errors=0;
printswitchoff,includeon=false;
IFLEVEL = 0;
IFLIST = TRUE;
csegtype=rcs;
end varinit;
pass0init: proc; /* initialize pass 0 */
simform=false;
maxcol=119;
if printdevice=console then maxcol=79;
call symbinit; /* initialize symbol table */
print$on=false;
call varinit;
end pass0init;
pass1init: proc; /* initialize for pass 1 */
call varinit;
end pass1init;
pass2init: proc; /* initialize for pass 2 (last pass) */
print$on=true;
call varinit;
call emitinit;
end pass2init;
pass0terminate: proc; /* terminate pass 0 */
call outtext(.pass0text); /* End of pass 0 */
end pass0terminate;
pass1terminate: proc; /* terminate pass 1 */
print$on=false; /* dummy */
call outtext(.pass1text); /* End of pass 1 */
end pass1terminate;
pass2terminate: proc; /* terminate pass 2 (last pass) */
DECLARE USEFACT BYTE;
USEFACT = (FREEPT-.MEMORY) / ((ENDOFSYMBTAB-.MEMORY) / 100 + 1);
errorprinted=false;
call emitterminate; /* terminate hex output module */
call symbterminate; /* print symbols */
if printdevice <> console then call printterminate (USEFACT);
CALL CLOSEFILES;
call outtext(.endtext); /* END OF ASSEMBLY... */
call decout(errors,.help(0)); /* print no of errors */
call outtext(.help(2));
CALL OUTTEXT (.USEFACTOR);
CALL DECOUT (USEFACT, .HELP(0));
CALL OUTTEXT (.HELP(3));
CALL WRITECONSOLE (25H); /* % */
CALL CRLF;
end pass2terminate;
include$close: proc (flag);
declare flag byte;
if eofset and include$on then$do
call close$include;
include$on,eofset=false;
if flag then$do
call scan; /* skip EOF */
call scan; /* prepare for next source line */
end$if;
end$if;
end include$close;
ASM86:
call globalinit; /* initialize some globals */
call outtext(.asm86text); /* CP/M 8086 ASSEMBLER.... */
if not filesetup then$do
call outtext(.parerrtext); /* PARAMETER ERROR */
CALL SYSTEMRESET;
end$if;
CALL OPENSOURCE;
CALL OPENOUTPUTFILES;
pass=0ffh;
do while (pass:=pass+1) < 3;
do case pass;
call pass0init; /* pass 0 */
call pass1init; /* pass 1 */
call pass2init; /* pass 2 */
end$case;
call scaninit;
call scan;
do while not eofset;
if userbreak then$do
eofset=true;
pass=3;
else$do
errorprinted=false;
call decodeline;
call includeclose(false); /* close include file if necessary */
call scan;
call includeclose(true); /* close include file if necessary */
end$if;
end$while;
do case pass;
call pass0terminate; /* pass 0 */
call pass1terminate; /* pass 1 */
call pass2terminate; /* pass 2 */
do; end; /* do nothing if userbreak */
end$case;
end$while;
call system$reset;
end$module mainp;


65
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/MNEM1.PLM Normal file
View File

@@ -0,0 +1,65 @@
$title ('INSTRUCTION MNEMONICS MODULE - PART 1')
mnem1:
do;
/*
modified 4/10/81 R. Silberstein
modified 6/16/81 R. Silberstein
*/
/***************** INSTRUCTION MNEMONICS *****************/
/*
This is all the instruction mnemonics for
the assembler. The mnemonics are grouped
according to the 6-bit hash value of the
mnemonics - values range from 0 to 0FH.
For each instruction, there is a pointer to
its codemacro definition.
*/
$include (:f1:mnem.lit)
$include (:f1:cmlink.ext)
/********* MNEMONICS TABLE ********/
declare
/*
* HASH VALUE (HEX) *
---------------------
*/
test opcod4 data (0,4,.test10,'TEST'), /* 0 */
push opcod4 public data (.test,4,.push3,'PUSH'),
SCASW OPCOD5 DATA (0,5,.SCASW1,'SCASW'), /* 1 */
repz opcod4 public data (.SCASW,4,.repe1,'REPZ'),
/* 2 */
aaa opcod3 public data (0,3,.aaa1,'AAA'), /* 3 */
/* 4 */
movs opcod4 public data (0,4,.movs2,'MOVS'), /* 5 */
daa opcod3 data (0,3,.daa1,'DAA'), /* 6 */
aad opcod3 data (.daa,3,.aad1,'AAD'),
pushf opcod5 public data (.aad,5,.pushf1,'PUSHF'),
MOVSB OPCOD5 PUBLIC DATA (0,5,.MOVSB1,'MOVSB'), /* 7 */
adc opcod3 public data (0,3,.adc11,'ADC'), /* 8 */
stos opcod4 data (0,4,.stos2,'STOS'), /* 9 */
LODSW OPCOD5 DATA (.STOS,5,.LODSW1,'LODSW'),
add opcod3 public data (.LODSW,3,.add11,'ADD'),
CMPSW OPCOD5 PUBLIC DATA (0,5,.CMPSW1,'CMPSW'), /* 0a */
STOSB OPCOD5 DATA (0,5,.STOSB1,'STOSB'), /* 0b */
ja opcod2 public data (.STOSB,2,.ja1,'JA'),
jb opcod2 data (0,2,.jb1,'JB'), /* 0c */
dec opcod3 public data (.jb,3,.dec3,'DEC'),
JC OPCOD2 DATA (0,2,.JB1,'JC'), /* 0D */
loopne opcod6 public data (.JC,6,.loopne1,'LOOPNE'),
/* 0e */
aam opcod3 data (0,3,.aam1,'AAM'), /* 0f */
je opcod2 data (.aam,2,.je1,'JE'),
repnz opcod5 public data (.je,5,.repne1,'REPNZ');
end mnem1;


74
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/MNEM2.PLM Normal file
View File

@@ -0,0 +1,74 @@
$title ('INSTRUCTION MNEMONICS MODULE - PART 2')
mnem2:
do;
/*
modified 4/10/81 R. Silberstein
modified 6/16/81 R. Silberstein
modified 7/24/81 R. Silberstein
*/
/***************** INSTRUCTION MNEMONICS *****************/
/*
This is all the instruction mnemonics for
the assembler. The mnemonics are grouped
according to the 6-bit hash value of the
mnemonics - values range from 10H to 1FH.
For each instruction, there is a pointer to
its codemacro definition.
*/
$include (:f1:mnem.lit)
$include (:f1:cmlink.ext)
/********* MNEMONICS TABLE ********/
declare
/*
* HASH VALUE (HEX) *
---------------------
*/
jae opcod3 public data (0,3,.jae1,'JAE'), /* 10 */
jbe opcod3 data (0,3,.jbe1,'JBE'), /* 11 */
jg opcod2 public data (.jbe,2,.jg1,'JG'),
lea opcod3 data (0,3,.lea1,'LEA'), /* 12 */
clc opcod3 public data (.lea,3,.clc1,'CLC'),
cmc opcod3 data (0,3,.cmc1,'CMC'), /* 13 */
cld opcod3 data (.cmc,3,.cld1,'CLD'),
iand opcod3 public data (.cld,3,.and10,'AND'),
loopz opcod5 public data (0,5,.loope1,'LOOPZ'), /* 14 */
aas opcod3 public data (0,3,.aas1,'AAS'), /* 15 */
jge opcod3 data (0,3,.jge1,'JGE'), /* 16 */
jl opcod2 public data (.jge,2,.jl1,'JL'),
sbb opcod3 data (0,3,.sbb11,'SBB'), /* 17 */
in opcod2 public data (.sbb,2,.in4,'IN'),
das opcod3 data (0,3,.das1,'DAS'), /* 18 */
cli opcod3 public data (.das,3,.cli1,'CLI'),
jna opcod3 data (0,3,.jbe1,'JNA'), /* 19 */
jo opcod2 public data (.jna,2,.jo1,'JO'),
jnb opcod3 data (0,3,.jae1,'JNB'), /* 1a */
jp opcod2 data (.jnb,2,.jp1,'JP'),
neg opcod3 data (.jp,3,.neg2,'NEG'),
inc opcod3 public data (.neg,3,.inc3,'INC'),
JNC OPCOD3 DATA (0,3,.JAE1,'JNC'), /* 1B */
esc opcod3 data (.JNC,3,.esc3,'ESC'),
jle opcod3 data (.esc,3,.jle1,'JLE'),
lahf opcod4 public data (.jle,4,.lahf1,'LAHF'),
cbw opcod3 data (0,3,.cbw1,'CBW'), /* 1c */
MOVSW OPCOD5 DATA (.CBW,5,.MOVSW1,'MOVSW'),
icall opcod4 public data (.MOVSW,4,.call3,'CALL'),
js opcod2 data (0,2,.js1,'JS'), /* 1d */
jne opcod3 public data (.js,3,.jne1,'JNE'),
jnae opcod4 data (0,4,.jb1,'JNAE'), /* 1e */
cwd opcod3 public data (.jnae,3,.cwd1,'CWD'),
jpe opcod3 data (0,3,.jp1,'JPE'), /* 1f */
jng opcod3 data (.jpe,3,.jle1,'JNG'),
jnbe opcod4 public data (.jng,4,.ja1,'JNBE');
end mnem2;


79
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/MNEM3.PLM Normal file
View File

@@ -0,0 +1,79 @@
$title ('INSTRUCTION MNEMONICS MODULE - PART 3')
mnem3:
do;
/*
modified 6/16/81 R. Silberstein
*/
/***************** INSTRUCTION MNEMONICS *****************/
/*
This is all the instruction mnemonics for
the assembler. The mnemonics are grouped
according to the 6-bit hash value of the
mnemonics - values range from 20H to 2FH.
For each instruction, there is a pointer to
its codemacro definition.
*/
$include (:f1:mnem.lit)
$include (:f1:cmlink.ext)
/********* MNEMONICS TABLE ********/
declare
/*
* HASH VALUE (HEX) *
---------------------
*/
isal opcod3 data (0,3,.sal4,'SAL'), /* 20 */
STOSW OPCOD5 DATA (.ISAL,5,.STOSW1,'STOSW'),
cmp opcod3 public data (.STOSW,3,.cmp11,'CMP'),
rcl opcod3 data (0,3,.rcl4,'RCL'), /* 21 */
ior opcod2 public data (.rcl,2,.or10,'OR'),
loopnz opcod6 data (0,6,.loopne1,'LOOPNZ'), /* 22 */
sahf opcod4 data (.loopnz,4,.sahf1,'SAHF'),
callf opcod5 public data (.sahf,5,.callf2,'CALLF'),
lds opcod3 data (0,3,.lds1,'LDS'), /* 23 */
div opcod3 public data (.lds,3,.div2,'DIV'),
jnge opcod4 data (0,4,.jl1,'JNGE'), /* 24 */
jnl opcod3 data (.jnge,3,.jge1,'JNL'),
jz opcod2 data (.jnl,2,.je1,'JZ'),
les opcod3 public data (.jz,3,.les1,'LES'),
/* 25 */
sar opcod3 public data (0,3,.sar4,'SAR'), /* 26 */
jno opcod3 data (0,3,.jno1,'JNO'), /* 27 */
rcr opcod3 data (.jno,3,.rcr4,'RCR'),
rep opcod3 data (.rcr,3,.rep1,'REP'),
ishl opcod3 data (.rep,3,.sal4,'SHL'),
jmp opcod3 public data (.ishl,3,.jmp2,'JMP'),
jnp opcod3 data (0,3,.jnp1,'JNP'), /* 28 */
hlt opcod3 public data (.jnp,3,.hlt1,'HLT'),
jnle opcod4 data (0,4,.jg1,'JNLE'), /* 29 */
jpo opcod3 data (.jnle,3,.jnp1,'JPO'),
lock opcod4 public data (.jpo,4,.lock1,'LOCK'),
scas opcod4 data (0,4,.scas2,'SCAS'), /* 2a */
stc opcod3 data (.scas,3,.stc1,'STC'),
sub opcod3 data (.stc,3,.sub11,'SUB'),
xchg opcod4 public data (.sub,4,.xchg6,'XCHG'),
jns opcod3 data (0,3,.jns1,'JNS'), /* 2b */
std opcod3 data (.jns,3,.std1,'STD'),
int opcod3 data (.std,3,.int2,'INT'),
ret opcod3 public data (.int,3,.ret3,'RET'),
repe opcod4 data (0,4,.repe1,'REPE'), /* 2c */
SCASB OPCOD5 DATA (.REPE,5,.SCASB1,'SCASB'),
idiv opcod4 public data (.SCASB,4,.idiv2,'IDIV'),
nop opcod3 data (0,3,.nop1,'NOP'), /* 2d */
rol opcod3 data (.nop,3,.rol4,'ROL'),
ishr opcod3 data (.rol,3,.shr4,'SHR'),
jmpf opcod4 public data (.ishr,4,.jmpf2,'JMPF'),
mul opcod3 public data (0,3,.mul2,'MUL'), /* 2e */
pop opcod3 public data (0,3,.pop4,'POP'); /* 2f */
end mnem3;


67
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/MNEM4.PLM Normal file
View File

@@ -0,0 +1,67 @@
$title ('INSTRUCTION MNEMONICS MODULE - PART 4')
mnem4:
do;
/*
modified 6/16/81 R. Silberstein
*/
/***************** INSTRUCTION MNEMONICS *****************/
/*
This is all the instruction mnemonics for
the assembler. The mnemonics are grouped
according to the 6-bit hash value of the
mnemonics - values range from 30H to 3FH.
For each instruction, there is a pointer to
its codemacro definition.
*/
$include (:f1:mnem.lit)
$include (:f1:cmlink.ext)
/********* MNEMONICS TABLE ********/
declare
/*
* HASH VALUE (HEX) *
---------------------
*/
sti opcod3 public data (0,3,.sti1,'STI'), /* 30 */
retf opcod4 data (0,4,.retf3,'RETF'), /* 31 */
inot opcod3 public data (.retf,3,.not2,'NOT'),
lods opcod4 data (0,4,.lods2,'LODS'), /* 32 */
jnz opcod3 data (.lods,3,.jne1,'JNZ'),
mov opcod3 public data (.jnz,3,.mov17,'MOV'),
ror opcod3 data (0,3,.ror4,'ROR'), /* 33 */
cmps opcod4 public data (.ror,4,.cmps2,'CMPS'),
LODSB OPCOD5 DATA (0,5,.LODSB1,'LODSB'), /* 34 */
iret opcod4 public data (.lodsb,4,.iret1,'IRET'),
wait opcod4 data (0,4,.wait1,'WAIT'), /* 35 */
CMPSB OPCOD5 DATA (.WAIT,5,.CMPSB1,'CMPSB'),
popf opcod4 public data (.CMPSB,4,.popf1,'POPF'),
/* 36 */
imul opcod4 public data (0,4,.imul2,'IMUL'), /* 37 */
out opcod3 public data (0,3,.out4,'OUT'), /* 38 */
retn opcod4 data (0,4,.ret3,'RETN'), /* 39 */
ixor opcod3 data (.retn,3,.xor10,'XOR'),
xlat opcod4 public data (.ixor,4,.xlat1,'XLAT'),
repne opcod5 data (0,5,.repne1,'REPNE'), /* 3a */
into opcod4 data (.repne,4,.into1,'INTO'),
loop opcod4 data (.into,4,.loop1,'LOOP'),
jmps opcod4 public data (.loop,4,.jmps1,'JMPS'),
/* 3b */
/* 3c */
/* 3d */
/* 3e */
jcxz opcod4 data (0,4,.jcxz1,'JCXZ'), /* 3f */
loope opcod5 public data (.jcxz,5,.loope1,'LOOPE');
/**************** END OF MNEMONIC TABLE ****************/
end mnem4;


227
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/OUTP.PLM Normal file
View File

@@ -0,0 +1,227 @@
$title ('HEX OUTPUT MODULE')
hexout:
do;
/*
modified 3/28/81 R. Silberstein
modified 3/30/81 R. Silberstein
modified 4/9/81 R. Silberstein
*/
/*
This is the module to produce the (hex-)output
from the assembler. The interface to other modules
goes through the subroutine
EMITCODEBYTE (outputbyte,segmenttype).
This routine outputs one byte of generated code of
a specified segment type (code,data,stack,extra).
The subroutine also updates the value of the current
instruction pointer of the current segment (CIP),
and prints the output code on the print line.
*/
$include (:f1:macro.lit)
$include (:f1:struc.lit)
$include (:f1:outp.lit)
$include (:f1:subr2.ext)
$include (:f1:files.ext)
$include (:f1:global.ext)
dcl
empty lit '0ffh', /* buffer empty value */
recordlimit lit '30', /* max no of bytes pr record */
loccip addr, /* local copy of instruction pointer */
startfound byte, /* true if start record sent */
gtyp byte, /* incomming byte type */
gbyt byte, /* incomming byte */
curtyp byte, /* current byte type */
sum byte, /* used to compute check sum */
buffer (35) byte, /* record buffer (RECORDLIMIT+5) */
recordlg byte at (.buffer(0)),
recordtype byte at (.buffer(3)),
offsetaddr addr at (.buffer(1)),
bufpt byte, /* buffer index */
/* Record type conversion table */
/* ( to be changed later ??? ) */
rectyp$I$tab(12) byte data
(0ffh,eoftype,0ffh,starttype,INTELdata,INTELdata,
INTELdata,INTELdata,INTELsegment,INTELsegment,INTELsegment,
INTELsegment),
rectyp$D$tab(12) byte data
(0ffh,eoftype,0ffh,starttype,DRcodedata,DRdatadata,
DRstackdata,DRextradata,DRcodesegm,DRdatasegm,DRstacksegm,
DRextrasegm);
/*********** subroutines **********/
rectyptab: procedure(n) byte;
declare n byte;
if intel$hex$on then$do
return rectyp$I$tab(n);
else$do
return rectyp$D$tab(n);
end$if;
end rectyptab;
switch$high$low: procedure(p);
declare p address, ch based p byte, (s1,s2) byte;
s1=ch;
p=p+1;
s2=ch;
ch=s1;
p=p-1;
ch=s2;
end switch$high$low;
writebyt: proc (ch);
dcl ch byte;
call outhexbyte(ch);
end writebyt;
writerecord: proc; /* write current recor to file */
call switch$high$low(.offsetaddr);
recordlg=bufpt-4;
sum=0; /* compute check sum */
i=0ffh;
do while (i:=i+1) < bufpt;
sum=sum+buffer(i);
end$while;
buffer(bufpt)=-sum; /* check sum */
call writebyt(':');
do i=0 to bufpt; /* print hexbytes to file */
call hex1out(buffer(i),.help(0));
call writebyt(help(0));
call writebyt(help(1));
end$do;
call writebyt(cr);
call writebyt(lf);
end writerecord;
enternewbyt: proc(b); /* enter a new byte into buffer */
dcl b byte;
if bufpt > recordlimit then$do /* test if record full */
call writerecord;
offsetaddr=cip;
bufpt=4;
end$if;
buffer(bufpt)=b;
bufpt=bufpt+1;
end enternewbyt;
enterinput: proc;
call enternewbyt(gbyt);
end enterinput;
eofrecord: proc; /* write end-of-file record to file */
if curtyp<>empty then call writerecord;
recordtype=rectyptab(eoftype);
offsetaddr=0;
bufpt=4;
call writerecord;
end eofrecord;
startrecord: proc; /* write a start record to file */
dcl seglow byte at (.csegvalue),seghigh byte at (.csegvalue+1),
offslow byte at (.cip),offshigh byte at (.cip+1);
if pass=2 then$do
startfound=true;
if curtyp <> empty then call writerecord;
bufpt=4;
offsetaddr=0;
recordtype=rectyptab(starttype);
if csegspec then$do
call enternewbyt(seghigh);
call enternewbyt(seglow);
else$do
call enternewbyt(0);
call enternewbyt(0);
end$if;
call enternewbyt(offshigh);
call enternewbyt(offslow);
call writerecord;
curtyp=empty;
end$if;
end startrecord;
segmbyte: proc; /* write a segment value byte to file */
if pass = 2 then$do
if curtyp <> gtyp then$do
if curtyp <> empty then call writerecord;
curtyp=gtyp;
recordtype=rectyptab(gtyp);
offsetaddr=0;
bufpt=4;
call enterinput;
else$do
call enterinput;
call writerecord;
curtyp=empty;
end$if;
end$if;
end segmbyte;
databyte: proc; /* write a data byte to file */
if pass=2 then$do
if (curtyp <> gtyp) or (loccip <> cip) then$do
if curtyp<>empty then call writerecord;
curtyp=gtyp;
recordtype=rectyptab(gtyp);
offsetaddr=cip;
bufpt=4;
end$if;
call enterinput;
call hex1out(gbyt,.prefix(prefixptr)); /* output to listing */
prefixptr=prefixptr+2;
end$if;
cip=cip+1; /* update instruction pointer */
loccip=cip;
end databyte;
emitinit: proc public;
startfound=false;
curtyp=empty;
end emitinit;
emitterminate: proc public;
call eofrecord; /* write EOF record */
end emitterminate;
emitcodebyte: proc (b,typ) public;
dcl (b,typ) byte;
gbyt=b; /* move to global variables */
gtyp=typ;
do case typ-CSdata;
do; /* CS data */
if not startfound then$do
call startrecord;
end$if;
call databyte;
end;
call databyte; /* DS data */
call databyte; /* SS data */
call databyte; /* ES data */
call segmbyte; /* CS value */
call segmbyte; /* DS value */
call segmbyte; /* SS value */
call segmbyte; /* ES value */
end$case;
end emitcodebyte;
end$module hexout;


298
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/PREDEF.PLM Normal file
View File

@@ -0,0 +1,298 @@
$title ('Predefined symbols')
predef:
do;
/*
modified 7/24/81 R. Silberstein
*/
/************** Module for predefined symbols ************/
/*
This module contains the tables and subroutines
for the PREDEFINED symbols of the ASM86 assembler.
The subroutine
PFIND (nochar,stringaddr,attributeaddr) byte
defines the interface to the other modules.
The routine tests if a given symbol is a predefined
symbol. If so the address of the symbol attributes
is returned.
The format of the symbol attributes is :
byte
**********************
0 * symbol type *
**********************
1 * symbol description *
**********************
2 * *
3 * symbol value *
**********************
/* Include language macros */
/* and general assembler */
/* definitions (literals). */
$include(:f1:macro.lit)
$include(:f1:equals.lit)
/* Predefined numbers: */
dcl
nbyte lit '1',
nword lit '2',
ndword lit '4';
$eject
/*
Here are the predefined symbols of
the assembler.
The symbols are grouped according to
the symbol lenghts. Moreover, each group
is sorted alphabeticly so that binary
search algorithm could be used.
*/
dcl
tok0(*) byte data(0), /* symbollength > 1 only */
tok1(*) byte data(0),
tok2(*) byte data(34,'AHALAXBHBLBPBXCHCLCSCXDBDDDHDIDL',
'DSDWDXEQESGEGTIFLELTNEORRBRSRWSISPSS'),
tok3(*) byte data(11,'ANDENDEQUMODNOTORGPTRSEGSHLSHRXOR'),
tok4(*) byte data(13,'BYTECSEGDBITDSEGENDMESEGLASTLISTRELBRELW',
'SSEGTYPEWORD'),
tok5(*) byte data(6,'DWORDEJECTENDIFMODRMSHORTTITLE'),
tok6(*) byte data(5,'IFLISTLENGTHNOLISTOFFSETSEGFIX'),
tok7(*) byte data(2,'INCLUDESIMFORM'),
tok8(*) byte data(3,'NOIFLISTNOSEGFIXPAGESIZE'),
tok9(*) byte data(2,'CODEMACROPAGEWIDTH');
/* Pointer table: */
dcl
tokpointer(*) address data(.tok0,.tok1,.tok2,.tok3,.tok4,
.tok5,.tok6,.tok7,.tok8,.tok9);
$eject
/*
This is the attribute table for
the predefined symbols.
*/
dcl
value0 byte,
value1 byte,
value2(34) struc (type byte,descr byte,value addr) data(
reg,byt,rah, reg,byt,ral, /* registers AH and AL */
reg,wrd,rax, reg,byt,rbh, /* registers AX and BH */
reg,byt,rbl, reg,wrd,rbp, /* registers BL and BP */
reg,wrd,rbx, reg,byt,rch, /* registers BX and CH */
reg,byt,rcl, reg,dwrd,rcs, /* registers CL and CS */
reg,wrd,rcx, /* register CX */
pseudo,nil,pdb, pseudo,nil,pdd, /* pseudos DB and DD */
reg,byt,rdh, reg,wrd,rdi, /* registers DH and DI */
reg,byt,rdl, reg,dwrd,rds, /* registers DL and DS */
pseudo,nil,pdw, /* pseudo DW */
reg,wrd,rdx, /* register DX */
operator,nil,oeq, /* operator EQ */
reg,dwrd,res, /* register ES */
operator,nil,oge, /* operator GE */
operator,nil,ogt, /* operator GT */
pseudo,nil,pif, /* pseudo IF */
operator,nil,ole, /* operator LE */
operator,nil,olt, /* operator LT */
operator,nil,one, /* operator NE */
operator,nil,oor, /* operator OR */
pseudo,nil,prb, /* pseudo RB */
pseudo,nil,prs, /* pseudo RS */
pseudo,nil,prw, /* pseudo RW */
reg,wrd,rsi, reg,wrd,rsp, /* registers SI and SP */
reg,dwrd,rss), /* register SS */
value3(11) struc (type byte,descr byte,value addr) data(
operator,nil,oand, /* operator AND */
pseudo,nil,pend,pseudo,nil,pequ,/* pseudos END and EQU */
operator,nil,omod, /* operator MOD */
operator,nil,onot, /* operator NOT */
pseudo,nil,porg, /* pseudo ORG */
operator,nil,optr, /* operator PTR */
operator,nil,oseg, /* operator SEG */
operator,nil,oshl, /* operator SHL */
operator,nil,oshr, /* operator SHR */
operator,nil,oxor), /* operator XOR */
value4(13) struc (type byte,descr byte,value addr) data(
number,byt,nbyte, /* 8 bit number BYTE (1) */
pseudo,nil,pcseg, /* pseudo CSEG */
pseudo,nil,pdbit, /* pseudo DBIT */
pseudo,nil,pdseg, /* pseudo DSEG */
pseudo,nil,pendm, /* pseudo ENDM */
pseudo,nil,peseg, /* pseudo ESEG */
operator,nil,olast, /* operator LAST */
pseudo,nil,plist, /* pseudo LIST */
pseudo,nil,prelb, /* pseudo RELB */
pseudo,nil,prelw, /* pseudo RELW */
pseudo,nil,psseg, /* pseudo SSEG */
operator,nil,otype, /* operator TYPE */
number,wrd,nword), /* 16 bit number WORD (2) */
value5(6) struc (type byte,descr byte,value addr) data(
number,dwrd,ndword, /* 32 bit number DWORD (4) */
pseudo,nil,peject, /* pseudo EJECT */
pseudo,nil,pendif, /* pseudo ENDIF */
pseudo,nil,pmodrm, /* pseudo MODRM */
operator,nil,oshort, /* operator SHORT */
pseudo,nil,ptitle), /* pseudo TITLE */
value6(5) struc (type byte,descr byte,value addr) data(
PSEUDO,NIL,PIFLIST, /* PSEUDO IFLIST */
operator,nil,olength, /* operator LENGTH */
pseudo,nil,pnolist, /* pseudo NOLIST */
operator,nil,ooffset, /* operator OFFSET */
pseudo,nil,psegfix), /* pseudo SEGFIX */
value7(2) struc (type byte,descr byte,value addr) data(
pseudo,nil,pinclude, /* pseudo INCLUDE */
pseudo,nil,psimform), /* pseudo SIMFORM */
value8(3) struc (type byte,descr byte,value addr) data(
PSEUDO,NIL,PNOIFLIST, /* PSEUDO NOIFLIST */
pseudo,nil,pnosegfix, /* pseudo NOSEGFIX */
pseudo,nil,ppagesize), /* pseudo PAGESIZE */
value9(2) struc (type byte,descr byte,value addr) data(
pseudo,nil,pcodemacro, /* pseudo CODEMACRO */
pseudo,nil,ppagewidth); /* pseudo PAGEWIDTH */
/* Pointer table: */
dcl
valuepointer(*) address data(.value0,.value1,.value2,.value3,.value4,
.value5,.value6,.value7,.value8,.value9);
$eject
/* Global variables and subroutines */
dcl
nochar byte,
stringaddr address,
attributeaddr address,
source based stringaddr (1) byte,
dest based attributeaddr (1)byte,
value address, /* pointer to attributes */
valuebyte based value (1) byte,
tok address, /* pointer to table strings */
tokenbyte based tok byte,
t$lookahead address, /* table string pointer */
look based t$lookahead (1) byte,
v$lookahead address, /* attribute table pointer */
noleft byte, /* no of tablestrings left */
half byte, /* noleft/2 */
i byte, /* counter */
attribute$length lit '4', /* no of bytes pr attribute */
equal lit '0', /* results of stringcompares */
greater lit '1',
less lit '2';
/* Routine to compare tablestring with given symbolstring */
compare: proc byte;
i=0ffh;
do while (i:=i+1) < nochar;
if source(i) > look(i) then
return greater;
if source(i) < look(i) then
return less;
end$while;
return equal;
end compare;
/* Recursive routine to perform binary tablesearch */
binsearch: proc byte reent;
if noleft = 0 then$do
return false;
else$do
half=noleft/2;
t$lookahead=tok+half*nochar;
v$lookahead=value+half*attributelength;
do case compare;
/* equal */
do;
value=v$lookahead; /* match found,pick up attributes */
do i=0 to attributelength-1;
dest(i)=valuebyte(i);
end$do;
return true;
end;
/* greater */
do;
tok=t$lookahead+nochar; /* test last half of table */
value=v$lookahead+attributelength;
noleft=noleft-half-1;
return binsearch;
end;
/* less */
do;
noleft=half; /* test first half of table */
return binsearch;
end;
end$case;
end$if;
end binsearch;
/*
Interface routine PFIND :
********** pfind (nochar,stringaddr,attibuteaddr) byte *********
Routine to test if a given symbol is a predefined
symbol.
entry: nochar = no of character in symbol
stringaddr = address of symbol string
attributeaddr = address to put the symbol-
attributes (if found)
exit: The routine returs TRUE if symbol found,
otherwise FALSE.
*/
pfind: proc (n,s,a) byte public;
dcl
n byte,
(s,a) address;
nochar=n; /* pick up parameters */
stringaddr=s;
attributeaddr=a;
if nochar < 10 then$do
value=valuepointer(nochar);
tok=tokpointer(nochar);
noleft=tokenbyte;
tok=tok+1;
return binsearch;
else$do
return false;
end$if;
end pfind;
/***************** end of module ***********************/
end$module predef;


218
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/PRINT.PLM Normal file
View File

@@ -0,0 +1,218 @@
$title ('PRINT MODULE')
print:
do;
/*
modified 3/26/81 R. Silberstein
modified 3/30/81 R. Silberstein
modified 4/7/81 R. Silberstein
modified 4/9/81 R. Silberstein
modified 4/16/81 R. Silberstein
modified 4/20/81 R. Silberstein
modified 5/5/81 R. Silberstein
modified 7/24/81 R. Silberstein
modified 7/27/81 R. Silberstein
modified 8/19/81 R. Silberstein
modified 9/2/81 R. Silberstein
modified 9/19/81 R. Silberstein
*/
$include (:f1:macro.lit)
$include (:f1:struc.lit)
$INCLUDE (:F1:DEV.LIT)
$include (:f1:files.ext)
$include (:f1:subr2.ext)
$include (:f1:global.ext)
$include (:f1:text.ext)
dcl
pageno byte, /* current page no */
lineno byte, /* current line no */
col byte, /* column counter */
field1start lit '6', /* start of hexoutput print */
FIELD15START LIT '19', /* START OF ABSOLUTE ADDRESS FIELD */
field2start lit '24'; /* start of source output print */
printbyt: proc(ch);
dcl ch byte;
if not asciichar(ch) then ch='#';
if ch <> lf then col=col+1;
if ch = cr then col=0;
call outprintbyte(ch);
end printbyt;
advance: proc(n); /* advance to column "n" */
dcl n byte;
do while n > col;
call printbyt(space);
end$while;
end advance;
printtext: proc(s);
dcl s address,ch based s byte;
DO WHILE CH <> 0;
CALL PRINTBYT (CH);
S = S + 1;
END;
end printtext;
printheader: proc;
COL = 0;
pageno=pageno+1;
call printtext(.initials);
call printtext(.sourcename);
call printtext(.(' ',0));
call printtext(.title);
call advance(maxcol-11);
call printtext(.pagetext);
call decout(pageno,.help(0));
call printtext(.help(1));
call printtext(.(cr,lf,cr,lf,cr,lf,0));
lineno=4;
end printheader;
/* Public routine to perform page eject */
eject: proc public;
if simform then$do
do while (lineno:=lineno+1) <= pagesize;
call printbyt(cr);
call printbyt(lf);
end$while;
else$do
call outprintbyte(formfeed);
end$if;
lineno=0;
end eject;
printnewpage: proc public;
IF LINENO > 4 THEN$DO
call eject;
call printheader;
END$IF;
end printnewpage;
incrementline: proc;
lineno = lineno + 1;
if lineno >= pagesize - 10 then call printnewpage;
end incrementline;
/* Print single byte,update column counter,
expand tabs (each 8.th column) */
print$single$byte: proc(ch) public;
dcl ch byte;
if ch=tab then$do
ch=8-((col-field2start) mod 8);
do while (ch:=ch-1) <> 0ffh;
call printbyt(space);
end$while;
else$do
call printbyt(ch);
if ch = lf then call incrementline;
end$if;
end print$single$byte;
print$crlf: proc public;
call print$single$byte(cr);
call print$single$byte(lf);
end print$crlf;
/* Print a field given by last column of field,source-
array containing ascii bytes,index of this array, and
index of last byte of source array. Before entry, the
current column position must be start of this field. */
print$field: proc (sourceindex,s,lastindex,stopcol);
dcl (sourceindex,s,lastindex) address,
stopcol byte,
source based s (1) byte,
k based sourceindex byte,
last based lastindex byte;
do while col < stopcol and k < last;
call print$single$byte(source(k));
k=k+1;
end$while;
end print$field;
print$sl: proc;
dcl (i,j) byte;
DECLARE K BYTE;
IF (PRINTDEVICE = NULL) AND NOT ERRORPRINTED THEN RETURN; /* NO NEED TO WASTE TIME HERE */
if include$on then$do
prefix(0)='=';
if prefixptr=0 then prefixptr=1;
end$if;
i,j,col=0;
/* print first field of line prefix */
call printfield(.i,.prefix(0),.prefixptr,field1start);
/* Print rest of prefix and source.
If line overflow, print rest on
following lines. */
if prefixptr-i+sourceptr > 0 then$do
do while (prefixptr-i) + (sourceptr-j) >0;
call advance(field1start);
call printfield(
.i,.prefix(0),.prefixptr,((field15start-1)/3)*3);
IF ABSADDR (0) <> SPACE THEN$DO
CALL ADVANCE (FIELD15START);
DO K = 0 TO 3;
CALL PRINTSINGLEBYTE (ABSADDR (K));
END;
END$IF;
if sourceptr-j >0 then$do
call advance(field2start);
call printfield(.j,.sourcebuf(0),.sourceptr,maxcol-1);
end$if;
call printcrlf;
end$while;
else$do
call printcrlf;
end$if;
end print$sl;
/* Public routine to print prefix and source line on printfile. */
print$source$line: proc public;
IF PRINT$ON OR ERRORPRINTED THEN CALL PRINT$SL;
CALL FILL (SPACE, PREFIXPTR, .PREFIX);
CALL FILL (SPACE, LENGTH (ABSADDR), .ABSADDR);
prefixptr,sourceptr=0;
end print$source$line;
/* Public routine to initiate print module */
printinit: proc public;
if print$on then$do
pageno=0;
LINENO = 0FFH;
CALL PRINTNEWPAGE;
end$if;
end printinit;
/* Public routine to print module information on printfile */
printterminate: proc (USEFACT) public;
DECLARE USEFACT BYTE;
if print$on then$do
CALL PRINTCRLF;
CALL PRINTCRLF;
call printtext(.endtext); /* END OF ASSEMBLY. NO OF ERRORS: */
call decout(errors,.help(0));
call printtext(.help(2));
CALL PRINTTEXT (.USEFACTOR);
CALL DECOUT (USEFACT, .HELP (0));
CALL PRINTTEXT (.HELP (3));
CALL PRINTTEXT (.(25H,CR,LF,0)); /* % */
end$if;
end printterminate;
end$module print;


355
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/PSEUD1.PLM Normal file
View File

@@ -0,0 +1,355 @@
$title ('PSEUDO INSTRUCTION MODULE-1')
pseudom:
do;
/*
modified 4/9/81 R. Silberstein
modified 4/15/81 R. Silberstein
modified 5/7/81 R. Silberstein
modified 7/24/81 R. Silberstein
modified 8/26/81 R. Silberstein
modified 8/19/81 R. Silberstein
*/
/*
This is the module to perform the decoding of
all legal pseudo instructions of the assembler.
There is one subroutine for each corresponding
pseudoinstruction.
*/
$include (:f1:macro.lit)
$include (:f1:struc.lit)
$include (:f1:equals.lit)
$include (:f1:pseud1.x86)
$include (:f1:outp.lit)
$include (:f1:subr2.ext)
$include (:f1:print.ext)
$include (:f1:scan.ext)
$include (:f1:symb.ext)
$include (:f1:expr.ext)
$include (:f1:ermod.ext)
$include (:f1:outp.ext)
$include (:f1:global.ext)
$eject
/*************** COMMON SUBROUTINES *************/
/* routine to test if rest of line is either a comment or empty -
if not, print error message - skip rest of line */
test$emptyline: proc;
if not emptyline then call errmsg(end$of$line$err);
call skip$rest$of$line;
end test$emptyline;
/* list current address in front of printline */
listcip: proc PUBLIC;
if (prefixptr=0) and (pass <> 0) then$do
call hex2out(cip,.prefix(1));
prefixptr=6;
end$if;
end list$cip;
/* common routine for ORG and RS (reserve storage pseudo) */
orgrs: proc (disp,typ);
dcl disp addr,typ byte,oper operandstruc at (.operands(0));
if noforwardexpr(.oper) then$do /* evaluate operand */
if oper.stype=number then$do
currentsymbol.length=oper.offset;
cip=disp+oper.offset*typ; /* compute new instruction pointer */
call test$emptyline;
return;
end$if;
end$if;
/* error in expression */
call errmsg(pseudooperr);
call skip$rest$of$line;
end orgrs;
/* perform handling for CSEG,DSEG,SSEG,ESEG routines */
segmentrout: proc (p1,p2,p3,segr);
dcl segr byte,(p1,p2,p3) address,
currentseg based p1 addr,
segspecified based p2 byte,
cipsave based p3 addr,
oper operandstruc at (.operands(0)),
low byte at (.csegvalue),high byte at (.csegvalue+1);
emit: proc;
dcl datatab(4) byte data (ESvalue,CSvalue,SSvalue,DSvalue);
call emitcodebyte(high,datatab(segr));
call emitcodebyte(low,datatab(segr));
call hex2out(csegvalue,.prefix(3)); /* print value on print line */
prefixptr=7;
end emit;
do case csegtype; /* save current segment attributes */
do; cureseg=csegvalue; espec=csegspec; escip=cip; end; /* ES */
do; curcseg=csegvalue; cspec=csegspec; cscip=cip; end; /* CS */
do; cursseg=csegvalue; sspec=csegspec; sscip=cip; end; /* SS */
do; curdseg=csegvalue; dspec=csegspec; dscip=cip; end; /* DS */
end$case;
if emptyline then$do /* allow no parameter */
call skip$rest$of$line;
csegvalue=0;
csegtype=segr;
csegspec=false; /* no segment value specified */
cip=0;
return;
end$if;
if specialtoken('$') then$do /* allow "$" */
csegtype=segr; /* pick up previous values */
csegspec=segspecified;
csegvalue=currentseg;
cip=cipsave;
if csegspec then call emit;
call scan; /* skip $ */
call test$emptyline;
return;
end$if;
if expression(.oper) then$do /* operand must be expression */
if oper.stype=number then$do
csegvalue=oper.offset; /* pick up segment value */
csegtype=segr;
csegspec=true; /* value is specified */
cip=0;
call emit;
call test$emptyline;
return;
end$if;
end$if;
/* must be illegal operand */
call skip$rest$of$line;
call errmsg(pseudooperr);
end segmentrout;
/* common routine for DB,DW and DD */
DB$DW$DD$common: proc(n);
dcl(n,continue) byte,lg addr;
DECLARE EP BYTE;
item: proc(n); /* find one element of element list */
dcl (n,i,errorprinted) byte,
oper operandstruc at (.operands(0)),
low byte at (.oper.offset),
high byte at (.oper.offset+1),
seglow byte at (.oper.segment),
seghigh byte at (.oper.segment+1);
emit: proc (outputbyte);
dcl outputbyte byte,
datatab(4) byte data (ESdata,CSdata,SSdata,DSdata);
call emitcodebyte(outputbyte,datatab(csegtype));
end emit;
locexpr: proc byte;
if expression(.oper) then$do
i=oper.stype;
if (i=number) or (i=variable) or (i=lab) then return true;
end$if;
return false;
end locexpr;
DBhandle: proc;
if (token.type=string) and (acclen > 1) then$do
lg=lg+acclen-1;
i=0ffh;
do while (i:=i+1) < acclen;
call emit(accum(i));
end$while;
oper.stype=number; /* dummy */
call scan; /* skip string */
else$do
if locexpr then$do
call emit(low);
else$do
call emit(0);
call errmsg(illexprelem);
end$if;
end$if;
end DBhandle;
DWhandle: proc;
if locexpr then$do
call emit(low);
call emit(high);
else$do
call emit(0);
call emit(0);
call errmsg(illexprelem);
end$if;
end DWhandle;
DDhandle: proc;
if locexpr then$do
if oper.stype <> number then$do
if (oper.sflag and segmbit) <> 0 then$do
call emit(low);
call emit(high);
call emit(seglow);
call emit(seghigh);
return;
else$do
call errmsg(misssegminfo);
end$if;
end$if;
end$if;
do i=0 to 3; call emit(0); end$do; /* dummy */
call errmsg(illexprelem);
end DDhandle;
/* ITEM main program */
lg=lg+1;
do case n;
call DBhandle;
call DWhandle;
call DDhandle;
end$case;
if specialtoken(',') then$do
call scan;
continue=true;
else$do
if emptyline then$do
call skip$rest$of$line;
else$do
CALL ERRMSG (ENDOFLINEERR);
CALL SKIPRESTOFLINE;
end$if;
end$if;
end item;
/* DB$DW$DD$common main program */
CALL LISTCIP;
EP = FALSE;
lg=0;
continue=true;
do while continue;
errorprinted=false;
continue=false;
call item(n);
EP = EP OR ERRORPRINTED;
end$while;
currentsymbol.length=lg;
ERRORPRINTED = EP; /* SO SOURCE LINE IS ECHOED IF ERROR */
end DB$DW$DD$common;
$eject
/***************** PSEUDO SUBROUTINES **************/
DBrout: proc public;
call DB$DW$DD$common(0);
end DBrout;
DWrout: proc public;
call DB$DW$DD$common(1);
end DWrout;
DDrout: proc public;
call DB$DW$DD$common(2);
end DDrout;
RSrout: proc (typ) public;
dcl typ byte;
call listcip; /* list current address on printline */
call orgrs(cip,typ); /* cip = cip + typ * expression */
end RSrout;
CSEGrout: proc public;
call segmentrout(.curcseg,.cspec,.cscip,rcs);
end CSEGrout;
DSEGrout: proc public;
call segmentrout(.curdseg,.dspec,.dscip,rds);
end DSEGrout;
SSEGrout: proc public;
call segmentrout(.cursseg,.sspec,.sscip,rss);
end SSEGrout;
ESEGrout: proc public;
call segmentrout(.cureseg,.espec,.escip,res);
end ESEGrout;
ORGrout: proc public;
call orgrs(0,byt); /* cip = 0 + expression */
end ORGrout;
EQUrout: proc public;
dcl oper operandstruc at (.operands(0)),
macdefpt based codemacroptr address;
codempossible: proc byte;
return (nextch=cr or nextch=';');
end codempossible;
do case pass;
do; /* pass 0 */
if codempossible and
findcodemacro(acclen,.accum(0),.codemacroptr) then$do
currentsymbol.stype=code;
call enterattributes(symbtabadr,.currentsymbol);
if not newmacro(acclensave,.accumsave,macdefpt) then
fullsymbtab=true;
else$do
nooper=0; /* find normal operand expression */
IF NOFORWARDOPER THEN$DO
call enterattributes(symbtabadr,.operands(0));
call skip$rest$of$line;
else$do
currentsymbol.stype=udefsymb;
call enterattributes(symbtabadr,.currentsymbol);
call skip$rest$of$line;
end$if;
end$if;
end;
do; /* pass 1 */
if currentsymbol.stype <> code then$do /* update symbol value */
nooper=0;
IF NOFORWARDOPER THEN$DO
call enterattributes(symbtabadr,.operands(0));
end$if;
end$if;
call skip$rest$of$line;
end;
do; /* pass 2 - scan to produce possible errormessages */
if currentsymbol.stype=code then$do
call scan;
else$do
nooper=0;
IF NOT NOFORWARDOPER OR (CURRENTSYMBOL.STYPE = ERROR) THEN$DO
call errmsg(pseudooperr);
call skip$rest$of$line; /* only one error message */
else$do
prefixptr=7;
call hex2out(oper.offset,.prefix(3));
end$if;
end$if;
call test$emptyline;
end;
end$case;
end EQUrout;
end$module pseudom;


291
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/PSEUD2.PLM Normal file
View File

@@ -0,0 +1,291 @@
$title ('PSEUDO INSTRUCTION MODULE-2')
pseudom:
do;
/*
modified 3/28/81 R. Silberstein
modified 4/1/81 R. Silberstein
modified 4/9/81 R. Silberstein
modified 4/15/81 R. Silberstein
modified 7/24/81 R. Silberstein
modified 9/2/81 R. Silberstein
*/
/*
This is the module to perform the decoding of
all legal pseudo instructions of the assembler.
There is one subroutine for each corresponding
pseudoinstruction.
*/
$include (:f1:macro.lit)
$include (:f1:struc.lit)
$include (:f1:equals.lit)
$include (:f1:ermod.lit)
$include (:f1:files.ext)
$include (:f1:subr1.ext)
$include (:f1:subr2.ext)
$include (:f1:scan.ext)
$include (:f1:print.ext)
$include (:f1:expr.ext)
$include (:f1:ermod.ext)
$include (:f1:pseud2.x86)
$eject
/*************** COMMON SUBROUTINES *************/
/* routine to test if rest of line is either a comment or empty -
if not, print error message - skip rest of line */
test$emptyline: proc;
if not emptyline then call errmsg(end$of$line$err);
call skip$rest$of$line;
end test$emptyline;
/* perform handling for PAGEWIDTH- and PAGESIZE-routine */
sizewidth: proc(p);
dcl oper operandstruc at (.operands(0)),p address,dest based p byte;
if pass=0 then$do
call skip$rest$of$line; /* do nothing in pass 0 */
else$do
if expression(.oper) then$do
if oper.stype = number then$do
dest=oper.offset;
call test$emptyline;
return;
end$if;
end$if;
call errmsg(pseudooperr);
call skip$rest$of$line;
end$if;
end sizewidth;
$eject
/***************** PSEUDO SUBROUTINES **************/
IFrout: proc public;
DECLARE IFNESTMAX LIT '5'; /* MAX LEVEL OF IF NEXTING */
dcl oper operandstruc at (.operands(0)),bool byte;
IFerr: proc;
call errmsg(ifparerr);
call skip$rest$of$line;
end IFerr;
skip$until$ENDIF: proc;
dcl pseudotype byte at (.token.value);
DECLARE LOCIFLEVEL BYTE;
DECLARE TEMP BYTE;
/* LOCIFLEVEL = IFLEVEL + 1; */
LOCIFLEVEL = 1; /* REPLACES ABOVE LINE SEE GLP(O.S.) */
IF PRINTON AND NOT IFLIST THEN$DO
CALL PRINTSOURCELINE;
PRINTON = FALSE;
TEMP = TRUE;
ELSE$DO
TEMP = FALSE;
END$IF;
do while not eofset; /* (forever) */
call scan;
IF TOKEN.TYPE = PSEUDO THEN$DO
IF PSEUDOTYPE = PENDIF THEN$DO
LOCIFLEVEL = LOCIFLEVEL - 1;
IF LOCIFLEVEL = 0 THEN$DO
CALL SCAN;
CALL TESTEMPTYLINE;
IF TEMP THEN PRINTON = TRUE;
RETURN;
END$IF;
ELSE$DO
IF PSEUDOTYPE = PIF THEN$DO
LOCIFLEVEL = LOCIFLEVEL + 1;
END$IF;
END$IF;
END$IF;
call skip$rest$of$line;
end$while;
end skip$until$ENDIF;
IF IFLEVEL = IFNESTMAX THEN$DO
call errmsg(nestediferr);
call skip$rest$of$line;
else$do
if not noforwardexpr(.oper) then$do
call IFerr;
else$do
if oper.stype <> number then$do
call IFerr;
else$do
bool=oper.offset;
if bool <> 0 then$do
IFLEVEL = IFLEVEL + 1;
call test$emptyline;
else$do
call skip$rest$of$line;
call skip$until$ENDIF;
end$if;
end$if;
end$if;
end$if;
end IFrout;
ENDIFrout: proc public;
IF IFLEVEL > 0 THEN$DO
IFLEVEL = IFLEVEL - 1;
call test$emptyline;
else$do
call errmsg(missiferr);
call skip$rest$of$line;
end$if;
end ENDIFrout;
INCLUDErout: proc public;
dcl (disk,i,errflag) byte,filname(11) byte,filtype(3) byte at (.filname (8));
syntaxerr: proc;
call errmsg(filesynterr);
errflag=true;
end syntaxerr;
accum$not$alpha: proc byte;
i=0ffh;
do while (i:=i+1) < acclen;
if not alphanumeric(accum(i)) then return true;
end$while;
return false;
end accum$not$alpha;
if include$on then$do
call errmsg(nestedincludeerr);
call skip$rest$of$line;
return;
end$if;
errflag=false;
disk=include$default; /* default disk is current one */
CALL FILL (SPACE, SIZE (FILNAME), .FILNAME);
if (acclen=1) and (nextch=':') and (letter(accum(0))) then$do
/* disk name found */
disk=accum(0)-'A';
call scan; /* skip : */
call scan; /* get filename */
end$if;
/* test syntax of filename */
if (acclen > 8) or accum$not$alpha then$do
call syntaxerr; /* illegal filename */
else$do
call copy(acclen,.accum(0),.filname); /* pick up filename */
call scan; /* skip filename */
/* test if filetype - if so, pick it up */
if specialtoken('.') then$do
call scan; /* skip . */
if (acclen > 3) or accum$not$alpha then$do
call syntaxerr;
else$do
call copy(acclen,.accum(0),.filtype(0));
call scan;
end$if;
ELSE$DO
CALL COPY (3, .('A86'), .FILTYPE); /* DEFAULT FILE TYPE */
end$if;
end$if;
if errflag then$do
call skip$rest$of$line;
else$do
/* try to open include file */
call i$file$setup(disk,.filname,.filtype);
CALL OPEN$INCLUDE;
call test$emptyline;
include$on=true;
end$if;
end INCLUDErout;
ENDrout: proc public;
call test$emptyline;
eofset=true;
end ENDrout;
PAGESIZErout: proc public;
call sizewidth(.pagesize);
end PAGESIZErout;
PAGEWIDTHrout: proc public;
call sizewidth(.maxcol);
end PAGEWIDTHrout;
TITLErout: proc public;
do case pass;
do; /* pass 0 */
if token.type=string then$do
call fill(0,length(title),.title(0));
if acclen > length(title) then acclen=length(title);
call copy(acclen,.accum(0),.title(0));
end$if;
call skip$rest$of$line;
end;
do; /* do nothing in pass 1 */
call skip$rest$of$line;
end;
do; /* pass 2 */
if token.type=string then$do
call scan;
call test$emptyline;
else$do
call errmsg(pseudooperr);
call skip$rest$of$line;
end$if;
end;
end$case;
end TITLErout;
EJECTrout: proc public;
if print$on then call printnewpage;
call test$emptyline;
end EJECTrout;
SIMFORMrout: proc public;
simform=true;
call test$emptyline;
end SIMFORMrout;
LISTrout: proc public;
call test$emptyline;
if printswitchoff then$do
printswitchoff=false;
print$on=true;
sourceptr=0;
end$if;
end LISTrout;
NOLISTrout: proc public;
if print$on then$do
call test$emptyline;
call printsourceline;
printswitchoff=true;
print$on=false;
else$do
call test$emptyline;
end$if;
end NOLISTrout;
IFLISTROUT: PROC PUBLIC;
CALL TESTEMPTYLINE;
IFLIST = TRUE;
END IFLISTROUT;
NOIFLISTROUT: PROC PUBLIC;
CALL TESTEMPTYLINE;
IFLIST = FALSE;
END NOIFLISTROUT;
end$module pseudom;


323
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/SCAN.PLM Normal file
View File

@@ -0,0 +1,323 @@
$title ('SCANNER MODULE')
scanm:
do;
/*
modified 3/26/81 R. Silberstein
modified 3/30/81 R. Silberstein
modified 4/10/81 R. Silberstein
modified 9/2/81 R. Silberstein
*/
$include (:f1:macro.lit)
$include (:f1:struc.lit)
$include (:f1:equals.lit)
$include (:f1:files.ext)
$include (:f1:predef.ext)
$include (:f1:subr2.ext)
$include (:f1:print.ext)
$include (:f1:global.ext)
/* Variables : */
dcl
eoffound byte, /* true if end-of-file is found */
lowercase byte, /* false if stringinput, otherwise true */
crfound byte, /* true if previous input was CR */
printready byte, /* true if output line to be printed */
stacksave addr; /* save of stack pointer */
/* Routine to perform unnormal exit from module */
exit: proc;
stackptr=stacksave; /* restore input stack */
end exit;
/* Put printcharacter into printfile output buffer */
putprintchar: proc(ch);
dcl ch byte;
sourcebuf(sourceptr)=ch;
if sourceptr < last(sourcebuf) then$do
sourceptr=sourceptr+1;
end$if;
end putprintchar;
/* Read single character from input file. Put characters
except CR-LF to printbuffer. Convert to uppercase letters */
read$input: proc byte;
dcl ch byte;
if eoffound then call exit; /* unnormal exit */
/* read byte from file */
if include$on then ch=inincludebyte; else ch=insourcebyte;
if ch=end$of$file then$do /* test for end-of-file */
eoffound=true;
else$do
if crfound and ch=lf then$do /* ignore LF after CR */
ch=space;
else$do;
if ch=cr then$do /* test for CR */
crfound=true;
else$do;
crfound=false;
call putprintchar(ch);
if ch=lf then ch=space; /* interpret LF within line as space */
end$if;
end$if;
end$if;
if not lowercase then$do /* convert to uppercase */
ch=upper(ch);
end$if;
return ch;
end read$input;
/* skip blanks and tab's in input */
skip$blanks: proc;
do while nextch=space or nextch=tab;
nextch=read$input;
end$while;
end skip$blanks;
/* Put character into accumulator */
putaccum: proc(ch);
dcl ch byte;
accum(acclen)=ch;
if acclen < last(accum) then$do
acclen=acclen+1;
end$if;
end put$accum;
/* Routine to scan remainder of token until a non-
alphanumeric character is found. Skip blanks
behind token */
get$remainder: proc(numb);
dcl (cont,numb) byte;
cont=true;
do while cont;
do while alphanumeric(nextch:=read$input);
call putaccum(nextch);
end$while;
cont=false;
if nextch = '@' or nextch = '_' then$do
cont=true;
if numb then call putaccum(nextch);
end$if;
end$while;
call skipblanks;
end get$remainder;
/* Routine to scan a text string. Called from SCAN */
stringr: proc;
dcl cont byte;
lowercase=true;
acclen=0;
cont=true;
do while cont;
nextch=readinput;
do while nextch <> '''' and nextch <> cr;
call putaccum(nextch);
nextch=read$input;
end$while;
if nextch='''' then$do
if (nextch:=readinput) = '''' then$do /* interpret '' as ' */
call putaccum(nextch);
else$do
lowercase=false;
call skipblanks;
token.type=string;
cont=false;
end$if;
else$do
lowercase=false;
token.type=error;
cont=false;
end$if;
end$while;
end stringr;
/* Routine to scan a number. Called from SCAN. Test syntax
of number, compute binary value. */
numbr: proc;
dcl
nobase byte, /* number system, 2,8,10 or 16 */
maxlgth byte, /* max legal no of digits */
(i,j) byte, /* counters */
ch byte,
value addr, /* 16 bit binary value */
errorflag byte; /* syntax error flag */
errorflag=false;
call getremainder(true); /* get rest of token */
ch=accum(acclen-1); /* pick up last character of token */
j=acclen-2;
/* B (binary) */
IF CH = 'B' THEN
do; nobase=2; maxlgth=16; end;
/* O or Q (octal) */
ELSE IF CH = 'O' OR CH = 'Q' THEN
do; nobase=8; maxlgth=6; end;
/* H (hexadecimal) */
ELSE IF CH = 'H' THEN
do; nobase=16; maxlgth=4; end;
/* D (decimal) */
ELSE IF CH = 'D' THEN
do; nobase=10; maxlgth=5; end;
/* no subscript, default=decimal */
ELSE
do; nobase=10; maxlgth=5; j=j+1; end;
i=0ffh; /* skip leading zeros */
do while accum(i:=i+1) = '0'; end;
if j < maxlgth+i then$do
value=0; /* syntax check number, compute binary value */
do while i <= j;
ch=accum(i);
ch=ch-'0';
if ch > 9 then ch=ch-7;
if ch >= nobase then$do
errorflag=true;
end$if;
value=value*nobase+ch;
i=i+1;
end$while;
else$do
errorflag=true;
end$if;
if errorflag then$do
token.type=error;
else$do
token.type=number;
token.descr=0;
token.value=value;
end$if;
end numbr;
/* Routine to scan an identifier. Lookup identifier in table
for predefined symbols */
identr: proc;
call get$remainder(false); /* get rest of token into accumulator */
/* look up identifier */
if not pfind(acclen,.accum(0),.token) then$do
token.type=ident;
end$if;
end identr;
/* PUBLIC subroutines : */
scaninit: proc public;
eofset,eoffound,crfound,lowercase,printready=false;
CALL FILL (SPACE, SIZE (PREFIX), .PREFIX);
CALL FILL (SPACE, LENGTH (ABSADDR), .ABSADDR);
sourceptr,prefixptr=0;
call printinit; /* initiate print module */
call rewindsource;
nextch=space;
end scaninit;
scan: proc public;
stacksave=stackptr;
if printready then$do
call print$source$line;
print$ready=false;
end$if;
call skipblanks;
if eoffound then$do
token.type=spec;
if crfound then$do
eoffound=false;
eofset=true;
else$do
printready=true; /* terminate line before EOF */
crfound=true;
accum(0)=cr;
end$if;
else$do
acclen=1;
accum(0)=nextch;
/* identifier */
IF LETTER (NEXTCH) THEN call identr;
/* number */
ELSE IF DIGIT (NEXTCH) THEN call numbr;
/* string */
ELSE IF NEXTCH = '''' THEN call stringr;
/* special letter */
ELSE
do;
token.type=spec;
if nextch='!' then accum(0) = cr;
IF NEXTCH = ';' THEN$DO
DO WHILE ACCUM (0) <> CR;
ACCUM (0) = READINPUT;
END$WHILE;
END$IF;
nextch=space;
if crfound then$do
print$ready=true;
else$do
call skipblanks;
end$if;
end;
end$if;
end scan;
skip$rest$of$line: proc public;
do while accum(0) <> cr;
call scan;
end$while;
end skip$rest$of$line;
specialtoken: proc(tok) byte public;
dcl tok byte;
if (token.type=spec) and (accum(0)=tok) then return true;
return false;
end specialtoken;
skip$until: proc(tok) byte public;
dcl tok byte;
do forever;
if token.type=spec then$do
if accum(0)=tok then$do
call scan;
return true;
end$if;
if accum(0)=cr then return false;
end$if;
call scan;
end$forever;
end skip$until;
emptyline: proc byte public;
return specialtoken(cr);
end emptyline;
end$module scanm;


47
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/SUBR1.PLM Normal file
View File

@@ -0,0 +1,47 @@
$title ('SUBROUTINE MODULE - PART 1')
subr1:
do;
$include (:f1:macro.lit)
/*
modified 3/26/81 R. Silberstein
*/
/* compute if number is in range (-128,127) */
/* exit 1 if in range, 2 otherwise */
typecalc: procedure(val) byte public;
declare val address,
lowb byte at (.val),
highb byte at (.val+1);
lowb=lowb and 80h;
if highb=0 then
if lowb=0 then return 1;
if highb=0ffh then
if lowb <> 0 then return 1;
return 2;
end typecalc;
/* test if number is a "word" (>255 and <-256) */
wrdtest: procedure(n) byte public;
declare n address;
return ((n < 0ff00h) and (n > 0ffh));
end wrdtest;
copy: procedure(n,s,d) public;
declare n byte,
(s,d) address,
sch based s byte,
dch based d byte;
DO WHILE (N := N - 1) <> 0FFH;
DCH = SCH;
D = D + 1;
S = S + 1;
END;
end copy;
end subr1;


148
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D12/SUBR2.PLM Normal file
View File

@@ -0,0 +1,148 @@
$title ('SUBROUTINE MODULE - PART 2')
subr2:
do;
$include(:f1:macro.lit)
$INCLUDE (:F1:STRUC.LIT)
$include(:f1:io.ext)
/*
modified 3/26/81 R. Silberstein
modified 3/28/81 R. Silberstein
modified 3/30/81 R. Silberstein
*/
outtext: procedure (t) public;
dcl t addr,
ch based t byte;
do while ch <> 0;
call write$console(ch);
t=t+1;
end$while;
end outtext;
OUTFILENAME: PROCEDURE (PTR);
DECLARE PTR ADDRESS, X BASED PTR FILEOSTRUCTURE, I BYTE;
CALL WRITE$CONSOLE (X.DISK + 'A');
CALL WRITE$CONSOLE (':');
DO I = 1 TO 8;
IF (X.FCBBLOCK (I) AND 7FH) = SPACE THEN I = 8;
ELSE CALL WRITE$CONSOLE (X.FCBBLOCK (I) AND 7FH);
END;
CALL WRITE$CONSOLE ('.');
DO I = 9 TO 11;
CALL WRITE$CONSOLE (X.FCBBLOCK (I) AND 7FH);
END;
CALL SYSTEMRESET;
END OUTFILENAME;
FILEABORT: PROCEDURE (PTR, TEXTADR) PUBLIC;
DECLARE (PTR, TEXTADR) ADDRESS;
CALL OUTTEXT (TEXTADR);
CALL WRITE$CONSOLE (':');
CALL WRITE$CONSOLE (SPACE);
CALL OUTFILENAME (PTR);
END FILEABORT;
fill: procedure (ch,n,pt) public;
dcl (ch,n) byte,pt address,buffer based pt byte;
DO WHILE (N := N - 1) <> 0FFH;
buffer=ch;
pt = pt + 1;
end$while;
end fill;
digit: procedure(ch) byte public;
dcl ch byte;
IF CH < '0' THEN RETURN FALSE;
return (ch <= '9');
end digit;
letter: procedure(ch) byte public;
dcl ch byte;
IF CH < 'A' THEN RETURN FALSE;
return (ch <= 'Z');
end letter;
alphanumeric: proc(ch) byte public;
dcl ch byte;
if letter(ch) then return true;
return digit(ch);
end alphanumeric;
asciichar: proc (ch) byte public;
dcl ch byte;
if ch=cr then return true;
IF CH = LF THEN RETURN TRUE;
IF CH < SPACE THEN RETURN FALSE;
return (ch <= 7eh);
end asciichar;
upper: procedure(ch) byte public;
dcl ch byte;
if ch >= 61h THEN IF ch <= 7eh then ch=ch-20h;
return ch;
end upper;
equal: procedure(n,s,d) byte public;
dcl n byte,
(s,d) address,
sch based s byte,
dch based d byte;
DO WHILE (N := N - 1) <> 0FFH;
IF SCH <> DCH THEN RETURN FALSE;
S = S + 1;
D = D + 1;
END$WHILE;
return true;
end equal;
hex1out: procedure(n,d) public;
dcl n byte,d addr,
dest based d (1) byte;
hexdigit: procedure(digit) byte;
dcl digit byte;
digit=digit+'0';
if digit > '9' then digit=digit+7;
return digit;
end hexdigit;
dest(0)=hexdigit(SHR (N, 4));
dest(1)=hexdigit(n and 0fh);
end hex1out;
hex2out: proc (n,d) public;
dcl n addr,
d addr;
call hex1out(HIGH (N),d);
call hex1out(LOW (N),d+2);
end hex2out;
decout: proc (n,d) public;
dcl
n addr,
d address,
dest based d (1) byte,
(i,space$or$zero,digit) byte,
divis(5) addr data (10000,1000,100,10,1);
space$or$zero=space;
do i=0 to 4;
if i=4 then space$or$zero='0';
digit=n/divis(i);
n=n mod divis(i);
if digit=0 then$do
dest(i)=space$or$zero;
else$do
dest(i)=digit+'0';
space$or$zero='0';
end$if;
end$do;
end decout;
end subr2;