COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	{$NOMAIN	Editor: Reparsing routine & Stmnt delete routine }
C00006 00003	(* aux routine: addNewDeclarations *)
C00010 00004	(* aux routine: reParse *)
C00023 00005	(* delStmnt *)
C00036 ENDMK
C⊗;
{$NOMAIN	Editor: Reparsing routine & Stmnt delete routine }

%include eparse.hdr;

{ Externally defined routines from elsewhere: }

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

	(* From FREE *)
procedure freeNode(n: nodep);					external;
procedure freeStatement(s: statementp);				external;

	(* From EROOT:  Inter-overlay calls *)
function e3dExprParse: nodep;					external;

	(* From PAUX1 *)
function getDtype(n: nodep): datatypes;				external;
function checkArg(n: nodep; d: datatypes): nodep;		external;

	(* From PAUX2 *)
function getdim(n: nodep; var d: nodep): nodep;			external;
function evalOrder(what,last: nodep; pcons: boolean): nodep;	external;
procedure relExpr(n: nodep);					external;

	(* From EAUX1A *)
procedure clearLine(i: integer);				external;
procedure pushStmnt(s: statementp; indent: integer);		external;
procedure pushNode(n: nodep);					external;
procedure borderLines;						external;

	(* From EPUT *)
procedure putLine;						external;
procedure putexpr(n: nodep; opp: integer);			external;

	(* From EAUX2A *)
procedure eMakeNewVar(newvar: varidefp);			external;
procedure flushVar(oldvar: varidefp);				external;

	(* From EAUX2C *)
procedure displayLines(var pfrom: integer);			external;
procedure insertLines(start,number,coff: integer);		external;
procedure deleteLines(start,number,coff: integer);		external;

	(* From EPUTST *)
procedure putstmnt(s: statementp; indent, plevel: integer);	external;

	(* From EMOVEO *)
procedure moveOrder(st: statementp);				external;

	(* From ETOKEN *)
procedure eDimCheck(n,d: nodep);				external;

	(* From PP *)
procedure relLine(l: linerecp);					external;
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;

	(* From DISP *)
procedure showCursor(line,col: integer); 			external;


procedure ePar3dGet; external;
procedure ePar3dGet;  begin end;

(* aux routine: addNewDeclarations *)

function addNewDeclarations: integer; external;
function addNewDeclarations;
 var s,sp: statementp; i,j,l: integer;
 begin
 l := 0;
 if newDeclarations <> nil then
   begin				(* deal with any new declarations *)
   s := newDeclarations;
   while s↑.stype <> blocktype do	(* find block they're in *)
    begin sp := s; s := s↑.last; l := l + 1 end;
   with s↑ do
    begin
    bcode↑.last := newDeclarations;
    bcode := sp;			(* splice us into block *)
    end;
   j := cursor;
   i := 1;
   while (j > i) do 
    with cursorStack[j] do
     if stmntp and (st = s) then i := j
      else begin cline := cline + l; j := j - 1; end;
   with cursorStack[i] do
    begin
    if cline < lineNum then lineNum := lineNum + l;
    if cline < topDline then
      begin
      topDline := topDline + l;
      botDline := botDline + l;
      for j := 1 to i do
       with cursorStack[j] do                      (* update line counts *)
	if stmntp then st↑.nlines := st↑.nlines + l;
      end
     else if cline < botDline then
      begin		
      insertLines(cline+1,l,cursor-i);
      curLine := cline;			(* set up for putStmnt *)
      firstLine := curLine + 1;
      lastLine := curline + l;
      s := s↑.bcode;
      for j := 1 to l do
       begin
       if s↑.variables↑.vtype = undeftype then
	 begin
(* *** probably should ask the luser to define it, but... *** *)
	 s↑.variables↑.vtype := svaltype;
	 end;
(* *** especially need to ask for array bounds *** *)
(* ***  & if procedure do something to set up a reasonable definition *** *)
       putStmnt(s,ind,99);		(* write out the declaration *)
       eMakeNewVar(s↑.variables);	(* if active block make env entry for var *)
       s := s↑.next;
       end;
      putLine;				(* force last line to be written out *)
      end;
    end;
   cursorLine := cursorLine + l;
   if ocur > 0 then ocur := ocur + l;
   borderLines;
   newDeclarations := nil;
   end;
  showCursor(cursorLine-topDline-firstDline+2,1);
  addNewDeclarations := l;
  end;

(* aux routine: reParse *)

procedure reParse(st: statementp); external;
procedure reParse;
 var i: integer; v: varidefp; lexp: nodep;

 procedure reParseAux(st: statementp);
  var s: statementp; n,np: nodep; d: datatypes;

  function reExpr(n,dim: nodep; d: datatypes): nodep;
   var i: integer;
   begin (* reExpr *)
   if n <> nil then
     begin
     if (n↑.ntype = exprnode) or 
	((n↑.ntype = leafnode) and (n↑.ltype = varitype)) then
       begin
       lbufp := 0;
       putExpr(n,0);			(* write expression into lbuf *)
       relExpr(n);			(* flush old expression *)
       for i := 1 to lbufp do		(* copy expression for getToken *)
	 listing[i] := lbuf[i];
       listing[lbufp+1] := ' ';
       curChar := 1;
       maxChar := lbufp + 1;
       endOfLine := false;
       eBackup := false;
       expandMacros := true;
       n := e3dExprParse;			(* parse new expression *)
       if n <> nil then
	 with n↑ do
	  if ntype = exprnode then elength := lbufp
	   else if (ntype = leafnode) and (ltype = svaltype) then wid := lbufp;
       if d <> nulltype then n := checkArg(n,d);	(* datatype still ok? *)
       if dim <> nil then eDimCheck(n,dim);	(* do dimensions still match? *)
       end;
     end;
   reExpr := n;
   end (* reExpr *);

  procedure reCmon(st: statementp); forward;

  procedure reClause(n: nodep);
   var d: datatypes;
   begin (* reClause *)
   with n↑ do
    case ntype of
deprnode,
apprnode,
destnode:	begin
		if ntype <> destnode then d := nulltype
		 else if st↑.stype = movetype then d := transtype
		 else d := svaltype;
		loc := reExpr(loc,distancedim↑.dim,d);
		reParseAux(code);
		end;
viaptnode:	begin
		via := reExpr(via,distancedim↑.dim,transtype);
		duration := reExpr(duration,timedim↑.dim,svaltype);
		velocity := reExpr(velocity,veldim↑.dim,vectype);
		reParseAux(code);
		end;
durnode:	begin
		durval := reExpr(durval,timedim↑.dim,svaltype);
		end;
sfacnode,
wobblenode,
swtnode:	begin
		clval := reExpr(clval,nil,svaltype);
		end;
ffnode:		begin
		ff := reExpr(ff,nil,transtype);
		end;
forcenode:	begin
		fval := reExpr(fval,nil,svaltype);
		fvec := reExpr(fvec,nil,vectype);
		if fframe <> nil then reClause(fframe);
		end;
stiffnode:	begin
		fv := reExpr(fv,nil,vectype);
		mv := reExpr(mv,nil,vectype);
		coc := reExpr(coc,nil,transtype);
		end;
cmonnode:	begin
		reCmon(cmon);
		end;
otherwise 	{do nothing};
     end;
   end (* reClause *);

  procedure reCmon (* st: statementp *);
   begin (* reCmon *)
   with st↑, oncond↑ do
    begin
    if (ntype = durnode) or (ntype = forcenode) then reClause(oncond)
     else if (ntype = exprnode) or (ntype = leafnode) then
      begin
      oncond := reExpr(oncond,nil,nulltype);
      exprCm := getDtype(oncond) <> eventtype;
      end;
    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;
    reParseAux(conclusion);
    end;
   end (* reCmon *);

  begin (* reParseAux *)
  if st <> nil then
    with st↑ do
     case stype of
blocktype:	begin
		pushStmnt(st,0);		(* for var lookup *)
		s := bcode;
		while s <> nil do begin reParseAux(s); s := s↑.next end;
		cursor := cursor - 1;
		end;
declaretype:	begin
		with variables↑ do
		 if tbits = 2 then		(* check for procedure *)
		   begin
		   pushNode(p);			(* for var lookup *)
		   reParseAux(p↑.body);
		   cursor := cursor - 1;
		   end;
		end;
coblocktype:	begin
		n := threads;
		while n <> nil do begin reParseAux(n↑.cstmnt); n := n↑.next end;
		end;
fortype:	begin
		forvar := reExpr(forvar,nil,svaltype);
		n := nil;
		n := getdim(forvar,n);
		initial := reExpr(initial,n,svaltype);
		step := reExpr(step,n,svaltype);
		final := reExpr(final,n,svaltype);
		relNode(n);
		reParseAux(fbody);
		with forvar↑ do
		 if ntype = leafnode then n := nil
		  else n := evalOrder(arg2,nil,true);  (* push array subscripts *)
		n := evalOrder(initial,n,true);
		n := evalOrder(step,n,true);
		exprs := evalOrder(final,n,true);
		end;

whiletype,
untiltype:	begin
		cond := reExpr(cond,nil,svaltype);
		exprs := evalOrder(cond,nil,true);
		reParseAux(body);
		end;
casetype:	begin
		index := reExpr(index,nil,svaltype);
		exprs := evalOrder(index,nil,true);
		n := caselist;
		s := nil;
		while n <> nil do
		 begin
		 if n↑.stmnt <> s then reParseAux(n↑.stmnt);
		 s := n↑.stmnt;
		 n := n↑.next;
		 end;
		end;
iftype:		begin
		icond := reExpr(icond,nil,svaltype);
		exprs := evalOrder(icond,nil,true);
		reParseAux(thn);
		reParseAux(els);
		end;
pausetype:	begin
		ptime := reExpr(ptime,timedim↑.dim,svaltype);
		exprs := evalOrder(ptime,nil,true);
		end;
prompttype,
printtype,
aborttype:	begin
		n := plist;
		while n <> nil do
		 begin
		 n↑.lval := reExpr(n↑.lval,nil,nulltype);
		 n := n↑.next;
		 end;
		exprs := evalOrder(plist,nil,false);
		end;
returntype:	begin		(*** * should check what procedure wants *** *)
		retval := reExpr(retval,nil,nulltype);
		exprs := evalOrder(retval,nil,true);
		end;
calltype:	begin
		what := reExpr(what,nil,nulltype);
		exprs := evalOrder(what,nil,true);
		end;
assigntype:	begin
		what := reExpr(what,nil,nulltype);
		n := nil;
		n := getDim(what,n);
		d := getDtype(what);
		if d = frametype then d := transtype;
		aval := reExpr(aval,n,d);
		relNode(n);
		with what↑ do
		 if ntype = leafnode then n := nil
		  else if op = arefop then n := arg2
		  else if arg1↑.ntype = leafnode then n := nil
		  else n := arg1↑.arg2;
		if n <> nil then
		  n := evalorder(n,nil,true);  (* deal with subscripts *)
		exprs := evalorder(aval,n,true);
		end;
affixtype,
unfixtype:	begin
		frame1 := reExpr(frame1,nil,frametype);
		frame2 := reExpr(frame2,nil,frametype);
		byvar := reExpr(byvar,distancedim↑.dim,transtype);
		atexp := reExpr(atexp,distancedim↑.dim,transtype);
		with frame1↑ do
		 if ntype = leafnode then n := nil
		  else n := evalOrder(arg2,nil,true);  (* push array subscripts *)
		with frame2↑ do
		 if ntype <> leafnode then n := evalOrder(arg2,n,true);
		if byvar <> nil then
		 with byvar↑ do
		  if ntype <> leafnode then n := evalOrder(arg2,n,true);
		if atexp <> nil then exprs := evalOrder(atexp,n,true)
		  else exprs := n;
		end;
signaltype,
waittype:	begin
		event := reExpr(event,nil,eventtype);
		if event↑.ntype <> leafnode then exprs := nil
		 else exprs := evalOrder(event↑.arg2,nil,true);
		end;
movetype,
operatetype,
opentype,
closetype,
centertype,
stoptype:	begin
		pushStmnt(st,0);		(* so grinch can be parsed *)
		cf := reExpr(cf,nil,nulltype);
		n := clauses;
		while n <> nil do
		 begin reClause(n); n := n↑.next end;
		moveOrder(st);
		cursor := cursor - 1;
		end;
cmtype:		begin
		reCmon(st);
		end;
wristtype:	begin
		fvec := reExpr(fvec,forcedim↑.dim,vectype);
		tvec := reExpr(tvec,torquedim↑.dim,vectype);
		n := nil;
		with fvec↑ do
		 if (ntype = exprnode) and (op = arefop) then
		   n := evalorder(arg2,n,true);	(* deal with subscripts *)
		with tvec↑ do
		 if (ntype = exprnode) and (op = arefop) then
		   n := evalorder(arg2,n,true);	(* deal with subscripts *)
		exprs := n;
		end;
otherwise 	{do nothing};
      end;
  end (* reParseAux *);

 begin (* reParse *)
 pp20L('Need to reparse...  ',18); ppLine;
 if st↑.stype = blocktype then
   begin
   v := st↑.variables;	(* need to push any array bounds info *)
   lexp := nil;
   while v <> nil do
    begin
    if v↑.tbits = 1 then lexp := evalOrder(v↑.a↑.bounds,lexp,false);
    v := v↑.next;
    end;
   st↑.exprs := lexp;
   end;
 reParseAux(st);
 lbufp := 0;
 i := addNewDeclarations;
 topDline := 0;					(* flush old display *)
 botDline := 0;
 displayLines(lineNum);				(* & redraw it *)
 end (* reParse *);

(* delStmnt *)

procedure delStmnt(arg: integer); external;
procedure delStmnt;
 var s,sp,so: statementp; n,np,no: nodep; v,vp: varidefp;
     ocur,i,j,dlines: integer; b,bv,reparsep: boolean;

 procedure resetPC(i,f:integer; st: statementp);
  var j: integer; p: pdbp;
  begin
  for j := 0 to debugLevel do
   begin	(* make sure no process is about to execute stmnt we're deleting *)
   if j = 0 then p := allPdbs else p := debugPdbs[j];
   while p <> nil do		(* run through all the active processes *)
    with p↑ do
     begin
     if (i <= linenum) and (linenum <= f) then
       begin
 (* *** check if we need to remove any fornodes from process stack *** *)
       spc := st;
       linenum := i;
       end;
     p := next;
     end;
   end;
  end;

 function newEmptyStmnt: statementp;
  var st: statementp; l: integer;
  begin
  st := newStatement;
  dlines := sp↑.nlines - 1;
  with st↑ do
   begin
   stype := emptytype;
   last := cursorStack[cursor-1].st;
   next := sp↑.next;
   end;
  if sp↑.stlab <> nil then sp↑.stlab↑.s := nil;	(* label points nowhere now *)
  resetPC(cursorLine,cursorLine + sp↑.nlines,st);
  freeStatement(sp);			(* delete old body *)
  ocur := cursorLine;			(* so we print out empty stmnt *)
  l := cursorLine - topDline + 1;
  relLine(lines[l]);			(* free up old line *)
  lines[l] := nil;
  cursorLine := cursorLine + 1;
  newEmptyStmnt := st;
  end;

 begin
 dlines := 0;
 ocur := 0;
 with cursorStack[cursor] do		(* don't care if it's a proc def *)
  if (not stmntp) and (nd↑.ntype = procdefnode) then cursor := cursor - 1
   else if stmntp and (st↑.stype = cmtype) then
    with cursorStack[cursor-1] do
     if (not stmntp) and (nd↑.ntype = cmonnode) then cursor := cursor - 1;

 with cursorStack[cursor] do
  begin					(* see what we're deleting *)
  if not stmntp then
    begin			(* case labels or motion clauses *)
    if nd↑.ntype = clistnode then
      begin				(* case labels *)
(* *** later *** *)
      end
     else
      begin				(* motion clauses *)
      np := nd;
      sp := cursorStack[cursor-1].st;
      n := sp↑.clauses;			(* find clause in list *)
      b := n = np;			(* deleting first clause? *)
      if (not b) and (n <> nil) then	(* find clause *)
        while (n↑.next <> nil) and (n↑.next <> np) do n := n↑.next;
      j := 1;
      while (j <= arg) and (np <> nil) do
       begin				(* delete them *)
       if np↑.ntype = viaptnode then
	 begin				(* check if via list *)
	 bv := np↑.next <> nil;
	 while bv do
	  with np↑.next↑ do
	   if (ntype = viaptnode) and vlist then
	     begin
	     no := np↑.next;
	     bv := next <> nil;
	     np↑.next := nil;
	     freeNode(np);		(* flush front part of via list *)
	     np := no;
	     end
	    else bv := false;
	 end;
       with np↑ do
	begin
	if (ntype = viaptnode) and (vcode <> nil) then
	  if vcode↑.stype = signaltype then i := 1
	   else
	    begin
	    i := vcode↑.conclusion↑.nlines;
	    flushVar(vcode↑.cdef);		(* flush the cmon variable *)
	    end
	 else if ((ntype = deprnode) or (ntype = apprnode)) and (code <> nil) then
	  if code↑.stype = signaltype then i := 1
	   else
	    begin
	    i := code↑.conclusion↑.nlines;
	    flushVar(code↑.cdef);		(* flush the cmon variable *)
	    end
	 else if ntype = cmonnode then
	  begin
	  i := cmon↑.nlines;
	  flushVar(cmon↑.cdef);		(* flush the cmon variable *)
	  end
	 else i := 0;
	dlines := dlines + i + 1;	(* how many lines are we deleting *)
	no := next;
	next := nil;	(* so freeNode doesn't clobber remaining clauses *)
	end;
       freeNode(np);
       np := no;
       j := j + 1;
       end;
      if b then sp↑.clauses := np		(* splice in last clauses *)
       else if n <> nil then n↑.next := np;
      moveOrder(sp);
      end
    end
   else
    begin
    sp := st;
    if (sp↑.stype = iftype) and (fieldNum = 2) then
      begin					(* flush ELSE *)
      dlines := sp↑.els↑.nlines + 1;
      resetPC(cursorLine+1,cursorLine + sp↑.els↑.nlines,sp↑.next);
      freeStatement(sp↑.els);
      sp↑.els := nil;
      sp↑.nlines := sp↑.nlines - dlines;
      end
     else if (sp↑.stype = affixtype) and (fieldNum = 5) then
      begin					(* flush atexp *)
      sp↑.atexp := nil;
      sp↑.nlines := sp↑.nlines - 1;
      dlines := 1;
      end
     else if ((prompttype <= sp↑.stype) and (sp↑.stype <= aborttype)) and
	     (fieldNum > 1) then
      begin					(* part of plist *)
(* *** yech!!! *** *)
      end
     else if (sp↑.stype = endtype) or (sp↑.stype = coendtype) then
      begin					(* no good *)
      pp20L('Can''t delete END or ',20); pp5('COEND',5); ppLine;
      end
     else
      with cursorStack[cursor-1] do
       if stmntp then
         case st↑.stype of
blocktype: begin
	   reparsep := false;
	   j := 1;
	   b := st↑.bcode = sp;			(* first stmnt in block? *)
	   while (j <= arg) and (sp↑.stype <> endtype) do
	    begin
	    dlines := dlines + sp↑.nlines;
	    if sp↑.stype = declaretype then
	      begin				(* flush the variables *)
	      reparsep := true;
	      v := sp↑.variables;
	      while v <> nil do
	       begin
	       vp := v↑.dnext;
	       flushVar(v);
	       v := vp;
	       end;
	      end
	     else if sp↑.stype = cmtype then
	      begin				(* flush the cmon variable *)
	      flushVar(sp↑.cdef);
	      end
	     else if sp↑.stype = dimdeftype then
	      begin			(* flush the dimension variable *)
	      flushVar(sp↑.dimname);
	      end
	     else if sp↑.stype = definetype then
	      begin			(* flush the macro variable *)
	      flushVar(sp↑.macname);
	      end;
	    so := sp↑.next;
	    so↑.last := sp↑.last;		(* splice block out of list *)
	    if b then st↑.bcode := so else sp↑.last↑.next := so;
	    if sp↑.stlab <> nil then sp↑.stlab↑.s := nil; (* update label *)
	    resetPC(cursorLine,cursorLine + sp↑.nlines,sp↑.next);
	    freeStatement(sp);			(* delete it *)
	    sp := so;
	    j := j + 1;
	    end;
	   if reparsep then
	     begin				(* need to reparse block *)
	     for i := 1 to cursor - 1 do	(* update cursor stack *)
	      with cursorStack[i] do
	       if stmntp then st↑.nlines := st↑.nlines - dlines;
	     reParse(curBlock);
	     if dprog↑.nlines < dispHeight then
	       for i := dprog↑.nlines + 1 to dprog↑.nlines + dlines do
		if i <= dispHeight then clearLine(i+1);
	     dlines := 0;		(* reParse will fix up the screen *)
	     end;
	   end;
coblocktype: begin	(* *** if active then kill sprouted processes *** *)
	   end;
iftype:    if st↑.thn = sp then st↑.thn := newEmptyStmnt
	    else st↑.els := newEmptyStmnt;
fortype:   st↑.fbody := newEmptyStmnt;
whiletype,
untiltype: st↑.body := newEmptyStmnt;
cmtype:    st↑.conclusion := newEmptyStmnt;
otherwise {do nothing};
	  end
	else if nd↑.ntype = colistnode then
	 begin				(* coblock *)
	 so := sp↑.last;
	 if so↑.nthreads = 1 then	(* only statement in coblock? *)
	   nd↑.cstmnt := newEmptyStmnt	(* yes - replace with an empty stmnt *)
	  else
	   begin			(* delete statement from coblock *)
	   dlines := dlines + sp↑.nlines;
	   if sp↑.stlab <> nil then sp↑.stlab↑.s := nil; (* update label *)
(* *** If active then kill process *** *)
	   resetPC(cursorLine,cursorLine + sp↑.nlines,sp↑.next);
	   freeStatement(sp);		(* delete it *)
	   if nd↑.next <> nil then nd↑.next↑.prev := nd↑.prev;
	   if nd↑.prev <> nil then nd↑.prev↑.next := nd↑.next
	    else so↑.threads := nd↑.next;
	   so↑.nthreads := so↑.nthreads - 1;
	   end
	 end
	else
	 begin			(* case list *)
(* *** later *** *)
	 end
    end
  end;
 if dlines > 0 then deleteLines(cursorLine,dlines,1);	(* fix up display *)
 firstLine := ocur;
 if ocur > 0 then lastLine := ocur else lastLine := -1;
 setCursor := true;
 curLine := 0;
 putStmnt(dProg,0,99);		(* reset cursor & possibly redraw a line *)
 setCursor := false;
 showCursor(cursorLine-topDline-firstDline+2,1);
 borderLines;
 end;