perm filename EPAR3E.2[EAL,HE] blob
sn#708035 filedate 1983-04-14 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00005 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 {$NOMAIN Editor: Aux parsing routines }
C00005 00003 (* aux function for motion clauses: clauseParse *)
C00023 00004 (* cmonParse *)
C00031 00005 (* mClauseParse *)
C00037 ENDMK
C⊗;
{$NOMAIN Editor: Aux parsing routines }
%include eparse.hdr;
{ Externally defined routines from elsewhere: }
(* From ALLOC *)
function newNode: nodep; external;
procedure relNode(n: nodep); external;
procedure relToken(n: tokenp); external;
procedure relStrng(n: strngp); external;
(* From EROOT: Inter-overlay calls *)
function e3eExprParse: nodep; external;
(* From EAUX1A *)
function makeNVar(vartype: datatypes; vid: identp): varidefp; external;
(* From EAUX1B *)
function getDtype(n: nodep): datatypes; external;
function checkArg(n: nodep; d: datatypes): nodep; external;
(* From EAUX1C *)
procedure errprnt; external;
function evalOrder(what,last: nodep; pcons: boolean): nodep; external;
procedure relExpr(n: nodep); external;
(* From EAUX2A *)
procedure makeNewVar(newvar: varidefp); external;
(* From ETOKEN *)
procedure getToken; external;
procedure dimCheck(n,d: nodep); external;
function copyToken: tokenp; external;
procedure getDelim(char: ascii); external;
(* From EMOVEO *)
procedure moveOrder(st: statementp); external;
(* From PP *)
procedure ppLine; external;
procedure ppOutNow; external;
procedure ppChar(ch: ascii); external;
procedure pp5(ch: c5str; length: integer); external;
procedure pp10(ch: cstring; length: integer); external;
procedure pp10L(ch: cstring; length: integer); external;
procedure pp20(ch: c20str; length: integer); external;
procedure pp20L(ch: c20str; length: integer); external;
procedure ppInt(i: integer); external;
procedure ppReal(r: real); external;
procedure ppStrng(length: integer; s: strngp); external;
procedure ppDtype(d: datatypes); external;
procedure ppDelChar; external;
procedure ePar3eGet; external;
procedure ePar3eGet; begin end;
(* aux function for motion clauses: clauseParse *)
function clauseParse(n: nodep; absSeen: boolean): nodep; external;
function clauseParse;
var cl,nv,vdim: nodep; b,bp,badcl: boolean; dummyrel: reltypes;
bits,i: integer; d: datatypes; fch: char;
function getcsys(defcsys: boolean): boolean; (* aux routine *)
var b: boolean; (* Also appears in EPAR3F *)
begin
b := defcsys;
with curToken do
if (ttype = reswdtype) and (rtype = filtype) and (filler = intype) then
begin (* see whether WORLD or HAND coord sys *)
getToken;
if (ttype = reswdtype) and (rtype = filtype) and
((filler = worldtype) or (filler = handtype)) then b := (filler=worldtype)
else
begin
backup := true;
pp20L(' Need HAND or WORLD ',20); pp5('here ',4); errprnt;
end
end
else backup := true;
getcsys := b;
end;
function relParse: reltypes;
begin
getToken; (* get the relation *)
with curToken do
if (ttype = reswdtype) and (rtype = optype) and (op <= sgtop) then
relParse := op
else
begin
pp20L(' Need a relational o',20); pp20('perator here ',12); errPrnt;
backUp := true;
relParse := seqop;
end;
end;
begin
getToken;
if n = nil then cl := newNode else cl := n;
badcl := false;
with curToken, cl↑ do
begin
if ttype = identtype then
begin
if id↑.name↑.ch = 'SPEED_FACT' then
begin (* should also really check for final "OR" of speed_factor, but... *)
ntype := sfacnode;
dummyrel := relParse; (* skip over the "=" *)
clval := checkArg(e3eExprParse,svaltype);
dimCheck(clval,nodim↑.dim);
end
else badcl := true (* any other identifier is an error *)
end
else if (ttype = reswdtype) and (rtype = filtype) then
begin
if filler = notype then
begin
getToken; (* look for NULLING or FLIP *)
notp := true;
if (ttype <> reswdtype) or (rtype <> clsetype) or
((clause <> nullingtype) and (clause <> fliptype)) then
begin
pp20L('Expecting "NULLING" ',20); pp20('or "FLIP" here ',14);
badcl := true; (* no good *)
end;
if clause = fliptype then ntype := flipnode else ntype := nullingnode;
end
else if (filler = righttype) or (filler = lefttype) then
begin
ntype := shouldernode;
notp := filler = righttype;
getToken; (* look for SHOULDER *)
if (ttype <> reswdtype) or (rtype <> clsetype) or
(clause <> shouldertype) then
begin
pp20L('Expecting "SHOULDER"',20); pp5(' here',5);
badcl := true; (* no good *)
end;
end
else badcl := true (* any other filler is an error *)
end
else if (ttype <> reswdtype) or (rtype <> clsetype) then badcl := true
else
case clause of
durationtype:
begin
ntype := durnode;
durrel := relParse;
durval := checkArg(e3eExprParse,svaltype);
dimCheck(durval,timedim↑.dim);
end;
velocitytype:
begin
ntype := velocitynode;
dummyrel := relParse;
clval := checkArg(e3eExprParse,vectype);
dimCheck(clval,veldim↑.dim);
end;
wobbletype,
stopwaittimetype:
begin
if clause = wobbletype then
begin
ntype := wobblenode;
vdim := angledim↑.dim;
end
else
begin
ntype := swtnode;
vdim := timedim↑.dim;
end;
dummyrel := relParse;
clval := checkArg(e3eExprParse,svaltype);
dimCheck(clval,vdim);
end;
fliptype,
nullingtype:
begin
if clause = fliptype then ntype := flipnode else ntype := nullingnode;
notp := false;
end;
elbowtype:
begin
ntype := elbownode;
getToken; (* see if it's UP or DOWN *)
if (ttype <> reswdtype) or (rtype <> filtype) or
((filler <> uptype) and (filler <> downtype)) then
begin
pp20L('Expecting "UP" or "D',20); pp10('OWN" here ',9); errprnt;
backup := true;
end;
notp := filler = uptype;
end;
lineartype,
jointspacetype:
begin
ntype := linearnode;
if clause = lineartype then notp := true else notp := false;
getToken; (* get MOTION token *)
if (ttype <> reswdtype) or (rtype <> filtype) or
(filler <> motiontype) then
begin
pp20L('Expecting "MOTION" h',20); pp5('ere ',3); errprnt;
backup := true;
end;
end;
cwtype,
ccwtype:
begin
ntype := cwnode;
if clause = cwtype then notp := false else notp := true;
end;
approachtype,
departuretype:
begin
if clause = approachtype then ntype := apprnode else ntype := deprnode;
dummyrel := relParse;
getToken; (* check for NILDEPROACH *)
if (ttype = reswdtype) and
(rtype = clsetype) and (clause = nildeproachtype) then loc := nil
else
begin (* need to get deproach value *)
backUp := true;
loc := e3eExprParse; (* can be scalar, vector or trans *)
dimCheck(loc,distancedim↑.dim);
end;
code := nil;
(* *** what about THEN ??? *** *)
end;
forcewristtype:
begin
ntype := wristnode;
getToken;
if (ttype = reswdtype) and (rtype = optype) and
(curToken.op = notop) then
begin
notp := true;
getToken;
end
else notp := false;
if (ttype <> reswdtype) or (rtype <> filtype) or
(filler <> zeroedtype) then
begin
backUp := true;
pp20L(' Garbage clause ',15); errPrnt;
end
end;
forceframetype:
begin
ntype := ffnode;
if not absSeen then dummyrel := relParse;
ff := checkArg(e3eExprParse,transtype);
dimCheck(ff,distancedim↑.dim);
csys := getcsys(true); (* use WORLD as default coord sys *)
end;
forcetype,
torquetype,
angularvelocitytype:
begin
ntype := forcenode;
if clause = forcetype then
begin ftype := force; vdim := forcedim↑.dim end
else if clause = torquetype then
begin ftype := torque; vdim := torquedim↑.dim end
else begin ftype := angvelocity; vdim := angveldim↑.dim end;
if absSeen then ftype := succ(ftype);
getToken;
if (ttype = delimtype) and (ch = '(') then (* short form *)
begin
b := true;
fvec := checkArg(e3eExprParse,vectype);
getDelim(')'); (* get closing ")" *)
getToken;
end
else b := false; (* long form *)
if absSeen then
begin
if (ttype <> reswdtype) or (rtype <> optype) or
(curToken.op <> absop) then
begin
backUp := true;
pp20L(' Need closing "|" he',20); pp5('re ',2); errPrnt;
end;
end
else backUp := true;
frel := relparse;
fval := checkArg(e3eExprParse,svaltype);
dimCheck(fval,vdim);
i := cursor;
bp := true;
while (i > 2) and bp do
with cursorStack[i] do
if stmntp and (movetype <= st↑.stype) and (st↑.stype <= floattype)
then bp := false else i := i - 1;
with cursorStack[i].st↑ do
if (stype = opentype) or (stype = closetype) or (stype = operatetype) then
begin
b := true; (* so we don't look for a vector specification *)
cl↑.fvec := nil;
end;
if not b then
begin
getToken;
if (ttype <> reswdtype) or (rtype <> filtype) or
((filler <> abouttype) and (filler <> alongtype)) then
begin
backUp := true;
pp20L(' Need ALONG or ABOUT',20); pp5(' here',5);
end;
fvec := checkArg(e3eExprParse,vectype);
end;
getToken; (* check for force frame *)
backUp := true;
if (ttype = reswdtype) and (rtype = filtype) and (filler = oftype) then
begin
rtype := clsetype; (* make curToken look like forceframe clause *)
clause := forceframetype;
fframe := clauseParse(nil,true);
end
else fframe := nil;
end;
stiffnesstype:
begin
ntype := stiffnode;
dummyrel := relParse; (* skip over the "=" *)
getDelim('('); (* now look for the "(" *)
fv := e3eExprParse; (* get the first stiffness component *)
if getDtype(fv) = svaltype then (* see if it's 6 scalars or 2 vectors *)
for i := 1 to 2 do
begin
nv := newNode;
with nv↑ do
begin
ntype := exprnode;
op := vmakeop;
if i = 2 then arg1 := checkArg(e3eExprParse,svaltype)
else arg1 := cl↑.fv;
getDelim(',');
arg2 := checkArg(e3eExprParse,svaltype);
getDelim(',');
arg3 := checkArg(e3eExprParse,svaltype);
end;
if i = 1 then begin fv := nv; getDelim(',') end else mv := nv;
end
else
begin (* two vectors *)
fv := checkArg(fv,vectype);
getDelim(','); (* now look for the separating "," *)
mv := checkArg(e3eExprParse,vectype);
end;
dimCheck(fv,fvstiffdim);
dimCheck(mv,mvstiffdim);
getDelim(')'); (* now look for the ")" *)
getToken; (* is a center of compliance given? *)
backup := true;
if (ttype = reswdtype) and (rtype = filtype) and (filler = abouttype) then
begin
rtype := clsetype; (* make curToken look like forceframe clause *)
clause := forceframetype;
cocff := clauseParse(nil,true);
end
else cocff := nil;
end;
gathertype:
begin
ntype := gathernode;
dummyrel := relParse; (* skip over the "=" *)
getDelim('('); (* now look for the "(" *)
b := false;
gbits := 0;
repeat
bits := 0;
getToken; (* get component to gather *)
if ttype = identtype then
if id↑.length = 2 then
with id↑.name↑ do
begin
if (ch[1] = 'F') or (ch[1] = 'M') then
begin
if ('X' <= ch[2]) and (ch[2] <= 'Z') then
begin
case ch[2] of
'X': bits := 1; (* fx = 1B mx = 10B *)
'Y': bits := 2; (* fy = 2B my = 20B *)
'Z': bits := 4; (* fz = 4B mz = 40B *)
end;
if ch[1] = 'M' then bits := bits * 8;
end
end
else if (ch[1] = 'T') and ('1' <= ch[2]) and (ch[2] <= '6') then
case ch[2] of
'1': bits := (*100B *) 64;
'2': bits := (*200B *) 128;
'3': bits := (*400B *) 256;
'4': bits := (*1000B*) 512;
'5': bits := (*2000B*) 1024;
'6': bits := (*4000B*) 2048;
end;
end
else if id↑.name↑.ch = 'TBL ' then bits := (*10000B*) 4096;
b := bits = 0; (* bad clause *)
gbits := gbits + bits; (* really need to logically OR these *)
if b then
begin
pp20L(' Expecting a force c',20); pp20('omponent here ',13);
errprnt;
if ttype = identtype then getToken; (* skip past bad identifier *)
end
else getToken; (* pick up the "," or ")" *)
until (ttype <> identtype) and ((ttype <> delimtype) or (ch <> ','));
backup := true;
getDelim(')'); (* now look for the ")" *)
end;
loadtype:
begin
ntype := loadnode;
dummyrel := relParse; (* skip over the "=" *)
loadval := checkArg(e3eExprParse,svaltype);
dimCheck(loadval,forcedim↑.dim);
getToken;
if (ttype = reswdtype) and (rtype = filtype) and (filler = attype) then
begin
loadvec := checkArg(e3eExprParse,vectype);
getToken;
end;
lcsys := getcsys(false); (* default is HAND *)
end;
otherwise {do nothing};
end;
end;
if badcl then
begin
if n = nil then begin relNode(cl); cl := nil; end;
backup := true;
pp20L(' Not a valid clause ',19); errprnt;
end;
clauseParse := cl;
end;
(* cmonParse *)
procedure cmonParse(st: statementp; getStart: boolean); external;
procedure cmonParse;
var inMove: boolean; i: integer; t: tokenp;
begin
with cursorStack[cursor-1] do
inMove := (not stmntp) and (nd↑.ntype = cmonnode);
with st↑, curToken do
begin
if oncond <> nil then
with oncond↑ do (* see what sort of cmon we were & release any old fields *)
if ntype = durnode then begin relExpr(durval); relNode(oncond) end
else if ntype = forcenode then
begin relExpr(fval); relExpr(fvec); relExpr(fframe); relNode(oncond) end
else if ntype = errornode then
begin
relExpr(eexpr); relNode(oncond);
if inMove then cursorStack[cursor-1].nd↑.errhandlerp := false;
end
else relExpr(oncond);
exprCm := false;
oncond := nil;
exprs := nil;
getToken; (* see what sort of cmon we are now *)
if getStart then
begin
deferCm := false;
if (ttype = reswdtype) and (rtype = filtype) and (filler = defertype) then
begin
deferCm := true;
getToken;
end;
if (ttype <> reswdtype) or (rtype <> stmnttype) or (stmnt <> cmtype) then
begin
pp20L(' Expecting an "ON" h',20); pp5('ere ',3); errPrnt;
end
else getToken;
end;
if (ttype = reswdtype) and (rtype = clsetype) then
begin
if (clause = durationtype) or (clause = forcetype) or (clause = torquetype) then
begin
backUp := true;
oncond := clauseParse(nil,false);
end
else if (clause = arrivaltype) or (clause = departingtype) then
begin
if inMove then
begin
st↑.oncond := newNode;
with st↑.oncond↑ do
if clause = arrivaltype then
begin
ntype := arrivalnode;
evar := makeNVar(eventtype,nil);
makeNewVar(evar); (* if active block deal with environment entry *)
end
else
ntype := departingnode;
end
else
begin
pp20L('Must be part of MOVE',20); pp10(' statement',10); errPrnt;
end;
end
else if clause = errortype then
begin
oncond := newNode;
with oncond↑ do
begin
ntype := errornode;
getToken; (* skip over the "=" *)
eexpr := e3eExprParse; (* get desired error bits *)
dimCheck(eexpr,nodim↑.dim);
end;
if not inMove then
begin (* no good *)
pp20L('Must be part of MOVE',20); pp10(' statement',10); errPrnt;
end
else
begin (* point back to motion statement, not cmon *)
cursorStack[cursor-1].nd↑.errhandlerp := true;
st↑.conclusion↑.next↑.bparent := cursorStack[cursor-2].st;
end;
end
else
begin pp20L('Unknown ON condition',20); errPrnt end
end
else if (ttype = reswdtype) and (rtype = optype) and (op = absop) then
begin (* is it |Force...| or |Torque...|? *)
getToken; (* see what next token is *)
backUp := true;
if (ttype = reswdtype) and (rtype = clsetype) and
((clause = forcetype) or (clause = torquetype)) then
oncond := clauseParse(nil,true) (* yes - |Force/Torque...| cmon *)
else
begin (* no - expression cmon *)
exprCm := true;
t := copyToken; (* make a copy of token we just peeked at *)
next := t; (* fix things up so the peeked at token is next *)
ttype := reswdtype; (* and the "|" gets seen again by exprParse *)
rtype := optype;
op := absop;
if macrodepth = 0 then (* pretend we're a macro *)
begin
macrodepth := 1;
curmacstack[macrodepth] := nil;
macrostack[macrodepth] := nil;
end;
oncond := e3eExprParse; (* get expression for cmon *)
relToken(t); (* done with peeked at token now *)
end
end
else
begin
backUp := true;
oncond := e3eExprParse; (* get the cmon condition *)
if getDtype(oncond) <> eventtype then exprCm := true;
end;
if oncond <> nil then
with oncond↑ do
if (ntype = forcenode) and not inMove then
begin
pp20L('Force sensing must b',20); pp20('e part of a MOVE sta',20);
pp10('tement ',6); errPrnt;
relExpr(oncond);
oncond := nil;
end
else if exprCm or (ntype = durnode) or (ntype = forcenode) then
exprs := evalOrder(oncond,nil,true)
else if ntype = exprnode then (* subscripted event *)
exprs := evalOrder(arg2,nil,true)
else exprs := nil;
end;
if inMove then moveOrder(cursorStack[cursor-2].st);
end;
(* mClauseParse *)
procedure mClauseParse(n: nodep); external;
procedure mClauseParse;
var np,no,oldVClauses: nodep; strp: strngp; b,movep,jointp: boolean;
oldVcode: statementp; pttype: nodetypes;
begin (* dest, via, with *)
with cursorStack[cursor-1].st↑ do
begin
movep := stype = movetype;
jointp := stype = jtmovetype;
end;
with n↑ do
if ntype = destnode then
begin
relExpr(loc);
if movep then loc := checkArg(e3eExprParse,transtype)
else loc := checkArg(e3eExprParse,svaltype);
if jointp then dimCheck(loc,angledim↑.dim)
else dimCheck(loc,distancedim↑.dim);
end
else if (ntype = viaptnode) or (ntype = byptnode) then
begin (* ** maybe should check that this is a MOVE stmnt ?? ** *)
pttype := n↑.ntype; (* remember if it's a VIA or BY *)
np := n;
oldVClauses := nil;
oldVcode := nil;
while np <> nil do (* first free up old values *)
begin
with np↑ do
begin
relExpr(via);
if vclauses <> nil then oldVClauses := vclauses; (* remember WHERE's *)
if vcode <> nil then oldVcode := vcode; (* need to remember old code *)
np := next;
end;
if np <> nil then
if (np↑.ntype <> pttype) or (not np↑.vlist) then np := nil;
end;
with curToken do
repeat
with n↑ do
begin
if jointp then via := checkArg(e3eExprParse,svaltype)
else if ntype = viaptnode then via := checkArg(e3eExprParse,transtype)
else if movep then
begin
via := e3eExprParse;
if getdtype(via) <> vectype then via := checkArg(via,transtype);
end
else via := checkArg(e3eExprParse,svaltype);
if jointp then dimCheck(via,angledim↑.dim)
else dimCheck(via,distancedim↑.dim);
vclauses := nil;
vcode := nil;
getToken;
end;
if (ttype = delimtype) and (ch = ',') then
begin (* need to add a new via point *)
if n↑.next = nil then b := true
else b := (n↑.next↑.ntype <> pttype) or (not n↑.next↑.vlist);
if b then
begin (* make up a new node *)
np := newNode;
with np↑ do
begin
ntype := pttype; (* VIA or BY point *)
next := n↑.next;
vlist := true;
end;
n↑.next := np;
n := np;
end
else n := n↑.next; (* just re-use next VIA/BY list node *)
b := false;
end
else b := true;
until b;
n↑.vclauses := oldVClauses; (* keep tabs on associated WHERE clauses *)
n↑.vcode := oldVcode; (* and also on any associated code *)
np := n↑.next;
while np <> nil do (* flush any extra via list nodes *)
with np↑ do
if (ntype = pttype) and vlist then
begin no := np; np := next; relNode(no); n↑.next := np end
else np := nil;
backup := true;
end
else if ntype = commentnode then
begin
while str <> nil do (* release old comment string *)
begin strp := str↑.next; relStrng(str); str := strp end;
curChar := 1;
maxChar := maxChar + 9;
flushComments := false;
getToken; (* get the comment *)
flushComments := true;
length := curToken.len; (* don't even need to check it?!? *)
str := curToken.str;
end
else
begin (* a WITH clause *)
case ntype of (* release old expressions *)
deprnode,
apprnode: relExpr(loc);
durnode: relExpr(durval);
velocitynode,
sfacnode,
wobblenode,
swtnode: relExpr(clval);
ffnode: relExpr(ff);
forcenode: begin relExpr(fval); relExpr(fvec); relExpr(fframe); end;
stiffnode: begin relExpr(fv); relExpr(mv); relExpr(cocff); end;
otherwise {do nothing};
end;
np := clauseParse(n,false);
end;
moveOrder(cursorStack[cursor-1].st);
end;