COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(*$NOMAIN	Routines to free up an AL program when we're done with it *)
C00004 00003	(* auxiliary routines: freStrng, freeVaridef, freeToken, freeNode, freeIds *)
C00011 00004	(* routine to free up a program once we're done with it: freeStatement *)
C00017 ENDMK
C⊗;
(*$NOMAIN	Routines to free up an AL program when we're done with it *)

%include ialhdr.pas;

(* External routines from elsewhere *)

	(* From ALLOC *)
procedure relToken(t: tokenp); 					external;			
procedure relNode(n: nodep); 					external;
procedure relStrng(n: strngp); 					external;
procedure relVector(n: vectorp); 				external;
procedure relTrans(n: transp); 					external;
procedure relIdent(n: identp); 					external;
procedure relVaridef(n: varidefp); 				external;
procedure relStatement(n: statementp); 				external;

	(* From INTERP - XX good luck Rick XX *)
procedure flushVar(oldvar: varidefp);				external;
(* auxiliary routines: freStrng, freeVaridef, freeToken, freeNode, freeIds *)

procedure freeStatement(s: statementp); external;	{also FORWARD}

procedure freeNode(n: nodep); external;			{also FORWARD}

procedure freStrng(st: strngp); external;
procedure freStrng;
 var stp: strngp;
 begin
 while st <> nil do
    begin stp := st↑.next; relStrng(st); st := stp end;
 end;

procedure freeToken(t: tokenp); external;
procedure freeToken;
 var tp: tokenp;
 begin
 while t <> nil do
  begin
  with t↑ do
   begin
   if ttype = constype then
     if cons↑.ltype = svaltype then relNode(cons) else freeNode(cons)
    else if ttype = comnttype then freStrng(str);
   tp := next;
   end;
  relToken(t);
  t := tp
  end;
 end;

procedure freeVaridef(v: varidefp); external;
procedure freeVaridef;
 var vp: varidefp;
 begin
 while v <> nil do
  with v↑ do
   begin
   if tbits = 2 then freeNode(p)		(* procedure definition *)
    else if odd(tbits) then freeNode(a)		(* array definition *)
    else
     case vtype of
macargtype: freeToken(marg);
dimensiontype: relNode(dim);
otherwise {do nothing};
    end;
   vp := next;
   relVaridef(v);
   v := vp;
   end;
 end;

procedure freeNode (* n: nodep *);
 var b: boolean;
 begin
 b := true;
 if n = nil then b := false
  else
   with n↑ do
    case ntype of
exprnode: begin
	  freeNode(arg1);
	  freeNode(arg2);
	  freeNode(arg3);
	  end;
leafnode: case ltype of
  vectype:   if v↑.refcnt <= 1 then relVector(v)
	      else v↑.refcnt := v↑.refcnt - 1;
  transtype: if t↑.refcnt <= 1 then relTrans(t)
	      else t↑.refcnt := t↑.refcnt - 1;
  strngtype: if (length <> 2) or (str↑.ch[1] <> chr(15B)) or
		(str↑.ch[2] <> chr(12B)) then freStrng(str) else b := false;
  otherwise {do nothing};
	   end;
listnode: begin
	  freeNode(lval);
	  freeNode(next);
	  end;
clistnode:begin
	  freeStatement(stmnt);
	  freeNode(next);
	  end;
colistnode: begin
	  freeStatement(cstmnt);
	  freeNode(next);
	  end;
deprnode,
apprnode,
destnode: begin
	  freeNode(loc);
	  freeStatement(code);
	  freeNode(next);
	  end;
byptnode,
viaptnode:begin
	  freeNode(via);
	  freeNode(vclauses);
	  freeStatement(vcode);
	  freeNode(next);
	  end;
durnode:  begin
	  freeNode(durval);
	  freeNode(next);
	  end;
wrtnode,
velocitynode,
sfacnode,
wobblenode,
swtnode:  begin
	  freeNode(clval);
	  freeNode(next);
	  end;
gathernode,
nullingnode,
wristnode,
elbownode,
shouldernode,
flipnode,
linearnode,
cwnode:	  freeNode(next);
ffnode:	  begin
	  if pdef then relNode(ff)
	   else freeNode(ff);
	  freeNode(next);
	  end;
forcenode:begin
	  freeNode(fval);
	  freeNode(fvec);
	  freeNode(fframe);
	  freeNode(next);
	  end;
loadnode: begin
	  freeNode(loadval);
	  freeNode(loadvec);
	  freeNode(next);
	  end;
stiffnode:begin
	  freeNode(fv);
	  freeNode(mv);
	  freeNode(cocff);
	  freeNode(next);
	  end;
cmonnode: begin
	  freeStatement(cmon);
	  freeNode(next);
	  end;
errornode:begin
	  freeNode(eexpr);
	  end;
calcnode: if not tvarp then relTrans(tval);	(* should never see one but *)
arraydefnode: freeNode(bounds);
bnddefnode:begin
	  freeNode(lower);
	  freeNode(upper);
	  freeNode(next);
	  end;
procdefnode:begin
	  freeVaridef(paramlist);
	  relStatement(body↑.next);
	  freeStatement(body);
	  end;
tlistnode: freeToken(tok);
otherwise {do nothing};
    end;
 if b then relNode(n);
 end;


procedure freeIds; external;
procedure freeIds;
 var i: integer; id,idp,idn: identp; st,stp: strngp;
 begin
 for i := 1 to 26 do
  begin
  idp := nil;
  id := idents[i];
  while id <> nil do
   with id↑ do
    begin
    idn := next;
    if predefined = nil then
      begin				(* flush id now *)
      st := name;			(* done with string *)
      while st <> nil do
	 begin stp := st↑.next; relStrng(st); st := stp end;
      relIdent(id);			(* and ident *)
      end
     else
      begin
      if idp = nil then idents[i] := id else idp↑.next := id;
      idp := id;
      end;
    id := idn;
    end;
  if idp = nil then idents[i] := nil;
  end;
 end;

(* routine to free up a program once we're done with it: freeStatement *)

procedure freeStatement(* s: statementp *);
 var st,stp: statementp; n: nodep;

    procedure clrBpt(st: statementp);	(* copied from EAUX3B *)
     var i: integer; b: boolean;
     begin
     if st↑.bpt then                (* don't do anything if bpt not set *)
       begin
       b := true;
       for i := 1 to nbpts do
	if b then b := bpts[i] <> st        (* first find statement in list *)
	 else bpts[i-1] := bpts[i];         (* then compact the list *)
       if not b then
	 begin
	 st↑.bpt := false;                  (* clear it only if we set it *)
	 bpts[nbpts] := nil;
	 nbpts := nbpts - 1;
	 end;
      (* else wonder how the bpt got set? *)
       end;
     end;

 begin
 if s <> nil then
   begin
   with s↑ do
    begin
    if bpt then clrBpt(s);		(* keep the debugger tables legit *)
    case stype of
progtype:	begin
		freeStatement(pcode↑.next);
		freeStatement(pcode);
		freeIds;
		end;
blocktype:	begin
		if blkid <> nil then
		  begin
		  freStrng(blkid↑.name);
		  relIdent(blkid);
		  end;
		st := bcode;
		while st <> nil do
		 begin
		 stp := st↑.next;
		 freeStatement(st);
		 st := stp;
		 end;
		freeVaridef(variables);
		end;
endtype,
coendtype:	if blkid <> nil then
		  begin
		  freStrng(blkid↑.name);
		  relIdent(blkid);
		  end;
coblocktype:	begin
		if cblkid <> nil then
		  begin
		  freStrng(cblkid↑.name);
		  relIdent(cblkid);
		  end;
		if threads <> nil then freeStatement(threads↑.cstmnt↑.next);
		freeNode(threads);
		end;
fortype:	begin
		freeNode(forvar);
		freeNode(initial);
		freeNode(step);
		freeNode(final);
		if fbody <> nil then freeStatement(fbody↑.next);
		freeStatement(fbody);
		end;
whiletype,
untiltype:	begin
		freeNode(cond);
		if body <> nil then freeStatement(body↑.next);
		freeStatement(body);
		end;
casetype:	begin
		freeNode(index);
		n := caselist;
		while n <> nil do
		 if n↑.stmnt = nil then n := n↑.next
		  else begin freeStatement(n↑.stmnt↑.next); n := nil end;
		freeNode(caselist);
		end;
iftype:		begin
		freeNode(icond);
		if thn <> nil then freeStatement(thn↑.next);
		freeStatement(thn);
		freeStatement(els);
		end;
pausetype:	freeNode(ptime);
prompttype,
printtype,
aborttype,
saytype:	freeNode(plist);
returntype:	freeNode(retval);
calltype:	freeNode(what);
assigntype:	begin
		freeNode(what);
		freeNode(aval);
		end;
affixtype,
unfixtype:	begin
		freeNode(frame1);
		freeNode(frame2);
		if stype = affixtype then
		  begin
		  freeNode(byvar);
		  freeNode(atexp);
		  end;
		end;
signaltype,
waittype:	freeNode(event);
movetype,
jtmovetype,
operatetype,
opentype,
closetype,
centertype:	begin
		freeNode(cf);
		freeNode(clauses);
		end;
setbasetype,
stoptype:	freeNode(cf);
cmtype:		begin
		if (not exprCm) and (oncond↑.ntype = leafnode) then
		  if oncond↑.vari↑.name = nil then flushVar(oncond↑.vari);
		flushVar(cdef);
		freeNode(oncond);
		freeStatement(conclusion↑.next);
		freeStatement(conclusion);
		end;
requiretype:	freStrng(rfils);
definetype:	begin
		freeVaridef(mpars);
		freeToken(macdef);
		end;
commenttype:	begin
		freStrng(str);
		freeStatement(cbody);
		end;
dimdeftype:	freeNode(dimexpr);
wristtype:	begin
		freeNode(arm);
		freeNode(ff);
		freeNode(fvec);
		freeNode(tvec);
		end;
armmagictype:	begin
		freeNode(cmdnum);
		freeNode(dev);
		freeNode(iargs);
		freeNode(oargs);
		end;
otherwise	{do nothing - shouldn't happen};
     end;
    end;
   relStatement(s);
   end;
 end;