COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	{$NOMAIN	Editor:  Expression parser routine }
C00005 00003	(* aux routines for parsing expressions(cont): eGetArgs *)
C00019 00004	(* function to parse expressions: eExprParse *)
C00036 ENDMK
C⊗;
{$NOMAIN	Editor:  Expression parser routine }

%include eparse.hdr;

{ Externally defined routines from elsewhere: }

	(* From ALLOC *)
function newNode: nodep;					external;
procedure relNode(n: nodep);					external;

	(* From PAUX1 *)
function getDtype(n: nodep): datatypes;				external;
function checkArg(n: nodep; d: datatypes): nodep;		external;
function copyExpr(n: nodep; lcp: boolean): nodep;		external;
function defNode(d: datatypes): nodep;				external;

	(* From PAUX2 *)
function getdim(n: nodep; var d: nodep): nodep;			external;

	(* From EAUX1A *)
function eMakeUVar(vartype: datatypes; vid: identp): varidefp;	external;
function eVarLookup(id: identp): varidefp;			external;

	(* From ETOKEN *)
procedure eGetToken;						external;
procedure eGetDelim(char: ascii);				external;
procedure eDimCheck(n,d: nodep);				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;

(* aux routines for parsing expressions(cont): eGetArgs *)

function eExprParse: nodep; external;		{also FORWARD}

procedure eGetArgs(opn: nodep); external;
procedure eGetArgs;
var arg,n,np,nhdr,d: nodep; nargs,i: integer; dch: ascii; dat: datatypes;
    absp,aref,func,qp,closep,b,bp: boolean; paramlist,v: varidefp;

 procedure check1(d: datatypes);
  begin
  opn↑.arg1 := checkArg(opn↑.arg1,d); (* check datatype is right *)
  end;

 procedure check2(d1,d2: datatypes);
  begin
  with opn↑ do
   begin
   arg1 := checkArg(arg1,d1);	  (* check datatype is right for first arg *)
   arg2 := checkArg(arg2,d2);	  (* and also check second *)
   end;
  end;

 procedure check3(d1,d2,d3: datatypes);
  begin
  with opn↑ do
   begin
   arg1 := checkArg(arg1,d1);	  (* check datatype is right for first arg *)
   arg2 := checkArg(arg2,d2);	  (* and also check second *)
   arg3 := checkArg(arg3,d3);	  (* and also check third *)
   end;
  end;

begin
with opn↑ do
 begin
 if not ((op=arefop) or (op=callop)) then arg1 := nil;
 arg2 := nil;
 arg3 := nil
 end;
if (opn↑.op = grinchop) then			(* grinch is special *)
  begin
  i := cursor;
  b := false;
  repeat
   with cursorStack[i] do
    if stmntp then b := (movetype <= st↑.stype) and (st↑.stype <= centertype);
   i := i - 1;
  until (i = 1) or b;
  if b then
    opn↑.arg1 := copyExpr(cursorStack[i+1].st↑.cf,true)	(* copy control frame *)
   else
    begin
    pp20L(' Grinch can only occ',20); pp20('ur in a motion state',20);
    pp5('ment.',5); ppLine;
    opn↑.op := badop;
    opn↑.arg1 := newNode;
    opn↑.arg2 := defNode(transtype);
    with opn↑.arg1↑ do
     begin
     ntype := exprnode;
     op := grinchop;
     arg1 := opn↑.arg2;
     arg2 := nil;
     arg3 := nil;
     end
    end
  end
 else if (opn↑.op <> inscalarop) then		(* expecting some args *)
  begin
  i := 0;
  nhdr := nil;
  d := nil;
  nargs := 1;
  absp := false;
  aref := false;
  func := false;
  qp := false;
  closep := true;
  b := true;
  paramlist := nil;
  case opn↑.op of
atan2op,
tmakeop,
fmakeop,
vsaxwrop,
dacop:	nargs := 2;
vmakeop,
constrop: nargs := 3;
queryop: begin
	 qp := true;
	 nargs := 99;			(* variable number of args *)
	 end;
absop:	absp := true;
arefop:	begin
	aref := true;
	n := opn↑.arg1↑.vari↑.a;	(* check it's defined *)
	if n = nil then nargs := 1 else nargs := n↑.numdims;
	end;
callop:	begin
	func := true;
	nargs := 0;
	n := opn↑.arg1↑.vari↑.p;	(* see if procedure is defined *)
	if n <> nil then
	  begin
	  paramlist := n↑.paramlist;
	  if paramlist = nil then closep := false;
	  end;
	end;
otherwise {do nothing};
   end;
  if not absp then
    begin
    eGetToken;			(* looking for opening '(' or '[' *)
    if aref then dch := '[' else dch := '(';
    with eCurToken do
     if (ttype <> delimtype) or (ch <> dch) then  (* not there - complain *)
      begin
      eBackup := true;
      if opn↑.op = timeop then
	begin
	b := false;		(* don't bother looking for args *)
	closep := false;	(* so we know not to expect a closing ')' *)
	opn↑.arg1 := defNode(svaltype);	(* use zero *)
	i := 1;
	end
       else if qp or not closep then  (* query doesn't need to take any args *)
	begin
	b := false;		(* don't bother looking for args *)
	closep := false;	(* so we know not to expect a closing ')' *)
	end
       else
	begin
	pp10(' Need a " ',9); ppChar(dch); pp10('" here.   ',7); ppLine;
	end;
      end;
    end;
  while b do
   begin					(* get the next argument *)
   if paramlist = nil then arg := eExprParse	(* implies (not func) *)
    else if paramlist↑.tbits <> 5 then arg := eExprParse
    else
     with eCurToken do
      begin			(* looking for array passed by reference *)
      eGetToken;
      bp := ttype = identtype;
      if bp then
	begin			 (* is it a defined variable and an array? *)
	v := eVarLookup(id);
	if v <> nil then bp := (v↑.vtype <> pconstype) and odd(v↑.tbits)
	 else bp := false;
	end;
      if bp then
	begin
	arg := newNode;
	arg↑.ntype := leafnode;
	arg↑.ltype := varitype;
	arg↑.vari := v;
	arg↑.vid := v↑.name;
	end
       else				(* no good *)
	begin
	pp20L(' Need an array varia',20); pp10('ble here  ',8); ppLine;
	arg := nil;
	end;
      end;
   if arg <> nil then		(* got one *)
     begin
     i := i + 1;
     if func or aref or qp then	(* add to arg list *)
       begin
       np := newNode;
       np↑.ntype := listnode;
       if func and (paramlist <> nil) then
	 with paramlist↑ do
	  begin		(* check parameter for correct data type *)
	  np↑.lval := checkArg(arg,vtype);
	  if dtype <> nil then d := dtype↑.dim	(* use dimension if it exists *)
	   else					(* otherwise use default *)
	    if (vtype = transtype) or (vtype = frametype) then
	      d := distancedim↑.dim
	     else if vtype = rottype then d := angledim↑.dim
	     else d := nodim↑.dim;
	  eDimCheck(arg,d);
	  d := nil;
	  paramlist := next;
	  if paramlist = nil then nargs := i;
	  end
	else if aref then
	 begin
	 np↑.lval := checkArg(arg,svaltype);
	 eDimCheck(arg,nodim↑.dim);
	 end
	else np↑.lval := arg;
       if nhdr = nil then nhdr := np else n↑.next := np;
       n := np;
       n↑.next := nil;
       end
      else
       begin
       with opn↑ do
	case i of
    1:	 arg1 := arg;
    2:	 arg2 := arg;
    3:	 arg3 := arg;
	 end;
       end;
     eGetToken;				(* looking for separating ',' *)
     with eCurToken do
      if (ttype <> delimtype) or (ch <> ',') then b := false (* that's it *)
     end
    else b := false;
   end;
  if absp then			(* looking for closing '|' *)
    begin
    with eCurToken do
     if (ttype <> reswdtype) or (rtype <> optype) or (op <> absop) then
      begin			(* not there - complain *)
      eBackup := true;
      pp10(' Need a " ',9); ppChar(chr(174B)); pp10('" here.   ',7); ppLine;
      end;
    if opn↑.arg1 = nil then opn↑.arg1 := defNode(svaltype);
    dat := getdtype(opn↑.arg1);	(* now figure out what sort of || we've got *)
    if dat = svaltype then opn↑.op := sabsop
     else if dat = vectype then opn↑.op := vmagnop
     else opn↑.op := tmagnop;
    end
   else if closep then
    begin
    if aref then dch := ']' else dch := ')';
    eBackup := true;			(* looking for closing ')' or ']' *)
    eGetDelim(dch);
    end
   else eBackup := true;
  if func or aref then		(* store arg list in arg 2 *)
    begin
    while (i < nargs) or (paramlist <> nil) do
     begin		  (* make sure we return the right size arg list *)
     i := i + 1;
     np := newNode;
     np↑.ntype := listnode;
     if func and (paramlist <> nil) then
       begin
       np↑.lval := defNode(paramlist↑.vtype);
       paramlist := paramlist↑.next;
       if paramlist = nil then nargs := i;
       end
      else np↑.lval := defNode(svaltype);
     if nhdr = nil then nhdr := np else n↑.next := np;
     n := np;
     n↑.next := nil;
     end;
    opn↑.arg2 := nhdr;
    end
   else if qp then opn↑.arg2 := nhdr		(* store arg list in arg 2 *)
   else
    with opn↑ do
     case op of		(* check args are of proper type & dimension *)
sqrtop:	  check1(svaltype);
logop,
expop,
asinop,
acosop,
adcop:	  begin
	  check1(svaltype);
	  eDimCheck(arg1,nodim↑.dim);
	  end;
timeop:   begin
	  check1(svaltype);
	  eDimCheck(arg1,timedim↑.dim);
	  end;
sinop,
cosop,
tanop:	  begin
	  check1(svaltype);
	  eDimCheck(arg1,angledim↑.dim);
	  end;
dacop,
atan2op:  begin
	  check2(svaltype,svaltype);
	  eDimCheck(arg1,nodim↑.dim);
	  eDimCheck(arg2,nodim↑.dim);
	  end;
vmakeop:  begin
	  check3(svaltype,svaltype,svaltype);
	  eDimCheck(arg2,getdim(arg1,d));
	  eDimCheck(arg3,d);
	  end;
unitvop:  check1(vectype);
vsaxwrop: begin
	  check2(vectype,svaltype);
	  eDimCheck(arg2,angledim↑.dim);
	  end;
tposop,
torientop,
tinvrtop: check1(transtype);
taxisop:  check1(rottype);
fmakeop,
tmakeop:  begin
	  check2(rottype,vectype);
	  eDimCheck(arg1,angledim↑.dim);
	  if op = fmakeop then eDimCheck(arg2,distancedim↑.dim);
	  end;
deproachop: begin
	  check1(frametype);
	  eDimCheck(arg1,distancedim↑.dim);
	  end;
constrop: begin
	  check3(vectype,vectype,vectype);
	  eDimCheck(arg1,distancedim↑.dim);
	  eDimCheck(arg2,distancedim↑.dim);
	  eDimCheck(arg3,distancedim↑.dim);
	  end;
otherwise {do nothing};
      end;
  if aref then				(* if array, check it's defined *)
   if opn↑.arg1↑.vari↑.a = nil then nargs := i;	(* it's not, assume all ok *)
  if (not qp) and (i <> nargs) then
   begin
   pp10L(' Need     ',6); ppInt(nargs); pp20(' arguments here.    ',16); ppLine;
   end;
  if d <> nil then relNode(d);		(* done with dimension node *)
  end;
end;

(* function to parse expressions: eExprParse *)

function eExprParse; (* : nodep *)
 var expstack, opstack: nodep; precstack: array [0..10] of integer;
     opsp,i,j: integer; n,np: nodep; vp: varidefp; opseen,done,badp: boolean;
     st: statementp;

 function badexpr: nodep;
  var n: nodep;
  begin
  n := newNode;
  badexpr := n;
  with n↑ do
   begin ntype:= exprnode; op:= badop; arg1:= nil; arg2:= newNode; arg3:= nil end;
  n := n↑.arg2;
  with n↑ do begin ntype := leafnode; ltype := transtype; t := niltrans end;
  if not badp then
   begin
   pp20L(' Bad expression     ',15); ppLine;
   badp := true;
   end;
  end;

 function gettype(n: nodep): datatypes;
  var d: datatypes;
  begin
  d := getdtype(n);
  if (d = rottype) or (d = frametype) then d := transtype;
  gettype := d;
  end;

 procedure pushexp(n: nodep);
  begin
  n↑.next := expstack;
  expstack := n;
  end;

 procedure cpushexp(n: nodep);
  begin
  if opseen then pushexp(n)		(* all okay *)
   else
    begin			(* yow! - we just saw an operand - complain *)
    pp20L(' Bad expression - co',20); pp20('nsecutive operands  ',18); ppline;
    end;
  opseen := false;			(* expecting an operator *)
  end;

 function popexp: nodep;
  var n: nodep;
  begin
  if expstack <> nil then
    begin
    n := expstack;
    expstack := expstack↑.next;
    n↑.next := nil;
    popexp := n;
    end
   else
    begin			(* this probably can't happen, but... *)
    pp20L(' Gack! - parse opera',20); pp20('nd expression stack ',20);
    pp10('underflow ',9); ppLine;
    popexp := badexpr;
    end;
  end;

 procedure pushop;
  begin
  if opsp <= 9 then
    begin
    n↑.next := opstack;
    opstack := n;
    opsp := opsp + 1;
    precstack[opsp] := i;
    end
   else
    begin
    pp20L(' Gack! - parse opera',20); pp20('tor expression stack',20);
    pp10(' overflow ',9); ppLine;
    end;
  opseen := true;			(* expecting an operand *)
  end;

 procedure popop;
  var n,n1,d: nodep; d1,d2: datatypes;
  begin (* popop *)
  d := nil;
  n := opstack;
  opstack := n↑.next;
  opsp := opsp - 1;
  with n↑ do
   begin				(* get its operand(s) *)
   next := nil;
   arg3 := nil;
   if (op = negop) or (op = notop) then arg2 := nil
    else
     begin
     arg2 := popexp;
     if expstack = nil then
       begin				(* whoops - wasn't any arg 2 *)
       expstack := arg2;
       arg2 := badexpr;
       end;
     end;
   arg1 := popexp;
   if op <= modop then
     begin
     arg1 := checkArg(arg1,svaltype);		(* check datatypes of args *)
     if op <> notop then arg2 := checkArg(arg2,svaltype);
     if (op <= sneop) or (op >= maxop) then	(* relation, max, min & mod *)
       begin
       if (op <> intop) and (op <> idivop) then	(* don't care about these *)
	 eDimCheck(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
       end
      else if op <= sexpop then			(* check dimensions too *)
       begin					(* args better be dimensionless *)
       eDimCheck(arg1,nodim↑.dim);
       if op <> notop then eDimCheck(arg2,nodim↑.dim);
       end
     end
    else if op = vdotop then
     begin
     arg1 := checkArg(arg1,vectype);
     arg2 := checkArg(arg2,vectype);
     end
    else if op = wrtop then
     begin
     arg1 := checkArg(arg1,vectype);
     arg2 := checkArg(arg2,transtype);
     end
    else if op = ftofop then
     begin
     arg1 := checkArg(arg1,transtype);
     arg2 := checkArg(arg2,transtype);
     eDimCheck(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
     end
    else if op >= addop then	(* need to determine proper op for given args *)
     case op of
negop:	begin				(* see if snegop or vnegop *)
	d1 := getdtype(arg1);
	if d1 = svaltype then op := snegop
	 else if d1 = vectype then op := vnegop
	 else begin n1 := badexpr; n1↑.arg1 := n; n := n1 end;
	end;
addop:	begin
	eDimCheck(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
	d1 := gettype(arg1);
	d2 := gettype(arg2);
	if d1 = undeftype then begin d1 := d2; arg1↑.vari↑.vtype := d1 end;
	if d2 = undeftype then
	  begin
	  if d1 = transtype then d2 := vectype else d2 := d1;
	  arg2↑.vari↑.vtype := d2
	  end;
	if (d1 = svaltype) and (d2 = svaltype) then op := saddop
	 else if (d1 = vectype) and (d2 = vectype) then op := vaddop
	 else if (d1 = transtype) and (d2 = vectype) then op := tvaddop
	 else begin op := saddop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
	end;
subop:	begin
	eDimCheck(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
	d1 := gettype(arg1);
	d2 := gettype(arg2);
	if d1 = undeftype then begin d1 := d2; arg1↑.vari↑.vtype := d1 end;
	if d2 = undeftype then
	  begin
	  if d1 = transtype then d2 := vectype else d2 := d1;
	  arg2↑.vari↑.vtype := d2
	  end;
	if (d1 = svaltype) and (d2 = svaltype) then op := ssubop
	 else if (d1 = vectype) and (d2 = vectype) then op := vsubop
	 else if (d1 = transtype) and (d2 = vectype) then op := tvsubop
	 else begin op := ssubop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
	end;
mulop:	begin
	d1 := gettype(arg1);
	d2 := gettype(arg2);
	if d1 = undeftype then begin d1 := d2; arg1↑.vari↑.vtype := d1 end;
	if d2 = undeftype then begin d2 := d1; arg2↑.vari↑.vtype := d2 end;
	if (d1 = svaltype) and (d2 = svaltype) then op := smulop
	 else if (d1 = svaltype) and (d2 = vectype) then op := svmulop
	 else if (d1 = vectype) and (d2 = svaltype) then op := vsmulop
	 else if (d1 = vectype) and (d2 = vectype) then op := crossvop
	 else if (d1 = transtype) and (d2 = vectype) then op := tvmulop
	 else if (d1 = transtype) and (d2 = transtype) then op := ttmulop
	 else begin op := smulop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
        if (op = ttmulop) or (op = tvmulop) then
	 eDimCheck(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
	end;
divop:	begin
	d1 := gettype(arg1);
	d2 := gettype(arg2);
	if d1 = undeftype then
	  begin d1 := svaltype; arg1↑.vari↑.vtype := d1 end;
	if d2 = undeftype then
	  begin d2 := svaltype; arg2↑.vari↑.vtype := d2 end;
	if (d1 = svaltype) and (d2 = svaltype) then op := sdivop
	 else if (d1 = vectype) and (d2 = svaltype) then op := vsdivop
	 else begin op := sdivop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
	end;
otherwise {do nothing};
     end;
   pushexp(n);		(* save it as operand for next operator *)
   if d <> nil then relNode(d);
   end;
  end (* popop *);

 function opprecedence(op: exprtypes): integer;
  var i: integer;
  begin
  i := 0;
    case op of
eqvop:	i := 1;
orop,
xorop:	i := 2;
andop:	i := 3;
sltop,
sleop,
seqop,
sgeop,
sgtop,
sneop:	i := 4;
addop,
subop:	i := 5;
wrtop:	i := 6;
mulop,
divop,
maxop,
minop,
idivop,
modop,
vdotop: i := 7;
sexpop,
ftofop:	i := 8;
negop,
notop:	i := 9;
otherwise {do nothing};
   end;
  opprecedence := i;
  end;

 begin (* eExprParse *)
 expstack := nil;
 opstack := nil;
 opsp := 0;
 precstack[0] := -1;
 done := false;
 opseen := true;			(* expecting an operand *)
 badp := false;			(* haven't complained about expression yet *)

 repeat
 eGetToken;
 with eCurToken do
  begin
  case ttype of				(* see what we've got *)
labeldeftype:
    begin done := true; eBackup := true end;
delimtype:
    if ch = '(' then
      begin
      cpushexp(eExprParse);		(* get the parenthesized expression *)
      eGetDelim(')');			(* get the closing ')' *)
      end
     else begin done := true; eBackup := true end;
reswdtype:
    if rtype <> optype then begin done := true; eBackup := true end
     else if not opseen and (op = absop) then
      begin done := true; eBackup := true end
     else if not (opseen and (op = addop)) then	(* we want to ignore unary + *)
      begin
      if opseen and (op = subop) then op := negop;
      n := newNode;
      n↑.ntype := exprnode;
      n↑.op := op;
      i := opprecedence(op);
      if i = 0 then			(* really an operand *)
	begin
	eGetArgs(n);			(* get any arguments op needs *)
	cpushexp(n);			(* save operand for its operator *)
	end
       else if opseen and ((op <> negop) and (op <> notop)) then
	begin			(* yow! - we just saw an operator - complain *)
	pp20L(' Bad expression - co',20); pp20('nsecutive operators ',19); ppLine;
	end
       else if i > precstack[opsp] then (* higher precedence so push on stack *)
	pushop
       else				(* lower precedence *)
	begin
	while (i <= precstack[opsp]) and (i < 9) do popop; (* 9 = prec(not,neg) *)
	pushop;
	end;
      end;
constype: cpushexp(cons);
identtype:
    begin
    vp := eVarLookup(id);
    if vp = nil then
      begin				(* undefined variable *)
      vp := eMakeUVar(undeftype,id);	(* define it somewhat *)
      eGetToken;	(* see if it's supposed to be a procedure or array *)
      eBackup := true;		(* we're just peeking *)
      if newVarOk then pp10L(' Undeclare',10);
      if (ttype = delimtype) and ((ch = '(') or (ch = '[')) then
	if ch = '[' then
	  begin
	  vp↑.tbits := 1;	(* array *)
	  vp↑.a := nil;
	  if newVarOk then pp20('d array variable    ',16);
	  end
	 else
	  begin
	  vp↑.tbits := 2;	(* procedure *)
	  vp↑.p := nil;
	  if newVarOk then pp20('d procedure         ',11);
	  end
       else if newVarOk then pp10('d variable',10);
      if newVarOk then
	begin pp20(' - will try to defin',20); pp5('e it.',5); ppLine end;
      end;
    if vp↑.vtype = pconstype then		(* constant *)
      begin
      np := newNode;			(* need to make a pointer to it *)
      with np↑ do
	begin
	ntype := leafnode;
	ltype := pconstype;
	cname := vp;
	pcval := vp↑.c;
	end;
      cpushexp(np);
      end
     else if odd(vp↑.tbits) or (vp↑.tbits = 2) then
      begin			(* array reference or procedure call *)
      n := newNode;
      with n↑ do
	begin
	ntype := exprnode;
	if odd(vp↑.tbits) then op := arefop else op := callop;
	arg1 := newNode;
	end;
      with n↑.arg1↑ do
	begin
	ntype := leafnode;
	ltype := varitype;
	vari := vp;
	vid := vp↑.name;
	end;
      eGetArgs(n);		(* get subscripts/parameters *)
      cpushexp(n);
      end
     else				(* variable *)
      begin
      n := newNode;
      with n↑ do
	begin
	ntype := leafnode;
	ltype := varitype;
	vari := vp;
	vid := vp↑.name;
	end;
      cpushexp(n);
      end;
    end;
otherwise {do nothing};
   end {case};
  end {with};
 until done;

 while opsp > 0 do popop;		(* bind the rest of the operators *)
 if expstack <> nil then eExprParse := popexp (* return what's left on stack *)
  else eExprParse := nil;
 while expstack <> nil do relNode(popexp);  (* probably don't need, but... *)
 end;