jvqsal.pas

East make Tray Icon in delphi

        Token := Copy(S, 1, P - 1);
        Delete(S, 1, P);
        S := Trim(S);
      end;
      // take care of aliases
      if Token = '.' then
        Token := '+=';
      // check for user procs
      haveproc := FProcs.Hash(Token, AActor, AParser);
      try // float
        fv := StrToFloat(Token);
        A := TJvAtom.Create;
        A.Value := fv;
        A.Actor := xValue;
        Atoms.AddObject(cLiteral, A);
      except
        if Pos(cProc, Token) = 1 then
        begin // begin of procedure
          if Pos(cEndProc, S) = 0 then
            raise EJVCLException.CreateResFmt(@RsEUnterminatedProcedureNears, [S]);
          APO(Token, xBoSub);
        end
        else
        if Token = cEndProc then
          APO(Token, xEoSub)
        else
        if Copy(Token, Length(Token) - 1, 2) = '()' then
          APO(Token, xProc) // proc call
        else
        if Pos(cVar, Token) = 1 then
        begin // define variable
          if Atoms.IndexOf(Token) <> -1 then
            raise EJVCLException.CreateResFmt(@RsEVariablesAllreadyDefineds, [Token, S]);
          A := TJvAtom.Create;
          A.Actor := xDefVariable;
          Atoms.AddObject(Token, A);
        end
        else
        if Token[1] = '$' then
        begin // variable value
          // find address
          I := Atoms.IndexOf(cVar + Copy(Token, 2, MaxInt));
          if I = -1 then
            raise EJVCLException.CreateResFmt(@RsEVariablesIsNotYetDefineds, [Token, S]);
          A := TJvAtom.Create;
          A.Value := I;
          A.Actor := xVariable;
          Atoms.AddObject(Token, A);
        end
        else
        if haveproc then
        begin
          if Assigned(AParser) then
            AParser
          else
            APO(Token, AActor);
        end
        else
          raise EJVCLException.CreateResFmt(@RsEProceduresNears, [Token, S]);
      end
    end
  end;

  // now resolve procs()
  if Atoms.Count = 0 then
    Exit;
  for I := 0 to Atoms.Count - 1 do
  begin
    S := Atoms[I];
    if Copy(S, Length(S) - 1, 2) = '()' then
    begin
      S := cProc + Copy(S, 1, Length(S) - 2);
      P := Atoms.IndexOf(S);
      if P = -1 then
        raise EJVCLException.CreateResFmt(@RsEUndefinedProcedures, [S]);
      TJvAtom(Atoms.Objects[I]).Value := P;
    end;
  end;
end;

function TJvSAL.Pop: Variant;
begin
  Dec(FSP);
  if FSP < 0 then
    raise EJVCLException.CreateRes(@RsEStackUnderflow);
  Result := FStack[FSP];
end;

procedure TJvSAL.Push(AValue: Variant);
begin
  FStack[FSP] := AValue;
  Inc(FSP);
  if FSP > StackLimit then
    raise EJVCLException.CreateRes(@RsEStackOverflow);
end;

procedure TJvSAL.SetScript(const Value: string);
begin
  FScript := Trim(StringReplace(Value, Cr, ' ', [rfReplaceAll]));
  Atoms.ClearAll;
  ParseScript;
end;

procedure TJvSAL.xDefVariable;
var
  A: TJvAtom;
begin
  A := TJvAtom(Atoms.Objects[PCProc]);
  FVariableName := Atoms[PCProc];
  FVariableName := '$' + Copy(FVariableName, 5, MaxInt);
  FVariable := A;
end;

procedure TJvSAL.xValue;
begin
  Push(TJvAtom(Atoms.Objects[PCProc]).Value);
end;

procedure TJvSAL.xVariable;
var
  Index: Integer;
  A: TJvAtom;
begin
  A := TJvAtom(Atoms.Objects[PCProc]);
  VariableName := Atoms[PCProc];
  Index := A.Value;
  Variable := TJvAtom(Atoms.Objects[Index]);
end;

procedure TJvSAL.Stop;
begin
  FStop := True;
end;

procedure TJvSAL.LoadFromFile(FileName: string);
begin
  Script := Loadstring(FileName);
end;

procedure TJvSAL.ClearProcedures;
begin
  //  FProcs.ClearAll;
  FProcs.Clear;
end;

procedure TJvSAL.AddProcedure(AName: string; AProcedure, AParser: TJvSALProc);
//var
//  A: TJvSALProcAtom;
begin
  //  A:=TJvSALProcAtom.Create;
  //  A.Actor:=AProcedure;
  //  A.Parser:=AParser;
  //  FProcs.AddObject(AName,A);
  FProcs.AddString(AName, AProcedure, AParser);
end;

function TJvSAL.RPop: Integer;
begin
  Dec(FRSP);
  if FRSP < 0 then
    raise EJVCLException.CreateRes(@RsEReturnStackUnderflow);
  Result := FRStack[FRSP];
end;

procedure TJvSAL.RPush(AValue: Integer);
begin
  FRStack[FRSP] := AValue;
  Inc(FRSP);
  if FRSP > StackLimit then
    raise EJVCLException.CreateRes(@RsEReturnStackOverflow);
end;

// end of subroutine, marked with end-proc

procedure TJvSAL.xEoSub;
begin
  PC := RPop;
end;

// begin of subroutine, marked with [
// loop to ]

procedure TJvSAL.xBoSub;
var
  Op: string;
  C: Integer;
begin
  C := Atoms.Count;
  repeat
    Op := Atoms[PC];
    Inc(FPC);
    if Op = cEndProc then
      Exit;
  until PC >= C;
  raise EJVCLException.CreateRes(@RsECouldNotFindEndOfProcedure);
end;

procedure TJvSAL.SetGetUnit(const Value: TOnGetUnitEvent);
begin
  FOnGetUnit := Value;
end;

// function call

procedure TJvSAL.xProc;
var
  Index: Integer;
begin
  Index := TJvAtom(Atoms.Objects[PCProc]).Value;
  RPush(PC);
  PC := Index + 1;
end;

procedure TJvSAL.SetVariable(const Value: TJvAtom);
begin
  FVariable := Value;
end;

procedure TJvSAL.SetVariableName(const Value: string);
begin
  FVariableName := Value;
end;

procedure TJvSAL.SetSelection(const Value: Variant);
begin
  FSelection := Value;
end;

procedure TJvSAL.SetUseDirective(const Value: string);
begin
  FUseDirective := Value;
end;

procedure TJvSAL.SetBeginOfComment(const Value: string);
begin
  FBeginOfComment := Value;
end;

procedure TJvSAL.SetEndOfComment(const Value: string);
begin
  FEndOfComment := Value;
end;

procedure TJvSAL.SetStringDelimiter(const Value: string);
begin
  FStringDelimiter := Value;
end;

procedure TJvSAL.SetPC(const Value: Integer);
begin
  FPC := Value;
end;

function TJvSAL.APO(Op: string; AProc: TJvSALProc): Integer;
var
  A: TJvAtom;
begin
  A := TJvAtom.Create;
  A.Actor := AProc;
  Result := Atoms.AddObject(Op, A);
end;

procedure TJvSAL.SetToken(const Value: string);
begin
  FToken := Value;
end;

procedure TJvSAL.SetCaption(const Value: string);
begin
  FCaption := Value;
end;

procedure TJvSAL.xNoParser;
begin
  // do nothing
end;

//=== { TJvAtom } ============================================================

procedure TJvAtom.SetActor(const Value: TJvSALProc);
begin
  FActor := Value;
end;

procedure TJvAtom.SetValue(const AValue: Variant);
begin
  FValue := AValue;
end;

//=== { TJvAtoms } ===========================================================

destructor TJvAtoms.Destroy;
begin
  ClearAll;
  inherited Destroy;
end;

procedure TJvAtoms.ClearAll;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
    TJvAtom(Objects[I]).Free;
  Clear;
end;

//=== { TJvSALProcAtom } =====================================================

procedure TJvSALProcAtom.SetActor(const Value: TJvSALProc);
begin
  FActor := Value;
end;

procedure TJvSALProcAtom.SetParser(const Value: TJvSALProc);
begin
  FParser := Value;
end;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvQSAL.pas,v $';
    Revision: '$Revision: 1.16 $';
    Date: '$Date: 2004/09/07 23:11:35 $';
    LogPath: 'JVCL\run'
  );

initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}

end.