jvqforth.pas

East make Tray Icon in delphi

    FPC := FCurrentValue;
end;

procedure TJvForthScript.procElse;
begin
  FPC := FCurrentValue;
end;

procedure TJvForthScript.procDrop;
begin
  vpop;
end;

procedure TJvForthScript.procDup;
var
  v: Variant;
begin
  v := vpop;
  vpush(v);
  vpush(v);
end;

procedure TJvForthScript.procSwap;
var
  v1, v2: Variant;
begin
  v1 := vpop;
  v2 := vpop;
  vpush(v1);
  vpush(v2);
end;

// just a marker

procedure TJvForthScript.procEndif;
begin
  // do nothing
end;

// keep looping until vpop=True

procedure TJvForthScript.procUntil;
begin
  if not vpop then
    FPC := FCurrentValue;
end;

procedure TJvForthScript.procRepeat;
begin
  // do nothing
end;

function TJvForthScript.rpop: Integer;
begin
  if FRSP <= 0 then
    raise EJvJanScriptError.CreateRes(@RsEReturnStackUnderflow)
  else
  begin
    Dec(FRSP);
    Result := FRStack[FRSP];
  end;
end;

procedure TJvForthScript.rpush(AValue: Integer);
begin
  FRStack[FRSP] := AValue;
  if FRSP < StackMax then
    Inc(FRSP)
  else
    raise EJvJanScriptError.CreateRes(@RsEReturnStackOverflow);
end;

procedure TJvForthScript.SetScriptTimeOut(const Value: Integer);
begin
  FScriptTimeOut := Value;
end;

procedure TJvForthScript.procEndsub;
begin
  FPC := rpop;
end;

// just skip till endSub

procedure TJvForthScript.procSub;
var
  c: Integer;
  token: TToken;
begin
  { TODO -oJVCL -cPOSSIBLEBUG : (p3) What should "c" really be here? }
  c := FAtoms.Count; //??
  while FPC < c do
  begin
    token := TAtom(FAtoms[FPC]).token;
    if token = dfoEndSub then
    begin
      Inc(FPC);
      Exit;
    end;
    Inc(FPC);
  end;
end;

// call to a user sub, just look it up

procedure TJvForthScript.procCall;
var
  Index: Integer;
begin
  //  Index:=FSubsList.IndexOf(FCurrentSymbol);
  Index := FCurrentValue;
  if Index <> -1 then
  begin
    rpush(FPC);
    //    FPC:=Integer(FsubsList.Objects[Index]);
    FPC := Index;
    Exit;
  end
  else
    raise EJvJanScriptError.CreateResFmt(@RsEProceduresNotDefined, [FCurrentSymbol]);
end;

procedure TJvForthScript.ProcVarGet;
var
  v: Variant;
begin
  v := FvarsList.GetVariable(FCurrentSymbol);
  if v <> null then
    vpush(v)
  else
    raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);
end;

procedure TJvForthScript.ProcVarSet;
var
  v: Variant;
begin
  v := vpop;
  FVarsList.SetVariable(FCurrentSymbol, v);
end;

procedure TJvForthScript.procCStr;
var
  s: string;
begin
  s := vpop;
  vpush(s);
end;

procedure TJvForthScript.procSysGet;
var
  Value: Variant;
  Handled: Boolean;
  err, prompt: string;
begin
  prompt := vpop;
  Handled := False;
  err := Format(RsESystemsNotDefined, [FCurrentSymbol]);
  if Assigned(onGetSystem) then
    onGetSystem(Self, FCurrentSymbol, prompt, Value, Handled, Err);
  if not Handled then
    raise EJvJanScriptError.Create(err)
  else
    Vpush(Value);
end;

procedure TJvForthScript.procSysSet;
var
  Value: Variant;
  Handled: Boolean;
  err: string;
begin
  Value := vpop;
  vpush(Value);
  Handled := False;
  err := Format(RsECanNotAssignSystems, [FCurrentSymbol]);
  if Assigned(onSetSystem) then
  begin
    onSetSystem(Self, FCurrentSymbol, Value, Handled, Err);
    if not Handled then
      raise EJvJanScriptError.Create(err);
  end;
end;

procedure TJvForthScript.SetonGetSystem(const Value: TOnGetSystem);
begin
  FOnGetSystem := Value;
end;

procedure TJvForthScript.SetonSetSystem(const Value: TOnSetSystem);
begin
  FOnSetSystem := Value;
end;

function TJvForthScript.popValue: Variant;
begin
  Result := vpop;
end;

procedure TJvForthScript.pushValue(AValue: Variant);
begin
  vpush(AValue);
end;

function TJvForthScript.canPopValue: Boolean;
begin
  Result := FVSP > 0;
end;

function TJvForthScript.canPushValue: Boolean;
begin
  Result := FVSP < StackMax;
end;

procedure TJvForthScript.procpi;
begin
  vpush(pi);
end;

procedure TJvForthScript.procDSO;
var
  AName, aMethod: string;
  table: TJvJanDSO;
  AField, AValue: string;
  AKey: Variant;
  c: Integer;
begin
  AName := FCurrentSymbol;
  aMethod := FCurrentValue;
  table := FDSOList.Table(AName);
  if aMethod = 'set' then
  begin
    AKey := vpop;
    AField := vpop;
    AValue := vpop;
    table.SetValue(AKey, AField, AValue);
  end
  else
  if aMethod = 'get' then
  begin
    AKey := vpop;
    AField := vpop;
    AValue := table.GetValue(AKey, AField);
    vpush(AValue);
  end
  else
  if aMethod = 'load' then
    table.LoadFromFile(FDSOBase + PathDelim + AName + '.txt')
  else
  if aMethod = 'save' then
    table.SaveToFile(FDSOBase + PathDelim + AName + '.txt')
  else
  if aMethod = 'Clear' then
    table.Clear
  else
  if aMethod = 'Count' then
  begin
    c := table.Count;
    vpush(c);
  end;
end;

procedure TJvForthScript.ProcDSOBase;
var
  s: string;
begin
  s := vpop;
  FDSOBase := s;
end;

procedure TJvForthScript.ProcSelDir;


var
  Dir: WideString;
begin
  Dir := FDSOBase;
  if SelectDirectory('Select Directory', PathDelim, Dir {$IFDEF UNIX}, True {$ENDIF}) then
    FDSOBase := Dir;
end;


procedure TJvForthScript.ProcExtVar;
var
  AName, aMethod: string;
begin
  AName := FCurrentSymbol;
  aMethod := FCurrentValue;
  if aMethod = 'set' then
    ProcAssign
  else
  if aMethod = 'get' then
    ProcVariable
  else
    raise EJvJanScriptError.CreateResFmt(@RsEUnrecognizeExternalVariableMethodss, [AName, amethod]);
end;

procedure TJvForthScript.ProcIntVar;
var
  AName, aMethod: string;
begin
  AName := FCurrentSymbol;
  aMethod := FCurrentValue;
  if aMethod = 'set' then
    ProcVarSet
  else
  if aMethod = 'get' then
    ProcVarGet
  else
  if aMethod = '1+' then
    ProcVarInc
  else
  if aMethod = '[1+]' then
    ProcVarIncIndex
  else
  if aMethod = '1-' then
    ProcVarDec
  else
  if aMethod = '1-?0' then
    ProcVarDecTestZero
  else
  if aMethod = '+' then
    ProcVarAdd
  else
  if aMethod = '-' then
    ProcVarSub
  else
  if aMethod = '*' then
    ProcVarMul
  else
  if aMethod = '/' then
    ProcVarDiv
  else
  if aMethod = '--' then
    ProcVarNeg
  else
  if aMethod = 'load' then
    ProcVarLoad
  else
  if aMethod = 'save' then
    ProcVarSave
  else
    raise EJvJanScriptError.CreateResFmt(@RsEUnrecognizeInternalVariableMethodss, [AName, amethod]);
end;

procedure TJvForthScript.procSystem;
var
  AName, aMethod: string;
begin
  AName := FCurrentSymbol;
  aMethod := FCurrentValue;
  if aMethod = 'set' then
    procSysSet
  else
  if aMethod = 'get' then
    procSysGet
  else
    raise EJvJanScriptError.CreateResFmt(@RsEUnrecognizeSystemMethodss, [AName, amethod]);
end;

procedure TJvForthScript.ProcVarDec;
var
  vo: TVariantObject;
begin
  vo := FvarsList.GetObject(FCurrentSymbol);
  if vo <> nil then
    vo.Value := vo.Value - 1
  else
    raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);
end;

procedure TJvForthScript.ProcVarInc;
var
  vo: TVariantObject;
begin
  vo := FvarsList.GetObject(FCurrentSymbol);
  if vo <> nil then
    vo.Value := vo.Value + 1
  else
    raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);
end;

procedure TJvForthScript.ProcVarAdd;
var
  vo: TVariantObject;
begin
  vo := FvarsList.GetObject(FCurrentSymbol);
  if vo <> nil then
    vo.Value := vo.Value + vpop
  else
    raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);
end;

procedure TJvForthScript.ProcVarDiv;
var
  vo: TVariantObject;
begin
  vo := FvarsList.GetObject(FCurrentSymbol);
  if vo <> nil then
    vo.Value := vo.Value / vpop
  else
    raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);
end;

procedure TJvForthScript.ProcVarMul;
var
  vo: TVariantObject;
begin
  vo := FvarsList.GetObject(FCurrentSymbol);
  if vo <> nil then
    vo.Value := vo.Value * vpop
  else
    raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);
end;

procedure TJvForthScript.ProcVarSub;
var
  vo: TVariantObject;
begin
  vo := FvarsList.GetObject(FCurrentSymbol);
  if vo <> nil then
    vo.Value := vo.Value - vpop
  else
    raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);
end;

procedure TJvForthScript.ProcVarNeg;
var
  vo: TVariantObject;
begin
  vo := FvarsList.GetObject(FCurrentSymbol);
  if vo <> nil then
    vo.Value := 0 - vo.Value
  else
    raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);
end;

procedure TJvForthScript.procPower;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(power(vpop, Value));
end;

procedure TJvForthScript.procAbs;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(abs(Value));
end;

procedure TJvForthScript.SetonInclude(const Value: TOnInclude);
begin
  FOnInclude := Value;
end;

procedure TJvForthScript.procTan;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(tan(Value));
end;

procedure TJvForthScript.procarccos;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(arccos(Value));
end;

procedure TJvForthScript.procarcsin;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(arcsin(Value));
end;

procedure TJvForthScript.procarctan;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(arctan(Value));
end;

procedure TJvForthScript.procarctan2;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(arctan2(vpop, Value));
end;

procedure TJvForthScript.ProcVarLoad;
var
  vo: TVariantObject;
  ap, fn, s: string;
begin
  fn := vpop;
  ap := ExtractFilePath(paramstr(0));
  fn := StringReplace(fn, '%', ap, []);
  vo := FvarsList.GetObject(FCurrentSymbol);
  if vo <> nil then
  begin
    s := loadstring(fn);
    vo.Value := s;
  end
  else
    raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);
end;

procedure TJvForthScript.ProcVarSave;
var
  vo: TVariantObject;
  ap, fn, s: string;
begin
  fn := vpop;
  ap := ExtractFilePath(paramstr(0));
  fn := StringReplace(fn, '%', ap, []);
  vo := FvarsList.GetObject(FCurrentSymbol);
  if vo <> nil then
  begin
    s := vo.Value;
    savestring(fn, s);
  end
  else
    raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);
end;

procedure TJvForthScript.ProcXML;
var
  AName, aMethod: string;
  xmldso: TJvXMLTree;
  n: TJvXMLNode;
  a: TJvXMLAttribute;
  aPath, atName: string;
  AValue: Variant;
  c, i, cc: Integer;
  appldir: string;
  b: Boolean;
begin
  n := nil;
  appldir := ExtractFilePath(paramstr(0));
  AName := FCurrentSymbol;
  aMethod := FCurrentValue;