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:
516
MPM OPERATING SYSTEMS/MPM-86/MPM-86 2.0 SOURCES/10/EXPR.PLM
Normal file
516
MPM OPERATING SYSTEMS/MPM-86/MPM-86 2.0 SOURCES/10/EXPR.PLM
Normal 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;
|
||||
|
||||
Reference in New Issue
Block a user