{
  LICENSE NOTE:
  Free use of this component in freeware and commercial projects
  is permitted provided you leave this License note
  un-altered in the source code.
  This unit "janPico" is original software written by Jan Verhoeven,
  hereafter called the author.
  The author can be reached at jan1.verhoeven@wxs.nl
  URL http://jansfreeware.com

  20060205  M.Majoor
            - Some bugs concerning uninitialized object resolved
            - Problem with 'repeat' can now be detected. Using any command
              before closing bracket of 'repeat' solves this.
            - LogicStack removed (*). Only a single stack now exists. All logical
              functions now use the normal stack. Logical operations (and/or
              /not/xor) are now -bit- operations
              0 is interpreted as 'false', otherwise it is 'true'
              (*) Actually the logic stack still exists but only to accomodate
              'if'..'else'
            - Added bool/shl/shr/delay/saystack/div/asinteger functions
            - Added loglevel/logfile/logappend/logmessage functions
            - Added openrfile/openwfile/readfile/writefile/filepos/closefile
              functions
            - Driver specialties added for supporting SAA7146A/FLEXCOP generic
              drivers (all specialties have a '_' character preceeding the name):
              _saa7146a        - selects SAA7146A generic driver (default)
              _?saa7146a       - returns SAA7146A selection
              _flexcop         - selects FLEXCOP  generic driver
              _?flexcop        - returns FLEXCOP  selection

              _version         - get driver version
              _cards           - get number of cards
              _handlecreate    - create handle to driver
              _handleclose     - close handle to driver
              _cardsubsys      - get SUBSYS of card (card identifier)
              _rd              - read  register (dword)
              _wr              - write register (dword)
              _notifywait      - wait for notification
              _notifygenerate  - generate manual notification
              _dmastatus       - get dma status
              _dmaallocate     - allocate dma
              _dmarelease      - release dma
              _dmard           - read dma
              _dmawr           - write dma
              _fifoallocate    - allocate fifo
              _fiforelease     - release  fifo
              _fiford          - read  fifo
              _irqwr           - write irq settings
              _irqrd           - read  irq settings

  20051118  M.Majoor
            - Added saystackd function
            - Added writefilestr function
  20060205  M.Majoor
            - Added ~         when used before a variable (not a property) it returns
                              the address. Example   var:Test ~Test
            - Added aschar    function - convert a numeric value to a character string
                              Typical use:  "PIC" 79 aschar &     -> "PICO"
            - Added readmem   Reads  the byte from the indicated address
            - Added writemem  Writes the byte to the indicated address
            - After a 'pop' (.popNumber etc) when the type is checked and it does
              not match, the item is always freed as it would have been without the raised error
}
unit janPico;

interface

uses
  Saa7146aInterface, FlexcopInterface,
  Saa7146aIoControl, FlexcopIoControl,
  MMSystem,
  Windows, SysUtils, Classes, Dialogs, janstrings,
  hashes, math, regexpr;

const
  PICOVERSION=2.2;

type
  TjanPico=class;
  TjanPicoFunction=class;

  TPicoKind=(jpkDefault,jpkText, jpkNumber,jpkDef,jpkBob,jpkEob,jpkIf,jpkElse);
  TPicoFunctionKind=(jpfkFunction, jpfkClass,jpfkObject);
  TjpoKind=(jpoNumber,jpoText,jpoReference);
  TPicoActor=procedure of object;
  TPicoExternal=procedure (sender:TjanPico;symbol:string) of object;
  TPicoUses=procedure (sender:TjanPico;const include:string; var text:string;var handled:boolean) of object;

  TjanPicoObject=class(TObject)
  private
    FNumber: extended;
    FText: string;
    FKind: TjpoKind;
    FReference: TjanPicoFunction;
    procedure SetKind(const Value: TjpoKind);
    procedure SetNumber(const Value: extended);
    procedure SetReference(const Value: TjanPicoFunction);
    procedure SetText(const Value: string);
  public
    function Clone:TjanPicoObject;
    property Number:extended read FNumber write SetNumber;
    property Text:string read FText write SetText;
    property Reference:TjanPicoFunction read FReference write SetReference;
    property Kind:TjpoKind read FKind write SetKind;
  end;

  TPicoVariant=class(TObject)
  private
    FValue: variant;
    procedure SetValue(const Value: variant);
  public
    property Value:variant read FValue write SetValue;
  end;


  TjanPicoWord=class(TObject)
  private
    FSymbol: string;
    FValue: extended;
    FActor: TPicoActor;
    FKind: TPicoKind;
    tokens:TList;
    FParent: TjanPicoWord;
    PC:integer;  // (sub) program counter
    SC:integer;
    FRoot: TjanPico;
    FFuncRef: TjanPicoFunction;
    procedure SetSymbol(const Value: string);
    procedure SetValue(const Value: extended);
    procedure SetActor(const Value: TPicoActor);
    procedure SetKind(const Value: TPicoKind);
    procedure SetParent(const Value: TjanPicoWord);
    procedure SetRoot(const Value: TjanPico);
    procedure SetFuncRef(const Value: TjanPicoFunction);
  public
    constructor Create;
    destructor Destroy; override;
    procedure ClearTokens;
    procedure ExecuteWord;
    function nextSibling:TjanPicoWord;
    property Symbol:string read FSymbol write SetSymbol;
    property Value:extended read FValue write SetValue;
    property Actor:TPicoActor read FActor write SetActor;
    property Kind:TPicoKind read FKind write SetKind;
    property Parent:TjanPicoWord read FParent write SetParent;
    property Root:TjanPico read FRoot write SetRoot;
    property FuncRef:TjanPicoFunction read FFuncRef write SetFuncRef;
  end;

  TjanPicoFunction=class(TjanPicoWord)
  private
    Funcs:TObjectHash;
    Vars:TObjectHash;
    FParentFunction: TjanPicoFunction;
    FClassString: string;
    FFunctionKind: TPicoFunctionKind;
    FInitialized: boolean;
    ClassList: TStringList;
    procedure SetParentFunction(const Value: TjanPicoFunction);
    procedure SetClassString(const Value: string);
    procedure SetFunctionKind(const Value: TPicoFunctionKind);
    procedure SetInitialized(const Value: boolean);
  public
    constructor Create;
    destructor Destroy; override;
    procedure ExecuteWord;
    property ParentFunction:TjanPicoFunction read FParentFunction write SetParentFunction;
    property FunctionKind:TPicoFunctionKind read FFunctionKind write SetFunctionKind;
    property ClassString:string read FClassString write SetClassString;
    property Initialized:boolean read FInitialized write SetInitialized;
  end;

  TChipset = (ctSaa7146a, ctFlexcop);
  
  TjanPico = class(TjanPicoFunction)
  private
    FHandles: array[TChipset] of array of THandle;        // Handles created by PICO functions (and to be close wehn terminated)
    FLogStream: TFileStream;                              // Filestream for log
    FLogLevel: Integer;                                   // LogLevel (< 0 no log)
    FLogFile: ShortString;                                // Log file
    FLogAppend: Boolean;                                  // True if log to append

    scan, scanL:integer;
    parseNode:TjanPicoWord;
   // exeNode:TjanPicoWord;
    FScript: string;
    stack:TList;
    LogicStack:TList;
    Includes:TIntegerHash;
    Classes:TObjectHash;
    FonExternal: TPicoExternal;
    FonUses: TPicoUses;
    CurrentFunction:TjanPicoFunction;
    FOnTrace: TPicoExternal;
    FSystemVars:TObjectHash;
    re:TRegExpr;
    genlist:TStringList;
    FHighPerformanceFrequency: TLargeInteger;
    FChipset: TChipset;
    procedure SetScript(const Value: string);
    procedure Parse;
    procedure AddToken(Token:string;Literal:boolean);
    function lastToken:TjanPicoWord;
    function GetToken(var Token:string; var Literal:boolean):boolean;
    procedure ClearStack;
    function  peek:TjanPicoObject;
    procedure lpushl(value:boolean);
    procedure lpush(value:boolean);
    function  lpopl:boolean;
    function  lpop:boolean;
    function FindVariableScope(varname:string):TjanPicoFunction;
    function FindFunctionScope(funcname:string):TjanPicoFunction;
    procedure SetonExternal(const Value: TPicoExternal);
    procedure SetonUses(const Value: TPicoUses);
    procedure SetOnTrace(const Value: TPicoExternal);
    function findMethod(pFunction:TjanPicoFunction;pMethodName:string):TjanPicoFunction;
    procedure initializeClass(pFunction:TjanPicoFunction);
    procedure initializeSystemVars;
    procedure _SetVarText(aVar:TObjectHash;aName:string;aValue:string);
    procedure _SetVarNumber(aVar:TObjectHash;aName:string;aValue:extended);
    function  _po(aObject:TObject):TjanPicoObject;
    { Private declarations }
  protected
    { Protected declarations }
    procedure picoNop;
    procedure picoString;
    procedure picoNumber;
    procedure picoTrace;
    // reflection
    procedure picoType;
    procedure picoClassNames;
    // math
    procedure picoAdd;
    procedure picoSub;
    procedure picoMul;
    procedure picoDiv;
    procedure picoDiv2;
    procedure picoMod;
    procedure picoPower;
    procedure picoAbs;
    procedure picoRound;
    procedure picoNeg;
    procedure picoSqr;
    procedure picoSqrt;
    procedure picoExp;
    procedure picoLn;
    procedure picoLog;
    procedure picoMax;
    procedure picoMin;
    // comparison
    procedure picoEq;
    procedure picoNe;
    procedure picoGe;
    procedure picoLe;
    procedure picoGt;
    procedure picoLt;
    // logic
    procedure picoAnd;
    procedure picoOr;
    procedure picoNot;
    procedure picoXor;
    procedure picoBool;
    // logic extension
    procedure picoShl;
    procedure picoShr;
    // stack
    procedure picoDup;
    procedure picoDrop;
    procedure picoSwap;
    // flow
    procedure picoDef;
    procedure picoCall;
    procedure picoCallMethod;
    procedure picoIf;
    procedure picoElse;
    procedure picoWhile;
    procedure picoRepeat;
    procedure picoCase;
    // variables
    procedure picoDefVariable;
    procedure picoSetVariable;
    procedure picoGetVariable;
    procedure picoGetVariableAddress;
    procedure picoSetProperty;
    procedure picoGetProperty;
    procedure picoSetSystemVar;
    procedure picoGetSystemVar;
    procedure picoGetSystemVarAddress;
    procedure picoSetRecordVar;
    procedure picoGetRecordVar;
    procedure picoVarInc;
    procedure picoVarDec;
    procedure picoVarAdd;
    procedure picoVarSub;
    procedure picoVarMul;
    procedure picoVarDiv;
    procedure picoVarEq;
    procedure picoVarNe;
    // interface
    procedure picoSay;
    procedure picoAsk;
    procedure picoSayStack;
    procedure picoSayStackD;
    // external
    procedure picoExternal;
    // Trigonometry
    procedure picoSin;
    procedure picoCos;
    procedure picoTan;
    procedure picoArcTan;
    // data and time
    procedure picoDate;
    procedure picoNow;
    procedure picoWeekNumber;
    procedure picoWeekDay;
    procedure picoYear;
    procedure picoMonth;
    procedure picoDay;
    procedure picoEaster;
    procedure picoDelay;
    // constants
    procedure picoPi;
    procedure picoTrue;
    procedure picoFalse;
    procedure picoMaxInt;
    procedure picoCr;
    // string
    procedure picoConCat;
    procedure picoLength;
    procedure picoLowercase;
    procedure picoUppercase;
    procedure picoLeft;
    procedure picoRight;
    procedure picoMid;
    procedure picoPosStr;
    procedure picoPosText;
    procedure picoFix;
    procedure picoSplit;
    procedure picoJoin;
    procedure picoReplaceStr;
    procedure picoReplaceText;
    procedure picoRegTest;
    procedure picoRegReplace;
    // lists
    procedure picoFirst;
    procedure picoLast;
    procedure picoCount;
    procedure picoPick;
    procedure picoAppend;
    procedure picoDelete;
    procedure picoIndex;
    procedure picoName;
    procedure picoValue;
    // conversion
    procedure PicoAsText;
    procedure PicoAsNumber;
    procedure PicoAsInteger;
    procedure PicoAsHex;
    procedure PicoAsChar;
    procedure PicoAsDate;
    procedure PicoFormatDate;
    procedure PicoDegrees;
    procedure PicoRadians;
    // testing
    procedure picoIsInteger;
    procedure picoIsFloat;
    procedure picoIsDate;
    // logging
    procedure picoLogLevel;
    procedure picoLogFile;
    procedure picoLogAppend;
    procedure picoLogMessage;
    // file
    procedure picoOpenRFile;
    procedure picoOpenWFile;
    procedure picoCloseFile;
    procedure picoReadFile;
    procedure picoWriteFile;
    procedure picoWriteFileStr;
    procedure picoFilePos;
    // driver specialties
    procedure picoReadMem;
    procedure picoWriteMem;
    procedure picoDriverSaa7146a;
    procedure picoDriverGetSaa7146a;
    procedure picoDriverFlexcop;
    procedure picoDriverGetFlexcop;
    procedure picoDriverVersion;
    procedure picoDriverCards;
    procedure picoDriverHandleCreate;
    procedure picoDriverHandleClose;
    procedure picoDriverCardSubsys;
    procedure picoDriverNotifyWait;
    procedure picoDriverNotifyGenerate;
    procedure picoDriverRd;
    procedure picoDriverWr;
    procedure picoDriverDmaStatus;
    procedure picoDriverDmaAllocate;
    procedure picoDriverDmaRelease;
    procedure picoDriverDmaRd;
    procedure picoDriverDmaWr;
    procedure picoDriverFifoAllocate;
    procedure picoDriverFifoRelease;
    procedure picoDriverFifoRd;
    procedure picoDriverIrqWr;
    procedure picoDriverIrqRd;
    procedure ToLog(LogString: string; Level: Integer);
  public
    { Public declarations }
    PCToken:TjanPicoWord;
    constructor Create;
    destructor Destroy; override;
    procedure ListSymbols(List:TStrings);
    procedure push(value:TjanPicoObject);
    procedure pushNumber(value:extended);
    procedure pushText(value:string);
    procedure pushObject(value:TjanPicoFunction);
    function  pop:TjanPicoObject;
    function popNumber:extended;
    function popInteger:integer;
    function popText:string;
    function popObject:TjanPicoFunction;
    function execute:TjanPicoObject;
    procedure executeFunction(FuncName: string);
    property Script:string read FScript write SetScript;
    property onExternal:TPicoExternal read FonExternal write SetonExternal;
    property onUses:TPicoUses read FonUses write SetonUses;
    property OnTrace:TPicoExternal read FOnTrace write SetOnTrace;
  published
    { Published declarations }
  end;


implementation


const
  MAXSTACKSIZE=100000;

{ TjanPico }

procedure TjanPico.AddToken(Token: string;Literal:boolean);
var
  pico:TjanPicoWord;
  picoFunction:TjanPicoFunction;
//  popWord:TjanPicoWord;
  e:extended;
  symbol,{nextToken,} ClassToken:string;
  i,c,p:integer;

  function LastPico:TjanPicoWord;
  begin
    result:=TjanPicoWord(tokens[tokens.count-1]);
  end;

  function ErrorSource:string;
  begin
    result:=copy(FScript,scan-20,40);
  end;

begin
  if token='{' then begin
    parseNode:=lastToken;
    exit;
  end
  else if token='}' then begin
    if parseNode is TjanPicoFunction then
      CurrentFunction:=TjanPicoFunction(parseNode).parentFunction;
    parseNode:=parseNode.Parent;
    if parseNode=nil then
      raise exception.create('Illegal } near '+ErrorSource);
    exit;
  end;
  // function
  if (posstr('function:',token)=1) or (posstr('class:',token)=1) or (posstr('object:',token)=1) then begin
    picoFunction:=TjanPicoFunction.Create;
    picoFunction.Parent:= parseNode;
    picoFunction.Root:=self;
    if (posstr('class:',token)=1) then begin
      symbol:=copy(token,7,maxint);
      picoFunction.FunctionKind:=jpfkClass;
    end
    else if (posstr('object:',token)=1) then begin
      symbol:=copy(token,8,maxint);
      picoFunction.FunctionKind:=jpfkObject;
    end
    else begin
      symbol:=copy(token,10,maxint);
      picoFunction.FunctionKind:=jpfkFunction;
    end;
    p:=pos('(',symbol);
    if p=0 then
      raise exception.create('Missing ( near '+ErrorSource);
    ClassToken:=copy(symbol,p+1,maxint);
    symbol:=copy(symbol,1,p-1);
    p:=pos(')',ClassToken);
    if p=0 then
      raise exception.create('Missing ) near '+ErrorSource);
    ClassToken:=copy(ClassToken,1,p-1);
    picoFunction.ClassString:=ClassToken;
    c:=picoFunction.ClassList.Count;
    if c>0 then begin
      for i:=0 to c-1 do
        if not Classes.Exists(picoFunction.ClassList[i]) then
          raise exception.create('Object from undefined class '+picoFunction.ClassList[i]+' near '+ErrorSource);
    end;
    picoFunction.Symbol:=symbol;
    if picoFunction.FunctionKind=jpfkClass then
      Classes[symbol]:=picoFunction;
    picoFunction.Actor:=picoDef;
    picoFunction.Kind:=jpkDef;
    picoFunction.ParentFunction:=CurrentFunction;
    //rpush(CurrentFunction);
    CurrentFunction.Funcs[symbol]:=picoFunction;
    CurrentFunction:=picoFunction;
    parseNode.tokens.add(picoFunction);
    exit;
  end;
  Pico:=TjanPicoWord.Create;
  Pico.Parent:=parseNode;
  Pico.Root:=self;
  Pico.Symbol:=Token;
  Pico.Kind:=jpkDefault;

  if Literal then begin
    Pico.Actor:=picoString;
  end
  else begin
    try
      e:=strtofloat(Token);
      Pico.Actor:=picoNumber;
      Pico.value:=e;
    except
      if token=';' then
        Pico.Actor:=picoNop
      else if copy(token,1,1)='#' then begin
        Pico.Actor:=picoNumber;
        Pico.value:=ISOStringToDate(copy(token,2,maxint));
      end
      else if copy(token,1,1)='$' then begin
        if janstrings.isInteger(token) then begin
          Pico.Actor:=picoNumber;
          Pico.value:=strtoint(token);
        end
        else
          raise exception.create('Invalid hexadecimal number '+token+' near '+ErrorSource);
      end
      else if token='type' then
        Pico.Actor:=picoType
      else if token='&' then
        Pico.Actor:=picoConCat
      else if token='trace' then
        Pico.Actor:=picoTrace
      else if token='length' then
        Pico.Actor:=picoLength
      else if token='uppercase' then
        Pico.Actor:=picoUppercase
      else if token='lowercase' then
        Pico.Actor:=picoLowercase
      else if token='left' then
        Pico.Actor:=picoLeft
      else if token='right' then
        Pico.Actor:=picoRight
      else if token='mid' then
        Pico.Actor:=picoMid
      else if token='posstr' then
        Pico.Actor:=picoPosStr
      else if token='postext' then
        Pico.Actor:=picoPosText
      else if token='replacestr' then
        Pico.Actor:=picoReplaceStr
      else if token='replacetext' then
        Pico.Actor:=picoReplaceText
      else if token='split' then
        pico.Actor:=picoSplit  
      else if token='join' then
        pico.Actor:=picoJoin
      else if token='regexpr.test' then
        pico.Actor:=picoRegTest
      else if token='regexpr.replace' then
        pico.Actor:=picoRegReplace
      else if token='first[]' then
        Pico.Actor:=picoFirst
      else if token='last[]' then
        Pico.Actor:=picoLast
      else if token='pick[]' then
        Pico.Actor:=picoPick
      else if token='index[]' then
        Pico.Actor:=picoIndex
      else if token='count[]' then
        Pico.Actor:=picoCount
      else if token='append[]' then
        Pico.Actor:=picoAppend
      else if token='delete[]' then
        Pico.Actor:=picoDelete
      else if token='name[]' then
        Pico.Actor:=picoName
      else if token='value[]' then
        Pico.Actor:=picoValue
      else if (pos('!!',token)=1) and (length(token)>2) then begin
        p:=pos('.',token);
        if p<4 then
          raise exception.create('Missing variable name in '+token);
        if p=length(token) then
          raise exception.create('Missing field name in '+token);
        Pico.symbol:=copy(token,3,maxint);
        Pico.Actor:=picoSetRecordVar;
      end
      else if (pos('??',token)=1) and (length(token)>2) then begin
        p:=pos('.',token);
        if p<4 then
          raise exception.create('Missing variable name in '+token);
        if p=length(token) then
          raise exception.create('Missing field name in '+token);
        Pico.symbol:=copy(token,3,maxint);
        Pico.Actor:=picoGetRecordVar;
      end
      else if token='fix' then
        Pico.Actor:=picoFix
      else if token='+' then
        Pico.Actor:=picoAdd
      else if token='-' then
        Pico.Actor:=picoSub
      else if token='*' then
        Pico.Actor:=picoMul
      else if token='/' then
        Pico.Actor:=picoDiv
      else if token='div' then
        Pico.Actor:=picoDiv2
      else if token='mod' then
        Pico.Actor:=picoMod
      else if token='^' then
        Pico.Actor:=picoPower
      else if token='max' then
        Pico.Actor:=picoMax
      else if token='min' then
        Pico.Actor:=picoMin
      else if token='abs' then
        Pico.Actor:=picoAbs
      else if token='round' then
        Pico.Actor:=picoRound
      else if token='neg' then
        Pico.Actor:=picoNeg
      else if token='sqr' then
        Pico.Actor:=picoSqr
      else if token='sqrt' then
        Pico.Actor:=picoSqrt
      else if token='exp' then
        Pico.Actor:=picoExp
      else if token='ln' then
        Pico.Actor:=picoLn
      else if token='log' then
        Pico.Actor:=picoLog
      else if token='==' then
        Pico.Actor:=picoEq
      else if token='!=' then
        Pico.Actor:=picoNe
      else if token='>' then
        Pico.Actor:=picoGt
      else if token='<' then
        Pico.Actor:=picoLt
      else if token='>=' then
        Pico.Actor:=picoGe
      else if token='<=' then
        Pico.Actor:=picoLe
      else if token='and' then
        Pico.Actor:=picoAnd
      else if token='or' then
        Pico.Actor:=picoOr
      else if token='xor' then
        Pico.Actor:=picoXor
      else if token='not' then
        Pico.Actor:=picoNot
      else if token='bool' then
        Pico.Actor:=picoBool
      else if token='shr' then
        Pico.Actor:=picoShr
      else if token='shl' then
        Pico.Actor:=picoShl
      else if token='dup' then
        Pico.Actor:=picoDup
      else if token='drop' then
        Pico.Actor:=picoDrop
      else if token='swap' then
        Pico.Actor:=picoSwap
      else if token='sin' then
        Pico.Actor:=picoSin
      else if token='tan' then
        Pico.Actor:=picoTan
      else if token='cos' then
        Pico.Actor:=picoCos
      else if token='arctan' then
        Pico.Actor:=picoArcTan
      else if token='pi' then
        Pico.Actor:=picoPi
      else if token='true' then
        Pico.Actor:=picoTrue
      else if token='false' then
        Pico.Actor:=picoFalse
      else if token='maxint' then
        Pico.Actor:=picoMaxInt
      else if token='cr' then
        Pico.Actor:=picoCr
      else if token='date' then
        Pico.Actor:=picoDate
      else if token='now' then
        Pico.Actor:=picoNow
      else if token='year' then
        Pico.Actor:=picoYear
      else if token='month' then
        Pico.Actor:=picoMonth
      else if token='day' then
        Pico.Actor:=picoDay
      else if token='weeknumber' then
        Pico.Actor:=picoWeeknumber
      else if token='weekday' then
        Pico.Actor:=picoWeekDay
      else if token='easter' then
        Pico.Actor:=picoEaster
      else if token='delay' then
        Pico.Actor:=picoDelay
      else if token='loglevel' then
        Pico.Actor:=picoLogLevel
      else if token='logfile' then
        Pico.Actor:=picoLogFile
      else if token='logappend' then
        Pico.Actor:=picoLogAppend
      else if token='logmessage' then
        Pico.Actor:=picoLogMessage
      else if token='openrfile' then
        Pico.Actor:=picoOpenRFile
      else if token='openwfile' then
        Pico.Actor:=picoOpenWFile
      else if token='readfile' then
        Pico.Actor:=picoReadFile
      else if token='writefile' then
        Pico.Actor:=picoWriteFile
      else if token='writefilestr' then
        Pico.Actor:=picoWriteFileStr
      else if token='filepos' then
        Pico.Actor:=picoFilePos
      else if token='closefile' then
        Pico.Actor:=picoCloseFile
      else if token='readmem' then
        Pico.Actor:=picoReadMem
      else if token='writemem' then
        Pico.Actor:=picoWriteMem
      else if token='_version' then
        Pico.Actor:=picoDriverVersion
      else if token='_cards' then
        Pico.Actor:=picoDriverCards
      else if token='_handlecreate' then
        Pico.Actor:=picoDriverHandleCreate
      else if token='_handleclose' then
        Pico.Actor:=picoDriverHandleClose
      else if token='_cardsubsys' then
        Pico.Actor:=picoDriverCardSubsys
      else if token='_rd' then
        Pico.Actor:=picoDriverRd
      else if token='_wr' then
        Pico.Actor:=picoDriverWr
      else if token='_notifywait' then
        Pico.Actor:=picoDriverNotifyWait
      else if token='_notifygenerate' then
        Pico.Actor:=picoDriverNotifyGenerate
      else if token='_dmastatus' then
        Pico.Actor:=picoDriverDmaStatus
      else if token='_dmaallocate' then
        Pico.Actor:=picoDriverDmaAllocate
      else if token='_dmarelease' then
        Pico.Actor:=picoDriverDmaRelease
      else if token='_dmard' then
        Pico.Actor:=picoDriverDmaRd
      else if token='_dmawr' then
        Pico.Actor:=picoDriverDmaWr
      else if token='_fifoallocate' then
        Pico.Actor:=picoDriverFifoAllocate
      else if token='_fiforelease' then
        Pico.Actor:=picoDriverFifoRelease
      else if token='_fiford' then
        Pico.Actor:=picoDriverFifoRd
      else if token='_irqwr' then
        Pico.Actor:=picoDriverIrqWr
      else if token='_irqrd' then
        Pico.Actor:=picoDriverIrqRd
      else if token='_saa7146a' then
        Pico.Actor:=picoDriverSaa7146a
      else if token='_?saa7146a' then
        Pico.Actor:=picoDriverGetSaa7146a
      else if token='_flexcop' then
        Pico.Actor:=picoDriverFlexcop
      else if token='_?flexcop' then
        Pico.Actor:=picoDriverGetFlexcop
      else if token='formatdate' then
        Pico.Actor:=picoFormatDate
      else if token='astext' then
        Pico.Actor:=picoAsText
      else if token='aschar' then
        Pico.Actor:=picoAsChar
      else if token='degrees' then
        Pico.Actor:=picoDegrees
      else if token='radians' then
        Pico.Actor:=picoRadians
      else if token='while' then
        Pico.Actor:=picoWhile
      else if token='repeat' then
        Pico.Actor:=picoRepeat
      else if token='case' then
        Pico.Actor:=picoCase
      else if token='isinteger' then
        Pico.actor:=picoIsInteger
      else if token='isfloat' then
        Pico.actor:=picoIsFloat
      else if token='isdate' then
        Pico.actor:=picoIsDate
      else if token='asdate' then
        Pico.actor:=picoAsDate
      else if token='asnumber' then
        Pico.actor:=picoAsNumber
      else if token='asinteger' then
        Pico.actor:=picoAsInteger
      else if token='ashex' then
        Pico.actor:=picoAsHex
      else if token='classnames' then
        Pico.Actor:=picoClassNames  
      else if posstr('var:',token)=1 then begin
        pico.Actor:=picoDefVariable;
        pico.symbol:=copy(token,5,maxint);
      end
      else if (length(token)>2) and (copy(token,1,2)='++') then begin
        Pico.Symbol:=copy(token,3,maxint);
        Pico.Actor:=picoVarInc;
      end
      else if (length(token)>2) and (copy(token,1,2)='--') then begin
        Pico.Symbol:=copy(token,3,maxint);
        Pico.Actor:=picoVarDec;
      end
      else if (length(token)>2) and (copy(token,1,2)='+=') then begin
        Pico.Symbol:=copy(token,3,maxint);
        Pico.Actor:=picoVarAdd;
      end
      else if (length(token)>2) and (copy(token,1,2)='-=') then begin
        Pico.Symbol:=copy(token,3,maxint);
        Pico.Actor:=picoVarSub;
      end
      else if (length(token)>2) and (copy(token,1,2)='*=') then begin
        Pico.Symbol:=copy(token,3,maxint);
        Pico.Actor:=picoVarMul
      end
      else if (length(token)>2) and (copy(token,1,2)='/=') then begin
        Pico.Symbol:=copy(token,3,maxint);
        Pico.Actor:=picoVarDiv;
      end
      else if (length(token)>2) and (copy(token,1,2)='==') then begin
        Pico.Symbol:=copy(token,3,maxint);
        Pico.Actor:=picoVarEq;
      end
      else if (length(token)>2) and (copy(token,1,2)='!=') then begin
        Pico.Symbol:=copy(token,3,maxint);
        Pico.Actor:=picoVarNe;
      end
      else if (length(token)>1) and (token[1]='!') then begin
        Pico.Symbol:=copy(token,2,maxint);
        if pos('system.',pico.symbol)=1 then begin
          Pico.symbol:=copy(pico.symbol,8, maxint);
          pico.Actor:=picoSetSystemVar;
        end
        else if pos('.',Pico.symbol)=0 then
          Pico.Actor:=picoSetVariable
        else
          Pico.Actor:=picoSetProperty;
      end
      else if (length(token)>1) and (token[1]='?') then begin
        Pico.Symbol:=copy(token,2,maxint);
        if pos('system.',pico.symbol)=1 then begin
          Pico.symbol:=copy(pico.symbol,8, maxint);
          pico.Actor:=picoGetSystemVar;
        end
        else if pos('.',Pico.symbol)=0 then
          Pico.Actor:=picoGetVariable
        else
          Pico.Actor:=picoGetProperty;
      end
      else if (length(token)>1) and (token[1]='~') then begin
        Pico.Symbol:=copy(token,2,maxint);
        if pos('system.',pico.symbol)=1 then begin
          Pico.symbol:=copy(pico.symbol,8, maxint);
          pico.Actor:=picoGetSystemVarAddress;
        end
        else if pos('.',Pico.symbol)=0 then
          Pico.Actor:=picoGetVariableAddress;
      end
      else if token='if' then begin
        Pico.Actor:=picoIf;
        Pico.Kind:=jpkIf;
      end
      else if token='else' then begin
        Pico.Actor:=picoElse;
        Pico.Kind:=jpkElse;
      end
      else if token='say' then
        Pico.Actor:=picoSay
      else if token='saystack' then
        Pico.Actor:=picoSayStack
      else if token='saystackd' then
        Pico.Actor:=picoSayStackD
      else if token='ask' then
        Pico.Actor:=picoAsk
      else if token[1]='@' then begin
        Pico.Symbol:=copy(token,2,maxint);
        Pico.Actor:=picoExternal;
      end
      else if pos('.',token)>0 then
        Pico.Actor:=picoCallMethod
      else
        Pico.Actor:=picoCall;
    end;
  end;
  parseNode.tokens.add(Pico);
end;


procedure TjanPico.ClearStack;
var
  i,c:integer;
begin
  c:=stack.count;
  if c=0 then exit;
  for i:=0 to c-1 do
    TPicoVariant(stack[i]).free;
  stack.clear;
end;


constructor TjanPico.Create;
begin
  inherited;
  QueryPerformanceFrequency(FHighPerformanceFrequency);
  FChipset := ctSaa7146a;

  parent:=nil;
  parentFunction:=nil;
  root:=self;
  Stack:=TList.create;
  LogicStack:=TList.create;
  Includes:=TIntegerHash.create;
  Classes:=TObjectHash.create;
  Classes.OwnsItems:=false;
  FSystemVars:=TObjectHash.create;
  FSystemVars.OwnsItems:=true;
  genlist:=TStringList.create;
  re:=TRegExpr.Create;
  FunctionKind:=jpfkFunction;
  FLogStream := nil;
  FLogLevel := 0;
  FLogAppend := False;
  FLogFile := 'picolog.msg';
end;

destructor TjanPico.Destroy;
var
  Loop    : Integer;
  Chipsets: TChipSet;
begin
  // Close all handles which were acquired through the scripting
  for Chipsets := Low(Chipsets) to High(Chipsets) do
  begin
  if Assigned(FHandles[Chipsets]) then
    if Length(FHandles[Chipsets]) > 0 then
      for Loop := 0 to Length(FHandles[Chipsets])-1 do
        if FHandles[Chipsets][Loop] <> INVALID_HANDLE_VALUE then
        begin
          case Chipsets of
            ctSaa7146a: Saa7146aCloseHandle(FHandles[Chipsets][Loop]);
            ctFlexcop : FlexcopCloseHandle (FHandles[Chipsets][Loop]);
          end;
        end;
  end;
  ClearStack;
  stack.free;
  LogicStack.free;
  Includes.free;
  Classes.free;
  FSystemVars.Free;
  genlist.free;
  re.free;
  if Assigned(FLogStream) then
  begin
    ToLog('-----------------------------END-----------------------------', 0);
    FreeAndNil(FLogStream);
  end;
  inherited;
end;


function TjanPico.execute: TjanPicoObject;
var
  Chipsets: TChipSet;
begin
  for Chipsets := Low(Chipsets) to High(Chipsets) do
    FHandles[ChipSets] := nil;
//  result:=nil;
  ClearStack;
  LogicStack.clear;
  FSystemVars.Clear;
  initializeSystemVars;
  CurrentFunction:=self;
  executeWord;
  if stack.count>0 then
    result:=pop
  else
    result:=nil;  
end;

function TjanPico.FindFunctionScope(funcname: string): TjanPicoFunction;
var
  pf:TjanPicoFunction;
begin
  if CurrentFunction.Funcs.Exists(funcname) then begin
    result:=CurrentFunction;
  end
  else begin
    pf:=CurrentFunction;
    while pf.parentFunction<>nil do begin
      pf:=pf.parentFunction;
      if pf.Funcs.Exists(funcname) then begin
        result:=pf;
        exit;
      end;
    end;
    result:=nil;
  end;
end;

function TjanPico.FindVariableScope(varname: string): TjanPicoFunction;
var
  pf:TjanPicoFunction;
begin
  if CurrentFunction.Vars.Exists(varname) then begin
    result:=CurrentFunction;
  end
  else begin
    pf:=CurrentFunction;
    while pf.parentFunction<>nil do begin
      pf:=pf.parentFunction;
      if pf.Vars.Exists(varname) then begin
        result:=pf;
        exit;
      end;
    end;
    result:=nil;
  end;
end;

function TjanPico.GetToken(var Token: string; var Literal:boolean): boolean;
var
  delim:char;
//  p:integer;

  function ErrorSource:string;
  begin
    result:=copy(FScript,scan-20,40);
  end;

begin
  result:=false;
  Token:='';
  Literal:=false;
  // skip spaces
  while (scan<=scanL) and (FScript[scan]=' ') do inc(scan);
  if scan>scanL then exit;
  // check string literal
  if FScript[scan] in ['"',''''] then begin
    delim:=FScript[scan];
    inc(scan);
    while (scan<=scanL) and (FScript[scan]<>delim) do begin
      if FScript[scan]='\' then begin
        inc(scan);
        if scan>ScanL then
          raise exception.create('Missing string terminator near '+ErrorSource);
        case FScript[scan] of
          'n': Token:=Token+cr;
          't': Token:=Token+tab;
        else
          Token:=Token+FScript[scan];
        end;
      end
      else
        Token:=Token+FScript[scan];
      inc(scan);
    end;
    if scan>scanL then exit;
    inc(scan);
    result:=true;
    Literal:=true;
    Token:=q_replacestr(Token,cr+' ',cr);
  end
  else begin
    Token:=Token+FScript[scan];
    inc(scan);
    while (scan<=scanL) and (FScript[scan]<>' ') do begin
      Token:=Token+FScript[scan];
      inc(scan);
    end;
    result:=true;
  end;
end;

function TjanPico.lastToken: TjanPicoWord;
var
  c:integer;
begin
  result:=nil;
  c:=parseNode.tokens.count;
  if c=0 then exit;
  result:=TjanPicoWord(parseNode.tokens[c-1]);
end;

procedure TjanPico.ListSymbols(List:TStrings);
var
  i,c:integer;
begin
  List.clear;
  c:=tokens.count;
  if c=0 then exit;
  for i:=0 to c-1 do
    List.Append(TjanPicoWord(tokens[i]).symbol);
end;

function TjanPico.lpopl: boolean;
var
  c:integer;
begin
  c:=LogicStack.count;
  if c=0 then
    raise exception.create('Logic stack underflow');
  if integer(logicStack[c-1])=0 then
    result:=false
  else
    result:=true;
  LogicStack.delete(c-1);
end;

function TjanPico.lpop: boolean;
var
  c:integer;
  e:extended;
begin
  c:=stack.count;
  if c=0 then
    raise exception.create('Stack underflow');
  e:=popNumber;
  if e=0 then
    result := false
  else
    result := true;
end;

procedure TjanPico.lpushl(value: boolean);
begin
  if LogicStack.Count>MAXSTACKSIZE then begin
    ClearStack;
    ClearTokens;
    raise exception.create('Logic stack overflow ('+inttostr(MAXSTACKSIZE)+').');
  end
  else begin
    if value then
      LogicStack.Add(pointer(1))
    else
      LogicStack.Add(pointer(0))
  end;
end;

procedure TjanPico.lpush(value: boolean);
begin
  if Stack.Count>MAXSTACKSIZE then begin
    ClearStack;
    ClearTokens;
    raise exception.create('Stack overflow ('+inttostr(MAXSTACKSIZE)+').');
  end
  else
    if value then
      pushNumber(-1)
    else
      pushNumber(0);
end;

procedure TjanPico.Parse;
var
  Token:string;
  Literal:boolean;

  procedure parseError(pMessage:string);
  begin
    Showmessage(pMessage);
    ClearTokens;
    ClearStack;
    Funcs.Clear;
  end;
begin
  DecimalSeparator:='.';
  ClearTokens;
  ClearStack;
  Funcs.Clear;
  Classes.clear;
  scan:=1;
  parseNode:=self;
  CurrentFunction:=self;
  scanL:=length(FScript);
  try
    while GetToken(Token,Literal) do
      AddToken(Token,Literal);
  except
    on E: exception do parseError(E.message);
  end;
end;

function TjanPico.peek: TjanPicoObject;
var
  c:integer;
begin
  c:=stack.count;
  if c=0 then
    raise exception.create('Stack underflow');
  result:=TjanPicoObject(stack[c-1]);
end;

procedure TjanPico.picoAbs;
var
  obj:TjanPicoObject;
begin
  obj:=pop;
  if obj.Kind<>jpoNumber then
    raise exception.create('Abs function expects a number');
  obj.Number:=abs(obj.number);
  push(obj);
end;

procedure TjanPico.picoAdd;
var
  v1,v2:extended;
begin
  v2:=popNumber;
  v1:=popNumber;
  pushNumber(v1+v2);
end;

procedure TjanPico.picoAnd;
var
  v1,v2:extended;
begin
  v2:=popNumber;
  v1:=popNumber;
  pushNumber((Round(v1) and Round(v2)));
end;

procedure TjanPico.picoShl;
var
  v1,v2:extended;
begin
  v2:=popNumber;
  v1:=popNumber;
  pushNumber((Round(v1) shl Round(v2)));
end;

procedure TjanPico.picoShr;
var
  v1,v2:extended;
begin
  v2:=popNumber;
  v1:=popNumber;
  pushNumber((Round(v1) shr Round(v2)));
end;

procedure TjanPico.picoArcTan;
begin
  pushNumber(arctan(popNumber));
end;

procedure TjanPico.picoAsk;
var
  Aprompt,aDefault:string;
begin
  aPrompt:=popText;
  aDefault:=popText;
  if not inputquery('Pico',aPrompt,ADefault) then
    pushText('')
  else
    pushText(ADefault);
end;

procedure TjanPico.PicoAsText;
var
  e:extended;
begin
  e:=popNumber;
  pushText(floattostr(e));
end;

procedure TjanPico.PicoAsChar;
var
  e:integer;
begin
  e:=Trunc(popNumber);
  pushText(Chr(Lo(e)));
end;

procedure TjanPico.picoCallMethod;
var
  funcname,methodname:string;
//  ClassString:string;
  pf:TjanPicoFunction;
//  symbol:string;
  calledFunction, methodFunction{, classFunction}:TjanPicoFunction;
  oldFunction:TjanPicoFunction;
  p:integer;
  obj:TjanPicoObject;
  objvar:boolean;
begin
  funcname:=PCToken.symbol;
  p:=pos('.',funcname);
  methodname:=copy(funcname,p+1,maxint);
  funcname:=copy(funcname,1,p-1);
  objvar:=false;
  if PCToken.FuncRef=nil then begin
    pf:=FindFunctionScope(funcname);
    if pf=nil then begin
      pf:=FindVariableScope(funcname);
      if pf=nil then
        raise exception.Create('Undefined object variable '+funcname);
      obj:=TjanPicoObject(pf.vars[funcname]);
      if obj.Kind<>jpoReference then
        raise exception.create(funcname+' does not reference a valid object.');
      calledFunction:=obj.Reference;
      objvar:=true;
    end
    else
      calledFunction:=TjanPicoFunction(pf.Funcs[funcname]);
    if calledFunction.FunctionKind<>jpfkObject then
      raise exception.create(funcname+' is not an object.');
    if not objvar then
      PCToken.FuncRef:=calledFunction;
  end
  else
    calledFunction:=PCToken.FuncRef;
  oldFunction:=CurrentFunction;
  CurrentFunction:=calledFunction;
  MethodFunction:=findMethod(calledFunction,methodname);
  if MethodFunction=nil then
      raise exception.Create('Undefined method '+methodname+' in function '+funcname);
  if not calledFunction.Initialized then begin
    InitializeClass(MethodFunction.ParentFunction);
    calledFunction.ExecuteWord;
    calledFunction.Initialized:=true;
  end;
  MethodFunction.ExecuteWord;
  CurrentFunction:=oldFunction;
end;

procedure TjanPico.picoCall;
var
  funcname{,methodname}:string;
//  ClassString:string;
  pf:TjanPicoFunction;
//  symbol:string;
  calledFunction{, methodFunction, classFunction}:TjanPicoFunction;
  oldFunction:TjanPicoFunction;
//  p:integer;
begin
  funcname:=PCToken.symbol;
  pf:=FindFunctionScope(funcname);
  if pf=nil then
    raise exception.Create('Undefined function '+funcname);
  calledFunction:=TjanPicoFunction(pf.Funcs[funcname]);
  if calledFunction.FunctionKind=jpfkObject then begin
    pushObject(calledFunction);
    exit;
  end;
  oldFunction:=CurrentFunction;
  CurrentFunction:=calledFunction;
  calledFunction.ExecuteWord;
  CurrentFunction:=oldFunction;
end;

procedure TjanPico.picoCase;
var
  i,c:integer;
  s:string;
  pico:TjanPicoWord;
begin
  if peek.Kind=jpoNumber then
    s:=floattostr(popNumber)
  else
    s:=popText;
  c:=PCToken.tokens.count;
  if c=0 then exit;
  for i:=0 to c-1 do begin
    pico:=TjanPicoWord(PCToken.tokens[i]);
    if pico.symbol=s then begin
      pico.ExecuteWord;
      exit;
    end;
  end;
end;

procedure TjanPico.picoCos;
begin
  pushNumber(cos(popNumber));
end;

procedure TjanPico.picoCr;
begin
  pushText(cr);
end;

procedure TjanPico.picoDate;
begin
  pushNumber(date);
end;

procedure TjanPico.picoDay;
var
  aDate:TDateTime;
begin
  aDate:=popNumber;
  pushNumber(janstrings.Date2Day(aDate));
end;

procedure TjanPico.picoDef;
begin
  // no operation

end;

procedure TjanPico.picoDefVariable;
var
  varname:string;
begin
  varname:=PCToken.symbol;
  _setVarText(CurrentFunction.Vars,varname,'');
end;

procedure TjanPico.PicoDegrees;
begin
  pushNumber(popNumber/pi*180);
end;

procedure TjanPico.picoDiv;
var
  v1,v2:extended;
begin
  v2:=popNumber;
  v1:=popNumber;
  pushNumber(v1/v2);
end;

procedure TjanPico.picoDiv2;
var
  v1,v2:extended;
begin
  v2:=popNumber;
  v1:=popNumber;
  v1:=v1/v2;
  pushNumber(trunc(v1));
end;

procedure TjanPico.picoDrop;
var
  obj:TjanPicoObject;
begin
  obj:=pop;
  obj.free;
end;

procedure TjanPico.picoDup;
var
  obj{, obj2}:TjanPicoObject;
begin
  obj:=peek;
  push(obj.Clone);
end;

procedure TjanPico.picoElse;
var
  v:variant;
begin
  v:=lpopl;
  if not v then begin
    PCToken.ExecuteWord;
  end
end;


procedure TjanPico.picoEq;
var
  obj:TjanPicoObject;
begin
  obj:=peek;
  if obj.Kind=jpoText then begin
    lpush(popText=popText);
  end
  else if obj.Kind=jpoNumber then begin
    lpush(popNumber=popNumber);
  end
  else
    raise exception.create('= operator expects number or text arguments');
end;

procedure TjanPico.picoExp;
begin
  pushNumber(exp(popNumber));
end;

procedure TjanPico.picoExternal;
begin
  if assigned(onExternal) then
    onExternal(self,PCToken.symbol);
end;

procedure TjanPico.picoFalse;
begin
  lpush(false);
end;

procedure TjanPico.picoFix;
var
  e:extended;
  count:integer;
  s:string;
begin
  count:=popInteger;
  e:=popNumber;
  s:='%8.'+inttostr(count)+'f';
  pushText(format(s,[e]));
end;

procedure TjanPico.PicoFormatDate;
var
  AFormat:string;
  ADate:TDateTime;
begin
  AFormat:=popText;
  ADate:=popNumber;
  pushText(formatdatetime(AFormat,ADate));
end;

procedure TjanPico.picoGe;
begin
  if peek.Kind=jpoText then
    lpush(popText>=popText)
  else
    lpush(popNumber>=popNumber);
end;

procedure TjanPico.picoGetVariable;
var
  varname:string;
  pf:TjanPicoFunction;
  obj:TjanPicoObject;
begin
  varname:=PCToken.symbol;
  pf:=FindVariableScope(varname);
  if pf=nil then
    raise exception.Create('Undefined variable '+varname);
  obj:=TjanPicoObject(pf.vars[varname]);
  if obj.Kind=jpoNumber then
    pushNumber(obj.Number)
  else if obj.Kind=jpoText then
    pushText(obj.Text)
  else
    pushObject(TjanPicoFunction(obj.Reference));  
end;

procedure TjanPico.picoGetVariableAddress;
var
  varname : string;
  pf      : TjanPicoFunction;
  obj     : TjanPicoObject;
  APointer: Pointer;
begin
  varname:=PCToken.symbol;
  pf:=FindVariableScope(varname);
  if pf=nil then
    raise exception.Create('Undefined variable '+varname);
  obj:=TjanPicoObject(pf.vars[varname]);
  if obj.Kind=jpoNumber then
    APointer := @obj.FNumber
  else if obj.Kind=jpoText then
    APointer := @obj.FText[1]
  else
    APointer := @obj.FReference;
  pushNumber(LongInt(APointer));
end;

procedure TjanPico.picoGt;
begin
  if peek.kind=jpoNumber then
    lpush(popNumber>popNumber)
  else
    lpush(popText>popText);
end;

procedure TjanPico.picoIf;
var
  v:variant;
  node:TjanPicoWord;
begin
  v:=lpop;
  node:=PCToken.nextSibling;
    if node<>nil then
      if node.Kind=jpkElse then
        lpushl(v);
  if v then begin
    PCToken.ExecuteWord;
    // PC:=TjanPicoWord(tokens[PC+1]).Link;
  end
end;


procedure TjanPico.picoLe;
begin
  if peek.kind=jpoNumber then
    lpush(popNumber<=popNumber)
  else
    lpush(popText<=popText);
end;

procedure TjanPico.picoLeft;
var
  s:string;
  c:integer;
begin
  c:=popInteger;
  s:=popText;
  pushText(copy(s,1,c));
end;

procedure TjanPico.picoLength;
begin
  pushNumber(length(popText));
end;

procedure TjanPico.picoLn;
begin
  pushNumber(ln(popNumber));
end;

procedure TjanPico.picoLog;
begin
  pushNumber(log10(popNumber));
end;

procedure TjanPico.picoLowercase;
begin
  pushText(lowercase(popText));
end;

procedure TjanPico.picoLt;
begin
  if peek.kind=jpoNumber then
    lpush(popNumber<popNumber)
  else
    lpush(popText<popText)
end;

procedure TjanPico.picoMax;
begin
  pushNumber(max(popNumber,popNumber));
end;

procedure TjanPico.picoMaxInt;
begin
  pushNumber(MaxInt);
end;

procedure TjanPico.picoMid;
var
  s:string;
  c,index:integer;
begin
  index:=popInteger;
  c:=popInteger;
  s:=popText;
  pushText(copy(s,index,c));
end;

procedure TjanPico.picoMin;
begin
  pushNumber(min(popNumber,popNumber));
end;

procedure TjanPico.picoMonth;
var
  aDate:TDateTime;
begin
  aDate:=popNumber;
  pushNumber(janstrings.Date2Month(aDate));
end;

procedure TjanPico.picoMul;
var
  v1,v2:extended;
begin
  v2:=popNumber;
  v1:=popNumber;
  pushNumber(v1*v2);
end;

procedure TjanPico.picoNe;
begin
  if peek.kind=jpoNumber then
    lpush(popNumber<>popNumber)
  else
    lpush(popText<>popText)
end;

procedure TjanPico.picoNeg;
begin
  pushNumber(-popNumber);
end;

procedure TjanPico.picoNop;
begin
  // do nothing
end;

procedure TjanPico.picoNot;
var
  v1:extended;
begin
  v1:=popNumber;
  pushNumber(not(Round(v1)));
end;

procedure TjanPico.picoBool;
begin
  lpush(lpop);
end;

procedure TjanPico.picoNow;
begin
  pushNumber(now);
end;

procedure TjanPico.picoNumber;
begin
  pushNumber(PCToken.value)
end;

procedure TjanPico.picoOr;
var
  v1,v2:extended;
begin
  v2:=popNumber;
  v1:=popNumber;
  pushNumber((Round(v1) or Round(v2)));
end;

procedure TjanPico.picoPi;
begin
  pushNumber(pi);
end;

procedure TjanPico.picoPosStr;
var
  substr, text:string;
  index:integer;
begin
  index:=popInteger;
  substr:=popText;
  text:=popText;
  pushNumber(janstrings.PosStr(substr,text,index));
end;

procedure TjanPico.picoPosText;
var
  substr, text:string;
  index:integer;
begin
  index:=popInteger;
  substr:=popText;
  text:=popText;
  pushNumber(janstrings.PosText(substr,text,index));
end;

procedure TjanPico.picoPower;
var
  Base, Exponent: Extended;
begin
  Exponent:=popNumber;
  Base:=popNumber;
  pushNumber(Power(Base, Exponent));
end;


procedure TjanPico.PicoRadians;
begin
  pushNumber(popNumber/180*pi);
end;

procedure TjanPico.picoRepeat;
var
  i,c:integer;
begin
  c:=popInteger;
  if c>0 then
    for i:=1 to c do begin
      PCToken.ExecuteWord;
      PCToken:=PCToken.parent;
      if PCToken.FSymbol <> 'repeat' then
        raise exception.create('Stack problem in repeat loop [use '';'' before closing bracket]');
    end;
end;

procedure TjanPico.picoReplaceStr;
var
  SourceString,FindString,ReplaceString:string;
begin
  ReplaceString:=popText;
  FindString:=popText;
  SourceString:=popText;
  pushText(q_replacestr(SourceString,FindString,ReplaceString));
end;

procedure TjanPico.picoReplaceText;
var
  SourceString,FindString,ReplaceString:string;
begin
  ReplaceString:=popText;
  FindString:=popText;
  SourceString:=popText;
  pushText(q_replacetext(SourceString,FindString,ReplaceString));
end;

procedure TjanPico.picoRight;
var
  s:string;
  c:integer;
begin
  c:=popInteger;
  s:=popText;
  pushText(copy(s,length(s)-c+1,c));
end;

procedure TjanPico.picoRound;
var
  v1:extended;
  i:integer;
begin
  v1:=popNumber;
  i:=round(v1);
  pushNumber(i);
end;

procedure TjanPico.picoSay;
begin
  showmessage(popText);
end;

procedure TjanPico.picoSayStack;
var
  c       : Integer;
  o       : TjanPicoObject;
  Loop    : Integer;
  StackStr: string;
begin
  c := Stack.Count;
  if c > 0 then
  begin
    if c >1 then
      StackStr   := format('saystack [%d]'#13 +
                           'bottom ---> top of stack'#13#13, [c])
    else
      StackStr   := 'saystack [1]'#13#13;
    for Loop := 1 to c do
    begin
      o := TjanPicoObject(stack[Loop-1]);
      case o.Kind of
        jpoNumber : if o.Number = Round(o.Number) then
                    begin
                      if Round(o.Number) < 0 then
                        StackStr := format('%s %d', [StackStr, Round(o.Number)])
                      else
                        StackStr := format('%s $%x', [StackStr, Round(o.Number)]);
                    end
                    else
                      StackStr := format('%s %f', [StackStr, o.Number]);
        jpoText   : StackStr := format('%s %s', [StackStr, o.Text]);
      end;
    end;
    showmessage(StackStr);
  end;
end;

procedure TjanPico.picoSayStackD;
var
  c       : Integer;
  o       : TjanPicoObject;
  Loop    : Integer;
  StackStr: string;
begin
  c := Stack.Count;
  if c > 0 then
  begin
    if c >1 then
      StackStr   := format('saystackd [%d]'#13 +
                           'bottom ---> top of stack'#13#13, [c])
    else
      StackStr   := 'saystackd [1]'#13#13;
    for Loop := 1 to c do
    begin
      o := TjanPicoObject(stack[Loop-1]);
      case o.Kind of
        jpoNumber : if o.Number = Round(o.Number) then
                      StackStr := format('%s %d', [StackStr, Round(o.Number)])
                    else
                      StackStr := format('%s %f', [StackStr, o.Number]);
        jpoText   : StackStr := format('%s %s', [StackStr, o.Text]);
      end;
    end;
    showmessage(StackStr);
  end;
end;

procedure TjanPico.picoSetVariable;
var
  varname:string;
  pf:TjanPicoFunction;
  obj, top:TjanPicoObject;
begin
  varname:=PCToken.symbol;
  pf:=FindVariableScope(varname);
  if pf=nil then
    raise exception.Create('Undefined variable '+varname);
  obj:=_po(pf.vars[varname]);
  top:=peek;
  if top.kind=jpoNumber then begin
    obj.Number:=popNumber;
    obj.Kind:=jpoNumber;
  end
  else if top.kind=jpoText then begin
    obj.Text:=popText;
    obj.Kind:=jpoText;
  end
  else begin
    obj.Reference:=popObject;
    obj.Kind:=jpoReference;
  end;
end;

procedure TjanPico.picoLogLevel;
begin
  FLogLevel := Round(popNumber);
  if FLogLevel >= 0 then
  begin
    if not Assigned(FLogStream) then
    begin
      try
        if FLogAppend and
          FileExists(FLogFile) then
        begin
          FLogStream := TFileStream.Create(FLogFile, fmOpenReadWrite);
          // Go to end of file (we will be appending)
          FLogStream.Seek(0, soFromEnd);
        end
        else
          FLogStream := TFileStream.Create(FLogFile, fmCreate);
      except
        FreeAndNil(FLogStream);
      end;
    end;
    if Assigned(FLogStream) then
    begin
      ToLog('----------------------------START----------------------------', 0);
      ToLog(format('PicoScript V%f, using log level %d', [PICOVERSION, FLogLevel]), 0);
    end;
  end
  else
    if Assigned(FLogStream) then
    begin
      ToLog('-----------------------------END-----------------------------', 0);
      FreeAndNil(FLogStream);
    end;
end;


procedure TjanPico.picoLogFile;
begin
  FLogFile := popText;
end;


procedure TjanPico.picoLogAppend;
begin
  FLogAppend := lpop;
end;


{------------------------------------------------------------------------------
  Params  : <LogString>  Data to log
            <Level>      Required log level: if this number if <= <LogLevel> then
                         it is logged.
                         $2x: No new line + time stamp
  Returns : -

  Descript: Write data to log. A timestamp is typically added.
  Notes   :
 ------------------------------------------------------------------------------}
procedure TJanPico.ToLog(LogString: string; Level: Integer);
var
  NewLog: string;
begin
  // Only log if the level is high enough
  if Level and ($0F)> FLogLevel then
    Exit;
  if not Assigned(FLogStream) then
    Exit;
  if (Level and $20) = 0 then
    NewLog := #13#10 + FormatDateTime('"T"HHMMSS"  "', Now) + LogString
  else
    NewLog := LogString;
  if NewLog = '' then
    NewLog := ' ';
  FLogStream.Write(NewLog[1], Length(NewLog));
end;


procedure TjanPico.picoLogMessage;
var
  LogString: string;
  LogLevel: Integer;
  c       : Integer;
  o       : TjanPicoObject;
  Loop    : Integer;
  StackStr: string;
  Hexa    : Boolean;
  TheNum  : Int64;
begin
  LogString := popText;
  LogLevel  := Round(popNumber);
  // Check special bits $8x and $4x are handled here
  if (LogLevel and $80) <> 0 then
  begin
    try
      Hexa := ((LogLevel and $40) <> 0);
      c := Stack.Count;
      if c > 0 then
      begin
        StackStr := '';
        for Loop := 1 to c do
        begin
          o := TjanPicoObject(stack[Loop-1]);
          case o.Kind of
            jpoNumber : if o.Number = Round(o.Number) then
                        begin
                          TheNum := Round(o.Number);
                          if TheNum < 0 then
                          begin
                            if StackStr = '' then
                              StackStr := format('%d', [TheNum])
                            else
                              StackStr := format('%s %d', [StackStr, TheNum]);
                          end
                          else
                            if StackStr = '' then
                            begin
                              if Hexa then
                                StackStr := format('$%.2x', [TheNum])
                              else
                                StackStr := format('%d', [TheNum]);
                            end
                            else
                            begin
                              if Hexa then
                                StackStr := format('%s $%.2x', [StackStr, TheNum])
                              else
                                StackStr := format('%s %d', [StackStr, TheNum]);
                            end;
                        end
                        else
                        begin
                          if StackStr = '' then
                            StackStr := format('%f', [o.Number])
                          else
                            StackStr := format('%s %f', [StackStr, o.Number]);
                        end;
            jpoText   : begin
                          if StackStr = '' then
                            StackStr := o.Text
                          else
                            StackStr := StackStr + ' ' + o.Text;
                        end;
          end;
        end;
        if StackStr = '' then
          LogString := LogString + ' [-]'
        else
          LogString := LogString + ' [' + StackStr + ']';
      end;
    except
      // In case some conversion goes wrong .... most likely a number
      ToLog('Exception in ''logmessage''.', $01);
    end;
  end;
  ToLog(LogString, LogLevel and $3F);
end;


procedure TjanPico.picoOpenRFile;
var
  FileName: string;
  AHandle : THandle;
begin
  FileName := popText;
  if FileName <> '' then
  begin
    AHandle := CreateFile(@FileName[1], GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0);
    if AHandle = INVALID_HANDLE_VALUE then
      AHandle := 0;
  end
  else
    AHandle := 0;
  pushNumber(AHandle);
end;


procedure TjanPico.picoOpenWFile;
var
  FileName: string;
  AHandle : THandle;
begin
  FileName := popText;
  AHandle := 0;
  if FileName <> '' then
  begin
    AHandle := CreateFile(@FileName[1], GENERIC_WRITE, 0, nil, OPEN_ALWAYS, 0, 0);
    if AHandle = INVALID_HANDLE_VALUE then
      AHandle := 0;
  end;
  pushNumber(AHandle);
end;


procedure TjanPico.picoCloseFile;
var
  AHandle : THandle;
begin
  AHandle := THandle(Round(popNumber));
  if AHandle <> 0 then
    CloseHandle(AHandle);
end;


procedure TjanPico.picoReadFile;
var
  AHandle: THandle;
  ToRead : Integer;
  InBuf  : PByteArray;
  DidRead: Dword;
  Loop   : Integer;
begin
  AHandle := THandle(Round(popNumber));
  ToRead  := Round(popNumber);
  GetMem(InBuf, ToRead);
  try
    if ReadFile(AHandle, InBuf^, ToRead, DidRead, nil) then
    begin
      if DidRead > 0 then
      begin
        for Loop := DidRead-1 downto 0 do
          pushNumber(InBuf[Loop]);
        pushNumber(DidRead);
      end
      else
        pushNumber(0);
    end
    else
      pushNumber(0);
  finally
    FreeMem(InBuf);
  end;
end;


procedure TjanPico.picoWriteFile;
var
  AHandle : THandle;
  ToWrite : Integer;
  OutBuf  : PByteArray;
  DidWrite: Dword;
  Loop    : Integer;
begin
  AHandle := THandle(Round(popNumber));
  ToWrite := Round(popNumber);
  GetMem(OutBuf, ToWrite);
  try
    if ToWrite > 0 then
    begin
      for Loop := 0 to ToWrite-1 do
        OutBuf[Loop] := Round(popNumber);
      lpush(WriteFile(AHandle, OutBuf^, ToWrite, DidWrite, nil));
    end
    else
      lpush(False);
  finally
    FreeMem(OutBuf);
  end;
end;


procedure TjanPico.picoWriteFileStr;
var
  AHandle : THandle;
  ToWrite : string;
  OutBuf  : PByteArray;
  DidWrite: Dword;
  Loop    : Integer;
begin
  AHandle := THandle(Round(popNumber));
  ToWrite := popText;
  GetMem(OutBuf, Length(ToWrite));
  try
    if Length(ToWrite) > 0 then
    begin
      for Loop := 1 to Length(ToWrite) do
        OutBuf[Loop-1] := Ord(ToWrite[Loop]);
      lpush(WriteFile(AHandle, OutBuf^, Length(ToWrite), DidWrite, nil));
    end
    else
      lpush(False);
  finally
    FreeMem(OutBuf);
  end;
end;


procedure TjanPico.picoFilePos;
var
  AHandle : THandle;
  Position: Integer;
begin
  AHandle  := THandle(Round(popNumber));
  Position := Round(popNumber);
  pushNumber(SetFilePointer(AHandle, Position, nil, FILE_BEGIN));
end;


procedure TjanPico.picoReadMem;
var
  Address: Integer;
  AByte  : PByte;
  BByte  : Byte;
begin
  Address := trunc(popNumber);
  try
    AByte := Pointer(Address);
    BByte := AByte^;
  except
    BByte := 0;
  end;
  pushNumber(BByte);
end;


procedure TjanPico.picoWriteMem;
var
  Address: Integer;
  AByte  : PByte;
  BByte  : Byte;
begin
  Address := trunc(popNumber);
  BByte   := Lo(trunc(popNumber));
  try
    AByte := Pointer(Address);
    AByte^ := BByte;
  except
  end;
end;


procedure TjanPico.picoDriverVersion;
var
  Success: Boolean;
  Handle : THandle;
  Major  : Word;
  Minor  : Word;
  Build  : Dword;
  Device : PChar;
begin
  Handle := Round(popNumber);
  GetMem(Device, 128);
  try
    Success := False;
    case FChipset of
      ctSaa7146a: Success := Saa7146aGetDriverVersion(Handle, @Major, @Minor, @Build, Device);
      ctFlexcop : Success := FlexcopGetDriverVersion (Handle, @Major, @Minor, @Build, Device);
    end;
    if Success then
    begin
      pushText(Device);
      pushNumber(Build);
      pushNumber(Minor);
      pushNumber(Major);
    end;
    lpush(Success);
  finally
    FreeMem(Device, 128);
  end;
end;

procedure TjanPico.picoDriverCards;
var
  Cards: Integer;
begin
  Cards := 0;
  case FChipset of
    ctSaa7146a: Cards := Saa7146aGetNumberOfCards;
    ctFlexcop : Cards := FlexcopGetNumberOfCards;
  end;
  pushNumber(Cards);
end;

procedure TjanPico.picoDriverHandleCreate;
var
  Card  : Dword;
  Handle: THandle;
begin
  Card   := Dword(Round(popNumber));
  Handle := INVALID_HANDLE_VALUE;
  case FChipset of
    ctSaa7146a: begin
                  Handle := Saa7146aCreateFile(Card);
                  // Add handle to the list of handles we have to remove when the
                  // scripts terminates
                  // Note: We just add and don't search for any, already deleted'
                  // items
                  if Handle <> INVALID_HANDLE_VALUE then
                  begin
                    SetLength(FHandles[ctSaa7146a], Length(FHandles[ctSaa7146a])+1);
                    FHandles[ctSaa7146a][Length(FHandles[ctSaa7146a])-1] := Handle;
                  end;
                end;
    ctFlexcop : begin
                  Handle := FlexCopCreateFile (Card);
                  // Add handle to the list of handles we have to remove when the
                  // scripts terminates
                  // Note: We just add and don't search for any, already deleted'
                  // items
                  if Handle <> INVALID_HANDLE_VALUE then
                  begin
                    SetLength(FHandles[ctFlexcop], Length(FHandles[ctFlexcop])+1);
                    FHandles[ctFlexcop][Length(FHandles[ctFlexcop])-1] := Handle;
                  end;
                end;
  end;
  pushNumber(Handle);
end;

procedure TjanPico.picoDriverHandleClose;
var
  Handle: THandle;
  Loop  : Integer;
begin
  Handle := Round(popNumber);
  case FChipset of
    ctSaa7146a: begin
                  Saa7146aCloseHandle(Handle);
                  if Length(FHandles[ctSaa7146a]) > 0 then
                    for Loop := 0 to Length(FHandles[ctSaa7146a])-1 do
                      if FHandles[ctSaa7146a][Loop] = Handle then
                        FHandles[ctSaa7146a][Loop] := INVALID_HANDLE_VALUE;
                end;
    ctFlexcop : begin
                  FlexCopCloseHandle(Handle);
                  if Length(FHandles[ctFlexcop]) > 0 then
                    for Loop := 0 to Length(FHandles[ctFlexcop])-1 do
                      if FHandles[ctFlexcop][Loop] = Handle then
                        FHandles[ctFlexcop][Loop] := INVALID_HANDLE_VALUE;
                end;
  end;
end;

procedure TjanPico.picoDriverCardSubsys;
var
  Card: Integer;
begin
  Card := Round(popNumber);
  case FChipset of
    ctSaa7146a: pushNumber(Saa7146aGetSubsysOfCard(Card));
    ctFlexcop : pushNumber(FlexCopGetSubsysOfCard(Card));
  end;
end;

procedure TjanPico.picoDriverNotifyWait;
var
  Handle : THandle;
  Success: Boolean;
begin
  Handle := Round(popNumber);
  Success := False;
  case FChipset of
    ctSaa7146a: Success := Saa7146aWaitForNotification(Handle);
    ctFlexcop : Success := FlexcopWaitForNotification (Handle);
  end;
  lpush(Success);
end;

procedure TjanPico.picoDriverNotifyGenerate;
var
  Handle : THandle;
  Success: Boolean;
begin
  Handle := Round(popNumber);
  Success := False;
  case FChipset of
    ctSaa7146a: Success := Saa7146aGenerateManualNotification(Handle);
    ctFlexcop : Success := FlexcopGenerateManualNotification (Handle);
  end;
  lpush(Success);
end;

procedure TjanPico.picoDriverRd;
var
  Handle   : THandle;
  Address  : Dword;
  Data     : Dword;
  Success  : Boolean;
begin
  Handle  := Round(popNumber);
  Address := Dword(Round(popNumber));
  Success := False;
  case FChipset of
    ctSaa7146a: Success := Saa7146aReadFromSaa7146aRegister(Handle, Address, Data);
    ctFlexcop : Success := FlexCopReadFromFlexCopRegister (Handle, Address, Data);
  end;
  if Success then
  begin
    pushNumber(Data);
    lpush(true)
  end
  else
    lpush(false);
end;

procedure TjanPico.picoDriverWr;
var
  Handle   : THandle;
  Address  : Dword;
  Data     : Dword;
  Success  : Boolean;
begin
  Handle  := Round(popNumber);
  Address := Dword(Round(popNumber));
  Data    := Dword(Round(popNumber));
  Success := False;
  case FChipset of
    ctSaa7146a: Success := Saa7146aWriteToSaa7146aRegister(Handle, Address, Data);
    ctFlexcop : Success := FlexCopWriteToFlexCopRegister  (Handle, Address, Data);
  end;
  lpush(Success);
end;

procedure TjanPico.picoDriverDmaStatus;
var
  Handle   : THandle;
  DmaBuffer: Dword;
  Status1  : TSaa7146aGetDmaStatus;
  Status2  : TFlexcopGetDmaStatus;
  Success  : Boolean;
begin
  Handle    := Round(popNumber);
  DmaBuffer := Dword(Round(popNumber));
  Success := False;
  case FChipset of
    ctSaa7146a: begin
                  Success := Saa7146aGetDmaStatus(Handle, DmaBuffer, Status1);
                  if Success then
                  begin
                    pushNumber(Status1.FifoOverflows);
                    pushNumber(Status1.Size);
                    pushNumber(Dword(Status1.PhysicalAddress.LowPart));
                    pushNumber(Dword(Status1.VirtualAddress));
                    pushNumber(Status1.Isr);
                    pushNumber(Status1.Interrupts);
                  end
                end;
    ctFlexcop : begin
                  Success := FlexcopGetDmaStatus (Handle, DmaBuffer, Status2);
                  if Success then
                  begin
                    pushNumber(Status2.FifoOverflows);
                    pushNumber(Status2.Size);
                    pushNumber(Dword(Status2.PhysicalAddress.LowPart));
                    pushNumber(Dword(Status2.VirtualAddress));
                    pushNumber(Status2.Isr);
                    pushNumber(Status2.Interrupts);
                  end
                end;
  end;
  lpush(Success);
end;

procedure TjanPico.picoDriverDmaAllocate;
var
  Handle : THandle;
  DmaSize: Dword;
  Status1: TSaa7146aDmaBuffer;
  Status2: TFlexcopDmaBuffer;
  Success: Boolean;
begin
  Handle  := Round(popNumber);
  DmaSize := Dword(Round(popNumber));
  Success := False;
  case FChipset of
    ctSaa7146a: begin
                  Success := Saa7146aAllocateDma(Handle, DmaSize, Status1);
                  if Success then
                  begin
                    pushNumber(Status1.Size);
                    pushNumber(Dword(Status1.PhysicalAddress.LowPart));
                    pushNumber(Dword(Status1.VirtualAddress));
                    pushNumber(Status1.Identifier);
                  end
                end;
    ctFlexcop : begin
                  Success := FlexcopAllocateDma (Handle, DmaSize, Status2);
                  if Success then
                  begin
                    pushNumber(Status2.Size);
                    pushNumber(Dword(Status2.PhysicalAddress.LowPart));
                    pushNumber(Dword(Status2.VirtualAddress));
                    pushNumber(Status2.Identifier);
                  end
                end;
  end;
  lpush(Success);
end;

procedure TjanPico.picoDriverDmaRelease;
var
  Handle   : THandle;
  DmaBuffer: Dword;
  Success  : Boolean;
begin
  Handle    := Round(popNumber);
  DmaBuffer := Dword(Round(popNumber));
  Success := False;
  case FChipset of
    ctSaa7146a: Success := Saa7146aReleaseDma(Handle, DmaBuffer);
    ctFlexcop : Success := FlexcopReleaseDma (Handle, DmaBuffer);
  end;
  lpush(Success);
end;

procedure TjanPico.picoDriverDmaRd;
var
  Handle   : THandle;
  Transfer1: TSaa7146aTransferBuffer;
  Transfer2: TFlexcopTransferBuffer;
  Success  : Boolean;
begin
  Handle    := Round(popNumber);
  Success := False;
  case FChipset of
    ctSaa7146a: begin
                  Transfer1.Identifier      := Round(popNumber);
                  Transfer1.TransferAddress := PChar(Round(popNumber));
                  Transfer1.SourceIndex     := Round(popNumber);
                  Transfer1.TargetIndex     := Round(popNumber);
                  Transfer1.TransferLength  := Round(popNumber);
                  Success := Saa7146aReadFromDma(Handle, Transfer1);
                end;
    ctFlexcop : begin
                  Transfer2.Identifier      := Round(popNumber);
                  Transfer2.TransferAddress := PChar(Round(popNumber));
                  Transfer2.SourceIndex     := Round(popNumber);
                  Transfer2.TargetIndex     := Round(popNumber);
                  Transfer2.TransferLength  := Round(popNumber);
                  Success := FlexcopReadFromDma (Handle, Transfer2);
                end;
  end;
  lpush(Success);
end;

procedure TjanPico.picoDriverDmaWr;
var
  Handle   : THandle;
  Transfer1: TSaa7146aTransferBuffer;
  Transfer2: TFlexcopTransferBuffer;
  Success  : Boolean;
begin
  Handle    := Round(popNumber);
  Success := False;
  case FChipset of
    ctSaa7146a: begin
                  Transfer1.Identifier      := Round(popNumber);
                  Transfer1.TransferAddress := PChar(Round(popNumber));
                  Transfer1.SourceIndex     := Round(popNumber);
                  Transfer1.TargetIndex     := Round(popNumber);
                  Transfer1.TransferLength  := Round(popNumber);
                  Success := Saa7146aWriteToDma(Handle, Transfer1);
                end;
    ctFlexcop : begin
                  Transfer2.Identifier      := Round(popNumber);
                  Transfer2.TransferAddress := PChar(Round(popNumber));
                  Transfer2.SourceIndex     := Round(popNumber);
                  Transfer2.TargetIndex     := Round(popNumber);
                  Transfer2.TransferLength  := Round(popNumber);
                  Success := FlexcopWriteToDma (Handle, Transfer2);
                end;
  end;
  lpush(Success);
end;

procedure TjanPico.picoDriverFifoAllocate;
var
  Handle   : THandle;
  Transfer1: TSaa7146aFifoTransferBuffer;
  Transfer2: TFlexcopFifoTransferBuffer;
  Success  : Boolean;
begin
  Handle    := Round(popNumber);
  Success := False;
  case FChipset of
    ctSaa7146a: begin
                  Transfer1.NumberOfBuffers := Round(popNumber);
                  Transfer1.TransferAddress := PChar(Round(popNumber));
                  popNumber;                                         // Dummy
                  Transfer1.TransferLength  := Round(popNumber);
                  Success := Saa7146aAllocateFifo(Handle, Transfer1);
                  if Success then
                    pushNumber(Transfer1.Identifier);
                end;
    ctFlexcop : begin
                  Transfer2.NumberOfBuffers    := Round(popNumber);
                  Transfer2.TransferAddress[0] := PChar(Round(popNumber));
                  Transfer2.TransferAddress[1] := PChar(Round(popNumber));
                  Transfer2.TransferLength     := Round(popNumber);
                  Success := FlexcopAllocateFifo(Handle, Transfer2);
                  if Success then
                    pushNumber(Transfer2.Identifier);
                end;
  end;
  lpush(Success);
end;

procedure TjanPico.picoDriverFifoRelease;
var
  Handle   : THandle;
  Transfer1: TSaa7146aFifoTransferBuffer;
  Transfer2: TFlexcopFifoTransferBuffer;
  Success  : Boolean;
begin
  Handle    := Round(popNumber);
  Success := False;
  case FChipset of
    ctSaa7146a: begin
                  Transfer1.Identifier      := Round(popNumber);
                  Transfer1.NumberOfBuffers := Round(popNumber);
                  Success := Saa7146aReleaseFifo(Handle, Transfer1);
                  if Success then
                  begin
                    pushNumber(Transfer1.NumberOfBuffers);
                    pushNumber(Transfer1.Identifier);
                  end;
                end;
    ctFlexcop : begin
                  Transfer2.Identifier      := Round(popNumber);
                  Transfer2.NumberOfBuffers := Round(popNumber);
                  Success := FlexcopReleaseFifo(Handle, Transfer2);
                  if Success then
                  begin
                    pushNumber(Transfer2.NumberOfBuffers);
                    pushNumber(Transfer2.Identifier);
                  end;
                end;
  end;
  lpush(Success);
end;

procedure TjanPico.picoDriverFifoRd;
var
  Handle   : THandle;
  Transfer1: TSaa7146aFifoTransferBuffer;
  Transfer2: TFlexCopFifoTransferBuffer;
  Success  : Boolean;
begin
  Handle    := Round(popNumber);
  Success := False;
  case FChipset of
    ctSaa7146a: begin
                  Transfer1.Identifier      := Round(popNumber);
                  Transfer1.TransferAddress := PChar(Round(popNumber));
                  Transfer1.TransferLength  := Round(popNumber);
                  Success := Saa7146aReadFromFifo(Handle, Transfer1);
                  if Success then
                  begin
                    pushNumber(Transfer1.AllOverflows);
                    pushNumber(Transfer1.Irqs);
                    pushNumber(Transfer1.Overflows);
                    pushNumber(Transfer1.OrderNumber);
                    lpush(Transfer1.IsValid);
                    pushNumber(Transfer1.TransferLength);
                  end;
                end;
    ctFlexcop : begin
                  Transfer2.Identifier         := Round(popNumber);
                  Transfer2.TransferAddress[0] := PChar(Round(popNumber));
                  Transfer2.TransferLength     := Round(popNumber);
                  Success := FlexcopReadFromFifo(Handle, Transfer2);
                  if Success then
                  begin
                    pushNumber(Transfer2.AllOverflows);
                    pushNumber(Transfer2.Irqs);
                    pushNumber(Transfer2.Overflows);
                    pushNumber(Transfer2.OrderNumber);
                    lpush(Transfer2.IsValid);
                    pushNumber(Transfer2.TransferLength);
                  end;
                end;
  end;
  lpush(Success);
end;

procedure TjanPico.picoDriverIrqWr;
var
  Handle   : THandle;
  Transfer1: TSaa7146aIrqTransferBuffer;
  Transfer2: TFlexCopIrqTransferBuffer;
  Success  : Boolean;
begin
  Handle    := Round(popNumber);
  Success := False;
  case FChipset of
    ctSaa7146a: begin
                  Transfer1.Identifier                          := Round(popNumber);
                  Transfer1.Information.IrqBufferingIsActive    := lpop;
                  Transfer1.Information.UseNotificationEvent    := lpop;
                  Transfer1.Information.UseSignaling            := lpop;
                  Transfer1.Information.UseFifo                 := lpop;
                  Transfer1.Information.IrqAutoDisable          := lpop;
                  Transfer1.Information.SignalSaa7146aRegister  := Round(popNumber);
                  Transfer1.Information.SignalAndValue          := Round(popNumber);
                  Transfer1.Information.SignalOrValue           := Round(popNumber);
                  Transfer1.Information.SignalXorValue          := Round(popNumber);
                  Transfer1.Information.FifoBufferFirstIndex    := Round(popNumber);
                  Transfer1.Information.FifoBufferLastIndex     := Round(popNumber);
                  Transfer1.Information.FifoBufferPreviousIndex := Transfer1.Information.FifoBufferFirstIndex;
                  Success := Saa7146aWriteToIrqHandling(Handle, Transfer1);
                end;
    ctFlexcop : begin
                  Transfer2.Identifier                          := Round(popNumber);
                  Transfer2.Information.IrqBufferingIsActive    := lpop;
                  Transfer2.Information.UseNotificationEvent    := lpop;
                  Transfer2.Information.UseSignaling            := lpop;
                  Transfer2.Information.UseFifo                 := lpop;
                  lpop;                                              // Dummy
                  Transfer2.Information.SignalFlexcopRegister   := Round(popNumber);
                  Transfer2.Information.SignalAndValue          := Round(popNumber);
                  Transfer2.Information.SignalOrValue           := Round(popNumber);
                  Transfer2.Information.SignalXorValue          := Round(popNumber);
                  Transfer2.Information.FifoBufferFirstIndex    := Round(popNumber);;
                  Transfer2.Information.FifoBufferLastIndex     := Round(popNumber);;
                  Transfer2.Information.FifoBufferPreviousIndex := Transfer2.Information.FifoBufferFirstIndex;
                  Success := FlexcopWriteToIrqHandling(Handle, Transfer2);
                end;
  end;
  lpush(Success);
end;

procedure TjanPico.picoDriverIrqRd;
var
  Handle   : THandle;
  Transfer1: TSaa7146aIrqTransferBuffer;
  Transfer2: TFlexCopIrqTransferBuffer;
  Success  : Boolean;
begin
  Handle    := Round(popNumber);
  Success := False;
  case FChipset of
    ctSaa7146a: begin
                  Transfer1.Identifier                          := Round(popNumber);
                  Success := Saa7146aReadFromIrqHandling(Handle, Transfer1);
                  if Success then
                  begin
                    pushNumber(Transfer1.Information.FifoOverflows);
                    pushNumber(Transfer1.Information.FifoBufferCirculations);
                    pushNumber(Transfer1.Information.FifoBufferPreviousIndex);
                    pushNumber(Transfer1.Information.IrqsWhenActive);
                  end;
                end;
    ctFlexcop : begin
                  Transfer2.Identifier                          := Round(popNumber);
                  Success := FlexcopReadFromIrqHandling(Handle, Transfer2);
                  if Success then
                  begin
                    pushNumber(Transfer2.Information.FifoOverflows);
                    pushNumber(Transfer2.Information.FifoBufferCirculations);
                    pushNumber(Transfer2.Information.FifoBufferPreviousIndex);
                    pushNumber(Transfer2.Information.IrqsWhenActive);
                  end;  
                end;
  end;
  lpush(Success);
end;

procedure TjanPico.picoDriverSaa7146a;
begin
  FChipset := ctSaa7146a;
end;

procedure TjanPico.picoDriverGetSaa7146a;
begin
  lpush(FChipset = ctSaa7146a);
end;

procedure TjanPico.picoDriverFlexCop;
begin
  FChipset := ctFlexcop;
end;

procedure TjanPico.picoDriverGetFlexCop;
begin
  lpush(FChipset = ctFlexcop);
end;

procedure TjanPico.picoSin;
begin
  pushNumber(sin(popNumber));
end;

procedure TjanPico.picoSqr;
begin
  pushNumber(sqr(popNumber));
end;

procedure TjanPico.picoSqrt;
begin
  pushNumber(sqrt(popNumber));
end;

procedure TjanPico.picoString;
begin
  pushText(PCToken.symbol);
end;

procedure TjanPico.picoSub;
var
  v1,v2:extended;
begin
  v2:=popNumber;
  v1:=popNumber;
  pushNumber(v1-v2);
end;

procedure TjanPico.picoSwap;
var
  c:integer;
begin
  c:=stack.count;
  if c<2 then
    raise exception.create('Stack underflow');
  stack.Exchange(c-2,c-1);
end;

procedure TjanPico.picoTan;
begin
  pushNumber(tan(popNumber));
end;

procedure TjanPico.picoTrace;
var
  s:string;
begin
  if peek.kind=jpoNumber then
    s:=floattostr(popNumber)
  else
    s:=popText;
  if assigned(onTrace) then
    onTrace(self,s);
end;

procedure TjanPico.picoTrue;
begin
  lpush(true);
end;


procedure TjanPico.picoUppercase;
begin
  pushText(uppercase(popText));
end;

procedure TjanPico.picoVarAdd;
var
  varname:string;
  pf:TjanPicoFunction;
  obj:TjanPicoObject;
begin
  varname:=PCToken.symbol;
  pf:=FindVariableScope(varname);
  if pf=nil then
    raise exception.Create('Undefined variable '+varname);
  obj:=_po(pf.vars[varname]);
  if obj.kind=jpoNumber then
    obj.Number:=obj.Number+popNumber
  else
    obj.Text:=obj.Text+popText;
end;

procedure TjanPico.picoVarDec;
var
  varname:string;
  pf:TjanPicoFunction;
  obj:TjanPicoObject;
begin
  varname:=PCToken.symbol;
  pf:=FindVariableScope(varname);
  if pf=nil then
    raise exception.Create('Undefined variable '+varname);
  obj:=_po(pf.vars[varname]);
  if obj.Kind=jpoNumber then
    obj.Number:=obj.Number-1
  else
    raise exception.create('Decrement not allowed on '+varname);
end;


procedure TjanPico.picoVarDiv;
var
  varname:string;
  pf:TjanPicoFunction;
  obj:TjanPicoObject;
begin
  varname:=PCToken.symbol;
  pf:=FindVariableScope(varname);
  if pf=nil then
    raise exception.Create('Undefined variable '+varname);
  obj:=_po(pf.vars[varname]);
  if obj.kind=jpoNumber then
    obj.Number:=obj.Number/popNumber
  else
    raise exception.create('Variable division not allowed on '+varname);
end;

procedure TjanPico.picoVarEq;
var
  varname:string;
  pf:TjanPicoFunction;
  obj:TjanPicoObject;
begin
  varname:=PCToken.symbol;
  pf:=FindVariableScope(varname);
  if pf=nil then
    raise exception.Create('Undefined variable '+varname);
  obj:=_po(pf.vars[varname]);
  if obj.kind=jpoNumber then
    lpush(obj.Number=popNumber)
  else
    lpush(obj.Text=popText);
end;

procedure TjanPico.picoVarInc;
var
  varname:string;
  pf:TjanPicoFunction;
  obj:TjanPicoObject;
begin
  varname:=PCToken.symbol;
  pf:=FindVariableScope(varname);
  if pf=nil then
    raise exception.Create('Undefined variable '+varname);
  obj:=_po(pf.vars[varname]);
  if obj.Kind=jpoNumber then
    obj.Number:=obj.Number+1
  else
    raise exception.create('Decrement not allowed on '+varname);
end;

procedure TjanPico.picoVarMul;
var
  varname:string;
  pf:TjanPicoFunction;
  obj:TjanPicoObject;
begin
  varname:=PCToken.symbol;
  pf:=FindVariableScope(varname);
  if pf=nil then
    raise exception.Create('Undefined variable '+varname);
  obj:=_po(pf.vars[varname]);  // BUG ??? added
  if obj.kind=jpoNumber then
    obj.Number:=obj.Number*popNumber
  else
    raise exception.create('Variable multiplication not allowed on '+varname);
end;

procedure TjanPico.picoVarNe;
var
  varname:string;
  pf:TjanPicoFunction;
  obj:TjanPicoObject;
begin
  varname:=PCToken.symbol;
  pf:=FindVariableScope(varname);
  if pf=nil then
    raise exception.Create('Undefined variable '+varname);
  obj:=_po(pf.vars[varname]);
  if obj.kind=jpoNumber then
    lpush(obj.Number<>popNumber)
  else
    lpush(obj.Text<>popText);
end;

procedure TjanPico.picoVarSub;
var
  varname:string;
  pf:TjanPicoFunction;
  obj:TjanPicoObject;
begin
  varname:=PCToken.symbol;
  pf:=FindVariableScope(varname);
  if pf=nil then
    raise exception.Create('Undefined variable '+varname);
  obj:=_po(pf.vars[varname]);  // BUG ??? added
  if obj.kind=jpoNumber then
    obj.Number:=obj.Number-popNumber
  else
    raise exception.create('Variable subtraction not allowed on '+varname);
end;

procedure TjanPico.picoWeekNumber;
var
  aDate:TDateTime;
begin
  aDate:=popNumber;
  pushText(janstrings.getWeekNumber(aDate));
end;

procedure TjanPico.picoWhile;
var
  v:variant;
begin
  v:=lpop;
  while v do begin
    PCToken.ExecuteWord;
    PCToken:=PCToken.parent;
    if PCToken.FSymbol <> 'while' then
      raise exception.create('Stack problem in while loop [use '';'' before closing bracket]');
    v:=lpop;
  end
end;

procedure TjanPico.picoXor;
var
  v1,v2:extended;
begin
  v2:=popNumber;
  v1:=popNumber;
  pushNumber((Round(v1) xor Round(v2)));
end;

procedure TjanPico.picoYear;
var
  aDate:TDateTime;
begin
  aDate:=popNumber;
  pushNumber(janstrings.Date2Year(aDate));
end;

function TjanPico.pop: TjanPicoObject;
var
  c:integer;
begin
  c:=stack.count;
  if c=0 then
    raise exception.create('Stack underflow');
  result:=TjanPicoObject(stack[c-1]);
  stack.delete(c-1);
end;

procedure TjanPico.push(value: TjanPicoObject);
begin
  if stack.count>MAXSTACKSIZE then begin
    ClearStack;
    ClearTokens;
    raise exception.create('Stack overflow ('+inttostr(MAXSTACKSIZE)+').')
  end
  else
    stack.Add(value);
end;



procedure TjanPico.SetonExternal(const Value: TPicoExternal);
begin
  FonExternal := Value;
end;

procedure TjanPico.SetOnTrace(const Value: TPicoExternal);
begin
  FOnTrace := Value;
end;

procedure TjanPico.SetonUses(const Value: TPicoUses);
begin
  FonUses := Value;
end;

procedure TjanPico.SetScript(const Value: string);
var
  p,p2:integer;
  include, includetext, tmp:string;
  handled:boolean;

  procedure RemoveComments;
  var
    cp,cp2:integer;
  begin
    repeat
      cp:=posstr('/*',FScript);
      if cp>0 then begin
        cp2:=posstr('*/',FScript,cp);
        if cp2=0 then
          raise exception.create('Unterminated comment near '+copy(FScript,cp,50));
        delete(FScript,cp,cp2-cp+2);  
      end;
    until cp=0;
  end;
begin
  Includes.Clear;
  FScript :=Value;
  // handle includes
  repeat
    p:=posstr('<<',FScript);
    if p>0 then begin
      p2:=posstr('>>',FScript,p);
      if p2=0 then
        raise exception.create('Missing >> near '+copy(FScript,p,50));
      include:=copy(FScript,p+2,p2-p-2);
      tmp:='<<'+include+'>>';
      if Includes.Exists(include) then begin
        FScript:=q_replacestr(FScript,tmp,'');
      end
      else begin
        Includes[include]:=1;
        includetext:='';
        handled:=false;
        if assigned(onUses) then begin
          onUses(self,include,includetext, handled);
          if not handled then
            raise exception.create('Can not find include: '+tmp);
        end
        else
          raise exception.create('OnUses is not assigned. Can not process '+tmp);
        FScript:=q_replacestr(FScript,tmp,includetext);
      end;
    end;
  until p=0;
  RemoveComments;
  FScript:= trim(Q_replacestr(FScript,cr,' '));
  Parse;
end;

function TjanPico.findMethod(pFunction: TjanPicoFunction;
  pMethodName: string): TjanPicoFunction;
var
  i,c:integer;
  ClassToken:string;
begin
  if not pFunction.Funcs.Exists(pMethodName) then begin
    if pFunction.ClassList.count=0 then
      result:=nil
    else begin
      c:=pFunction.ClassList.count;
      for i:=0 to c-1 do begin
        ClassToken:=pFunction.ClassList[i];
        if Classes.Exists(ClassToken) then begin
          result:=findMethod(TjanPicoFunction(Classes[ClassToken]),pMethodName);
          if result<>nil then exit;
        end;
      end;
      result:=nil;
    end;
  end
  else
    result:=TjanPicoFunction(pFunction.funcs[pMethodName]);  
end;

procedure TjanPico.initializeClass(pFunction: TjanPicoFunction);
var
  ClassToken:string;
  i,c:integer;
begin
  c:=pFunction.ClassList.Count;
  if c>0 then begin
    for i:=0 to c-1 do begin
      ClassToken:=pFunction.ClassList[i];
      if not Classes.Exists(ClassToken) then
        raise exception.create('Undefined class '+ClassToken);
      initializeClass(TjanPicoFunction(Classes[ClassToken]));
    end;
  end;  
  pFunction.ExecuteWord;
end;

procedure TjanPico.picoGetProperty;
var
  funcname,propname:string;
//  ClassString:string;
  pf:TjanPicoFunction;
//  symbol:string;
  calledFunction{, methodFunction, classFunction}:TjanPicoFunction;
  oldFunction:TjanPicoFunction;
  p:integer;
  obj:TjanPicoObject;
  objvar:boolean;
begin
  funcname:=PCToken.symbol;
  p:=pos('.',funcname);
  propname:=copy(funcname,p+1,maxint);
  funcname:=copy(funcname,1,p-1);
  objvar:=false;
  if PCToken.FuncRef=nil then begin
    pf:=FindFunctionScope(funcname);
    if pf=nil then begin
      pf:=FindVariableScope(funcname);
      if pf=nil then
        raise exception.Create('Undefined object variable '+funcname);
      obj:=TjanPicoObject(pf.vars[funcname]);
      if obj.Kind<>jpoReference then
        raise exception.create(funcname+' does not reference a valid object.');
      calledFunction:=obj.Reference;
      objvar:=true;
    end
    else
      calledFunction:=TjanPicoFunction(pf.Funcs[funcname]);
    if calledFunction.FunctionKind<>jpfkObject then
      raise exception.create(funcname+' is not an object.');
    if not objvar then
      PCToken.FuncRef:=calledFunction;
  end
  else
    calledFunction:= PCToken.FuncRef;
  oldFunction:=CurrentFunction;
  CurrentFunction:=calledFunction;
  if not calledFunction.Initialized then begin
    InitializeClass(calledFunction);
    calledFunction.ExecuteWord;
    calledFunction.Initialized:=true;
  end;
  if calledFunction.Funcs.Exists('get_'+propname) then begin
    TjanPicoFunction(calledFunction.Funcs['get_'+propname]).ExecuteWord;
  end
  else begin
    if not calledFunction.Vars.Exists(propname) then
      raise exception.create('Undefined property '+propname+' in object '+funcname);
    obj:=_po(calledFunction.Vars[propname]);
    if obj.Kind=jpoNumber then
      pushNumber(obj.Number)
    else
      pushText(obj.Text);
  end;
  CurrentFunction:=oldFunction;
end;

procedure TjanPico.picoSetProperty;
var
  funcname,propname:string;
//  ClassString:string;
  pf:TjanPicoFunction;
//  symbol:string;
  calledFunction{, methodFunction, classFunction}:TjanPicoFunction;
  oldFunction:TjanPicoFunction;
  p:integer;
  objvar:boolean;
  obj:TjanPicoObject;
begin
  funcname:=PCToken.symbol;
  p:=pos('.',funcname);
  propname:=copy(funcname,p+1,maxint);
  funcname:=copy(funcname,1,p-1);
  objvar:=false;
  oldFunction:=CurrentFunction;
  if PCToken.FuncRef=nil then begin
    pf:=FindFunctionScope(funcname);
    if pf=nil then begin
      pf:=FindVariableScope(funcname);
      if pf=nil then
        raise exception.Create('Undefined object variable '+funcname);
      obj:=TjanPicoObject(pf.vars[funcname]);
      if obj.Kind<>jpoReference then
        raise exception.create(funcname+' does not reference a valid object.');
      calledFunction:=obj.Reference;
      objvar:=true;
    end
    else
      calledFunction:=TjanPicoFunction(pf.Funcs[funcname]);
    if calledFunction.FunctionKind<>jpfkObject then
      raise exception.create(funcname+' is not an object.');
    oldFunction:=CurrentFunction;
    CurrentFunction:=calledFunction;
    if not calledFunction.Initialized then begin
      InitializeClass(calledFunction);
      calledFunction.ExecuteWord;
      calledFunction.Initialized:=true;
    end;
    if not objvar then
      PCToken.FuncRef:=calledFunction;
  end
  else
    calledFunction:=PCToken.FuncRef;
  if calledFunction.Funcs.Exists('set_'+propname) then begin
    TjanPicoFunction(calledFunction.Funcs['set_'+propname]).ExecuteWord;
  end
  else begin
    if not calledFunction.Vars.Exists(propname) then
      raise exception.create('Undefined property '+propname+' in object '+funcname);
    calledFunction.Vars[propname]:=pop;
  end;
  CurrentFunction:=oldFunction;
end;

procedure TjanPico.picoIsInteger;
var
  s:string;
  i:integer;
begin
  s:=popText;
  try
    i:=strtoint(s);
    lpush(true);
  except
    lpush(false);
  end;
end;

procedure TjanPico.picoIsFloat;
var
  s:string;
  e:extended;
begin
  s:=popText;
  try
    e:=strtofloat(s);
    lpush(true);
  except
    lpush(false);
  end;
end;

procedure TjanPico.picoIsDate;
var
  s:string;
  d:TdateTime;
begin
  s:=popText;
  d:=ISOStringToDate(s);
  if d<>0 then
    lpush(true)
  else
    lpush(false);
end;

procedure TjanPico.PicoAsDate;
var
  s:string;
  d:TDateTime;
begin
  s:=popText;
  d:=ISOStringToDate(s);
  if d=0 then
    raise exception.create(s+' is not a valid ISO date.');
  pushNumber(d);
end;

procedure TjanPico.PicoAsNumber;
var
  s:string;
  e:extended;
begin
  s:=popText;
  if janstrings.isfloat(s,e) then
    pushNumber(e)
  else
    raise exception.create(s+' is not a valid floating point value.');
end;

procedure TjanPico.PicoAsInteger;
var
  s:string;
  Value: Integer;
  Error: Integer;
begin
  s:=popText;
  Val(s, Value, Error);
  if Error <> 0 then
    raise exception.create(s+' is not a valid integer value.')
  else
    pushNumber(Value);
end;

procedure TjanPico.picoGetSystemVar;
var
  obj:TjanPicoObject;
begin
  if FSystemVars.Exists(PCToken.symbol) then begin
    obj:=_po(FSystemVars[PCToken.symbol]);
    if obj.Kind=jpoNumber then
      pushNumber(obj.number)
    else
      pushText(obj.text);
  end
  else
    raise exception.create('Undefine system variable '+PCToken.symbol);
end;

procedure TjanPico.picoGetSystemVarAddress;
var
  obj:TjanPicoObject;
begin
  if FSystemVars.Exists(PCToken.symbol) then begin
    obj:=_po(FSystemVars[PCToken.symbol]);
    if obj.Kind=jpoNumber then
      pushNumber(Integer(@obj.FNumber))
    else
      pushNumber(Integer(@obj.Ftext[1]));
  end
  else
    raise exception.create('Undefine system variable '+PCToken.symbol);
end;

procedure TjanPico.picoSetSystemVar;
begin
  FSystemVars[PCToken.symbol]:=pop;
end;

procedure TjanPico.initializeSystemVars;
begin
  _SetVartext(Fsystemvars,'path',extractfilepath(ParamStr(0){application.exename}));
  _SetVarNumber(Fsystemvars,'version',PICOVERSION);  
end;

procedure TjanPico.PicoAsHex;
var
  i:integer;
begin
  try
    i:=popInteger;
    pushText(format('%x',[i]));
  except
    on E:exception do showmessage(E.message);
  end;
end;

procedure TjanPico.picoMod;
var
  v1,v2:integer;
begin
  v2:=popInteger;
  v1:=popInteger;
  pushNumber(v1 mod v2);
end;

procedure TjanPico.picoWeekDay;
var
  aDate:TDateTime;
begin
  aDate:=popNumber;
  pushNumber(janstrings.ISODayOfWeek(aDate));
end;

procedure TjanPico.picoEaster;
begin
  pushNumber(janstrings.Easter(popInteger));
end;

procedure TjanPico.picoDelay;
var
  Delay: Dword;
  StartTiming: TLargeInteger;
  Timing: TLargeInteger;
  DiffTiming: TLargeInteger;
  DeltaTiming: TLargeInteger;
  TimeCaps: TTimeCaps;
  TimeMs: Integer;
begin
  // Depending on the required delay we do the following:
  // < 1 ms   - High performance wait with sleep(0)
  // 1....    - Sleep with in/decreased resolution, any 'us' remainder
  //            is handled with the high resolution counter
  Delay := Dword(Round(popNumber));
  if Delay <= 0 then
    Exit;
  if Delay >= 1000 then
  begin
    // We have a delay >= 1 ms. Since delays < 10 ms are typically NOT
    // possible using a standard Sleep(x)!! we have to adjust the
    // resolution accordingly. No matter what we increase the resolution
    // to the highest possible.
    if timeGetDevCaps(@TimeCaps, SizeOf(TimeCaps)) = TIMERR_NOERROR then
    begin
      TimeMs := Delay div 1000;
      timeBeginPeriod(1);
      Sleep(TimeMs);
      timeEndPeriod(1);
      Delay := Delay - (TimeMs * 1000);
    end;
  end;
  // Handle 'us' remainder (note that this increases the system load to 100%
  // although other processes do get time to run)
  if Delay < 1000 then
  begin
    QueryPerformanceCounter(StartTiming);
    DeltaTiming := Delay * FHighPerformanceFrequency;
    DeltaTiming := DeltaTiming div 1000000;
    repeat
      Sleep(0);
      QueryPerformanceCounter(Timing);
      if Timing > StartTiming then
        DiffTiming := Timing - StartTiming
      else
        DiffTiming := StartTiming - Timing;
    until DiffTiming >= DeltaTiming;
  end
end;


procedure TjanPico.picoGetRecordVar;
var
  source,varname, fieldname, value:string;
  pf:TjanPicoFunction;
  p:integer;
  obj:TjanPicoObject;
begin
  varname:=PCToken.symbol;
  p:=pos('.',varname);
  fieldname:=copy(varname,p+1,maxint);
  varname:=copy(varname,1,p-1);
  pf:=FindVariableScope(varname);
  if pf=nil then
    raise exception.Create('Undefined variable '+varname);
  obj:=_po(pf.vars[varname]);
  if obj.kind<>jpoText then
    raise exception.create(varname+' is not a text variable.');
  source:=obj.Text;
  value:=janstrings.GetStyleValue(source,fieldname);
  pushText(value);
end;

procedure TjanPico.picoSetRecordVar;
var
  source,varname, fieldname, value:string;
  pf:TjanPicoFunction;
  p:integer;
  obj:TjanPicoObject;
begin
  if peek.kind=jpoNumber then
    value:=floattostr(popNumber)
  else
    value:=popText;
  varname:=PCToken.symbol;
  p:=pos('.',varname);
  fieldname:=copy(varname,p+1,maxint);
  varname:=copy(varname,1,p-1);
  pf:=FindVariableScope(varname);
  if pf=nil then
    raise exception.Create('Undefined variable '+varname);
  obj:=_po(pf.vars[varname]);
  if obj.kind<>jpoText then
    raise exception.create(varname+' is not a text variable.');
  source:=obj.Text;
  source:=janstrings.SetStyleValue(source,fieldname,value);
  obj.Text:=source
end;

procedure TjanPico.picoCount;
begin
  genlist.text:=popText;
  pushNumber(genlist.count);
end;

procedure TjanPico.picoFirst;
begin
  genlist.text:=popText;
  if genlist.count=0 then
    pushText('')
  else
    pushText(genlist[0]);
end;

procedure TjanPico.picoLast;
begin
  genlist.text:=popText;
  if genlist.count=0 then
    pushText('')
  else
    pushText(genlist[genlist.count-1]);
end;

procedure TjanPico.picoPick;
var
  index:integer;
begin
  index:=popInteger;
  genlist.text:=popText;
  if index>=genlist.count then
    raise exception.create('List index out of bounds '+inttostr(index)+' in '+genlist.text);
  pushText(genlist[index]);
end;

procedure TjanPico.picoAppend;
var
  value:string;
begin
  value:=popText;
  genlist.text:=popText;
  genlist.Append(value);
  pushText(genlist.text);
end;

procedure TjanPico.picoDelete;
var
  index:integer;
begin
  index:=popInteger;
  genlist.text:=popText;
  if index>=genlist.count then
    raise exception.create('List index out of bounds '+inttostr(index)+' in '+genlist.text);
  genlist.Delete(index);
  pushText(genlist.text);
end;

procedure TjanPico.picoIndex;
var
  s:string;
begin
  s:=popText;
  genlist.text:=popText;
  pushNumber(genlist.indexof(s));
end;

procedure TjanPico.picoValue;
var
  s:string;
begin
  s:=popText;
  genlist.text:=popText;
  pushText(genlist.Values[s]);
end;

procedure TjanPico.picoName;
var
  index:integer;
begin
  index:=popInteger;
  genlist.text:=popText;
  if index>=genlist.count then
    raise exception.create('List index out of bounds '+inttostr(index)+' in '+genlist.text);
  pushText(genlist.Names[index]);
end;

function TjanPico.popNumber: extended;
var
  obj:TjanPicoObject;
begin
  obj:=pop;
  try
    if obj.Kind<>jpoNumber then
      raise exception.create('Number expected with '+PCToken.symbol);
    result:=obj.Number;
  finally
    obj.free;
  end;  
end;

procedure TjanPico.pushNumber(value: extended);
var
  obj:TjanPicoObject;
begin
  obj:=TjanPicoObject.create;
  obj.Number:=value;
  obj.Kind:=jpoNumber;
  push(obj);
end;

function TjanPico.popText: string;
var
  obj:TjanPicoObject;
begin
  obj:=pop;
  try
    if obj.kind<>jpoText then
      raise exception.create('Text expected with '+PCToken.symbol);
    result:=obj.Text;
  finally
    obj.free;
  end;  
end;

procedure TjanPico.pushText(value: string);
var
  obj:TjanPicoObject;
begin
  obj:=TjanPicoObject.create;
  obj.Text:=value;
  obj.Kind:=jpoText;
  push(obj);
end;

function TjanPico.popInteger: integer;
var
  obj:TjanPicoObject;
begin
  obj:=pop;
  try
    if obj.Kind<>jpoNumber then
      raise exception.create('Number expected with '+PCToken.symbol);
    result:=round(obj.Number);
  finally
    obj.free;
  end;  
end;

procedure TjanPico._SetVarNumber(aVar:TObjectHash;aName:string;aValue:extended);
var
 obj:TjanPicoObject;
begin
  if avar.Exists(aName) then begin
    obj:=TjanPicoObject(avar[aName]);
    obj.Kind:=jpoNumber;
    obj.Number:=aValue;
  end
  else begin
    obj:=TjanPicoObject.create;
    obj.Kind:=jpoNumber;
    obj.Number:=aValue;
    avar[aname]:=obj;
  end;
end;

procedure TjanPico._SetVarText(aVar:TObjectHash;aName:string;aValue:string);
var
 obj:TjanPicoObject;
begin
  if avar.Exists(aName) then begin
    obj:=TjanPicoObject(avar[aName]);
    obj.Kind:=jpoText;
    obj.Text:=aValue;
  end
  else begin
    obj:=TjanPicoObject.create;
    obj.Kind:=jpoText;
    obj.Text:=aValue;
    avar[aname]:=obj;
  end;
end;

function TjanPico._po(aObject: TObject): TjanPicoObject;
begin
  result:=TjanPicoObject(aObject);
end;

procedure TjanPico.picoConCat;
var
  s1,s2:string;
begin
  s2:=popText;
  s1:=popText;
  pushText(s1+s2);
end;

procedure TjanPico.picoType;
var
  obj:TjanPicoObject;
begin
  obj:=pop;
  if obj.Kind=jpoNumber then
    pushtext('number')
  else if obj.Kind=jpoText then
    pushtext('text')
  else if obj.Kind=jpoReference then
    pushText('reference')
  else
    pushText('');      
end;

procedure TjanPico.pushObject(value: TjanPicoFunction);
var
  obj:TjanPicoObject;
begin
  obj:=TjanPicoObject.create;
  obj.Reference:=value;
  obj.Kind:=jpoReference;
  push(obj);
end;

function TjanPico.popObject: TjanPicoFunction;
var
  obj:TjanPicoObject;
begin
  obj:=pop;
  try
    if obj.kind<>jpoReference then
      raise exception.create('Object expected with '+PCToken.symbol);
    result:=TjanPicoFunction(obj.reference);
  finally
    obj.free;
  end;  
end;

procedure TjanPico.picoClassNames;
var
  obj:TjanPicoFunction;
begin
  obj:=popObject;
  pushText(obj.ClassList.text);
end;


procedure TjanPico.picoSplit;
var
  ASource,Asplit:string;
begin
  ASplit:=popText;
  ASource:=popText;
  janstrings.Split(ASource,ASplit,genlist);
  pushText(genlist.Text);
end;

procedure TjanPico.picoJoin;
var
  ASource,AJoin:string;
begin
  AJoin:=popText;
  genlist.text:=popText;
  ASource:=janstrings.Join(AJoin,genlist);
  pushText(ASource);
end;

procedure TjanPico.picoRegTest;
var
  expr:string;
  ASource:string;
begin
  expr:=popText;
  ASource:=popText;
  re.Expression:=expr;
  lpush(re.Exec(ASource));
end;

procedure TjanPico.picoRegReplace;
var
  Expression,AInputStr,AReplaceStr:string;
begin
  Expression:=popText;
  AReplaceStr:=popText;
  AInputStr:=popText;
  re.Expression:=Expression;
  pushText(re.Replace(AInputStr,AReplaceStr));
end;

procedure TjanPico.executeFunction(FuncName: string);
begin
  if not funcs.Exists(FuncName) then
    raise exception.create('Undefined function '+funcname+'.');
  TjanPicoFunction(funcs[FuncName]).executeWord;
end;

{ TjanPicoWord }

procedure TjanPicoWord.ClearTokens;
var
  i,c:integer;
begin
  c:=tokens.count;
  if c=0 then exit;
  for i:=0 to c-1 do
    TjanPicoWord(tokens[i]).free;
  tokens.clear;
end;

constructor TjanPicoWord.Create;
begin
  tokens:=TList.create;
end;

destructor TjanPicoWord.Destroy;
begin
  ClearTokens;
  tokens.free;
  inherited;
end;

procedure TjanPicoWord.ExecuteWord;
begin
  PC:=0;
  SC:=tokens.count;
  if SC=0 then exit;
  while PC<SC do begin
    root.PCToken:=TjanPicoWord(tokens[pc]);
    root.PCToken.Actor;
    inc(PC);
  end;
end;

function TjanPicoWord.nextSibling: TjanPicoWord;
var
  index:integer;
begin
  result:=nil;
  if parent=nil then exit;
  index:=parent.tokens.indexOf(self);
  if index<(parent.tokens.count-1) then
    result:=TjanPicoWord(parent.tokens[index+1]);
end;

procedure TjanPicoWord.SetActor(const Value: TPicoActor);
begin
  FActor := Value;
end;



procedure TjanPicoWord.SetFuncRef(const Value: TjanPicoFunction);
begin
  FFuncRef := Value;
end;

procedure TjanPicoWord.SetKind(const Value: TPicoKind);
begin
  FKind := Value;
end;

procedure TjanPicoWord.SetParent(const Value: TjanPicoWord);
begin
  FParent := Value;
end;

procedure TjanPicoWord.SetRoot(const Value: TjanPico);
begin
  FRoot := Value;
end;

procedure TjanPicoWord.SetSymbol(const Value: string);
begin
  FSymbol := Value;
end;

procedure TjanPicoWord.SetValue(const Value: extended);
begin
  FValue := Value;
end;

{ TPicoVariant }

procedure TPicoVariant.SetValue(const Value: variant);
begin
  FValue := Value;
end;


{ TjanPicoFunction }

constructor TjanPicoFunction.Create;
begin
  inherited;
  Funcs:=TObjectHash.Create;
  Funcs.OwnsItems:=false;
  Vars:=TObjectHash.create;
  Vars.OwnsItems:=true;
  ClassList:=TStringList.create;
  ClassString:='';
  Initialized:=false;
end;

destructor TjanPicoFunction.Destroy;
begin
  funcs.free;
  vars.free;
  ClassList.Free;
  inherited;
end;

procedure TjanPicoFunction.ExecuteWord;
begin
  case FunctionKind of
    jpfkFunction: Vars.clear;
  end;
  
  inherited;
end;


procedure TjanPicoFunction.SetClassString(const Value: string);
begin
  FClassString := Value;
  janstrings.Split(value,',',ClassList);
end;

procedure TjanPicoFunction.SetFunctionKind(const Value: TPicoFunctionKind);
begin
  FFunctionKind := Value;
end;

procedure TjanPicoFunction.SetInitialized(const Value: boolean);
begin
  FInitialized := Value;
end;

procedure TjanPicoFunction.SetParentFunction(
  const Value: TjanPicoFunction);
begin
  FParentFunction := Value;
end;


{ TjanPicoObject }

function TjanPicoObject.Clone: TjanPicoObject;
begin
  result:=TjanPicoObject.create;
  result.Text:=text;
  result.Number:=number;
  result.Reference:=reference;
  result.Kind:=kind;
end;

procedure TjanPicoObject.SetKind(const Value: TjpoKind);
begin
  FKind := Value;
end;

procedure TjanPicoObject.SetNumber(const Value: extended);
begin
  FNumber := Value;
end;

procedure TjanPicoObject.SetReference(const Value: TjanPicoFunction);
begin
  FReference := Value;
end;

procedure TjanPicoObject.SetText(const Value: string);
begin
  FText := Value;
end;

end.
