Unit pr_exec;

Interface

Uses crt, pr_defs, progdefs, strings, pr_built, pr_bdef, math, fkscr;

Type prstack_t = Record
                   s : LongInt;
                   f : dfunction_tp;
                 End;

Const MAX_STACK_DEPTH = 32;
Const LOCALSTACK_SIZE = 2048;

Var  pr_stack         : Array[0..MAX_STACK_DEPTH-1] Of prstack_t;
     pr_depth         : LongInt;
     localstack       : Array[0..LOCALSTACK_SIZE-1] Of LongInt;
     localstack_used  : LongInt;
     pr_trace         : Boolean;
     pr_xfunction     : dfunction_tp;
     pr_xstatement    : LongInt;
     pr_argc          : Integer;
     SafeExit         : Pointer;

Function PR_LoadBPC(filename : string) : Integer;
Procedure PR_ExecuteProgram (fnum : LongInt);
Function PR_NumFunc(fname : PChar) : LongInt;
Procedure cmd_exec;

Implementation

Uses Console;

Procedure cmd_exec;
Var func : LongInt;
    fn : PChar;
Begin
  fn := GetToken;
  func := PR_NumFunc(fn);
  If func = -1 Then Begin
    Con_Write('Function "');
    Con_Write(StrPas(StrLower(fn)));
    Con_WriteLn('" not found.');
  End Else PR_ExecuteProgram( func );
End;

Function PR_NumFunc(fname : PChar) : LongInt;
var i,q : longint;
Begin
  q := -1;
  For i := 1 To progs^.numfunctions - 1 Do Begin
    If StrIComp(fname, PChar(@pr_strings^[pr_functions^[i].s_name])) = 0 Then
    Begin
      q := i; break;
    End;
  End;
  PR_NumFunc := q;
End;

Function PR_LoadBPC(filename : string) : Integer;
Type a_long = Array[0..0] Of longint;
     a_byte = Array[0..0] Of Byte;
Var  F : File;
     i : Integer;
     b : ^a_byte;
     l : ^a_long;
Begin
  {$I-}
  Assign(F, filename); Reset(F, 1);
  If IOResult <> 0 Then Begin PR_LoadBPC := -1; Exit; End;
  {$I+}
  GetMem(progs, FileSize(F)); progsize := FileSize(F);
  BlockRead(F, progs^, FileSize(F));
  Close(F);

  b := @progs^; l := @progs^;

  pr_functions := ppr_functions(@b^[progs^.ofs_functions]);
	pr_strings := ppr_strings(@b^[progs^.ofs_strings]);
	pr_globaldefs := ppr_globaldefs(@b^[progs^.ofs_globaldefs]);
	pr_fielddefs := ppr_fielddefs(@b^[progs^.ofs_fielddefs]);
	pr_statements := ppr_statements(@b^[progs^.ofs_statements]);

	pr_global_struct := ppr_global_struct(@b^[progs^.ofs_globals]);
	pr_globals := @pr_global_struct^;

  PR_LoadBPC := 0;
End;

Function PR_EnterFunction (f : dfunction_tp) : LongInt;
Var i, j, c, o : LongInt;
Begin
	pr_stack[pr_depth].s := pr_xstatement;
	pr_stack[pr_depth].f := pr_xfunction;
	pr_depth := pr_depth + 1;
	If (pr_depth >= MAX_STACK_DEPTH) Then
    PR_RunError ('stack overflow');

  { save off any locals that the new function steps on }
	c := f^.locals;
	If (localstack_used + c > LOCALSTACK_SIZE) Then
		PR_RunError ('PR_ExecuteProgram: locals stack overflow'#13#10);

	For i := 0 To c - 1 Do
    localstack[localstack_used+i] := memlong(@pr_globals^[f^.parm_start + i]);
	localstack_used := localstack_used + c;

  { copy parameters }
	o := f^.parm_start;
	For i := 0 To f^.numparms-1 Do Begin
  	For j := 0 To f^.parm_size[i]-1 Do Begin
			pr_globals^[o] := pr_globals^[OFS_PARM0+i*3+j];
			o := o + 1;
		End;
	End;

	pr_xfunction := f;
	PR_EnterFunction := f^.first_statement - 1;
End;

Function PR_LeaveFunction : LongInt;
Var i, c : LongInt;
Begin
	if (pr_depth <= 0) Then
		PR_RunError ('prog stack underflow');

  { restore locals from the stack }
	c := pr_xfunction^.locals;
	localstack_used := localstack_used - c;
	If (localstack_used < 0) Then
		PR_RunError ('PR_ExecuteProgram: locals stack underflow'#13#10);

	for i := 0 To c - 1 Do
		pr_globals^[pr_xfunction^.parm_start + i] := localstack[localstack_used+i];

  {up stack}
	pr_depth := pr_depth - 1;
	pr_xfunction := pr_stack[pr_depth].f;
	PR_LeaveFunction := pr_stack[pr_depth].s;
End;

Procedure PR_ExecuteProgram (fnum : LongInt);
Type bytearr = Array[0..0] Of Byte;
Var  a, b, c       : eval_tp;
     s             : LongInt;
     st            : dstatement_tp;
     f, newf       : dfunction_tp;
     runaway, i    : Longint;
     q             : Float;
     ed            : edict_tp;
     exitdepth     : longint;
     ptr           : eval_tp;
     temp          : ^bytearr;
Begin
	If ((fnum = 0) Or (fnum >= progs^.numfunctions)) Then Begin
		PR_RunError ('PR_ExecuteProgram: NULL function');
	End;

	f := @pr_functions^[fnum];

	runaway := 100000;

  { make a stack frame }
	exitdepth := pr_depth;

	s := PR_EnterFunction (f);

  Repeat
	  s := s + 1; {Next statement}

  	st := @pr_statements^[s];
  	a := eval_tp(@pr_globals^[st^.a]);
  	b := eval_tp(@pr_globals^[st^.b]);
  	c := eval_tp(@pr_globals^[st^.c]);

    runaway := runaway - 1;
	  If (runaway <= 0) Then
		  PR_RunError ('runaway loop error');

  	pr_xfunction^.profile := pr_xfunction^.profile + 1;
  	pr_xstatement := s;

    Case optypes(st^.op) Of
  	  OP_ADD_F:   c^._float := a^._float + b^._float;
      OP_ADD_V:	  Begin
                    c^.vector[0] := a^.vector[0] + b^.vector[0];
		                c^.vector[1] := a^.vector[1] + b^.vector[1];
		                c^.vector[2] := a^.vector[2] + b^.vector[2];
                  End;
      OP_SUB_F:   c^._float := a^._float - b^._float;
	    OP_SUB_V:   Begin
		                c^.vector[0] := a^.vector[0] - b^.vector[0];
		                c^.vector[1] := a^.vector[1] - b^.vector[1];
		                c^.vector[2] := a^.vector[2] - b^.vector[2];
                  End;
	    OP_MUL_F:	  c^._float := a^._float * b^._float;
	    OP_MUL_V:	  c^._float := a^.vector[0]*b^.vector[0]
      			                 + a^.vector[1]*b^.vector[1]
			                       + a^.vector[2]*b^.vector[2];
	    OP_MUL_FV:  Begin
                   c^.vector[0] := a^._float * b^.vector[0];
		               c^.vector[1] := a^._float * b^.vector[1];
		               c^.vector[2] := a^._float * b^.vector[2];
                  End;
	    OP_MUL_VF:  Begin
                   c^.vector[0] := b^._float * a^.vector[0];
		               c^.vector[1] := b^._float * a^.vector[1];
		               c^.vector[2] := b^._float * a^.vector[2];
		              End;
      OP_PWR_F:   c^._float := pwr(a^._float, b^._float);

      OP_INC:     Begin
                    a^._float := a^._float + 1;
                    c^._float := a^._float;
                  End;
      OP_DEC:     Begin
                    a^._float := a^._float - 1;
                    c^._float := a^._float;
                  End;

      OP_INCBY_F: Begin
                    b^._float := b^._float + a^._float;
                  End;
      OP_INCBY_V: Begin
                    b^.vector[0] := b^.vector[0] + a^.vector[0];
                    b^.vector[1] := b^.vector[1] + a^.vector[1];
                    b^.vector[2] := b^.vector[2] + a^.vector[2];
                  End;

      OP_DECBY_F: Begin
                    b^._float := b^._float - a^._float;
                  End;
      OP_DECBY_V: Begin
                    b^.vector[0] := b^.vector[0] - a^.vector[0];
                    b^.vector[1] := b^.vector[1] - a^.vector[1];
                    b^.vector[2] := b^.vector[2] - a^.vector[2];
                  End;

      OP_MULBY_F: Begin
                    b^._float := b^._float * a^._float;
                  End;
      OP_MULBY_V: Begin
                    b^.vector[0] := b^.vector[0] * a^.vector[0];
                    b^.vector[1] := b^.vector[1] * a^.vector[1];
                    b^.vector[2] := b^.vector[2] * a^.vector[2];
                  End;
      OP_MULBY_FV:Begin
                    b^.vector[0] := b^.vector[0] * a^._float;
                    b^.vector[1] := b^.vector[1] * a^._float;
                    b^.vector[2] := b^.vector[2] * a^._float;
                  End;
      OP_MULBY_VF:Begin
                    q := b^._float;
                    b^.vector[0] := a^.vector[0] * q;
                    b^.vector[1] := a^.vector[1] * q;
                    b^.vector[2] := a^.vector[2] * q;
                  End;
      OP_DIVBY:   Begin
                    b^._float := b^._float / a^._float;
                  End;

      OP_SHL:     Begin
                    b^._float := Trunc(b^._float) Shl Trunc(a^._float);
                  End;
      OP_SHR:     Begin
                    b^._float := Trunc(b^._float) Shr Trunc(a^._float);
                  End;

	    OP_DIV_F:	  c^._float := a^._float / b^._float;
      OP_BITAND:  c^._float := Trunc(a^._float) And Trunc(b^._float);
	    OP_BITOR:   c^._float := Trunc(a^._float) Or Trunc(b^._float);
	    OP_GE:  	  c^._float := Integer(a^._float >= b^._float);
	    OP_LE:      c^._float := Integer(a^._float <= b^._float);
	    OP_GT:	    c^._float := Integer(a^._float > b^._float);
	    OP_LT:      c^._float := Integer(a^._float < b^._float);
	    OP_AND:     c^._float := Integer(Boolean(Trunc(a^._float) And Trunc(b^._float)));
	    OP_OR:      c^._float := Integer(Boolean(Trunc(a^._float) Or Trunc(b^._float)));
	    OP_NOT_F:   c^._float := Integer(Not Trunc(a^._float));
	    OP_NOT_V:   c^._float := Integer(Not (a^.vector[0] = 0) And
                                       Not (a^.vector[1] = 0) And
                                       Not (a^.vector[2] = 0));
      OP_NOT_S:   c^._float := Integer(Integer(Not a^.nstring) Or Integer(@pr_strings^[a^.nstring] = nil));
	    OP_NOT_FNC:	c^._float := Not a^.func;
	    OP_NOT_ENT:	c^._float := Integer(a^.edict <> 0);
	    OP_EQ_F:    c^._float := Integer(a^._float = b^._float);
	    OP_EQ_V:    c^._float := Integer(
                               (a^.vector[0] = b^.vector[0]) and
					                     (a^.vector[1] = b^.vector[1]) and
					                     (a^.vector[2] = b^.vector[2]));
      OP_EQ_S:    c^._float := strcomp(@pr_strings^[a^.nstring],@pr_strings^[b^.nstring]);
	    OP_EQ_E:		c^._float := Integer(a^._int = b^._int);
	    OP_EQ_FNC:	c^._float := Integer(a^.func = b^.func);

	    OP_NE_F:		c^._float := Integer(a^._float <> b^._float);
	    OP_NE_V:		c^._float := Integer((a^.vector[0] <> b^.vector[0]) Or
                                       (a^.vector[1] <> b^.vector[1]) Or
					                             (a^.vector[2] <> b^.vector[2]));
      OP_NE_S:    c^._float := strcomp(@pr_strings^[a^.nstring],@pr_strings^[b^.nstring]);
	    OP_NE_E:		c^._float := Integer(a^._int <> b^._int);
	    OP_NE_FNC:	c^._float := Integer(a^.func <> b^.func);

	    OP_STORE_F,
	    OP_STORE_ENT,
	    OP_STORE_FLD,
	    OP_STORE_S,
	    OP_STORE_FNC:	b^._int := a^._int;

	    OP_STORE_V: Begin
		                b^.vector[0] := a^.vector[0];
		                b^.vector[1] := a^.vector[1];
		                b^.vector[2] := a^.vector[2];
		              End;

	    OP_STOREP_F,
	    OP_STOREP_ENT,
	    OP_STOREP_FLD,
	    OP_STOREP_S,
	    OP_STOREP_FNC: Begin
                       temp := @edicts^;
                       ptr := eval_tp(@temp^[b^._int]);
		                   ptr^._int := a^._int;
		                 End;
	    OP_STOREP_V: Begin
                     temp := @edicts^;
                     ptr := eval_tp(@temp^[b^._int]);
		                 ptr^.vector[0] := a^.vector[0];
		                 ptr^.vector[1] := a^.vector[1];
		                 ptr^.vector[2] := a^.vector[2];
		               End;
	    OP_ADDRESS:	 Begin
                     ed := @(edicts^[a^.edict]);
		                 If (ed = @edicts^) Then
			                 PR_RunError ('assignment to null entity');
                     c^._int := Ofs(ed^.v[b^._int]) - Ofs(edicts^);
		               End;
	    OP_LOAD_F,
      OP_LOAD_FLD,
	    OP_LOAD_ENT,
	    OP_LOAD_S,
	    OP_LOAD_FNC: Begin
		                 ed := @(edicts^[a^.edict]);
                     a := @(ed^.v[b^._int]);
		                 c^._int := a^._int;
		               End;
	    OP_LOAD_V:   Begin
                     ed := @(edicts^[a^.edict]);
                     a := @(ed^.v[b^._int]);
		                 c^.vector[0] := a^.vector[0];
		                 c^.vector[1] := a^.vector[1];
		                 c^.vector[2] := a^.vector[2];
		               End;
	    OP_IFNOT:	If (a^._int = 0) Then s := s + (st^.b - 1);
	    OP_IF:	  If (a^._int <> 0) Then s := s + (st^.b - 1);
	    OP_GOTO:  s := s + (st^.a - 1);

	    OP_CALL0..OP_CALL8: Begin
		              pr_argc := integer(st^.op) - integer(OP_CALL0);
		              If (a^.func = 0) Then
			              PR_RunError ('NULL function');

		              newf := @pr_functions^[a^.func];

		              If (newf^.first_statement < 0) Then Begin
			              i := -newf^.first_statement;
			              if (i > pr_numbuiltins) Then
                      PR_RunError ('Bad builtin call number');
			              pr_builtins[i];
                    continue;
		              End;
                  s := PR_EnterFunction (newf);
                End;

	    OP_DONE,
	    OP_RETURN: Begin
		               pr_globals^[OFS_RETURN] := pr_globals^[st^.a];
		               pr_globals^[OFS_RETURN+1] := pr_globals^[st^.a+1];
		               pr_globals^[OFS_RETURN+2] := pr_globals^[st^.a+2];

		               s := PR_LeaveFunction;
		               If (pr_depth = exitdepth) Then
			               Exit;      {ALL DONE!}
                 End;
	    OP_STATE:  Begin
                 End;
	    else PR_RunError ('Bad opcode');
    End;
  Until 1=0;
End;

Procedure PR_Exit;
Begin
  If assigned(progs) Then FreeMem(progs, progsize);
  FreeMem(edicts, sizeof(edict_t) * numedicts);
  Crt.TextColor(7); Crt.Textbackground(0);
  TextMode(C80); Crt.GotoXY(1,1);
  CursorShow; BlinkOn;
  ExitProc := SafeExit;
End;

Var i : Integer;
    memsz : LongInt;
Begin
  localstack_used := 0;
  pr_depth := 0;
  For I := 0 To LOCALSTACK_SIZE-1 Do localstack[i] := 0;
  numedicts := ((MemAvail Div 2) Div sizeof(edict_t));
  memsz := sizeof(edict_t) * numedicts;
  GetMem(edicts, memsz);
  For i := 0 To numedicts - 1 Do edicts^[i].free := True;
  i := 0;
  {Make DAMN SURE we deallocate the progs:}
  SafeExit := ExitProc;
  ExitProc := @PR_Exit;
End.
