COMMENT ⊗   VALID 00010 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	{$NOMAIN	Individual statement interpreters }
C00005 00003	procedure doProg		(* ** ** *) external
C00006 00004	procedure doBlock external
C00008 00005	procedure doCoblock external
C00010 00006	procedure doEnd external
C00014 00007	procedure doFor external
C00016 00008	procedure doIf external
C00017 00009	procedure doWhile external
C00018 00010	procedure doUntil external
C00019 ENDMK
C⊗;
{$NOMAIN	Individual statement interpreters }

%include ialhdr.pas;

{ Externally defined routines: }

	(* From ALLOC *)
procedure relNode(n: nodep);					external;
procedure relEentry(n: enventryp);				external;
function newEheader: envheaderp; 				external;
function newEnvironment: environp;				external;

	(* From IAUX1A *)
function pop: nodep;						external;
function gtVarn (n: nodep): enventryp;				external;
function getPdb: pdbp;						external;
procedure freePdb(p: pdbp);					external;
function getEvent: eventp;					external;
procedure freeEvent(e: eventp);					external;
procedure makeVar(e: enventryp; vari: varidefp; tbits: integer);external;
function enterEntry (var i,j: integer; var env: environp;
		 envhdr: envheaderp; v: varidefp): enventryp;	external;
procedure killStack;						external;

	(* From IAUX1B *)
procedure sleep(whenV: integer);				external;

	(* From IAUX2A *)
procedure killEnv;						external;

	(* From IAUX2B *)
function cmonCheck: boolean;					external;

	(* Display-related Routines *)
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 doProg;		(* ** ** *) external;
procedure doProg;
 begin

 (* *** stuff to reset affixments *** *)

 speedfactor↑.s := 2.0;			(* initialize speed_factor *)

 curInt↑.spc := curInt↑.spc↑.pcode;
 curInt↑.mode := 0;
 end;

procedure doBlock; external;
procedure doBlock;
 var i,j: integer; v: varidefp;
     envhdr: envheaderp; e: enventryp; envir: environp;
 begin
 with curInt↑ do
  begin
  if spc↑.variables <> nil then
   with spc↑ do
    begin
    envhdr := newEheader;
    envhdr↑.parent := env;
    env := envhdr;
    envhdr↑.block := spc;
    envhdr↑.varcnt := 0;
    envhdr↑.procp := false;
    envir := newEnvironment;	(* always need at least one environment record *)
    envir↑.next := nil;
    envhdr↑.env[0] := envir;
    for j := 1 to 4 do envhdr↑.env[j] := nil;
    for j := 0 to 9 do envir↑.vals[j] := nil;
    i := 0;
    j := -1;
    v := variables;
    while v <> nil do
     begin
     if v↑.vtype < dimensiontype then
       begin
       e := enterEntry(i,j,envir,envhdr,v);
       makeVar(e,v,v↑.tbits);		(* make variable environment entry *)
       end
      else (* if v↑.vtype = freevartype then - need to do it for macros too *)
       begin
       relEentry(enterEntry(i,j,envir,envhdr,v));  (* space past env entry *)
       envir↑.vals[j] := nil;
       end;
     v := v↑.next
     end;
    for i := j+1 to 9 do envir↑.vals[i] := nil;
    end;
  mode := 0;
  spc := spc↑.bcode;
  end;
 end;

procedure doCoblock; external;
procedure doCoblock;
 var e: eventp;

 procedure sched(n: nodep);
  var p: pdbp;
  begin
  if n↑.next <> nil then sched(n↑.next);	(* maintain lexical order *)
  if n↑.cstmnt↑.stype <> commenttype then
    begin			(* we don't want to schedule comments (yet) *)
    p := getPdb;		(* get a pdb for this thread *)
    with p↑ do
     begin
     next := activeInts;	(* add us to list of active interpreters *)
     activeInts := p;
     status := runqueue;
     spc := n↑.cstmnt;
     sdef := spc;
     evt := e;			(* event to signal when we go away *)
     end;
   end;
  end;

 begin
 with curInt↑ do
  case mode of
1: begin	(* schedule the parallel threads for execution *)
   mode := 2;
   if spc↑.threads <> nil then
     begin
     e := getEvent; (* event to use for signalling when all threads are done *)
     e↑.count := -spc↑.nthreads;
     e↑.waitlist := curInt;
     sched(spc↑.threads);		(* schedule all the threads *)
     curInt↑.status := joinwait;
     curInt := nil;
     resched := true;			(* start up first of them *)
     end;
   end;
2: begin	(* all threads are done - continue with main *)
   mode := 0;
   spc := spc↑.next;
   end;
  end;
 end;

procedure doEnd; external;
procedure doEnd;
 var spcp: statementp; e: eventp; b: boolean;
 begin
 b := true;
 with curInt↑ do
  begin
  spcp := spc↑.bparent;
  case spcp↑.stype of
progtype:	begin
		running := false;	(* all done running *)
		mode := 0;
		end;
blocktype:	begin
		if spcp↑.variables <> nil then 	(* any variables? *)
		  b := cmonCheck;	(* any cmons now running? *)
		if b then
		  begin	 		(* no - we can clean things up *)
		  if spcp↑.variables <> nil then killEnv;
		  spcp := spcp↑.next;
		  mode := 0;
		  end
		 else sleep(30);	(* give cmons time to finish *)
		end;
coblocktype:	begin
		if evt = nil then
		  begin
		  running := false;	(* break to debugger *)
		(* *** if not iSingleThreadMode then complain??? *** *)
		  end
		 else
		  begin
		  b := false;
		  e := evt;
		  killStack;		(* flush stack *)
		  freePdb(curInt);
		  if e↑.count = -1 then
		    begin			(* this was last thread *)
		    curInt := e↑.waitlist;	(* return to main *)
		    curInt↑.status := nowrunning;
		    freeEvent(e);
		    if activeInts <> nil then
		     if curInt↑.priority < activeInts↑.priority then
		       resched := true;
		    end
		   else
		    begin			(* other threads still executing *)
		    e↑.count := e↑.count + 1;
		    curInt := nil;		(* swap in someone else *)
		    resched := true;
		    end;
		  end;
		end;
cmtype:		begin			(* terminate or resched this cmon *);
		cm↑.running := false;
		killStack;
		b := false;
		spc := spcp;		(* set us up for next time *)
		mode := 0;
		if not cm↑.enabled then
		  begin			(* we're done, swap us out *)
		  curInt↑.status := nullqueue;
		  curInt := nil;	(* swap in someone else *)
		  resched := true;
		  end;
		end;
fortype:	begin
		if sp↑.ntype <> forvalnode then		(* gack! stack error *)
		  begin
		  pp20L('Can''t find FOR node ',20); pp20('- stack error!!!    ',16);
		  ppLine;
		  (* could try to recover, but.... *)
		  end;
		sp↑.fvar↑.s := sp↑.fvar↑.s + sp↑.fstep;	(* next for value *)
		mode := 2;				(* do for check *)
		end;
untiltype:	mode := 2;
whiletype:	mode := 0;
movetype,					(* for error handler *)
iftype,
casetype:	begin
		spcp := spcp↑.next;
		mode := 0;
		end;
otherwise 	{do nothing};
   end;
  if b then spc := spcp;
  end;
 end;

procedure doFor; external;
procedure doFor;
 var ev: enventryp; fnode, res: nodep;
 begin
 with curInt↑ do
  case mode of
1:  begin  (* stack contains: forvar subscripts, initial, step & final values *)
    ev := gtVarn(spc↑.forvar);	(* access variable *)
    res := pop;			(* get initial value *)
    ev↑.s := res↑.s;		(* store it away *)
    relNode(res);		(* release node *)
    fnode := sp;		(* get step value *)
    fnode↑.ntype := forvalnode;
    fnode↑.fstep := fnode↑.s;	(* copy step value - note s & step fields may overlap *)
    fnode↑.fvar := ev;		(* copy environment entry *)
    mode := 2;
    end;
2:  begin
    fnode := sp;
    if (fnode↑.fvar↑.s - fnode↑.next↑.s) * fnode↑.fstep <= 0.0 (* (cur-fin)*step *)
     then spc:= spc↑.fbody	(* go interpret for body *)
     else begin
	  spc := spc↑.next;	(* move on to next statement *);
	  res := fnode↑.next;
	  sp := res↑.next;	(* pop for nodes off of stack *)
	  relNode(fnode);	(* and release them *)
	  relNode(res);
	  end;
    mode := 0;
    end;
  end;
 end;

procedure doIf; external;
procedure doIf;
 var res: nodep; s: statementp;
 begin
 with curInt↑ do
  begin
  res := pop;			(* pop value off of stack *)
  s := spc;
  if res↑.s = 0.0 then spc := s↑.els else spc := s↑.thn;
  if spc = nil then spc := s↑.next;	(* if nil clause just go on to next stmnt *)
  relNode(res);
  mode := 0;
  end;
 end;

procedure doWhile; external;
procedure doWhile;
 var res: nodep;
 begin
 with curInt↑ do
  begin
  res := pop;			(* pop value off of stack *)
  if res↑.s = 0.0 then spc := spc↑.next	(* if false move on to next stmnt *)
   else if spc↑.body <> nil then spc := spc↑.body;
  relNode(res);
  mode := 0;
  end;
 end;

procedure doUntil; external;
procedure doUntil;
 var res: nodep;
 begin
 with curInt↑ do
  case mode of
1:  begin
    if spc↑.body <> nil then begin spc := spc↑.body; mode := 0 end
     else mode := 2;
    end;
2:  begin
    epc := spc↑.exprs;	(* need to evaluate until condition *)
    mode := 3;
    end;
3:  begin
    res := pop;			(* pop value off of stack *)
    if (res↑.s <> 0.0) then
      begin
      spc := spc↑.next;		(* if true move on to next stmnt *)
      mode := 0;
      end
     else mode := 1;		(* if still false repeat body *)
    relNode(res);
    end;
  end;
 end;