← Back to branch summary

~ubuntu-branches/ubuntu/dapper/fpc/dapper

« back to all changes in this revision

Viewing changes to fcl/db/dbase/dbf_prsdef.pas

  • Committer: Bazaar Package Importer
  • Author(s): Carlos Laviola
  • Date: 2005-05-30 11:59:10 UTC
  • mfrom: (1.2.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20050530115910-x5pbzm4qqta4i94h
Tags: 2.0.0-2
http://bugs.debian.org/310907
debian/fp-compiler.postinst.in: forgot to reapply the patch that
correctly creates the slave link to pc(1).  (Closes: #310907)

Show diffs side-by-side

added added

removed removed

Lines of Context:
fcl/db/dbase/dbf_prsdef.pas
 
1
unit dbf_prsdef;
 
2
 
 
3
interface
 
4
 
 
5
{$I Dbf_Common.inc}
 
6
 
 
7
uses
 
8
  SysUtils,
 
9
  Classes,
 
10
  Dbf_Common,
 
11
  Dbf_PrsSupp;
 
12
 
 
13
const
 
14
  MaxArg = 6;
 
15
  ArgAllocSize = 32;
 
16
 
 
17
type
 
18
  TExpressionType = (etInteger, etString, etBoolean, etLargeInt, etFloat, etDateTime,
 
19
    etLeftBracket, etRightBracket, etComma, etUnknown);
 
20
 
 
21
  PPChar = ^PChar;
 
22
  PBoolean = ^Boolean;
 
23
  PInteger = ^Integer;
 
24
  PDateTime = ^TDateTime;
 
25
  EParserException = class(Exception);
 
26
  PExpressionRec = ^TExpressionRec;
 
27
  PDynamicType = ^TDynamicType;
 
28
 
 
29
  TExprWord = class;
 
30
 
 
31
  TExprFunc = procedure(Expr: PExpressionRec);
 
32
 
 
33
//-----
 
34
 
 
35
  TDynamicType = class(TObject)
 
36
  private
 
37
    FMemory: PPChar;
 
38
    FMemoryPos: PPChar;
 
39
    FSize: PInteger;
 
40
  public
 
41
    constructor Create(DestMem, DestPos: PPChar; Size: PInteger);
 
42
 
 
43
    procedure AssureSpace(ASize: Integer);
 
44
    procedure Resize(NewSize: Integer; Exact: Boolean);
 
45
    procedure Rewind;
 
46
    procedure Append(Source: PChar; Length: Integer);
 
47
    procedure AppendInteger(Source: Integer);
 
48
 
 
49
    property Memory: PPChar read FMemory;
 
50
    property MemoryPos: PPChar read FMemoryPos;
 
51
    property Size: PInteger read FSize;
 
52
  end;
 
53
 
 
54
  TExpressionRec = record
 
55
    //used both as linked tree and linked list for maximum evaluation efficiency
 
56
    Oper: TExprFunc;
 
57
    Next: PExpressionRec;
 
58
    Res: TDynamicType;
 
59
    ExprWord: TExprWord;
 
60
    AuxData: pointer;
 
61
    ResetDest: Boolean;
 
62
    Args: array[0..MaxArg-1] of PChar;
 
63
    ArgsPos: array[0..MaxArg-1] of PChar;
 
64
    ArgsSize: array[0..MaxArg-1] of Integer;
 
65
    ArgsType: array[0..MaxArg-1] of TExpressionType;
 
66
    ArgList: array[0..MaxArg-1] of PExpressionRec;
 
67
  end;
 
68
 
 
69
  TExprCollection = class(TNoOwnerCollection)
 
70
  public
 
71
    procedure Check;
 
72
    procedure EraseExtraBrackets;
 
73
  end;
 
74
 
 
75
  TExprWordRec = record
 
76
    Name: PChar;
 
77
    ShortName: PChar;
 
78
    IsOperator: Boolean;
 
79
    IsVariable: Boolean;
 
80
    IsFunction: Boolean;
 
81
    NeedsCopy: Boolean;
 
82
    FixedLen: Boolean;
 
83
    CanVary: Boolean;
 
84
    ResultType: TExpressionType;
 
85
    MinArg: Integer;
 
86
    MaxArg: Integer;
 
87
    TypeSpec: PChar;
 
88
    Description: PChar;
 
89
    ExprFunc: TExprFunc;
 
90
  end;
 
91
 
 
92
  TExprWord = class(TObject)
 
93
  private
 
94
    FName: string;
 
95
    FExprFunc: TExprFunc;
 
96
  protected
 
97
    FRefCount: Cardinal;
 
98
 
 
99
    function GetIsOperator: Boolean; virtual;
 
100
    function GetIsVariable: Boolean;
 
101
    function GetNeedsCopy: Boolean;
 
102
    function GetFixedLen: Integer; virtual;
 
103
    function GetCanVary: Boolean; virtual;
 
104
    function GetResultType: TExpressionType; virtual;
 
105
    function GetMinFunctionArg: Integer; virtual;
 
106
    function GetMaxFunctionArg: Integer; virtual;
 
107
    function GetDescription: string; virtual;
 
108
    function GetTypeSpec: string; virtual;
 
109
    function GetShortName: string; virtual;
 
110
  public
 
111
    constructor Create(AName: string; AExprFunc: TExprFunc);
 
112
 
 
113
    function LenAsPointer: PInteger; virtual;
 
114
    function AsPointer: PChar; virtual;
 
115
    function IsFunction: Boolean; virtual;
 
116
 
 
117
    property ExprFunc: TExprFunc read FExprFunc;
 
118
    property IsOperator: Boolean read GetIsOperator;
 
119
    property CanVary: Boolean read GetCanVary;
 
120
    property IsVariable: Boolean read GetIsVariable;
 
121
    property NeedsCopy: Boolean read GetNeedsCopy;
 
122
    property FixedLen: Integer read GetFixedLen;
 
123
    property ResultType: TExpressionType read GetResultType;
 
124
    property MinFunctionArg: Integer read GetMinFunctionArg;
 
125
    property MaxFunctionArg: Integer read GetMaxFunctionArg;
 
126
    property Name: string read FName;
 
127
    property ShortName: string read GetShortName;
 
128
    property Description: string read GetDescription;
 
129
    property TypeSpec: string read GetTypeSpec;
 
130
  end;
 
131
 
 
132
  TExpressShortList = class(TSortedCollection)
 
133
  public
 
134
    function KeyOf(Item: Pointer): Pointer; override;
 
135
    function Compare(Key1, Key2: Pointer): Integer; override;
 
136
    procedure FreeItem(Item: Pointer); override;
 
137
  end;
 
138
 
 
139
  TExpressList = class(TSortedCollection)
 
140
  private
 
141
    FShortList: TExpressShortList;
 
142
  public
 
143
    constructor Create;
 
144
    destructor Destroy; override;
 
145
    procedure Add(Item: Pointer); override;
 
146
    function  KeyOf(Item: Pointer): Pointer; override;
 
147
    function  Compare(Key1, Key2: Pointer): Integer; override;
 
148
    function  Search(Key: Pointer; var Index: Integer): Boolean; override;
 
149
    procedure FreeItem(Item: Pointer); override;
 
150
  end;
 
151
 
 
152
  TConstant = class(TExprWord)
 
153
  private
 
154
    FResultType: TExpressionType;
 
155
  protected
 
156
    function GetResultType: TExpressionType; override;
 
157
  public
 
158
    constructor Create(AName: string; AVarType: TExpressionType; AExprFunc: TExprFunc);
 
159
  end;
 
160
 
 
161
  TFloatConstant = class(TConstant)
 
162
  private
 
163
    FValue: Double;
 
164
  public
 
165
    // not overloaded to support older Delphi versions
 
166
    constructor Create(AName: string; AValue: string);
 
167
    constructor CreateAsDouble(AName: string; AValue: Double);
 
168
 
 
169
    function AsPointer: PChar; override;
 
170
 
 
171
    property Value: Double read FValue write FValue;
 
172
  end;
 
173
 
 
174
  TUserConstant = class(TFloatConstant)
 
175
  private
 
176
    FDescription: string;
 
177
  protected
 
178
    function GetDescription: string; override;
 
179
  public
 
180
    constructor CreateAsDouble(AName, Descr: string; AValue: Double);
 
181
  end;
 
182
 
 
183
  TStringConstant = class(TConstant)
 
184
  private
 
185
    FValue: string;
 
186
  public
 
187
    constructor Create(AValue: string);
 
188
 
 
189
    function AsPointer: PChar; override;
 
190
  end;
 
191
 
 
192
  TIntegerConstant = class(TConstant)
 
193
  private
 
194
    FValue: Integer;
 
195
  public
 
196
    constructor Create(AValue: Integer);
 
197
 
 
198
    function AsPointer: PChar; override;
 
199
  end;
 
200
 
 
201
  TBooleanConstant = class(TConstant)
 
202
  private
 
203
    FValue: Boolean;
 
204
  public
 
205
    // not overloaded to support older Delphi versions
 
206
    constructor Create(AName: string; AValue: Boolean);
 
207
 
 
208
    function AsPointer: PChar; override;
 
209
 
 
210
    property Value: Boolean read FValue write FValue;
 
211
  end;
 
212
 
 
213
  TVariable = class(TExprWord)
 
214
  private
 
215
    FResultType: TExpressionType;
 
216
  protected
 
217
    function GetCanVary: Boolean; override;
 
218
    function GetResultType: TExpressionType; override;
 
219
  public
 
220
    constructor Create(AName: string; AVarType: TExpressionType; AExprFunc: TExprFunc);
 
221
  end;
 
222
 
 
223
  TFloatVariable = class(TVariable)
 
224
  private
 
225
    FValue: PDouble;
 
226
  public
 
227
    constructor Create(AName: string; AValue: PDouble);
 
228
 
 
229
    function AsPointer: PChar; override;
 
230
  end;
 
231
 
 
232
  TStringVariable = class(TVariable)
 
233
  private
 
234
    FValue: PPChar;
 
235
    FFixedLen: Integer;
 
236
  protected
 
237
    function GetFixedLen: Integer; override;
 
238
  public
 
239
    constructor Create(AName: string; AValue: PPChar; AFixedLen: Integer);
 
240
 
 
241
    function LenAsPointer: PInteger; override;
 
242
    function AsPointer: PChar; override;
 
243
 
 
244
    property FixedLen: Integer read FFixedLen;
 
245
  end;
 
246
 
 
247
  TDateTimeVariable = class(TVariable)
 
248
  private
 
249
    FValue: PDateTimeRec;
 
250
  public
 
251
    constructor Create(AName: string; AValue: PDateTimeRec);
 
252
 
 
253
    function AsPointer: PChar; override;
 
254
  end;
 
255
 
 
256
  TIntegerVariable = class(TVariable)
 
257
  private
 
258
    FValue: PInteger;
 
259
  public
 
260
    constructor Create(AName: string; AValue: PInteger);
 
261
 
 
262
    function AsPointer: PChar; override;
 
263
  end;
 
264
 
 
265
{$ifdef SUPPORT_INT64}
 
266
 
 
267
  TLargeIntVariable = class(TVariable)
 
268
  private
 
269
    FValue: PLargeInt;
 
270
  public
 
271
    constructor Create(AName: string; AValue: PLargeInt);
 
272
 
 
273
    function AsPointer: PChar; override;
 
274
  end;
 
275
 
 
276
{$endif}
 
277
 
 
278
  TBooleanVariable = class(TVariable)
 
279
  private
 
280
    FValue: PBoolean;
 
281
  public
 
282
    constructor Create(AName: string; AValue: PBoolean);
 
283
 
 
284
    function AsPointer: PChar; override;
 
285
  end;
 
286
 
 
287
  TLeftBracket = class(TExprWord)
 
288
    function GetResultType: TExpressionType; override;
 
289
  end;
 
290
 
 
291
  TRightBracket = class(TExprWord)
 
292
  protected
 
293
    function GetResultType: TExpressionType; override;
 
294
  end;
 
295
 
 
296
  TComma = class(TExprWord)
 
297
  protected
 
298
    function GetResultType: TExpressionType; override;
 
299
  end;
 
300
 
 
301
  TFunction = class(TExprWord)
 
302
  private
 
303
    FIsOperator: Boolean;
 
304
    FOperPrec: Integer;
 
305
    FMinFunctionArg: Integer;
 
306
    FMaxFunctionArg: Integer;
 
307
    FDescription: string;
 
308
    FTypeSpec: string;
 
309
    FShortName: string;
 
310
    FResultType: TExpressionType;
 
311
  protected
 
312
    function GetDescription: string; override;
 
313
    function GetIsOperator: Boolean; override;
 
314
    function GetMinFunctionArg: Integer; override;
 
315
    function GetMaxFunctionArg: Integer; override;
 
316
    function GetResultType: TExpressionType; override;
 
317
    function GetTypeSpec: string; override;
 
318
    function GetShortName: string; override;
 
319
 
 
320
    procedure InternalCreate(AName, ATypeSpec: string; AMinFuncArg: Integer; AResultType: TExpressionType;
 
321
      AExprFunc: TExprFunc; AIsOperator: Boolean; AOperPrec: Integer);
 
322
  public
 
323
    constructor Create(AName, AShortName, ATypeSpec: string; AMinFuncArg: Integer; AResultType: TExpressionType; AExprFunc: TExprFunc; Descr: string);
 
324
    constructor CreateOper(AName, ATypeSpec: string; AResultType: TExpressionType; AExprFunc: TExprFunc; AOperPrec: Integer);
 
325
 
 
326
    function IsFunction: Boolean; override;
 
327
 
 
328
    property OperPrec: Integer read FOperPrec;
 
329
    property TypeSpec: string read FTypeSpec;
 
330
  end;
 
331
 
 
332
  TVaryingFunction = class(TFunction)
 
333
    // Functions that can vary for ex. random generators
 
334
    // should be TVaryingFunction to be sure that they are
 
335
    // always evaluated
 
336
  protected
 
337
    function GetCanVary: Boolean; override;
 
338
  end;
 
339
 
 
340
const
 
341
  ListChar = ','; {the delimiter used with the 'in' operator: e.g.,
 
342
  ('a' in 'a,b') =True
 
343
  ('c' in 'a,b') =False}
 
344
 
 
345
function ExprCharToExprType(ExprChar: Char): TExpressionType;
 
346
 
 
347
 
 
348
 
 
349
implementation
 
350
 
 
351
function ExprCharToExprType(ExprChar: Char): TExpressionType;
 
352
begin
 
353
  case ExprChar of
 
354
    'B': Result := etBoolean;
 
355
    'I': Result := etInteger;
 
356
    'L': Result := etLargeInt;
 
357
    'F': Result := etFloat;
 
358
    'D': Result := etDateTime;
 
359
    'S': Result := etString;
 
360
  else
 
361
    Result := etUnknown;
 
362
  end;
 
363
end;
 
364
 
 
365
procedure _FloatVariable(Param: PExpressionRec);
 
366
begin
 
367
  with Param^ do
 
368
    PDouble(Res.MemoryPos^)^ := PDouble(Args[0])^;
 
369
end;
 
370
 
 
371
procedure _BooleanVariable(Param: PExpressionRec);
 
372
begin
 
373
  with Param^ do
 
374
    PBoolean(Res.MemoryPos^)^ := PBoolean(Args[0])^;
 
375
end;
 
376
 
 
377
procedure _StringConstant(Param: PExpressionRec);
 
378
begin
 
379
  with Param^ do
 
380
    Res.Append(Args[0], StrLen(Args[0]));
 
381
end;
 
382
 
 
383
procedure _StringVariable(Param: PExpressionRec);
 
384
begin
 
385
  with Param^ do
 
386
    Res.Append(PPChar(Args[0])^, StrLen(PPChar(Args[0])^));
 
387
end;
 
388
 
 
389
procedure _StringVariableFixedLen(Param: PExpressionRec);
 
390
begin
 
391
  with Param^ do
 
392
    Res.Append(PPChar(Args[0])^, PInteger(Args[1])^);
 
393
end;
 
394
 
 
395
procedure _DateTimeVariable(Param: PExpressionRec);
 
396
begin
 
397
  with Param^ do
 
398
    PDateTimeRec(Res.MemoryPos^)^ := PDateTimeRec(Args[0])^;
 
399
end;
 
400
 
 
401
procedure _IntegerVariable(Param: PExpressionRec);
 
402
begin
 
403
  with Param^ do
 
404
    PInteger(Res.MemoryPos^)^ := PInteger(Args[0])^;
 
405
end;
 
406
 
 
407
{
 
408
procedure _SmallIntVariable(Param: PExpressionRec);
 
409
begin
 
410
  with Param^ do
 
411
    PSmallInt(Res.MemoryPos^)^ := PSmallInt(Args[0])^;
 
412
end;
 
413
}
 
414
 
 
415
{$ifdef SUPPORT_INT64}
 
416
 
 
417
procedure _LargeIntVariable(Param: PExpressionRec);
 
418
begin
 
419
  with Param^ do
 
420
    PLargeInt(Res.MemoryPos^)^ := PLargeInt(Args[0])^;
 
421
end;
 
422
 
 
423
{$endif}
 
424
 
 
425
{ TExpressionWord }
 
426
 
 
427
constructor TExprWord.Create(AName: string; AExprFunc: TExprFunc);
 
428
begin
 
429
  FName := AName;
 
430
  FExprFunc := AExprFunc;
 
431
end;
 
432
 
 
433
function TExprWord.GetCanVary: Boolean;
 
434
begin
 
435
  Result := False;
 
436
end;
 
437
 
 
438
function TExprWord.GetDescription: string;
 
439
begin
 
440
  Result := EmptyStr;
 
441
end;
 
442
 
 
443
function TExprWord.GetShortName: string;
 
444
begin
 
445
  Result := EmptyStr;
 
446
end;
 
447
 
 
448
function TExprWord.GetIsOperator: Boolean;
 
449
begin
 
450
  Result := False;
 
451
end;
 
452
 
 
453
function TExprWord.GetIsVariable: Boolean;
 
454
begin
 
455
  Result := (@FExprFunc = @_StringVariable)         or
 
456
            (@FExprFunc = @_StringConstant)         or
 
457
            (@FExprFunc = @_StringVariableFixedLen) or
 
458
            (@FExprFunc = @_FloatVariable)          or
 
459
            (@FExprFunc = @_IntegerVariable)        or
 
460
//            (@FExprFunc = @_SmallIntVariable)       or
 
461
{$ifdef SUPPORT_INT64}
 
462
            (@FExprFunc = @_LargeIntVariable)       or
 
463
{$endif}
 
464
            (@FExprFunc = @_DateTimeVariable)       or
 
465
            (@FExprFunc = @_BooleanVariable);
 
466
end;
 
467
 
 
468
function TExprWord.GetNeedsCopy: Boolean;
 
469
begin
 
470
  Result := (@FExprFunc <> @_StringConstant)         and
 
471
//            (@FExprFunc <> @_StringVariable)         and
 
472
//            (@FExprFunc <> @_StringVariableFixedLen) and
 
473
// string variable cannot be used as normal parameter
 
474
// because it is indirectly referenced and possibly
 
475
// not null-terminated (fixed len)
 
476
            (@FExprFunc <> @_FloatVariable)          and
 
477
            (@FExprFunc <> @_IntegerVariable)        and
 
478
//            (@FExprFunc <> @_SmallIntVariable)       and
 
479
{$ifdef SUPPORT_INT64}
 
480
            (@FExprFunc <> @_LargeIntVariable)       and
 
481
{$endif}
 
482
            (@FExprFunc <> @_DateTimeVariable)       and
 
483
            (@FExprFunc <> @_BooleanVariable);
 
484
end;
 
485
 
 
486
function TExprWord.GetFixedLen: Integer;
 
487
begin
 
488
  // -1 means variable, non-fixed length
 
489
  Result := -1;
 
490
end;
 
491
 
 
492
function TExprWord.GetMinFunctionArg: Integer;
 
493
begin
 
494
  Result := 0;
 
495
end;
 
496
 
 
497
function TExprWord.GetMaxFunctionArg: Integer;
 
498
begin
 
499
  Result := 0;
 
500
end;
 
501
 
 
502
function TExprWord.GetResultType: TExpressionType;
 
503
begin
 
504
  Result := etUnknown;
 
505
end;
 
506
 
 
507
function TExprWord.GetTypeSpec: string;
 
508
begin
 
509
  Result := EmptyStr;
 
510
end;
 
511
 
 
512
function TExprWord.AsPointer: PChar;
 
513
begin
 
514
  Result := nil;
 
515
end;
 
516
 
 
517
function TExprWord.LenAsPointer: PInteger;
 
518
begin
 
519
  Result := nil;
 
520
end;
 
521
 
 
522
function TExprWord.IsFunction: Boolean;
 
523
begin
 
524
  Result := False;
 
525
end;
 
526
 
 
527
{ TConstant }
 
528
 
 
529
constructor TConstant.Create(AName: string; AVarType: TExpressionType; AExprFunc: TExprFunc);
 
530
begin
 
531
  inherited Create(AName, AExprFunc);
 
532
 
 
533
  FResultType := AVarType;
 
534
end;
 
535
 
 
536
function TConstant.GetResultType: TExpressionType;
 
537
begin
 
538
  Result := FResultType;
 
539
end;
 
540
 
 
541
{ TFloatConstant }
 
542
 
 
543
constructor TFloatConstant.Create(AName, AValue: string);
 
544
begin
 
545
  inherited Create(AName, etFloat, _FloatVariable);
 
546
 
 
547
  if Length(AValue) > 0 then
 
548
    FValue := StrToFloat(AValue)
 
549
  else
 
550
    FValue := 0.0;
 
551
end;
 
552
 
 
553
constructor TFloatConstant.CreateAsDouble(AName: string; AValue: Double);
 
554
begin
 
555
  inherited Create(AName, etFloat, _FloatVariable);
 
556
 
 
557
  FValue := AValue;
 
558
end;
 
559
 
 
560
function TFloatConstant.AsPointer: PChar;
 
561
begin
 
562
  Result := PChar(@FValue);
 
563
end;
 
564
 
 
565
{ TUserConstant }
 
566
 
 
567
constructor TUserConstant.CreateAsDouble(AName, Descr: string; AValue: Double);
 
568
begin
 
569
  FDescription := Descr;
 
570
 
 
571
  inherited CreateAsDouble(AName, AValue);
 
572
end;
 
573
 
 
574
function TUserConstant.GetDescription: string;
 
575
begin
 
576
  Result := FDescription;
 
577
end;
 
578
 
 
579
{ TStringConstant }
 
580
 
 
581
constructor TStringConstant.Create(AValue: string);
 
582
var
 
583
  firstChar, lastChar: Char;
 
584
begin
 
585
  inherited Create(AValue, etString, _StringConstant);
 
586
 
 
587
  firstChar := AValue[1];
 
588
  lastChar := AValue[Length(AValue)];
 
589
  if (firstChar = lastChar) and ((firstChar = '''') or (firstChar = '"')) then
 
590
    FValue := Copy(AValue, 2, Length(AValue) - 2)
 
591
  else
 
592
    FValue := AValue;
 
593
end;
 
594
 
 
595
function TStringConstant.AsPointer: PChar;
 
596
begin
 
597
  Result := PChar(FValue);
 
598
end;
 
599
 
 
600
{ TBooleanConstant }
 
601
 
 
602
constructor TBooleanConstant.Create(AName: string; AValue: Boolean);
 
603
begin
 
604
  inherited Create(AName, etBoolean, _BooleanVariable);
 
605
 
 
606
  FValue := AValue;
 
607
end;
 
608
 
 
609
function TBooleanConstant.AsPointer: PChar;
 
610
begin
 
611
  Result := PChar(@FValue);
 
612
end;
 
613
 
 
614
{ TIntegerConstant }
 
615
 
 
616
constructor TIntegerConstant.Create(AValue: Integer);
 
617
begin
 
618
  inherited Create(IntToStr(AValue), etInteger, _IntegerVariable);
 
619
 
 
620
  FValue := AValue;
 
621
end;
 
622
 
 
623
function TIntegerConstant.AsPointer: PChar;
 
624
begin
 
625
  Result := PChar(@FValue);
 
626
end;
 
627
 
 
628
{ TVariable }
 
629
 
 
630
constructor TVariable.Create(AName: string; AVarType: TExpressionType; AExprFunc: TExprFunc);
 
631
begin
 
632
  inherited Create(AName, AExprFunc);
 
633
 
 
634
  FResultType := AVarType;
 
635
end;
 
636
 
 
637
function TVariable.GetCanVary: Boolean;
 
638
begin
 
639
  Result := True;
 
640
end;
 
641
 
 
642
function TVariable.GetResultType: TExpressionType;
 
643
begin
 
644
  Result := FResultType;
 
645
end;
 
646
 
 
647
{ TFloatVariable }
 
648
 
 
649
constructor TFloatVariable.Create(AName: string; AValue: PDouble);
 
650
begin
 
651
  inherited Create(AName, etFloat, _FloatVariable);
 
652
  FValue := AValue;
 
653
end;
 
654
 
 
655
function TFloatVariable.AsPointer: PChar;
 
656
begin
 
657
  Result := PChar(FValue);
 
658
end;
 
659
 
 
660
{ TStringVariable }
 
661
 
 
662
constructor TStringVariable.Create(AName: string; AValue: PPChar; AFixedLen: Integer);
 
663
begin
 
664
  // variable or fixed length?
 
665
  if (AFixedLen < 0) then
 
666
    inherited Create(AName, etString, _StringVariable)
 
667
  else
 
668
    inherited Create(AName, etString, _StringVariableFixedLen);
 
669
 
 
670
  // store pointer to string
 
671
  FValue := AValue;
 
672
  FFixedLen := AFixedLen;
 
673
end;
 
674
 
 
675
function TStringVariable.AsPointer: PChar;
 
676
begin
 
677
  Result := PChar(FValue);
 
678
end;
 
679
 
 
680
function TStringVariable.GetFixedLen: Integer;
 
681
begin
 
682
  Result := FFixedLen;
 
683
end;
 
684
 
 
685
function TStringVariable.LenAsPointer: PInteger;
 
686
begin
 
687
  Result := @FFixedLen;
 
688
end;
 
689
 
 
690
{ TDateTimeVariable }
 
691
 
 
692
constructor TDateTimeVariable.Create(AName: string; AValue: PDateTimeRec);
 
693
begin
 
694
  inherited Create(AName, etDateTime, _DateTimeVariable);
 
695
  FValue := AValue;
 
696
end;
 
697
 
 
698
function TDateTimeVariable.AsPointer: PChar;
 
699
begin
 
700
  Result := PChar(FValue);
 
701
end;
 
702
 
 
703
{ TIntegerVariable }
 
704
 
 
705
constructor TIntegerVariable.Create(AName: string; AValue: PInteger);
 
706
begin
 
707
  inherited Create(AName, etInteger, _IntegerVariable);
 
708
  FValue := AValue;
 
709
end;
 
710
 
 
711
function TIntegerVariable.AsPointer: PChar;
 
712
begin
 
713
  Result := PChar(FValue);
 
714
end;
 
715
 
 
716
{$ifdef SUPPORT_INT64}
 
717
 
 
718
{ TLargeIntVariable }
 
719
 
 
720
constructor TLargeIntVariable.Create(AName: string; AValue: PLargeInt);
 
721
begin
 
722
  inherited Create(AName, etLargeInt, _LargeIntVariable);
 
723
  FValue := AValue;
 
724
end;
 
725
 
 
726
function TLargeIntVariable.AsPointer: PChar;
 
727
begin
 
728
  Result := PChar(FValue);
 
729
end;
 
730
 
 
731
{$endif}
 
732
 
 
733
{ TBooleanVariable }
 
734
 
 
735
constructor TBooleanVariable.Create(AName: string; AValue: PBoolean);
 
736
begin
 
737
  inherited Create(AName, etBoolean, _BooleanVariable);
 
738
  FValue := AValue;
 
739
end;
 
740
 
 
741
function TBooleanVariable.AsPointer: PChar;
 
742
begin
 
743
  Result := PChar(FValue);
 
744
end;
 
745
 
 
746
{ TLeftBracket }
 
747
 
 
748
function TLeftBracket.GetResultType: TExpressionType;
 
749
begin
 
750
  Result := etLeftBracket;
 
751
end;
 
752
 
 
753
{ TRightBracket }
 
754
 
 
755
function TRightBracket.GetResultType: TExpressionType;
 
756
begin
 
757
  Result := etRightBracket;
 
758
end;
 
759
 
 
760
{ TComma }
 
761
 
 
762
function TComma.GetResultType: TExpressionType;
 
763
begin
 
764
  Result := etComma;
 
765
end;
 
766
 
 
767
{ TExpressList }
 
768
 
 
769
constructor TExpressList.Create;
 
770
begin
 
771
  inherited;
 
772
 
 
773
  FShortList := TExpressShortList.Create;
 
774
end;
 
775
 
 
776
destructor TExpressList.Destroy;
 
777
begin
 
778
  inherited;
 
779
  FShortList.Free;
 
780
end;
 
781
 
 
782
procedure TExpressList.Add(Item: Pointer);
 
783
var
 
784
  I: Integer;
 
785
begin
 
786
  inherited;
 
787
 
 
788
  { remember we reference the object }
 
789
  Inc(TExprWord(Item).FRefCount);
 
790
 
 
791
  { also add ShortName as reference }
 
792
  if Length(TExprWord(Item).ShortName) > 0 then
 
793
  begin
 
794
    FShortList.Search(FShortList.KeyOf(Item), I);
 
795
    FShortList.Insert(I, Item);
 
796
  end;
 
797
end;
 
798
 
 
799
function TExpressList.Compare(Key1, Key2: Pointer): Integer;
 
800
begin
 
801
  Result := StrIComp(PChar(Key1), PChar(Key2));
 
802
end;
 
803
 
 
804
function TExpressList.KeyOf(Item: Pointer): Pointer;
 
805
begin
 
806
  Result := PChar(TExprWord(Item).Name);
 
807
end;
 
808
 
 
809
procedure TExpressList.FreeItem(Item: Pointer);
 
810
begin
 
811
  Dec(TExprWord(Item).FRefCount);
 
812
  FShortList.Remove(Item);
 
813
  if TExprWord(Item).FRefCount = 0 then
 
814
    inherited;
 
815
end;
 
816
 
 
817
function TExpressList.Search(Key: Pointer; var Index: Integer): Boolean;
 
818
var
 
819
  SecIndex: Integer;
 
820
begin
 
821
  Result := inherited Search(Key, Index);
 
822
  if not Result then
 
823
  begin
 
824
    Result := FShortList.Search(Key, SecIndex);
 
825
    if Result then
 
826
      Index := IndexOf(FShortList.Items[SecIndex]);
 
827
  end;
 
828
end;
 
829
 
 
830
function TExpressShortList.Compare(Key1, Key2: Pointer): Integer;
 
831
begin
 
832
  Result := StrIComp(PChar(Key1), PChar(Key2));
 
833
end;
 
834
 
 
835
function TExpressShortList.KeyOf(Item: Pointer): Pointer;
 
836
begin
 
837
  Result := PChar(TExprWord(Item).ShortName);
 
838
end;
 
839
 
 
840
procedure TExpressShortList.FreeItem(Item: Pointer);
 
841
begin
 
842
end;
 
843
 
 
844
{ TExprCollection }
 
845
 
 
846
procedure TExprCollection.Check;
 
847
var
 
848
  brCount, I: Integer;
 
849
begin
 
850
  brCount := 0;
 
851
  for I := 0 to Count - 1 do
 
852
  begin
 
853
    case TExprWord(Items[I]).ResultType of
 
854
      etLeftBracket: Inc(brCount);
 
855
      etRightBracket: Dec(brCount);
 
856
    end;
 
857
  end;
 
858
  if brCount <> 0 then
 
859
    raise EParserException.Create('Unequal brackets');
 
860
end;
 
861
 
 
862
procedure TExprCollection.EraseExtraBrackets;
 
863
var
 
864
  I: Integer;
 
865
  brCount: Integer;
 
866
begin
 
867
  if (TExprWord(Items[0]).ResultType = etLeftBracket) then
 
868
  begin
 
869
    brCount := 1;
 
870
    I := 1;
 
871
    while (I < Count) and (brCount > 0) do
 
872
    begin
 
873
      case TExprWord(Items[I]).ResultType of
 
874
        etLeftBracket: Inc(brCount);
 
875
        etRightBracket: Dec(brCount);
 
876
      end;
 
877
      Inc(I);
 
878
    end;
 
879
    if (brCount = 0) and (I = Count) and (TExprWord(Items[I - 1]).ResultType =
 
880
      etRightBracket) then
 
881
    begin
 
882
      for I := 0 to Count - 3 do
 
883
        Items[I] := Items[I + 1];
 
884
      Count := Count - 2;
 
885
      EraseExtraBrackets; //Check if there are still too many brackets
 
886
    end;
 
887
  end;
 
888
end;
 
889
 
 
890
{ TFunction }
 
891
 
 
892
constructor TFunction.Create(AName, AShortName, ATypeSpec: string; AMinFuncArg: Integer; AResultType: TExpressionType;
 
893
  AExprFunc: TExprFunc; Descr: string);
 
894
begin
 
895
  //to increase compatibility don't use default parameters
 
896
  FDescription := Descr;
 
897
  FShortName := AShortName;
 
898
  InternalCreate(AName, ATypeSpec, AMinFuncArg, AResultType, AExprFunc, false, 0);
 
899
end;
 
900
 
 
901
constructor TFunction.CreateOper(AName, ATypeSpec: string; AResultType: TExpressionType;
 
902
  AExprFunc: TExprFunc; AOperPrec: Integer);
 
903
begin
 
904
  InternalCreate(AName, ATypeSpec, -1, AResultType, AExprFunc, true, AOperPrec);
 
905
end;
 
906
 
 
907
procedure TFunction.InternalCreate(AName, ATypeSpec: string; AMinFuncArg: Integer; AResultType: TExpressionType;
 
908
  AExprFunc: TExprFunc; AIsOperator: Boolean; AOperPrec: Integer);
 
909
begin
 
910
  inherited Create(AName, AExprFunc);
 
911
 
 
912
  FMaxFunctionArg := Length(ATypeSpec);
 
913
  FMinFunctionArg := AMinFuncArg;
 
914
  if AMinFuncArg = -1 then
 
915
    FMinFunctionArg := FMaxFunctionArg;
 
916
  FIsOperator := AIsOperator;
 
917
  FOperPrec := AOperPrec;
 
918
  FTypeSpec := ATypeSpec;
 
919
  FResultType := AResultType;
 
920
 
 
921
  // check correctness
 
922
  if FMaxFunctionArg > MaxArg then
 
923
    raise EParserException.Create('Too many arguments');
 
924
end;
 
925
 
 
926
function TFunction.GetDescription: string;
 
927
begin
 
928
  Result := FDescription;
 
929
end;
 
930
 
 
931
function TFunction.GetIsOperator: Boolean;
 
932
begin
 
933
  Result := FIsOperator;
 
934
end;
 
935
 
 
936
function TFunction.GetMinFunctionArg: Integer;
 
937
begin
 
938
  Result := FMinFunctionArg;
 
939
end;
 
940
 
 
941
function TFunction.GetMaxFunctionArg: Integer;
 
942
begin
 
943
  Result := FMaxFunctionArg;
 
944
end;
 
945
 
 
946
function TFunction.GetResultType: TExpressionType;
 
947
begin
 
948
  Result := FResultType;
 
949
end;
 
950
 
 
951
function TFunction.GetShortName: string;
 
952
begin
 
953
  Result := FShortName;
 
954
end;
 
955
 
 
956
function TFunction.GetTypeSpec: string;
 
957
begin
 
958
  Result := FTypeSpec;
 
959
end;
 
960
 
 
961
function TFunction.IsFunction: Boolean;
 
962
begin
 
963
  Result := True;
 
964
end;
 
965
 
 
966
{ TVaryingFunction }
 
967
 
 
968
function TVaryingFunction.GetCanVary: Boolean;
 
969
begin
 
970
  Result := True;
 
971
end;
 
972
 
 
973
{ TDynamicType }
 
974
 
 
975
constructor TDynamicType.Create(DestMem, DestPos: PPChar; Size: PInteger);
 
976
begin
 
977
  inherited Create;
 
978
 
 
979
  FMemory := DestMem;
 
980
  FMemoryPos := DestPos;
 
981
  FSize := Size;
 
982
end;
 
983
 
 
984
procedure TDynamicType.Rewind;
 
985
begin
 
986
  FMemoryPos^ := FMemory^;
 
987
end;
 
988
 
 
989
procedure TDynamicType.AssureSpace(ASize: Integer);
 
990
begin
 
991
  // need more memory?
 
992
  if ((FMemoryPos^) - (FMemory^) + ASize) > (FSize^) then
 
993
    Resize((FMemoryPos^) - (FMemory^) + ASize, False);
 
994
end;
 
995
 
 
996
procedure TDynamicType.Resize(NewSize: Integer; Exact: Boolean);
 
997
var
 
998
  tempBuf: PChar;
 
999
  bytesCopy, pos: Integer;
 
1000
begin
 
1001
  // if not exact requested make newlength a multiple of ArgAllocSize
 
1002
  if not Exact then
 
1003
    NewSize := NewSize div ArgAllocSize * ArgAllocSize + ArgAllocSize;
 
1004
  // create new buffer
 
1005
  GetMem(tempBuf, NewSize);
 
1006
  // copy memory
 
1007
  bytesCopy := FSize^;
 
1008
  if bytesCopy > NewSize then
 
1009
    bytesCopy := NewSize;
 
1010
  Move(FMemory^^, tempBuf^, bytesCopy);
 
1011
  // save position in string
 
1012
  pos := FMemoryPos^ - FMemory^;
 
1013
  // delete old mem
 
1014
  FreeMem(FMemory^);
 
1015
  // assign new
 
1016
  FMemory^ := tempBuf;
 
1017
  FSize^ := NewSize;
 
1018
  // assign position
 
1019
  FMemoryPos^ := FMemory^ + pos;
 
1020
end;
 
1021
 
 
1022
procedure TDynamicType.Append(Source: PChar; Length: Integer);
 
1023
begin
 
1024
  // make room for string plus null-terminator
 
1025
  AssureSpace(Length+4);
 
1026
  // copy
 
1027
  Move(Source^, FMemoryPos^^, Length);
 
1028
  Inc(FMemoryPos^, Length);
 
1029
  // null-terminate
 
1030
  FMemoryPos^^ := #0;
 
1031
end;
 
1032
 
 
1033
procedure TDynamicType.AppendInteger(Source: Integer);
 
1034
begin
 
1035
  // make room for number
 
1036
  AssureSpace(12);
 
1037
  Inc(FMemoryPos^, GetStrFromInt(Source, FMemoryPos^));
 
1038
  FMemoryPos^^ := #0;
 
1039
end;
 
1040
 
 
1041
end.
 
1042