jvqforth.pas

East make Tray Icon in delphi

      p := Pos('..', s);
      if p = 0 then
      begin
        if (aList[Index]) = sv then
        begin
          Result := Index;
          Exit;
        end;
      end
      else
      begin
        s1 := trim(Copy(s, 1, p - 1));
        s2 := trim(Copy(s, p + 2, Length(s)));
        if (sv >= s1) and (sv <= s2) then
        begin
          Result := Index;
          Exit;
        end;
      end;
    except
      Exit;
    end;
  end;
end;

// used by dfoIN
// tests if AValue is in aSet

function FuncIn(AValue: Variant; aSet: Variant): Boolean;
var
  List: TStringList;
  s: string;
  p: Integer;
  token: string;

  function GetToken: Boolean;
  begin
    Result := False;
    s := trimleft(s);
    if s = '' then
      Exit;
    p := 1;
    if s[1] = '"' then
    begin // get string
      p := posstr('"', s, 2);
      if p = 0 then
        raise EJvJanScriptError.CreateResFmt(@RsEUnterminatedStringNears, [s]);
      token := Copy(s, 2, p - 2);
      Delete(s, 1, p);
      Result := True;
    end
    else
    begin
      p := Pos(' ', s);
      if p = 0 then
      begin
        token := s;
        Result := True;
        s := '';
      end
      else
      begin
        token := Copy(s, 1, p - 1);
        Delete(s, 1, p);
        Result := True
      end;
    end
  end;

begin
  Result := False;
  s := aSet;
  if s = '' then
    Exit;
  List := TStringList.create;
  try
    while gettoken do
      List.append(token);
    //    c:=List.Count;
    case VarType(AValue) of
      varString:
        begin
          Result := IndexOfString(List, AValue) > -1;
        end;
      varInteger, varByte:
        begin
          Result := IndexOfInteger(List, AValue) > -1;
        end;
      varSingle, varDouble:
        begin
          Result := IndexOfFloat(List, AValue) > -1;
        end;
      varDate:
        begin
          Result := IndexOfDate(List, AValue) > -1;
        end;
    else
      raise EJvJanScriptError.CreateRes(@RsEUnrecognizedDataTypeInSetOperation);
    end;
  finally
    List.Free;
  end;
end;

//=== { TJvForthScript } =====================================================

constructor TJvForthScript.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAtoms := TAtomList.Create;
  FIncludes := TStringList.create;
  FSubsList := TStringList.create;
  FVarsList := TvariantList.Create;
  FDSOList := TJvJanDSOList.Create;
  FXMLList := TJvJanXMLList.Create;
  FXMLSelect := TList.Create;
  FDSOBase := ExtractFilePath(paramstr(0));
  if FDSOBase[Length(FDSOBase)] = PathDelim then
    Delete(FDSOBase, Length(FDSOBase), 1);
  FVSP := 0;
  // osp := 0;
  FRSP := 0;
  FInDevice := 'dialog';
  FOutDevice := 'dialog';
  FScriptTimeOut := 30; // seconds
end;

destructor TJvForthScript.Destroy;
begin
  FAtoms.Free;
  FIncludes.Free;
  FSubsList.Free;
  FVarsList.Free;
  FDSOList.Free;
  FXMLList.Free;
  FXMLSelect.Free;
  inherited Destroy;
end;

procedure TJvForthScript.vpush(AValue: Variant);
begin
  //FVStack.push(AValue);
  FVStack[FVSP] := AValue;
  if FVSP < StackMax then
    Inc(FVSP)
  else
    raise EJvJanScriptError.CreateRes(@RsEStackOverflow);
end;

(*
procedure TJvForthScript.opush(AValue: TToken);
begin
  ostack[osp] := AValue;
  if osp < StackMax then
    Inc(osp);
end;
*)
(*
function TJvForthScript.opop: TToken;
begin
  showmessage('opop');
  if osp <= 0 then
    Result := dfonop
  else
  begin
    Dec(osp);
    Result := ostack[osp];
  end;
end;
*)
(*
procedure TJvForthScript.ppush(AValue: TToken);
begin
  FPStack[FPSP] := AValue;
  if FPSP < StackMax then
    Inc(FPSP);
end;
*)
(*
function TJvForthScript.ppop: TToken;
begin
  if FPSP = 0 then
    Result := dfoError
  else
  begin
    Dec(FPSP);
    Result := FPStack[FPSP];
  end;
end;
*)
function TJvForthScript.vpop: Variant;
begin
  if FVSP = 0 then
    raise EJvJanScriptError.CreateRes(@RsEStackUnderflow)
  else
  begin
    Dec(FVSP);
    Result := FVStack[FVSP];
  end;
end;

procedure TJvForthScript.SetScript(const Value: string);
begin
  if Value <> FScript then
  begin
    FScript := Value;
    ParseScript;
  end;
end;

procedure TJvForthScript.ParseScript;
var
  s: string;
  i, p, p2: Integer;
  atom: TAtom;
  //  atomoperation: TToken;
  atomsymbol: string;
  atomValue: Variant;
  //  atomproc: TProcVar;
  token: string;
  vinteger: Integer;
  vfloat: double;
  vdate: TdateTime;
  // handling of includes:
  incfile: string;
  Handled: Boolean;
  incScript: string;
  errStr: string;
  TimeOutTicks: Cardinal;
  deltaTicks: Cardinal;

  function pushatom(aToken: TToken): Integer;
    //    var cc: Integer;
  begin
    atom := TAtom.Create;
    atom.Token := atoken;
    atom.Symbol := atomsymbol;
    atom.Value := atomValue;
    Result := FAtoms.Add(atom);
  end;

  procedure opush(aToken: TToken);
    //    var cc: Integer;
  begin
    atom := TAtom.Create;
    atom.Token := atoken;
    atom.Symbol := token;
    atom.Value := atomValue;
    FAtoms.Add(atom);
  end;

  procedure brcpush(proc: TProcVar);
    //    var cc: Integer;
  begin
    atom := TAtom.Create;
    atom.Proc := proc;
    atom.Symbol := atomsymbol;
    atom.Value := atomValue;
    atom.IsOperand := False;
    FAtoms.Add(atom);
  end;

  function GetToken: Boolean;
  begin
    Result := False;
    s := trimleft(s);
    if s = '' then
      Exit;
    p := 1;
    if s[1] = '"' then
    begin // get string
      p := posstr('"', s, 2);
      if p = 0 then
        raise EJvJanScriptError.CreateResFmt(@RsEUnterminatedStringNears, [s]);
      token := Copy(s, 1, p);
      Delete(s, 1, p);
      Result := True;
    end
    else
    if s[1] = '[' then
    begin // get block
      p := posstr(']', s, 2);
      if p = 0 then
        raise EJvJanScriptError.CreateResFmt(@RsEUnterminatedBlockNear, [s]);
      token := Copy(s, 1, p);
      Delete(s, 1, p);
      Result := True;
    end
    else
    begin
      p := Pos(' ', s);
      if p = 0 then
      begin
        token := s;
        Result := True;
        s := '';
      end
      else
      begin
        token := Copy(s, 1, p - 1);
        Delete(s, 1, p);
        Result := True
      end;
    end
  end;

begin
  FAtoms.ClearObjects;
  FSubsList.Clear;
  // reset return stack; needed in resolving flow statements
  FRSP := 0;
  s := FScript;
  // include any include files, include files start with $$ and end with ;
  // when the parser detects and include file it will raise the oninclude event
  // include files can also include files (nested includes)
  deltaTicks := FScriptTimeOut * 1000;
  TimeOutticks := GetTickCount + DeltaTicks;
  FIncludes.Clear; // Clear the includes List
  repeat
    if GetTickCount > timeOutTicks then
      raise EJvJanScriptError.CreateResFmt(@RsEParserTimedOutAfterdSecondsYouMayHa, [FScriptTimeout]);
    p := posstr('$$', s);
    if p > 0 then
    begin
      p2 := posstr(';', s, p);
      if p2 = 0 then
        raise EJvJanScriptError.CreateResFmt(@RsEUnterminatedIncludeNears, [Copy(s, p, Length(s))]);
      incfile := Copy(s, p + 2, p2 - p - 2) + '.jan';
      if posstr(' ', incfile, 1) > 0 then
        raise EJvJanScriptError.CreateResFmt(@RsEIllegalSpaceCharacterInTheIncludeFi, [incfile]);
      i := FIncludes.IndexOf(incfile);
      if i <> -1 then
      begin
        Delete(s, p, p2 - p + 1);
      end
      else
      begin
        errStr := Format(RsECanNotFindIncludeFiles, [incfile]);
        Handled := False;
        incScript := '';
        if not Assigned(oninclude) then
          raise EJvJanScriptError.CreateResFmt(@RsEOnIncludeHandlerNotAssignedCanNotHa, [Copy(s, p, Length(s))]);
        oninclude(Self, incfile, incScript, Handled, errStr);
        if not Handled then
          raise EJvJanScriptError.Create(errStr);
        Delete(s, p, p2 - p + 1);
        Insert(incScript, s, p);
        FIncludes.Append(incFile);
      end;
    end;
  until p = 0;
  s := trim(StringReplace(s, sLineBreak, ' ', [rfreplaceall]));
  // remove comments
  repeat
    p := Pos('{', s);
    if p > 0 then
    begin
      p2 := posstr('}', s, p);
      if p2 = 0 then
        raise EJvJanScriptError.CreateResFmt(@RsEMissingCommentTerminatorNears, [s]);
      Delete(s, p, p2 - p + 1);
    end;
  until p = 0;
  if s = '' then
    Exit;
  while gettoken do
  begin
    if token = 'cstr' then
      opush(dfoCstr)
    else
    if token = 'seldir' then
      opush(dfoseldir)
    else
    if token = 'dsobase' then
      opush(dfodsobase)
    else
    if token = 'dup' then
      opush(dfoDup)
    else
    if token = 'drop' then
      opush(dfoDrop)
    else
    if token = 'swap' then
      opush(dfoSwap)
    else
    if token = 'if' then
    begin
      p := pushatom(dfoIf);
      rpush(p);
    end
    else
    if token = 'endif' then
    begin
      p := pushatom(dfoEndIf);
      p2 := rpop;
      atom := TAtom(FAtoms[p2]);
      atom.Value := p + 1;
    end
    else
    if token = 'else' then
    begin
      p := pushatom(dfoElse);
      p2 := rpop;
      rpush(p);
      atom := TAtom(FAtoms[p2]);
      atom.Value := p + 1;
    end
    else
    if token = 'repeat' then
    begin
      p := pushatom(dforepeat);
      rpush(p);
    end
    else
    if token = 'until' then
    begin
      atomValue := rpop;
      pushatom(dfoUntil);
    end
    else
    if token = 'now' then
      opush(dfonow)
    else
    if token = 'datestr' then
      opush(dfodatestr)
    else
    if token = 'timestr' then
      opush(dfotimestr)
    else
    if token = 'shellexecute' then
      opush(dfoshellexecute)
    else
    if token = ';' then
      opush(dfoEndSub)
    else
    if token = 'crlf' then
      opush(dfocrlf)
    else
    if token = '--' then
      opush(dfoNegate)
    else
    if token = '-' then
      opush(dfoSubtract)
    else
    if token = '+' then
      opush(dfoAdd)
    else
    if token = '*' then
      opush(dfoMultiply)
    else
    if token = '/' then
      opush(dfoDivide)
    else
    if token = '^' then
      opush(dfoPower)
    else
    if token = 'abs' then
      opush(dfoAbs)
    else
    if token = 'left' then
      opush(dfoleft)
    else
    if token = 'right' then
      opush(dforight)
    else
    if token = 'sqr' then
      opush(dfosqr)
    else
    if token = 'sqrt' then
      opush(dfosqrt)
    else
    if token = 'sin' then
      opush(dfosin)
    else
    if token = 'cos' then
      opush(dfocos)
    else
    if token = 'tan' then
      opush(dfotan)
    else
    if token = 'arcsin' then
      opush(dfoarcsin)
    else
    if token = 'arccos' then
      opush(dfoarccos)
    else
    if token = 'arctan' then
      opush(dfoarctan)
    else
    if token = 'arctan2' then
      opush(dfoarctan2)
    else
    if token = 'pi' then
      opush(dfopi)
    else
    if token = '<>' then
      opush(dfoNe)
    else
    if token = '>=' then
      opush(dfoGe)
    else
    if token = '>' then
      opush(dfoGt)
    else
    if token = '<=' then
      opush(dfoLe)
    else
    if token = '<' then
      opush(dfoLt)
    else
    if token = '=' then
      opush(dfoEq)
    else
    if token = 'or' then
      opush(dfoOr)
    else
    if token = 'and' then
      opush(dfoAnd)
    else
    if token = 'in' then
      opush(dfoIn)
    else
    if token = 'xor' then
      opush(dfoXor)
    else
    if token = 'not' then
      opush(dfoNot)
    else
    if token = 'like' then
      opush(dfoLike)
    else
    if token = 'unlike' then
      opush(dfoUnLike)
    // check for block
    else
    if token[1] = '[' then
    begin
      atomsymbol := token;
      atomValue := Copy(token, 2, Length(token) - 2);
      pushatom(dfoSet);
    end
    // check for sub
    else
    if token[Length(token)] = '=' then
    begin
      atomsymbol := Copy(token, 1, Length(token) - 1);
      p := pushatom(dfosub);
      FSubsList.AddObject(atomsymbol, Tobject(p + 1));
    end
    // check for xml object