-- BasicInterpA.mesa
-- edited by Brotz and Hilton, September 23, 1982  2:28 PM

DIRECTORY
  BasicDefs,
  BasicImpDefs,
  BasicOps,
  Inline,
  IODefs,
  RealFns,
  RealOps,
  Storage,
  StreamDefs,
  String,
  vmD: FROM "VirtualMgrDefs";

BasicInterpA: PROGRAM
  IMPORTS BasicImpDefs, BasicOps, Inline, IODefs, RealFns, RealOps, Storage, StreamDefs,
    String, vmD
  EXPORTS BasicImpDefs, BasicOps =

BEGIN
OPEN BasicDefs, BasicImpDefs;

stack: PUBLIC ARRAY (0 .. stackLimit) OF BasicValue;
stackPointer: PUBLIC CARDINAL _ 0;

currentProgLine: PUBLIC ProgramLineDescPtr _ NIL;
contPc: PUBLIC ProgramLineDescPtr _ NIL;

autoIncrement: PUBLIC CARDINAL _ 10;
autoOn: PUBLIC BOOLEAN _ FALSE;  -- used for automatic numbering --
autoStart: PUBLIC CARDINAL _ 10;

dataLinePc: PUBLIC ProgramLineDescPtr _ NIL;
dataItem: PUBLIC CARDINAL _ 0;
noMoreData: PUBLIC BOOLEAN _ FALSE;

fnEvalStack: PUBLIC FnEvalRecordPtr _ NIL;

goSubHead: PUBLIC GoSubStackPtr _ NIL;

loadedConfigs: PUBLIC LoadedConfigRecPtr _ NIL;

nextStackHead: PUBLIC NextStackPtr _ NIL;

trigMode: PUBLIC TrigonometricMode _ radians;


opCode: PUBLIC ARRAY [1 .. BasicOps.nOps] OF BasicOps.OpCodeRec _
  [[BasicOps.PushOp, var, "Push"],
  [BasicOps.PopOp, var, "Pop"],
  [BasicOps.PushIOp, byte, "PushI"],
  [AddOp, loner, "Add"],
  [BasicOps.SubOp, loner, "Sub"],
  [BasicOps.MulOp, loner, "Mul"],
  [DivOp, loner, "Div"],
  [CallBuiltInFnOp, var, "CallBuiltInFn"],
  [Arr1PushOp, var, "Arr1Push"],
  [Arr2PushOp, var, "Arr2Push"],
  [Arr1PopOp, var, "Arr1Pop"],
  [Arr2PopOp, var, "Arr2Pop"],
  [CallUserFnOp, var, "CallUserFn"],
  [AndOp, loner, "And"],
  [BasicOps.OrOp, loner, "Or"],
  [BasicOps.NotOp, loner, "Not"],
  [ExpOp, loner, "Exp"],
  [EqualOp, loner, "Equal"],
  [BasicOps.NEOp, loner, "NE"],
  [GEOp, loner, "GE"],
  [BasicOps.LEOp, loner, "LE"],
  [GreaterOp, loner, "Greater"],
  [BasicOps.LesserOp, loner, "Lesser"],
  [BasicOps.ReadOp, loner, "Read"],
  [BasicOps.PrintOp, loner, "Print"],
  [EndOp, loner, "End"],
  [FnEndOp, loner, "FnEnd"],
  [GoToOp, label, "GoTo"],
  [GoSubOp, label, "GoSub"],
  [DoneOp, loner, "Done"],
  [BasicOps.OnGoToOp, labelList, "OnGoTo"],
  [BasicOps.OnGoSubOp, labelList, "OnGoSub"],
  [IfZeroDoneOp, loner, "IfZeroDone"],
  [ForOp, var, "For"],
  [BasicOps.NextOp, var, "Next"],
  [BasicOps.ReturnOp, loner, "Return"],
  [BasicOps.QuitOp, loner, "Quit"],
  [BasicOps.UnaryMinusOp, loner, "UnaryMinus"],
  [BasicOps.TabOp, loner, "Tab"],
  [BasicOps.LoadOp, loner, "Load"],
  [BasicOps.RunOp, loner, "Run"],
  [ContOp, loner, "Cont"],
  [AutoOp, loner, "Auto"],
  [BasicOps.ListOp, loner, "List"],
  [BasicOps.RenumberOp, loner, "Renumber"],
  [BasicOps.StopOp, loner, "Stop"],
  [DeleteOp, loner, "Delete"],
  [DimOp, var, "Dim"],
  [DimStrOp, var, "DimStr"],
  [DefFnOp, defFn, "DefFn"],
  [BasicOps.NormalOp, loner, "Normal"],
  [CodeListOp, loner, "CodeList"],
  [ImageOp, loner, "Image"],
  [BasicOps.UsingOp, label, "Using"],
  [InputNumOp, byte, "InputNum"],
  [InputStrOp, byte, "InputStr"],
  [BasicOps.RestoreOp, loner, "Restore"],
  [DataOp, varList, "Data"],
  [BasicOps.Str1PushOp, var, "Str1Push"],
  [BasicOps.Str2PushOp, var, "Str2Push"],
  [BasicOps.Str1PopOp, var, "Str1Pop"],
  [BasicOps.Str2PopOp, var, "Str2Pop"],
  [HelpOp, loner, "Help"]];


AddOp: BasicOps.OpCodeProc =
BEGIN
RETURN[ArithmeticOp[add], pc];
END;  -- of AddOp --


AndOp: BasicOps.OpCodeProc =
BEGIN
bv1, bv2: BasicValue;
bv2 _ Pop[];
bv1 _ Pop[];
IF (bv1.type = string) # (bv2.type = string) THEN
  RunTimeError["And between numeric and string!"L];
IF bv1.type = string THEN
  BEGIN
  string: STRING _ Storage.String[bv1.stringValue.length + bv2.stringValue.length];
  String.AppendString[string, bv1.stringValue];
  String.AppendString[string, bv2.stringValue];
  Storage.FreeString[bv1.stringValue];
  Storage.FreeString[bv2.stringValue];
  bv1.stringValue _ string;
  Push[bv1];
  Storage.FreeString[bv1.stringValue];
  END
ELSE BEGIN
  i1: CARDINAL _ ConvertToCardinal[@bv1];
  i2: CARDINAL _ ConvertToCardinal[@bv1];
  PushInteger[IF i1 = 0 OR i2 = 0 THEN 0 ELSE 1];
  END;
RETURN[FALSE, pc];
END;  -- of AndOp --


AppendByte: PUBLIC PROCEDURE [cm: vmD.ComposedMessagePtr, byte: BasicOps.Byte] =
BEGIN
vmD.AppendMessageChar[cm, LOOPHOLE[byte]];
END;  -- of AppendByte --


AppendPointer: PUBLIC PROCEDURE [cm: vmD.ComposedMessagePtr, pointer: POINTER] =
BEGIN
TwoHalf: TYPE = MACHINE DEPENDENT RECORD [high, low: BasicOps.Byte];
vmD.AppendMessageChar[cm, LOOPHOLE[LOOPHOLE[pointer, TwoHalf].high]];
vmD.AppendMessageChar[cm, LOOPHOLE[LOOPHOLE[pointer, TwoHalf].low]];
END;  -- of AppendPointer --


ArithmeticOp: PUBLIC PROCEDURE [op: BasicOps.ArithmeticOpType]
  RETURNS [done: BOOLEAN] =
BEGIN
bv1, bv2, result: BasicValue;
real1, real2: REAL;
int1, int2: Numeric;
operation: {integer, real} _ integer;
bv2 _ Pop[];
bv1 _ Pop[];
IF bv1.type = string OR bv2.type = string THEN
  BEGIN
  IF bv1.type = string THEN Storage.FreeString[bv1.stringValue];
  IF bv2.type = string THEN Storage.FreeString[bv2.stringValue];
  RunTimeError["Non-Numeric value in numeric expression"L];
  END;
IF bv1.type = real OR bv2.type = real OR op = exp OR op = div THEN
  BEGIN  -- make sure both numbers are real --
  [real1, real2] _ FloatIntegers[@bv1, @bv2];
  operation _ real;
  END
ELSE  -- make sure both numbers are integers --
  {int1 _ bv1.integerValue; int2 _ bv2.integerValue};
IF operation = real THEN
  result _ BasicValue[real, real[realValue: 
    SELECT op FROM
      add => RealOps.FAdd[real1, real2],
      sub => RealOps.FSub[real1, real2],
      mul => RealOps.FMul[real1, real2],
      div => RealOps.FDiv[real1, real2],
      exp => RealFns.Power[real1, real2],
      ENDCASE => ERROR]]
ELSE result _ BasicValue[integer, integer[integerValue:
    SELECT op FROM
      add => int1 + int2,
      sub => int1 - int2,
      mul => int1 * int2,
      div => int1 / int2,
      ENDCASE => ERROR]];
Push[result];
RETURN[FALSE];
END;  -- of ArithmeticOp --


Arr1PopOp: BasicOps.OpCodeProc =
BEGIN
bvIndex, bv: BasicValue;
index: CARDINAL;
vp: VariablePtr;
done _ FALSE;
bv _ Pop[];
bvIndex _ Pop[];
[vp, newPc] _ FetchPointer[cm, pc];
index _ ConvertToCardinal[@bvIndex];
WITH varptr: vp SELECT FROM
  numeric =>
    BEGIN
    IF varptr.arrayPtr = NIL THEN
      BEGIN
      IF index <= optionBase + 9 THEN AllocateArray[optionBase + 9, optionBase, vp]
      ELSE RunTimeError["Array index out of bounds."L];
      END;
    IF index ~IN [varptr.arrayPtr.lb1 .. varptr.arrayPtr.ub1] THEN
      RunTimeError["Array index out of bounds."L]
    ELSE varptr.arrayPtr.base[index - varptr.arrayPtr.lb1] _ bv;
    END;
  ENDCASE => RunTimeError["Assignment to non-numeric array"L];
END;  -- of Arr1PopOp --


Arr1PushOp: BasicOps.OpCodeProc =
BEGIN
bvIndex: BasicValue;
index: CARDINAL;
vp: VariablePtr;
done _ FALSE;
bvIndex _ Pop[];
[vp, newPc] _ FetchPointer[cm, pc];
index _ ConvertToCardinal[@bvIndex];
WITH varptr: vp SELECT FROM
  numeric =>
    BEGIN
    IF varptr.arrayPtr = NIL THEN
      BEGIN
      IF index <= optionBase + 9 THEN AllocateArray[optionBase + 9, optionBase, vp]
      ELSE RunTimeError["Array index out of bounds."L];
      END;
    IF index ~IN [varptr.arrayPtr.lb1 .. varptr.arrayPtr.ub1] THEN
      RunTimeError["Array index out of bounds."L]
    ELSE Push[varptr.arrayPtr.base[index - varptr.arrayPtr.lb1]];
    END;
  ENDCASE => RunTimeError["Assignment to non-numeric array"L];
END;  -- of Arr1PushOp --


Arr2PopOp: BasicOps.OpCodeProc =
BEGIN
bvIndex1, bvIndex2, bv: BasicValue;
index1, index2: CARDINAL;
vp: VariablePtr;
done _ FALSE;
bv _ Pop[];
bvIndex2 _ Pop[];
bvIndex1 _ Pop[];
[vp, newPc] _ FetchPointer[cm, pc];
index1 _ ConvertToCardinal[@bvIndex1];
index2 _ ConvertToCardinal[@bvIndex2];
WITH varptr: vp SELECT FROM
  numeric =>
    BEGIN
    IF varptr.arrayPtr = NIL THEN
      BEGIN
      IF (index1 <= optionBase + 9) AND (index2 <= optionBase + 9) THEN
        AllocateArray[optionBase + 9, optionBase + 9, vp]
      ELSE RunTimeError["Array index out of bounds."L];
      END;
    IF index1 ~IN [varptr.arrayPtr.lb1 .. varptr.arrayPtr.ub1]
      OR index2 ~IN [varptr.arrayPtr.lb2 .. varptr.arrayPtr.ub2]
      THEN RunTimeError["Array index out of bounds."L]
    ELSE varptr.arrayPtr.base
      [(index1 - varptr.arrayPtr.lb1) * (varptr.arrayPtr.ub2 - varptr.arrayPtr.lb2 + 1)
        + (index2 - varptr.arrayPtr.lb2)] _ bv;
    END;
  ENDCASE => RunTimeError["Assignment to non-numeric array"L];
END;  -- of Arr2PopOp --


Arr2PushOp: BasicOps.OpCodeProc =
BEGIN
bvIndex1, bvIndex2: BasicValue;
index1, index2: CARDINAL;
vp: VariablePtr;
done _ FALSE;
bvIndex2 _ Pop[];
bvIndex1 _ Pop[];
[vp, newPc] _ FetchPointer[cm, pc];
index1 _ ConvertToCardinal[@bvIndex1];
index2 _ ConvertToCardinal[@bvIndex2];
WITH varptr: vp SELECT FROM
  numeric =>
    BEGIN
    IF varptr.arrayPtr = NIL THEN
      BEGIN
      IF (index1 <= optionBase + 9) AND (index2 <= optionBase + 9) THEN
        AllocateArray[optionBase + 9, optionBase + 9, vp]
      ELSE RunTimeError["Array index out of bounds."L];
      END;
    IF index1 ~IN [varptr.arrayPtr.lb1 .. varptr.arrayPtr.ub1]
      OR index2 ~IN [varptr.arrayPtr.lb2 .. varptr.arrayPtr.ub2]
      THEN RunTimeError["Array index out of bounds."L]
    ELSE Push[varptr.arrayPtr.base
      [(index1 - varptr.arrayPtr.lb1) * (varptr.arrayPtr.ub2 - varptr.arrayPtr.lb2 + 1)
        + (index2 - varptr.arrayPtr.lb2)]];
    END;
  ENDCASE => RunTimeError["Assignment to non-numeric array"L];
END;  -- of Arr2PushOp --


AutoOp: BasicOps.OpCodeProc =
BEGIN
bv: BasicValue;
bv _ Pop[];
autoIncrement _ ConvertToCardinal[@bv];
bv _ Pop[];
autoOn _ TRUE;
autoStart _ ConvertToCardinal[@bv] - autoIncrement;
-- OutputAutoLineNumber[] will add autoIncrement back to autoStart.
END;  -- of AutoOp --


CallBuiltInFnOp: BasicOps.OpCodeProc =
BEGIN
bv1, bv2: BasicValue;
varPtr: VariablePtr;
bv2 _ Pop[];
bv1 _ Pop[];
[varPtr, newPc] _ FetchPointer[cm, pc];
WITH v: varPtr SELECT FROM
  builtInFunction =>
    IF v.proc = NIL THEN RunTimeError["Undefined built-in function!"L]
    ELSE Push[v.proc[bv1, bv2]];
  ENDCASE => ERROR;
RETURN[FALSE, newPc];
END;  -- of CallBuiltInFnOp --


CallUserFnOp: BasicOps.OpCodeProc =
BEGIN
bv: BasicValue;
varPtr: VariablePtr;
bv _ Pop[];
[varPtr, pc] _ FetchPointer[cm, pc];
WITH v: varPtr SELECT FROM
  userFunction =>
    BEGIN
    node: FnEvalRecordPtr _ Storage.Node[SIZE[FnEvalRecord]];
    parVarPtr: VariablePtr;
    newProgLine: ProgramLineDescPtr;
    [newPc, newProgLine] _ FindUserFunctionDef[varPtr, cm];
    [parVarPtr, newPc] _ FetchPointer[cm, newPc];
    node^ _ FnEvalRecord
      [next: fnEvalStack, fn: @v, parameter: parVarPtr, returnPc: pc,
      returnProgLine: currentProgLine];
    fnEvalStack _ node;
    currentProgLine _ newProgLine;
    IF parVarPtr # LOOPHOLE[0] THEN
      BEGIN
      PushDownVariable[parVarPtr];
      WITH p: parVarPtr SELECT FROM
        numeric => p.value _ bv;
        string =>
          BEGIN
          target: STRING _ p.value.stringValue;
          target.length _ MIN[bv.stringValue.length, target.maxlength];
          FOR i: CARDINAL IN [0 .. target.length) DO
            target[i] _ bv.stringValue[i];
            ENDLOOP;
          Storage.FreeString[bv.stringValue];
          END;
        ENDCASE => ERROR;
      END;
    v.value _ BasicValueZero;
    END
  ENDCASE => ERROR;
RETURN[FALSE, newPc];
END;  -- of CallUserFnOp --


ChooseLineNumber: PUBLIC PROCEDURE [cm: vmD.ComposedMessagePtr, pc: vmD.CharIndex]
  RETURNS [CARDINAL] =
BEGIN
bv: BasicValue _ Pop[];
i: CARDINAL _ ConvertToCardinal[@bv];
lineNumber: POINTER;
IF i < 1 THEN RunTimeError["ON expression out of range!"L];
THROUGH [1 .. i] DO
  [lineNumber, pc] _ FetchPointer[cm, pc];
  IF lineNumber = LOOPHOLE[0] THEN RunTimeError["ON expression out of range!"L];
  ENDLOOP;
RETURN[LOOPHOLE[lineNumber]];
END;  -- of ChooseLineNumber --


ClearStack: PUBLIC PROCEDURE =
-- Clears execution stack.
BEGIN
bv: BasicValue;
UNTIL stackPointer = 0 DO
  bv _ Pop[];
  IF bv.type = string THEN Storage.FreeString[bv.stringValue];
  ENDLOOP;
END;  -- of ClearStack --


CodeListOp: BasicOps.OpCodeProc =
BEGIN
ListOperation[ListSourceAndCodeLine];
RETURN[FALSE, pc];
END;  -- of CodeListOp --


Compare: PUBLIC PROCEDURE [bvp1, bvp2: BasicValuePtr] RETURNS [result: INTEGER] =
-- Returns -1 if bvp1 < bvp2, 0 if bvp1 = bvp2, 1 if bvp1 > bvp2.
BEGIN
SELECT bvp1.type FROM
  integer =>
    SELECT bvp2.type FROM
      integer => RETURN
        [SELECT bvp1.integerValue FROM
          = bvp2.integerValue => 0,
          < bvp2.integerValue => -1,
          ENDCASE => 1];
      real => RETURN[RealOps.FComp[RealOps.Float[bvp1.integerValue], bvp2.realValue]];
      string =>
        BEGIN
        Storage.FreeString[bvp2.stringValue];
        RunTimeError["Comparing numeric to string!"L];
        END;
      ENDCASE;
  real =>
    SELECT bvp2.type FROM
      integer => RETURN[RealOps.FComp[bvp1.realValue, RealOps.Float[bvp2.integerValue]]];
      real => RETURN[RealOps.FComp[bvp1.realValue, bvp2.realValue]];
      string =>
        BEGIN
        Storage.FreeString[bvp2.stringValue];
        RunTimeError["Comparing numeric to string!"L];
        END;
      ENDCASE;
  string =>
    SELECT bvp2.type FROM
      integer, real =>
        BEGIN
        Storage.FreeString[bvp1.stringValue];
        RunTimeError["Comparing string to numeric!"L];
        END;
      string => BEGIN
        result _ String.CompareStrings[bvp1.stringValue, bvp2.stringValue];
        Storage.FreeString[bvp1.stringValue];
        Storage.FreeString[bvp2.stringValue];
        END;
      ENDCASE;
  ENDCASE;
END;  -- of Compare --


ContOp: BasicOps.OpCodeProc =
BEGIN
bv: BasicValue;
IF contPc = NIL THEN RunTimeError["Can't continue."L];
bv _ BasicValue[type: integer, varPart: integer[integerValue: contPc.lineNumber]];
Push[bv];
[ , ] _ BasicOps.RunOp[cm, pc];
RETURN[TRUE, pc];
END;  -- of ContOp --


ConvertToCardinal: PUBLIC PROCEDURE [bv: BasicValuePtr] RETURNS [n: CARDINAL] =
BEGIN
SELECT bv.type FROM
  integer => n _ Inline.LowHalf[bv.integerValue];
  real => n _ RealOps.RoundC[bv.realValue];
  ENDCASE =>
    BEGIN
    Storage.FreeString[bv.stringValue];
    RunTimeError["Numeric value required."L];
    END;
END;  -- of ConvertToCardinal --


DataOp: BasicOps.OpCodeProc =
BEGIN
currentProgLine _ currentProgLine.next;
RETURN[TRUE, pc];
END;  -- of DataOp --


DefFnOp: BasicOps.OpCodeProc =
BEGIN
fnVarPtr: VariablePtr;
byte: BasicOps.Byte;
[byte, newPc] _ FetchByte[cm, pc];
[fnVarPtr, newPc] _ FetchPointer[cm, newPc];
WITH v: fnVarPtr SELECT FROM
  userFunction => v.defLineNumber _ currentProgLine.lineNumber;
  ENDCASE => ERROR;
IF byte = 2 THEN
  currentProgLine _ SearchForOpCodeByLines[cm, currentProgLine.next, BasicOps.FnEnd];
IF currentProgLine = NIL THEN RunTimeError["Missing FN END statement!"L];
currentProgLine _ currentProgLine.next;
RETURN[TRUE, newPc];
END;  -- of DefFnOp --


DeleteOp: BasicOps.OpCodeProc =
BEGIN
bv: BasicValue;
cur, prev, next: ProgramLineDescPtr;
start, end: CARDINAL;
startText, endText, startCode, endCode: vmD.CharIndex;
bv _ Pop[];
end _ ConvertToCardinal[@bv];
bv _ Pop[];
start _ ConvertToCardinal[@bv];
prev _ NIL;
FOR cur _ programLineDescHead, cur.next UNTIL cur = NIL OR cur.lineNumber >= start DO
  prev _ cur;
  ENDLOOP;
IF cur = NIL OR cur.lineNumber > start THEN
  RunTimeError["Initial DELETE line number does not exist."L];
startText _ endText _ cur.start;
startCode _ endCode _ cur.codeStart;
UNTIL cur = NIL OR (end # 0 AND cur.lineNumber > end) DO
  endText _ cur.end;
  endCode _ cur.codeEnd;
  next _ cur.next;
  Storage.Free[cur];
  IF prev = NIL THEN programLineDescHead _ next ELSE prev.next _ next;
  cur _ next;
  IF end = 0 THEN EXIT;
  ENDLOOP;
vmD.DeleteRangeInMessage[[startText, endText, cM]];
vmD.DeleteRangeInMessage[[startCode, endCode, codeCm]];
UNTIL cur = NIL DO
  cur.start _ cur.start - (endText - startText);
  cur.end _ cur.end - (endText - startText);
  cur.codeStart _ cur.codeStart - (endCode - startCode);
  cur.codeEnd _ cur.codeEnd - (endCode - startCode);
  cur _ cur.next;
  ENDLOOP;
RETURN[TRUE, pc];
END;  -- of DeleteOp --


DimOp: BasicOps.OpCodeProc =
BEGIN
bv1, bv2: BasicValue;
ub1, ub2: CARDINAL;
varPtr: VariablePtr;
bv2 _ Pop[];
bv1 _ Pop[];
ub1 _ ConvertToCardinal[@bv1];
ub2 _ ConvertToCardinal[@bv2];
[varPtr, newPc] _ FetchPointer[cm, pc];
WITH v: varPtr SELECT FROM
  numeric =>
    IF v.arrayPtr = NIL OR v.arrayPtr.ub1 # ub1
      OR ((ub2 = 0 AND v.arrayPtr.ub2 # optionBase)
            OR (ub2 # 0 AND v.arrayPtr.ub2 # ub2)) THEN
      BEGIN
      optionBaseCalled _ TRUE;
      IF v.arrayPtr # NIL THEN Storage.Free[v.arrayPtr];
      AllocateArray[ub1, IF ub2 = 0 THEN optionBase ELSE ub2, varPtr];
      RETURN[FALSE, newPc];
      END;
  ENDCASE => RunTimeError["DIM'ed array variable already in use!"L];
END;  -- of DimOp --


DimStrOp: BasicOps.OpCodeProc =
BEGIN
bv: BasicValue _ Pop[];
varPtr: VariablePtr;
length: CARDINAL _ ConvertToCardinal[@bv];
[varPtr, newPc] _ FetchPointer[cm, pc];
WITH v: varPtr SELECT FROM
  string =>
    IF varPtr.value.stringValue.maxlength # length THEN 
      BEGIN
      Storage.FreeString[varPtr.value.stringValue];
      varPtr.value.stringValue _ Storage.String[length];
      RETURN[FALSE, newPc];
      END;
  ENDCASE => RunTimeError["String DIMension of non-string variable!"L];
END;  -- of DimStrOp --


DivOp: BasicOps.OpCodeProc =
BEGIN
RETURN[ArithmeticOp[div], pc];
END;  -- of DivOp --


DoneOp: BasicOps.OpCodeProc =
BEGIN
currentProgLine _ currentProgLine.next;
RETURN[TRUE, pc];
END;  -- of DoneOp --


EndOp: BasicOps.OpCodeProc =
BEGIN
currentProgLine _ NIL;
RETURN[TRUE, pc];
END;  -- of EndOp --


EqualOp: BasicOps.OpCodeProc =
BEGIN
PushInteger[IF BasicOps.PopAndCompare[] = 0 THEN 1 ELSE 0];
RETURN[FALSE, pc];
END;  -- of EqualOp --


ExpOp: BasicOps.OpCodeProc =
BEGIN
RETURN[ArithmeticOp[exp], pc];
END;  -- of ExpOp --


FetchByte: PUBLIC PROCEDURE [cm: vmD.ComposedMessagePtr, pc: vmD.CharIndex]
  RETURNS [byte: BasicOps.Byte, newPc: vmD.CharIndex] =
BEGIN
byte _ LOOPHOLE[vmD.GetMessageChar[cm, pc]];
newPc _ pc + 1;
END;  -- of FetchByte --


FetchPointer: PUBLIC PROCEDURE [cm: vmD.ComposedMessagePtr, pc: vmD.CharIndex]
  RETURNS [pointer: POINTER, newPc: vmD.CharIndex] =
BEGIN
TwoHalf: TYPE = MACHINE DEPENDENT RECORD [high, low: BasicOps.Byte];
LOOPHOLE[pointer, TwoHalf].high _ LOOPHOLE[vmD.GetMessageChar[cm, pc]];
LOOPHOLE[pointer, TwoHalf].low _ LOOPHOLE[vmD.GetMessageChar[cm, pc + 1]];
newPc _ pc + 2;
END;  -- of FetchPointer --


FindUserFunctionDef: PROCEDURE [fn: VariablePtr, cm: vmD.ComposedMessagePtr]
  RETURNS [pc: vmD.CharIndex, line: ProgramLineDescPtr] =
-- "fn" is a userFunction variable.  "line" returned is the program line on which "fn"s
--   definition is found, "pc" is the code pc for the parameter variable in the DefFn op code.
BEGIN

ThisIsIt: PROCEDURE RETURNS [BOOLEAN] =
  BEGIN
  byte: BasicOps.Byte;
  var: VariablePtr;
  [byte, pc] _ FetchByte[cm, line.codeStart];
  IF byte # BasicOps.DefFn THEN RETURN[FALSE];
  [byte, pc] _ FetchByte[cm, pc];
  [var, pc] _ FetchPointer[cm, pc];
  RETURN[var = fn];
  END;  -- of ThisIsIt --

WITH v: fn SELECT FROM
  userFunction =>
    BEGIN
    IF v.defLineNumber # 0 THEN
      BEGIN
      line _ FindLineNumber[v.defLineNumber];
      IF ThisIsIt[] THEN RETURN;
      END;
    line _ programLineDescHead;
    DO
      line _ SearchForOpCodeByLines[cm, line, BasicOps.DefFn];
      IF line = NIL THEN RunTimeError["Function definition not found!"L];
      IF ThisIsIt[] THEN RETURN;
      line _ line.next;
      ENDLOOP;
    END;
  ENDCASE => ERROR;
END;  -- of FindUserFunctionDef --


FloatIntegers: PROCEDURE [value1, value2: BasicValuePtr]
  RETURNS [real1, real2: REAL] =
BEGIN
real1 _ IF value1.type = real THEN value1.realValue
  ELSE RealOps.Float[value1.integerValue];
real2 _ IF value2.type = real THEN value2.realValue
  ELSE RealOps.Float[value2.integerValue];
END; -- of FloatIntegers --


FnEndOp: BasicOps.OpCodeProc =
BEGIN
node: FnEvalRecordPtr _ fnEvalStack;
IF node = NIL THEN RunTimeError["Unmatched FN END!"L];
Push[node.fn.value];
PopVariable[node.parameter];
fnEvalStack _ node.next;
newPc _ node.returnPc;
currentProgLine _ node.returnProgLine;
Storage.Free[node];
RETURN[FALSE, newPc];
END;  -- of FnEndOp --


ForOp: BasicOps.OpCodeProc =
BEGIN
bvInitial, bvFinal, bvStep: BasicValue;
bvZero: BasicValue _ BasicValueZero;
stepResult, boundsResult: INTEGER;
varPtr: VariablePtr;
node: NextStackPtr;
bvStep _ Pop[];
bvFinal _ Pop[];
bvInitial _ Pop[];
[varPtr, newPc] _ FetchPointer[cm, pc];
IF bvStep.type = string OR bvFinal.type = string OR bvInitial.type = string THEN
  RunTimeError["String value illegal in FOR statement!"L];
varPtr.value _ bvInitial;
stepResult _ Compare[@bvStep, @bvZero];
IF stepResult = 0 THEN RunTimeError["Zero step value in FOR statement!"L];
boundsResult _ Compare[@bvInitial, @bvFinal];
IF stepResult = boundsResult THEN
  BEGIN
  plpc: ProgramLineDescPtr _ currentProgLine;
  nextVarPtr: VariablePtr;
  DO
    plpc _ SearchForOpCodeByLines[cm, plpc.next, BasicOps.Next];
    IF plpc = NIL THEN RunTimeError["Corresponding NEXT statement not found!"L];
    [nextVarPtr, ] _ FetchPointer[cm, plpc.codeStart + 1];
    IF nextVarPtr = varPtr THEN {currentProgLine _ plpc.next; RETURN[TRUE, newPc]};
    ENDLOOP;
  END;
node _ Storage.Node[SIZE[NextStackRec]];
node^ _ NextStackRec
  [next: nextStackHead,
  varPtr: varPtr,
  stepDirection: stepResult,
  stepValue: bvStep,
  finalValue: bvFinal,
  progLine: currentProgLine];
nextStackHead _ node;
currentProgLine _ currentProgLine.next;
RETURN[TRUE, newPc];
END;  -- of ForOp --


GEOp: BasicOps.OpCodeProc =
BEGIN
PushInteger[IF BasicOps.PopAndCompare[] >= 0 THEN 1 ELSE 0];
RETURN[FALSE, pc];
END;  -- of GEOp --


GoSubGuts: PUBLIC PROCEDURE [lineNumber: CARDINAL] =
BEGIN
node: GoSubStackPtr;
node _ Storage.Node[SIZE[GoSubRec]];
node^ _ GoSubRec[goSubHead, currentProgLine];
goSubHead _ node;
currentProgLine _ FindLineNumber[LOOPHOLE[lineNumber]];
IF currentProgLine = NIL THEN RunTimeError["GOSUB target not found!"L];
END;  -- of GoSubGuts --


GoSubOp: BasicOps.OpCodeProc =
BEGIN
lineNumber: POINTER;
[lineNumber, newPc] _ FetchPointer[cm, pc];
GoSubGuts[LOOPHOLE[lineNumber]];
RETURN[TRUE, newPc];
END;  -- of GoSubOp --


GoToGuts: PUBLIC PROCEDURE [lineNumber: CARDINAL] =
BEGIN
currentProgLine _ FindLineNumber[lineNumber];
IF currentProgLine = NIL THEN RunTimeError["GO TO target not found!"L];
END;  -- of GoToGuts --


GoToOp: BasicOps.OpCodeProc =
BEGIN
lineNumber: POINTER;
[lineNumber, newPc] _ FetchPointer[cm, pc];
GoToGuts[LOOPHOLE[lineNumber]];
RETURN[TRUE, pc];
END;  -- of GoToOp --


GreaterOp: BasicOps.OpCodeProc =
BEGIN
PushInteger[IF BasicOps.PopAndCompare[] = 1 THEN 1 ELSE 0];
RETURN[FALSE, pc];
END;  -- of GreaterOp --


HelpOp: BasicOps.OpCodeProc =
BEGIN
IODefs.WriteLine["Begin each line with either a line number or with a command."L];
IODefs.WriteLine["A line number indicates a program line to be executed later;"L];
IODefs.WriteLine["no line number indicates a direct command to be executed immediately."L];
IODefs.WriteLine["Commands supported by Laurel Basic are acceptable either in program"L];
IODefs.WriteLine["lines, as direct commands, or in both contexts according to the following lists."L];
IODefs.WriteLine[""L];
IODefs.WriteLine["Direct commands"L];
IODefs.WriteLine["AUTO, CONTINUE, CODELIST, DELETE, HELP, LIST, NORMAL, QUIT, RUN"L];
IODefs.WriteLine[""L];
IODefs.WriteLine["Program commands"L];
IODefs.WriteLine["!, CLEAR, DATA, DEF FN, DIM, END, FN END, FOR, GOSUB, GOTO,"L];
IODefs.WriteLine["IF, INPUT, NEXT, ON GOSUB, ON GOTO, PAUSE, REM, RETURN, STOP"L];
IODefs.WriteLine[""L];
IODefs.WriteLine["Direct or program commands"L];
IODefs.WriteLine["DEG, DISPLAY, LET, LOAD, OPTION BASE, PRINT, RAD, READ, RESTORE, "L];
IODefs.WriteLine[""L];
IODefs.WriteLine["Pre-loaded functions include:"L];
IODefs.WriteLine["ABS, ACS, ASN, ATN, ATN2, CEIL, CHR$, COS, COT, CSC, DTR, ESP,"L];
IODefs.WriteLine["EXP, FLOOR, FP, IP, INT, LEN, LGT, LOG, MAX, MIN, NUM, PI, POS,"L];
IODefs.WriteLine["RTD, RMD, SEC, SGN, SIN, SQR, TAN, UPC$, VAL, VAL$"L];
IODefs.WriteLine[""L];
RETURN[TRUE, pc];
END;  -- of HelpOp --


IfZeroDoneOp: BasicOps.OpCodeProc =
BEGIN
bv: BasicValue _ Pop[];
i: CARDINAL _ ConvertToCardinal[@bv];
IF i = 0 THEN currentProgLine _ currentProgLine.next;
RETURN[i = 0, pc];
END;  -- of IfZeroDoneOp --


ImageOp: BasicOps.OpCodeProc =
BEGIN
currentProgLine _ currentProgLine.next;
RETURN[TRUE, pc];
END;  -- of ImageOp --


InputNumOp: BasicOps.OpCodeProc =
BEGIN
byte: BasicOps.Byte;
value: BasicValue;
[byte, newPc] _ FetchByte[cm, pc];
IF byte = 0 THEN
  BEGIN
  IODefs.WriteLine["?"L];
  IODefs.ReadLine[inputLine];
  inputLineIndex _ 0;
  END;
value _ GetInputValue[FALSE];
Push[value];
IF value.type = string THEN Storage.FreeString[value.stringValue];
RETURN[FALSE, newPc];
END;  -- of InputNumOp --


InputStrOp: BasicOps.OpCodeProc =
BEGIN
byte: BasicOps.Byte;
value: BasicValue;
[byte, newPc] _ FetchByte[cm, pc];
IF byte = 0 THEN
  BEGIN
  IODefs.WriteLine["?"L];
  IODefs.ReadLine[inputLine];
  inputLineIndex _ 0;
  END;
value _ GetInputValue[TRUE];
Push[value];
IF value.type = string THEN Storage.FreeString[value.stringValue];
RETURN[FALSE, newPc];
END;  -- of InputStrOp --


InterpretCode: PUBLIC PROCEDURE [cm: vmD.ComposedMessagePtr, pc: vmD.CharIndex] =
BEGIN
done: BOOLEAN _ FALSE;
op: BasicOps.Byte;
StreamDefs.ResetControlDEL[];
UNTIL done DO
  IF StreamDefs.ControlDELtyped[] THEN RunTimeError["Program interrupted!"L];
  [op, pc] _ FetchByte[cm, pc];
  [done, pc] _ opCode[op].proc[cm, pc];
  ENDLOOP;
END;  -- of InterpretCode --


END.  -- of BasicInterpA --
(1792)\f1