mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-25 17:34:06 +00:00
Upload
Digital Research
This commit is contained in:
351
MPM OPERATING SYSTEMS/MPM-86/MPM-86 2.0 SOURCES/10/CM.PLM
Normal file
351
MPM OPERATING SYSTEMS/MPM-86/MPM-86 2.0 SOURCES/10/CM.PLM
Normal 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;
|
||||
|
||||
Reference in New Issue
Block a user