   1. 
   -----------

    pascalc.dcu    Pascal - 
     Delphi.       :

 -       Variant,   
      .

 -     ,     
       .     
    ,      .   
        ,   .
            0..255 
     (  1).

 -      :
    : +, -, *, /, ^ (  ), SHL, SHR
      : BITOR,BITAND,BITXOR,BITNOT
    : >, <, >=, <=, =, <>, AND, OR, NOT,  TRUE  FALSE.
    T   .    .

 -     :
    BEGIN ... END
    IF ... THEN ... ELSE
    CASE
    FOR ... TO/DOWNTO ... DO
    WHILE ... DO
    REPEAT ... UNTIL
    CONTINUE
    BREAK
    GOTO
    EXIT
    USES
    INCLUDE

 -       interface   .
            ,  
    .      .
            . 
           .

 -    ,     .
              
    .     ,   
             .
    (    MyArr    MyArr[1]).
           ,  
          .   
    ,          .
          . 
        .   
           (  )
     -  .  ,       
     .   MyArr[1][2]    2- 
    1-   MyArr.  MyArr[1]     
       MyArr,    .   
               ,
      .

 -      user-defined. M pasfunc.pas 
           Delphi.  
       demo-.     ,
            
    .     ,   
         (  write ). 
              
    .        
      .      
     ,    VAR-,  
            
    .         
      .   pasfunc.pas    
     (- Max, Min).     ,  
     .

 -        .   
            .
           ,    
         .    
      "result".       
       ,     
     VAR-       
     .        
         ,   , 
           
    .       ,   ,
              
    .   ,      
    ,     / .  , 
             ,
            .

           USES  INCLUDE.
      :  USES ' ';
                    INCLUDE ' ';

     USES  INCLUDE  ,   
    .  INCLUDE      .  USES
         ,    
       .


   2. .
   ------------

    PASCALC    " ". 
        ,   . 
         .     
   , ,       , 
     (  )   .

   http://alexboiko.da.ru
   http://alexboiko.chat.ru


   3.   :
   -----------------------------------

unit pascalc;

{$F+,B-,R-}

interface

uses
  Windows, Messages, SysUtils, Classes, Math;

type TToken =
  (tEMPTY,    tVR,       tCON,      tTRUE,     tFALSE,
   tEQU,      tOR,       tAND,      tNOT,      tXOR,
   tCOMMA,    tLBL,      tNEQ,      tGT,       tLS,
   tGTE,      tLSE,      tADD,      tSUB,      tMUL,
   tDIV,      tPWR,      tLBR,      tRBR,      tLARR,
   tRARR,     tSEMI,     tREM,      tREMB,     tREME,
   tASSIGN,   tBEGIN,    tEND,      tIF,       tTHEN,
   tELSE,     tFOR,      tTO,       tDOWNTO,   tDO,
   tWHILE,    tREPEAT,   tUNTIL,    tBREAK,    tCONTINUE,
   tEXIT,     tGOTO,     tSHL,      tSHR,      tPROC,
   tFUNCT,    tUSES,     tINCLUDE,  tCASE,     tOF,
   tCOMMA2);

type TTokenSet = set of TToken;

const
  ResWords : array[TToken] of string[10] =
   ('',         '',         '',         'TRUE',     'FALSE',
    '=',        'OR',       'AND',      'NOT',      'XOR',
    ',',        ':',        '<>',       '>',        '<',
    '>=',       '<=',       '+',        '-',        '*',
    '/',        '^',        '(',        ')',        '[',
    ']',        ';',        '//',       '{',        '}',
    ':=',       'BEGIN',    'END',      'IF',       'THEN',
    'ELSE',     'FOR',      'TO',       'DOWNTO',   'DO',
    'WHILE',    'REPEAT',   'UNTIL',    'BREAK',    'CONTINUE',
    'EXIT',     'GOTO',     'SHL',      'SHR',      'PROCEDURE',
    'FUNCTION', 'USES',     'INCLUDE',  'CASE',     'OF',
    '..');

const
  Alpha          : set of char = ['_','0'..'9','a'..'z','A'..'Z',''..'','',''..'',''];
  StrDelimiter   : char = '''';
  DecimalPoint   : char = '.';
  TokenDelimiter : char = #127;


type TVar = record
  Name  : string;
  Value : variant;
end;

type TPVar = ^TVar;

type TVarList = class (TList)
  destructor Destroy; override;
  procedure  ClearAll;
  function   AddVar(V:TVar) : boolean;
  function   AddValue(N:string; V:variant) : boolean;
  function   VarExist(N:string):boolean;
  function   VarIndex(N:string):integer;
  function   VarByName(N:string;var V:TVar) : boolean;
  function   SetVar(V:TVar) : boolean;
  function   SetValue(N:string; V:variant) : boolean;
  procedure  CopyTo(VL:TVarList);
end;

type TPVarList = ^TVarList;

type PProcessProc = procedure;

type PFunction = function(Sender:TObject; var A:TVarList; var R:TVar) : boolean;

type TFunc = record
  Name : string;
  Func : Pointer;
end;

type TPFunc = ^TFunc;

type TFuncList = class (TList)
  destructor Destroy; override;
  procedure  ClearAll;
  function   AddFunction(N:string; F:Pointer) : boolean;
end;

type TProcedure = record
  Name   : string;
  Body   : string;
  Params : string;
  Result : boolean;
end;

type TPProcedure = ^TProcedure;

type TProcList = class(TList)
  destructor Destroy; override;
  procedure  ClearAll;
  function   AddProc(Proc:TProcedure):boolean;
  function   ProcIndex(Name:string):integer;
  function   ProcByName(Name:string; var Proc:TProcedure):boolean;
end;


type TPasCalc = class
  constructor Create;
  destructor  Destroy; override;
  procedure   ClearVars;
  function    VarCount : integer;
  function    VarIndex(N:string) : integer;
  function    VarByName(N:string; var V:TVar) : boolean;
  function    VarByIndex(I:integer; var V:TVar) : boolean;
  function    SetVar(V:TVar) : boolean;
  function    SetValue(N:string; V:variant):boolean;
  procedure   ClearFuncs;
  function    SetFunction(N:string; F:Pointer) : boolean;
  procedure   SetProcessProc(P:Pointer);
  function    Parse(S:string) : string;
  function    Calculate(S:string; var R:TVar) : boolean;
  function    Execute(S:string):boolean;
  private
    Expr        : string;
    ExprIndex   : integer;
    Token       : string;
    TokenCode   : TToken;

    BlockLevel  : integer;
    BlockCmd    : TToken;
    GotoLabel   : string;

    VarList     : TVarList;
    FuncList    : TFuncList;
    ProcList    : TProcList;

    ProcessProc : PProcessProc;

    LastString  : string;
    LastParsed  : string;

    procedure Clear;
    procedure Process;
    procedure Error(Msg,Line:string; Code:integer);
    procedure Level1(var R:TVar);
    procedure Level2(var R:TVar);
    procedure Level3(var R:TVar);
    procedure Level4(var R:TVar);
    procedure Level5(var R:TVar);
    procedure Level6(var R:TVar);
    procedure Level7(var R:TVar);
    procedure Level8(var R:TVar);
    procedure Arith(o : TToken; var R,H:TVar);
    procedure Unary(o : TToken; var R:TVar);
    function  GetIndex(S:string; var Index:integer; var T:TToken) : string;
    function  GetFuncParams(S:string; var Index:integer) : string;
    function  FindFunc(N:string) : integer;
    function  FindArray(N:string) : boolean;
    procedure SetVarDirect(var R:TVar);
    function  CallFunc(N:string; A:string; var V:TVar) : boolean;
    function  CallProc(N:string; A:string; var V:TVar) : boolean;
    function  GetTextToken(S: string; var Index : integer; var Code : TToken) : string;
    function  TokenStr(T:TToken;S:string) : string;
    function  GetToken(S:string; var Index : integer; var Code : TToken) : string;
    function  GetTokenCode(S: string; var Index:integer; var Code:TToken) : integer;
    function  GetTokenLine(S:string; var Index:integer; var Code:TToken;
                           StopToken:TTokenSet) : string;
    function  NextToken(S:string; Index:integer) : TToken;
    function  GetOperator(Txt:string; var Index : integer; EndToken:TTokenSet) : string;
    function  ParseOperator(Txt:string; var Cmd,Line,Lbl : string) : TToken;
    function  DelRemarks(S:string) : string;
    function  UnParse(S:string; Show:boolean) : string;
    function  PreProcess(Txt:string):string;
    function  Calc(S:string; var R:TVar) : boolean;
    procedure Exec(Txt:string);
    procedure DoSet(CmdLine,Cmd,Line:string);
    procedure DoIf(CmdLine,Line:string);
    procedure DoBegin(CmdLine,Line:string);
    procedure DoFor(CmdLine,Line:string);
    procedure DoBreak(CmdLine,Line:string);
    procedure DoContinue(CmdLine,Line:string);
    procedure DoExit(CmdLine,Line:string);
    procedure DoWhile(CmdLine,Line:string);
    procedure DoRepeat(CmdLine,Line:string);
    procedure DoGoto(CmdLine,Line:string);
    procedure DoCase(CmdLine,Line:string);
  public
    Stop     : boolean;
    ErrCode  : integer;
    ErrMsg   : string;
    ErrLine  : string;
  end;


   4.  (unit PASFUNC.PAS)
   ------------------------------

   //     

   Val
   IntToStr
   StrToInt
   FloatToStr
   StrToFloat
   Copy
   Pos
   Length
   Insert
   Delete
   Trim
   TrimLeft
   TrimRight
   UpperCase
   LowerCase
   Format

   //       

   Now
   Date
   Time
   DateToStr
   StrToDate
   TimeToStr
   StrToTime
   FormatDateTime
   DayOfWeek
   IncMonth
   DecodeDate
   DecodeTime
   EncodeDate
   EncodeTime

   //  

   Abs
   Int
   Frac
   Round
   Ceil
   Floor
   Trunc
   Sin
   Cos
   Tan
   ArcSin
   ArcCos
   ArcTan
   Exp
   Ln
   IntPower
   Sqr
   Sqrt
   Min
   Max
   Inc
   Dec

   //  PASCALC    .
   //       .

   SetVar
   GetVar


   5.  
   -------------------------------

       demo-.    
          pasfunc.pas, 
   c     ,    .
         Value  R:TVar   true.
      (     ) 
     false.

       TPasCalc.    SetProcessProc
            
    .       .
       ,       
    (Application.ProcessMessages ).    ,  
       Process,     .

     TPasCalc.SetFunction     
        .   pasfunc.pas  
     SetFunctions.     
    SetVarNum  SetVarStr.

    Calculate      
      R:TVar,   Execute    
     .    VarCount, VarByIndex 
   VarByName     .     
     ErrCode.  ErrMsg  ErrLine    
      .

      Calculate  Execute     
        .     
       ClearVars.     
    ClearFuncs.     
   ,    true  TPasCalc.Stop.

          
      Parse,    .
            Calculate  Execute.


   6.   (ErrCode)
   ------------------------

   0  -  O.K.
   1  -    
   2  -   
   3  -    
   4  -      
   5  -    
   6  -  a  
   7  -    
   8  -    
   9  -   
   10 -   END
   11 -   END
   12 -   TO  DOWNTO
   13 -    
   14 -   DO
   15 -  BREAK  
   16 -   UNTIL
   17 -   UNTIL
   18 -    
   19 -     
   20 -     
   21 -   ']'
   22 -   '['
   23 -    0
   24 -    /
   25 -    
   26 -     
   27 -   OF   CASE
   28 -   ELSE   CASE
   29 -       CASE


   7. :
   ---------

    
   alexboiko@mtu-net.ru
   http://alexboiko.da.ru
