jvqforth.pas

East make Tray Icon in delphi

    else
    if (token[1] = '?') and (Length(token) > 1) then
    begin
      p := Pos('.', token);
      if (p = 0) or (p < 3) or (p = Length(token)) then
        raise EJvJanScriptError.CreateResFmt(@RsEMissingXmlMethodSpecifierNears, [s]);
      atomsymbol := Copy(token, 2, p - 2);
      atomValue := Copy(token, p + 1, Length(token));
      pushatom(dfoXML);
    end
    // check for data source object
    else
    if (token[1] = '_') and (Length(token) > 1) then
    begin
      p := Pos('.', token);
      if (p = 0) or (p < 3) or (p = Length(token)) then
        raise EJvJanScriptError.CreateResFmt(@RsEMissingDataSourceMethodSpecifierNea, [s]);
      atomsymbol := Copy(token, 2, p - 2);
      atomValue := Copy(token, p + 1, Length(token));
      pushatom(dfoDSO);
    end
    // system
    else
    if (token[1] = ')') and (Length(token) > 1) then
    begin
      p := Pos('.', token);
      if (p = 0) or (p < 3) or (p = Length(token)) then
        raise EJvJanScriptError.CreateResFmt(@RsEMissingSystemMethodSpecifierNears, [s]);
      atomsymbol := Copy(token, 2, p - 2);
      atomValue := Copy(token, p + 1, Length(token));
      pushatom(dfoSystem);
    end
    // external variable
    else
    if (token[1] = '>') and (Length(token) > 1) then
    begin
      p := Pos('.', token);
      if (p = 0) or (p < 3) or (p = Length(token)) then
        raise EJvJanScriptError.CreateResFmt(@RsEMissingExternalVariableMethodSpecif, [s]);
      atomsymbol := Copy(token, 2, p - 2);
      atomValue := Copy(token, p + 1, Length(token));
      pushatom(dfoExtVar);
    end
    // check for internal variable
    else
    if (token[1] = ':') and (Length(token) > 1) then
    begin
      p := Pos('.', token);
      if (p = 0) or (p < 3) or (p = Length(token)) then
        raise EJvJanScriptError.CreateResFmt(@RsEMissingInternalVariableMethodSpecif, [s]);
      atomsymbol := Copy(token, 2, p - 2);
      atomValue := Copy(token, p + 1, Length(token));
      pushatom(dfoIntVar);
    end
    // check for string
    else
    if token[1] = '"' then
    begin
      atomsymbol := token;
      atomValue := Copy(token, 2, Length(token) - 2);
      pushatom(dfostring);
    end
    // check Integer, float or date
    else
    begin
      try // Integer
        vinteger := StrToInt(token);
        atomsymbol := token;
        atomValue := vinteger;
        pushatom(dfoInteger);
      except
        try // float
          vfloat := strtofloat(token);
          atomsymbol := token;
          atomValue := vfloat;
          pushatom(dfofloat);
        except
          try // date
            vdate := strtodate(token);
            atomsymbol := token;
            atomValue := vdate;
            pushatom(dfoDate);
          except // must be call to sub
            atomsymbol := token;
            p := FSubsList.IndexOf(atomsymbol);
            if p = -1 then
              raise EJvJanScriptError.CreateResFmt(@RsEUndefinedWordsNears, [atomsymbol, s]);
            p := Integer(FsubsList.Objects[p]);
            atomValue := p;
            pushatom(dfoCall);
          end;
        end;
      end;
    end;
  end;
end;

procedure TJvForthScript.doToken(aToken: TToken);
begin
  case aToken of
    dfonow: ProcNow;
    dfodatestr: ProcDateStr;
    dfotimestr: ProcTimeStr;
    dfoshellexecute: ProcShellExecute;
    dfocrlf: ProcCrLf;
    dfoCStr: procCStr;
    dfoXML: ProcXML;
    dfoDSO: procDSO;
    dfoSeldir: ProcSelDir;
    dfoDSOBase: ProcDSOBase;
    dfoIntVar: ProcIntVar;
    dfoExtVar: ProcExtVar;
    dfoSystem: procSystem;
    //    dfoVarGet: ProcVarGet;
    //    dfoVarset: ProcVarSet;
    //    dfoSysGet: procSysGet;
    //    dfoSysSet: procSysSet;
    dfoSub: procSub;
    dfoEndSub: procEndSub;
    dfoCall: procCall;
    dfodrop: procdrop;
    dfodup: procdup;
    dfoswap: procswap;
    dfoIf: procif;
    dfoElse: procElse;
    dfoEndIf: procEndIf;
    dfoRepeat: procRepeat;
    dfoUntil: procUntil;
    dfonop: procNop;
    //    dfoassign: ProcAssign;
    //    dfovariable: ProcVariable;
    dfointeger: procInteger;
    dfofloat: procFloat;
    dfoset: procSet;
    dfostring: procString;
    dfoboolean: procBoolean;
    dfoDate: procDate;
    dfoeq: procEq;
    dfone: procNe;
    dfogt: procGt;
    dfolt: procLt;
    dfoge: procGe;
    dfole: procLe;
    dfolike: procLike;
    dfounlike: procUnlike;
    dfonot: procNot;
    dfoand: procAnd;
    dfoxor: procXor;
    dfoor: procOr;
    dfoIn: procIn;
    dfoadd: procAdd;
    dfosubtract: procSubtract;
    dfomultiply: procMultiply;
    dfodivide: procDivide;
    dfoPower: procPower;
    dfoAbs: procAbs;
    dfopi: procpi;
    dfosin: procSin;
    dfocos: procCos;
    dfotan: procTan;
    dfoarcsin: procarcsin;
    dfoarccos: procarccos;
    dfoarctan: procarctan;
    dfoarctan2: procarctan2;
    dfonegate: procNegate;
    dfosqr: procSqr;
    dfosqrt: procSqrt;
    dfoleft: procLeft;
    dforight: procRight;
  end;
end;

function TJvForthScript.Execute: Variant;
var
  c: Integer;
  atom: TAtom;
  Token: TToken;
  TimeOutTicks: Cardinal;
  deltaTicks: cardinal;
begin
  Result := null;
  // osp := 0;
  FVSP := 0;
  FPSP := 0;
  FRSP := 0;
  c := FAtoms.Count;
  FVarsList.ClearObjects;
  FDSOList.ClearTables;
  FXMLList.ClearXMLS;
  FXMLSelect.Clear;
  FXMLSelectRecord := -1;
  if c = 0 then
    Exit;
  FPC := 0;
  deltaTicks := FScriptTimeOut * 1000;
  TimeOutticks := GetTickCount + DeltaTicks;
  // evaluate all FAtoms
  while FPC < c do
  begin
    if GetTickCount > timeOutTicks then
      raise EJvJanScriptError.CreateResFmt(@RsEScriptTimedOutAfterdSeconds, [FScriptTimeout]);
    atom := TAtom(FAtoms[FPC]);
    Inc(FPC);
    FCurrentValue := atom.Value;
    FCurrentSymbol := atom.Symbol;
    token := atom.Token;
    case token of
      dfoInteger..dfoDate:
        begin
          vpush(FCurrentValue)
        end;
    else
      begin
        doToken(token);
      end;
    end
  end;
  if FVSP <= 0 then
    Result := null
  else
    Result := vpop;
end;

procedure TJvForthScript.SetOnGetVariable(const Value: TOnGetVariable);
begin
  FOnGetVariable := Value;
end;

(*)
procedure TJvForthScript.ClearAtoms;
var
  i, c: Integer;
begin
  c := FAtoms.Count;
  if c = 0 then
    Exit;
  for i := 0 to c - 1 do
    Tobject(FAtoms[i]).Free;
  FAtoms.Clear;
end;
(*)

procedure TJvForthScript.SetOnSetVariable(const Value: TOnSetVariable);
begin
  FOnSetVariable := Value;
end;

procedure TJvForthScript.procAdd;
var
  Value: Variant;
begin
  Value := vpop;
  Value := vpop + Value;
  vpush(Value);
end;

procedure TJvForthScript.procAnd;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(vpop and Value);
end;

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

procedure TJvForthScript.procBoolean;
begin
  Vpush(FCurrentValue);
  doproc;
end;

procedure TJvForthScript.doproc;
var
  token: TToken;
begin
  if FPSP <= 0 then
    Exit;
  Dec(FPSP);
  token := FPStack[FPSP];
  doToken(token);
end;

procedure TJvForthScript.procCos;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(cos(Value));
end;

procedure TJvForthScript.procDate;
begin
  Vpush(FCurrentValue);
  doproc;
end;

procedure TJvForthScript.procDivide;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(vpop / Value);
end;

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

procedure TJvForthScript.procFloat;
begin
  Vpush(FCurrentValue);
  doproc;
end;

procedure TJvForthScript.procGe;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(vpop >= Value);
end;

procedure TJvForthScript.procGt;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(vpop > Value);
end;

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

procedure TJvForthScript.procInteger;
begin
  Vpush(FCurrentValue);
  doproc;
end;

procedure TJvForthScript.procLe;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(vpop <= Value);
end;

procedure TJvForthScript.procLeft;
var
  Value, v2: Variant;
  vali: Integer;
  vals: string;
begin
  Value := vpop;
  v2 := vpop;
  vali := Value;
  vals := v2;
  Value := Copy(vals, 1, vali);
  vpush(Value);
end;

procedure TJvForthScript.procLike;
var
  Value: Variant;
begin
  Value := vartostr(vpop);
  vpush(Pos(LowerCase(Value), LowerCase(vartostr(vpop))) > 0);
end;

procedure TJvForthScript.procLt;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(vpop < Value);
end;

procedure TJvForthScript.procMultiply;
var
  Value: Variant;
begin
  Value := vpop;
  Value := vpop * Value;
  vpush(Value);
end;

procedure TJvForthScript.procNe;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(vpop <> Value);
end;

procedure TJvForthScript.procNegate;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(0 - Value);
end;

procedure TJvForthScript.procNop;
begin
  //  just do nothing
end;

procedure TJvForthScript.procNot;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(not Value);
end;

procedure TJvForthScript.procOr;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(vpop or Value);
end;

procedure TJvForthScript.procRight;
var
  Value, v2: Variant;
  vali: Integer;
  vals: string;
begin
  Value := vpop;
  v2 := vpop;
  vali := Value;
  vals := v2;
  if vali <= Length(vals) then
    Value := Copy(vals, Length(vals) - vali + 1, vali)
  else
    Value := vals;
  vpush(Value);
end;

procedure TJvForthScript.procSet;
begin
  Vpush(FCurrentValue);
  doproc;
end;

procedure TJvForthScript.procSin;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(Sin(Value));
end;

procedure TJvForthScript.procSqr;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(Sqr(Value));
end;

procedure TJvForthScript.procSqrt;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(Sqrt(Value));
end;

procedure TJvForthScript.procString;
begin
  Vpush(FCurrentValue);
  doproc;
end;

procedure TJvForthScript.procSubtract;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(vpop - Value);
end;

procedure TJvForthScript.procUnlike;
var
  Value: Variant;
begin
  Value := vartostr(vpop);
  vpush(Pos(LowerCase(Value), LowerCase(vartostr(vpop))) = 0);
end;

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

procedure TJvForthScript.procXor;
var
  Value: Variant;
begin
  Value := vpop;
  vpush(vpop xor Value);
end;

procedure TJvForthScript.procIf;
var
  v: Variant;
begin
  v := vpop;
  if v then
    Exit
  else