COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	{$NOMAIN	EDIT-called routines to flush things }
C00004 00003	(* Aux routines:  flushLevel, flushAll, unwind, flushPdb, flushKids *)
C00013 ENDMK
C⊗;
{$NOMAIN	EDIT-called routines to flush things }

%include ialhdr.pas;

{ Externally defined routines: }

	(* From ALLOC *)
procedure relCmoncb(n: cmoncbp);				external;
procedure relPdb(n: pdbp);					external;

	(* From IAUX1A *)
function getPdb: pdbp;						external;
function getELev(hdr: envheaderp): integer;			external;
function getVar (level, offset: byte): enventryp;		external;
procedure freePdb(p: pdbp);					external;
procedure freeEvent(e: eventp);					external;
procedure killStack;						external;

	(* From IAUX1B *)
procedure deClkQueue(po: pdbp);					external;

	(* From IAUX2A *)
procedure killEnv;						external;

(* Aux routines:  flushLevel, flushAll, unwind, flushPdb, flushKids *)

procedure flushLevel(dLev: integer); external;	(* to clean up from debugger *)
procedure flushLevel;
 var b: boolean; pri: integer; e: eventp; pp,po: pdbp; ee: enventryp;
 begin
 pri := dLev * 10;
 if curInt <> nil then
  if curInt↑.priority >= pri then curInt := nil;
 b := true;
 while b and (activeInts <> nil) do		(* flush run queue *)
  if activeInts↑.priority >= pri then activeInts := activeInts↑.next
   else b := false;
 b := true;
 while b and (readQueue <> nil) do		(* flush read queue *)
  if readQueue↑.priority >= pri then readQueue := readQueue↑.next
   else b := false;
 e := allEvents;
 while e <> nil do
  with e↑ do
   begin
   b := true;
   while b and (waitlist <> nil) do		(* clean up event's waitlist *)
    if waitlist↑.priority >= pri then
      begin
      waitlist := waitlist↑.next;
      count := count + 1;
      end
     else b := false;
   e := next;
   end;
 po := curInt;
 pp := allPdbs;
 while pp <> nil do
  begin
  curInt := pp;
  pp := pp↑.nextPdb;
  with curInt↑ do
   if priority >= pri then			(* may need to flush this one *)
     begin
     killStack;
     while level < getELev(env) do killEnv;	(* flush envs process created *)
     if status = sleepqueue then deClkQueue(curInt);
     if cm <> nil then
       with cm↑ do
	if oldcmon <> nil then
	  begin
	  with cmon↑.cdef↑ do ee := getVar(level,offset);
	  ee↑.c := oldcmon;
	  freePdb(pdb);		(* done with this incarnation of cmon *)
	  if cmon↑.oncond↑.ntype = forcenode then freeEvent(evt);
	  relCmoncb(cm);
	  end
	 else
	  begin					(* set us up for later *)
	  priority := (priority mod 10) + 1;	(* base level priority again *)
	  spc := cm↑.cmon;
	  mode := 0;
	  status := nullqueue;
	  running := false;
	  enabled := false;
	  end
      else
       begin
       if (not procp) and (evt <> nil) then freeEvent(evt);
       freePdb(curInt);
       end;
     end;
  end;
 curInt := po;
 end;

procedure flushAll(p: pdbp; dLev: integer); external;	(* for use by EDIT *)
procedure flushAll;
 var b: boolean; i: integer; e: eventp; pp,po: pdbp;
 begin
 flushLevel(dLev);
 if p <> nil then
  begin						(* flush process *)
  po := curInt;
  curInt := p;
  with curInt↑ do
   begin
   killStack;
   while level < getELev(env) do killEnv;	(* flush envs process created *)
   if status = sleepqueue then deClkQueue(curInt);
   if cm = nil then relPdb(curInt);
   end;
  curInt := po;
  end;
 if dLev = 0 then
   begin
   etime := 0;
   stime := 0;
   curtime := 0;
   curInt := nil;
   activeInts := nil;
   readQueue := nil;
   resched := false;
(* *** would like to flush any leftover events, unless we saved outermost *** *)
(* *** environment - if we are then we can't....			  *** *)
(* while allEvents <> nil do freeEvent(allEvents);  (* flush any old events *)
   e := allEvents;			(* at least we can reset them though *)
   while e <> nil do
    with e↑ do
     begin e↑.waitlist := nil; count := 0; e := next end;
   curInt := getPdb;
   speedfactor↑.s := 2.0;			(* re-initialize speed_factor *)
   iSingleThreadMode := false;			(* reset no wait mode *)
(* ??? any other system defined variables need to be reset/reinitialized? ??? *)
   end;
 end;

procedure unwind(p: pdbp; eLev: integer); external;	(* for use by EDIT *) 
procedure unwind;
 var po: pdbp;
 begin
 po := curInt;
 curInt := p;
 while eLev < getELev(curInt↑.env) do killEnv;	(* unwind inner environments *)
 curInt := po;
 end;

procedure flushPdb(p: pdbp); external;	(* for use by EDIT *)
procedure flushPdb;
 var po: pdbp;
 begin
 if p↑.status = runqueue then
   if activeInts = p then activeInts := p↑.next
    else
     begin
     po := activeInts;
     while (po↑.next <> nil) and (po↑.next <> p) do po := po↑.next;
     if po <> nil then po↑.next := p↑.next;
     end
  else if p↑.status = inputqueue then
   if readQueue = p then readQueue := p↑.next
    else
     begin
     po := readQueue;
     while (po↑.next <> nil) and (po↑.next <> p) do po := po↑.next;
     if po <> nil then po↑.next := p↑.next;
     end;
 p↑.priority := 255;	(* so we can free just this process using flushLevel *)
 flushLevel(25);
 end;

procedure flushKids(p: pdbp; zapit: boolean); external;
procedure flushKids;
 var pp: pdbp; b: boolean;
 begin
 if p↑.status = joinwait then
   begin
   b := false;
   repeat
    pp := allPdbs;
    repeat					(* find one of the threads *)
     with pp↑ do
      if (not procp) and (cm = nil) and (evt <> nil) then
	if evt↑.waitlist = p then
	  begin flushKids(pp,true); pp := nil end;	(* flush it *)
     if pp <> nil then					(* move on to next *)
       begin pp := pp↑.nextPdb; b := pp = nil end;
    until pp = nil;
   until b;				(* repeat til we find all of them *)
   end
  else if p↑.status = proccall then
   begin
   pp := allPdbs;
   repeat
    if pp↑.procp and (pp↑.opdb = p) then
      begin flushKids(pp,true); pp := nil end		(* flush it *)
     else pp := pp↑.nextPdb;
   until pp = nil;
   end;
 if zapit then flushPdb(p);
 end;