Porting TextCraft to Oxygene
TextCraft is a simple yet powerful text parser, designed for general purpose parsing jobs. I originally implemented it for Delphi, it’s the base-parser for the LDEF bytecode assembler amongst other things. It was ported to Smart Pascal, then Freepascal – and now finally Oxygene.
The LDEF Assembler is a part of the Quartex Media Desktop
The LDEF assembler and bytecode engine is currently implemented in Smart and compiles for Javascript. It’s a complete assembler and VM allowing coders to approach Asm.js from an established instruction-set. In short: you feed it source-code, it spits out bytecodes that you can execute super fast in either the browser or elsewhere. As long as there is a VM implementation available.
The Javascript version works really well, especially on node.js. In essence, i don’t need to re-compile the toolchain when moving between arm, x86, windows, linux or osx. Think of it as a type of Java bytecodes or CLR bytecodes.
Getting the code to run under Oxygene, means that I can move the whole engine into WebAssembly. The parser, assembler and linker (et-al) can thus run as WebAssembly, and I can use that from my JavaScript front-end code. Best of both worlds – the flamboyant creativity of JavaScript, and the raw speed of WebAssembly.
The port
Before I can move over the top-level parser + assembler etc, the generic parser code has to work. I was reluctant to start because I imagined the porting would take at least a day, but luckily it took me less than an hour. There are a few superficial differences between Smart, Delphi, Freepascal and Oxygene; for example the Copy() function for strings is not a lose function in Oxygene, instead you use String.SubString(). Functions like High() and Low() on strings likewise has to be refactored.
But all in all the conversion was straight-forward, and TextCraft is now a part of the QTX library for Oxygene. I’ll be uploading a commit to GIT with the whole shabam soon.
Well, hope the WordPress parser doesnt screw this up too bad.
namespace qtxlib;
//##################################################################
// TextCraft 1.2
// Written by Jon L. Aasenden
//
// This is a port of TC 1.2 from Freepascal. TextCraft is initially
// a Delphi parser framework. The original repository can be found
// on BitBucket at:
//
// https://bitbucket.org/hexmonks/main
//
//##################################################################
{$DEFINE USE_INCLUSIVE}
{$define USE_BMARK}
interface
uses
qtxlib, System, rtl,
RemObjects.Elements.RTL.Delphi,
RemObjects.Elements.RTL.Delphi.VCL;
type
// forward declarations
TTextBuffer = class;
TParserContext = class;
TCustomParser = class;
TParserModelObject = class;
// Exceptions
ETextBuffer = class(Exception);
EModelObject = class(Exception);
// Callback functions
TTextValidCB = function (Item: Char): Boolean;
// Bookmark datatype
TTextBufferBookmark = class
public
property bbOffset: Integer;
property bbCol: Integer;
property bbRow: Integer;
function Equals(const ThisMark: TTextBufferBookmark): Boolean;
end;
{.$DEFINE USE_BMARK}
TTextBuffer = class(TErrorObject)
private
FData: String;
FOffset: Integer;
FLength: Integer;
FCol: Integer;
FRow: Integer;
{$IFDEF USE_BMARK}
FBookmarks: List;
{$ENDIF}
procedure SetCacheData(NewText: String);
public
property Column: Integer read FCol;
property Row: Integer read FRow;
property Count: Integer read FLength;
property Offset: Integer read FOffset;
property CacheData: String read FData write SetCacheData;
// These functions map directly to the "Current"
// character where the offset is placed, and is used to
// write code that makes more sense to human eyes
function CrLf: Boolean;
function Space: Boolean;
function Tab: Boolean;
function SemiColon: Boolean;
function Colon: Boolean;
function ConditionEnter: Boolean;
function ConditionLeave: Boolean;
function BracketEnter: Boolean;
function BracketLeave: Boolean;
function Ptr: Boolean;
function Punctum: Boolean;
function Question: Boolean;
function Less: Boolean;
function More: Boolean;
function Equal: Boolean;
function Pipe: Boolean;
function Numeric: Boolean;
function Empty: Boolean;
function BOF: Boolean;
function EOF: Boolean;
function Current: Char;
function First: Boolean;
function Last: Boolean;
// Same as "Next", but does not automatically
// consume CR+LF, used when parsing textfragments
function NextNoCrLf: Boolean;
// Normal Next function, will automatically consume
// CRLF when it encounters it
function Next: Boolean;
function Back: Boolean;
function Bookmark: TTextBufferBookmark;
procedure Restore(const Mark: TTextBufferBookmark);
{$IFDEF USE_BMARK}
procedure Drop;
{$ENDIF}
procedure ConsumeJunk;
procedure ConsumeCRLF;
function Compare(const CompareText: String;
const CaseSensitive: Boolean): Boolean;
function Read(var Fragment: Char): Boolean; overload;
function Read: Char; overload;
function ReadTo(const CB: TTextValidCB; var TextRead: String): Boolean; overload;
function ReadTo(const Resignators: TSysCharSet; var TextRead: String): Boolean; overload;
function ReadTo(MatchText: String): Boolean; overload;
function ReadTo(MatchText: String; var TextRead: String): Boolean; overload;
function ReadToEOL: Boolean; overload;
function ReadToEOL(var TextRead: String): Boolean; overload;
function Peek: Char; overload;
function Peek(CharCount: Integer; var TextRead: String): Boolean; overload;
function NextNonControlChar(const CompareWith: Char): Boolean;
function NextNonControlText(const CompareWith: String): Boolean;
function ReadWord(var TextRead: String): Boolean;
function ReadQuotedString: String;
function ReadCommaList(var cList: List): Boolean;
function NextLine: Boolean;
procedure Inject(const TextToInject: String);
function GetCurrentLocation: TTextBufferBookmark;
function Trail: String;
procedure Clear;
procedure LoadBufferText(const NewBuffer: String);
constructor Create(const BufferText: String); overload; virtual;
finalizer;
begin
{$IFDEF USE_BMARK}
FBookmarks.Clear();
disposeAndNil(FBookmarks);
{$endif}
Clear();
end;
end;
TParserContext = class(TErrorObject)
private
FBuffer: TTextBuffer;
FStack: Stack;
public
property Buffer: TTextBuffer read FBuffer;
property Model: TParserModelObject;
procedure Push(const ModelObj: TParserModelObject);
function Pop: TParserModelObject;
function Peek: TParserModelObject;
procedure ClearStack;
constructor Create(const SourceCode: String); reintroduce; virtual;
finalizer;
begin
FStack.Clear();
FBuffer.Clear();
disposeAndNil(FStack);
disposeAndNil(FBuffer);
end;
end;
TCustomParser = class(TErrorObject)
private
FContext: TParserContext;
protected
procedure SetContext(const NewContext: TParserContext);
public
property Context: TParserContext read FContext;
function Parse: Boolean; virtual;
constructor Create(const ParseContext: TParserContext); reintroduce; virtual;
end;
TParserModelObject = class(TObject)
private
FParent: TParserModelObject;
FChildren: List;
protected
function GetParent: TParserModelObject; virtual;
function ChildGetCount: Integer; virtual;
function ChildGetItem(const Index: Integer): TParserModelObject; virtual;
function ChildAdd(const Instance: TParserModelObject): TParserModelObject; virtual;
public
property Parent: TParserModelObject read GetParent;
property Context: TParserContext;
procedure Clear; virtual;
constructor Create(const AParent: TParserModelObject); virtual;
finalizer;
begin
Clear();
FChildren := nil;
end;
end;
implementation
//#####################################################################
// Error messages
//#####################################################################
const
CNT_ERR_BUFFER_EMPTY = 'Buffer is empty error';
CNT_ERR_OFFSET_BOF = 'Offset at BOF error';
CNT_ERR_OFFSET_EOF = 'Offset at EOF error';
CNT_ERR_COMMENT_NOTCLOSED = 'Comment not closed error';
CNT_ERR_OFFSET_EXPECTED_EOF = 'Expected EOF error';
CNT_ERR_LENGTH_INVALID = 'Invalid length error';
//#####################################################################
// TTextBufferBookmark
//#####################################################################
function TTextBufferBookmark.Equals(const ThisMark: TTextBufferBookmark): boolean;
begin
result := ( (ThisMark nil) and (ThisMark self) )
and (self.bbOffset = ThisMark.bbOffset)
and (self.bbCol = ThisMark.bbCol)
and (self.bbRow = ThisMark.bbRow);
end;
//#####################################################################
// TTextBuffer
//#####################################################################
constructor TTextBuffer.Create(const BufferText: string);
begin
inherited Create();
if length(BufferText) > 0 then
LoadBufferText(BufferText)
else
Clear();
end;
procedure TTextBuffer.Clear;
begin
FData := '';
FOffset := -1;
FLength := 0;
FCol := -1;
FRow := -1;
{$IFDEF USE_BMARK}
FBookmarks.Clear();
{$ENDIF}
end;
procedure TTextBuffer.SetCacheData(NewText: string);
begin
LoadBufferText(NewText);
end;
function TTextBuffer.Trail: string;
begin
if not Empty then
begin
if not EOF then
result := FData.Substring(FOffset, length(FData) );
//result := Copy( FData, FOffset, length(FData) );
end;
end;
procedure TTextBuffer.LoadBufferText(const NewBuffer: string);
begin
// Flush existing buffer
Clear();
// Load in buffertext, init offset and values
var TempLen := NewBuffer.Length;
if TempLen > 0 then
begin
FData := NewBuffer;
FOffset := 0; // start at BOF
FCol := 0;
FRow := 0;
FLength := TempLen;
end;
end;
function TTextBuffer.GetCurrentLocation: TTextBufferBookmark;
begin
if Failed then
ClearLastError();
if not Empty then
begin
result := TTextBufferBookmark.Create;
result.bbOffset := FOffset;
result.bbCol := FCol;
result.bbRow := FRow;
end else
raise ETextBuffer.Create
('Failed to return position, buffer is empty error');
end;
function TTextBuffer.Bookmark: TTextBufferBookmark;
begin
if Failed then
ClearLastError();
if not Empty then
begin
result := TTextBufferBookmark.Create;
result.bbOffset := FOffset;
result.bbCol := FCol;
result.bbRow := FRow;
{$IFDEF USE_BMARK}
FBookmarks.add(result);
{$ENDIF}
end else
raise ETextBuffer.Create
('Failed to bookmark location, buffer is empty error');
end;
procedure TTextBuffer.Restore(const Mark: TTextBufferBookmark);
begin
if Failed then
ClearLastError();
if not Empty then
begin
if Mark nil then
begin
FOffset := Mark.bbOffset;
FCol := Mark.bbCol;
FRow := Mark.bbRow;
Mark.Free;
{$IFDEF USE_BMARK}
var idx := FBookmarks.Count;
if idx > 0 then
begin
dec(idx);
FOffset := FBookmarks[idx].bbOffset;
FCol := FBookmarks[idx].bbCol;
FRow := FBookmarks[idx].bbRow;
FBookmarks.Remove(idx);
//FBookmarks.SetLength(idx)
//FBookmarks.Delete(idx,1);
end else
raise ETextBuffer.Create('Failed to restore bookmark, none exist');
{$ENDIF}
end else
raise ETextBuffer.Create('Failed to restore bookmark, object was nil error');
end else
raise ETextBuffer.Create
('Failed to restore bookmark, buffer is empty error');
end;
{$IFDEF USE_BMARK}
procedure TTextBuffer.Drop;
begin
if Failed then
ClearLastError();
if not Empty then
begin
if FBookmarks.Count > 0 then
FBookmarks.Remove(FBookmarks.Count-1)
else
raise ETextBuffer.Create('Failed to drop bookmark, none exist');
end else
raise ETextBuffer.Create
('Failed to drop bookmark, buffer is empty error');
end;
{$ENDIF}
function TTextBuffer.Read(var Fragment: char): boolean;
begin
if Failed then
ClearLastError();
if not Empty then
begin
result := FOffset <= length(FData);
if result then
begin
// return character
Fragment := FData[FOffset];
// update offset
inc(FOffset)
end else
begin
// return invalid char
Fragment := #0;
// Set error reason
SetLastError('Offset at BOF error');
end;
end else
begin
result := false;
Fragment := #0;
SetLastError('Buffer is empty error');
end;
end;
function TTextBuffer.Read: char;
begin
if Failed then
ClearLastError();
if not Empty then
begin
result := Current;
Next();
end else
result := #0;
end;
function TTextBuffer.ReadToEOL: boolean;
begin
if Failed then
ClearLastError();
if not Empty() then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
// Keep start
var LStart := FOffset;
// Enum until match of EOF
{$IFDEF USE_INCLUSIVE}
repeat
if (FData[FOffset] = #13)
and (FData[FOffset + 1] = #10) then
begin
result := true;
break;
end else
begin
inc(FOffset);
inc(FCol);
end;
until EOF();
{$ELSE}
While FOffset < High(FData) do
begin
if (FData[FOffset] = #13)
and (FData[FOffset + 1] = #10) then
begin
result := true;
break;
end else
begin
inc(FOffset);
inc(FCol);
end;
end;
{$ENDIF}
// Last line in textfile might not have
// a CR+LF, so we have to check for termination
if not result then
begin
if EOF then
begin
if LStart = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset <= high(FData) ) )
and ( (FData[FOffset] = '= Low(FData)) and (FOffset ') );
end;
function TTextBuffer.Equal: boolean;
begin
result := (not Empty)
and ( (FOffset >= Low(FData)) and (FOffset = Low(FData)) and (FOffset = Low(FData)) and (FOffset LStart then
begin
// Any text to return? Or did we start
// directly on a CR+LF and have no text to give?
var LLen := FOffset - LStart;
TextRead := FData.Substring(LStart, LLen);
//TextRead := Copy(FData, LStart, LLen);
end;
// Either way, we exit because CR+LF has been found
result := true;
break;
end;
inc(FOffset);
inc(FCol);
until EOF();
{$ELSE}
While FOffset LStart then
begin
// Any text to return? Or did we start
// directly on a CR+LF and have no text to give?
var LLen := FOffset - LStart;
TextRead := copy(FData, LStart, LLen);
end;
// Either way, we exit because CR+LF has been found
result := true;
break;
end;
inc(FOffset);
inc(FCol);
end;
{$ENDIF}
// Last line in textfile might not have
// a CR+LF, so we have to check for EOF and treat
// that as a terminator.
if not result then
begin
if FOffset >= high(FData) then
begin
if LStart 0 then
begin
TextRead := FData.Substring(LStart, LLen);
//TextRead := Copy(FData, LStart, LLen);
result := true;
end;
exit;
end;
end;
end;
end;
end;
function TTextBuffer.ReadTo(const CB: TTextValidCB; var TextRead: string): boolean;
begin
if Failed then
ClearLastError();
TextRead := '';
if not Empty then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
if not assigned(CB) then
begin
SetLastError('Invalid callback handler');
exit;
end;
{$IFDEF USE_INCLUSIVE}
repeat
if not CB(Current) then
break
else
TextRead := TextRead + Current;
if not Next() then
break;
until EOF();
{$ELSE}
while not EOF do
begin
if not CB(Current) then
break
else
TextRead := TextRead + Current;
if not Next() then
break;
end;
{$ENDIF}
result := TextRead.Length > 0;
end else
begin
result := false;
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
end;
function TTextBuffer.ReadTo(const Resignators: TSysCharSet; var TextRead: string): boolean;
begin
if Failed then
ClearLastError();
TextRead := '';
if not Empty then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
{$IFDEF USE_INCLUSIVE}
repeat
if not Resignators.Contains(Current) then
TextRead := TextRead + Current
else
break;
if not Next() then
break;
until EOF();
{$ELSE}
while not EOF do
begin
if not (Current in Resignators) then
TextRead := TextRead + Current
else
break;
if not Next() then
break;
end;
{$ENDIF}
result := TextRead.Length > 0;
end else
begin
result := false;
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
end;
function TTextBuffer.ReadTo(MatchText: string): boolean;
begin
if Failed then
ClearLastError();
if not Empty() then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
var MatchLen := length(MatchText);
if MatchLen > 0 then
begin
MatchText := MatchText.ToLower();
repeat
var TempCache := '';
if Peek(MatchLen, TempCache) then
begin
TempCache := TempCache.ToLower();
result := SameText(TempCache, MatchText);
if result then
break;
end;
if not Next then
break;
until EOF;
end;
end else
begin
result := false;
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
end;
function TTextBuffer.ReadTo(MatchText: string; var TextRead: string): boolean;
begin
if Failed then
ClearLastError();
result := false;
TextRead := '';
if not Empty() then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
if MatchText.Length > 0 then
begin
MatchText := MatchText.ToLower();
repeat
var TempCache := '';
if Peek(MatchText.Length, TempCache) then
begin
TempCache := TempCache.ToLower();
result := SameText(TempCache, MatchText);
if result then
break
else
TextRead := TextRead + Current;
end else
TextRead := TextRead + Current;
if not Next() then
break;
until EOF;
end;
end else
begin
result := false;
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
end;
procedure TTextBuffer.Inject(const TextToInject: string);
begin
if length(FData) > 0 then
begin
var lSeg1 := FData.Substring(1, FOffset);
var lSeg2 := FData.Substring(FOffset + 1, length(FData));
//var LSeg1 := Copy(FData, 1, FOffset);
//var LSeg2 := Copy(FData, FOffset+1, FData.Length);
FData := lSeg1 + TextToInject + lSeg2;
end else
FData := TextToInject;
end;
function TTextBuffer.Compare(const CompareText: string;
const CaseSensitive: boolean): boolean;
begin
if Failed then
ClearLastError();
if not Empty() then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
var LenToRead := CompareText.Length;
if LenToRead > 0 then
begin
// Peek will set an error message if it
// fails, so we dont need to set anything here
var ReadData := '';
if Peek(LenToRead, ReadData) then
begin
case CaseSensitive of
false: result := ReadData.ToLower() = CompareText.ToLower();
true: result := ReadData = CompareText;
end;
end;
end else
SetLastError(CNT_ERR_LENGTH_INVALID);
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
procedure TTextBuffer.ConsumeJunk;
begin
if Failed then
ClearLastError();
if not Empty then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
repeat
case Current of
' ':
begin
end;
'"':
begin
break;
end;
#8, #09:
begin
end;
'/':
begin
(* Skip C style remark *)
if Compare('/*', false) then
begin
if ReadTo('*/') then
begin
inc(FOffset, 2);
Continue;
end else
SetLastError(CNT_ERR_COMMENT_NOTCLOSED);
end else
begin
(* Skip Pascal style remark *)
if Compare('//', false) then
begin
if ReadToEOL() then
begin
continue;
end else
SetLastError(CNT_ERR_OFFSET_EXPECTED_EOF);
end;
end;
end;
'(':
begin
(* Skip pascal style remark *)
if Compare('(*', false)
and not Compare('(*)', false) then
begin
if ReadTo('*)') then
begin
inc(FOffset, 2);
continue;
end else
SetLastError(CNT_ERR_COMMENT_NOTCLOSED);
end else
break;
end;
#13:
begin
if FData[FOffset + 1] = #10 then
inc(FOffset, 2)
else
inc(FOffset, 1);
//if Peek = #10 then
// ConsumeCRLF;
continue;
end;
#10:
begin
inc(FOffset);
continue;
end;
else
break;
end;
if not Next() then
break;
until EOF;
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
procedure TTextBuffer.ConsumeCRLF;
begin
if not Empty then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
if (FData[FOffset] = #13) then
begin
if FData[FOffset + 1] = #10 then
inc(FOffset, 2)
else
inc(FOffset);
inc(FRow);
FCol := 0;
end;
end;
end;
function TTextBuffer.Empty: boolean;
begin
result := FLength < 1;
end;
// This method will look ahead, skipping space, tab and crlf (also known
// as control characters), and when a non control character is found it will
// perform a string compare. This method uses a bookmark and will restore
// the offset to the same position as when it was entered.
//
// Notes: The method "NextNonControlChar" is a similar method that
// performs a char-only compare.
function TTextBuffer.NextNonControlText(const CompareWith: string): boolean;
begin
if Failed then
ClearLastError();
if not Empty then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
var Mark := Bookmark();
try
// Iterate ahead
repeat
if not (Current in [' ', #13, #10, #09]) then
break;
Next();
until EOF();
// Compare unless we hit the end of the line
if not EOF then
result := Compare(CompareWith, false);
finally
Restore(Mark);
end;
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
// This method will look ahead, skipping space, tab and crlf (also known
// as control characters), and when a non control character is found it will
// perform a string compare. This method uses a bookmark and will restore
// the offset to the same position as when it was entered.
function TTextBuffer.NextNonControlChar(const CompareWith: char): boolean;
begin
if Failed then
ClearLastError();
if not Empty then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
var Mark := Bookmark();
try
repeat
if not (Current in [' ', #13, #10, #09]) then
break;
Next();
until EOF();
//if not EOF then
result := Current.ToLower() = CompareWith.ToLower();
//result := LowerCase(Current) = LowerCase(CompareWith);
finally
Restore(Mark);
end;
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
function TTextBuffer.Peek: char;
begin
if Failed then
ClearLastError();
if not Empty then
begin
if (FOffset 0 do
begin
TextRead := TextRead + Current;
if not Next() then
break;
dec(CharCount);
end;
finally
Restore(Mark);
end;
result := TextRead.Length > 0;
end else
SetLastError(CNT_ERR_OFFSET_EOF);
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
function TTextBuffer.First: boolean;
begin
if Failed then
ClearLastError();
if not Empty then
begin
FOffset := Low(FData);
result := true;
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
function TTextBuffer.Last: boolean;
begin
if Failed then
ClearLastError();
if not Empty then
begin
FOffset := high(FData);
result := true;
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
function TTextBuffer.NextNoCrLf: boolean;
begin
if Failed then
ClearLastError();
if not Empty then
begin
// Check that we are not EOF
result := FOffset <= high(FData);
if result then
begin
// Update offset into buffer
inc(FOffset);
// update column, but not if its in a lineshift
if not (FData[FOffset] in [#13, #10]) then
inc(FCol);
end else
SetLastError(CNT_ERR_OFFSET_EOF);
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
function TTextBuffer.Next: boolean;
begin
if Failed then
ClearLastError();
if not Empty() then
begin
if BOF() then
begin
if not First() then
exit;
end;
if EOF() then
begin
SetLastError(CNT_ERR_OFFSET_EOF);
exit;
end;
// Update offset into buffer
inc(FOffset);
// update column
inc(FCol);
// This is the same as ConsumeCRLF
// But this does not generate any errors since we PEEK
// ahead into the buffer to make sure the combination
// is correct before we adjust the ROW + offset
if FOffset Low(FData));
if result then
dec(FOffset)
else
SetLastError(CNT_ERR_OFFSET_BOF);
end else
SetLastError(CNT_ERR_BUFFER_EMPTY);
end;
function TTextBuffer.Current: char;
begin
if Failed then
ClearLastError();
// Check that buffer is not empty
if not Empty then
begin
// Check that we are on char 1 or more
if FOffset >= Low(FData) then
begin
// Check that we are before or on the last char
if (FOffset <= high(FData)) then
result := FData[FOffset]
else
begin
SetLastError(CNT_ERR_OFFSET_EOF);
result := #0;
end;
end else
begin
SetLastError(CNT_ERR_OFFSET_BOF);
result := #0;
end;
end else
begin
SetLastError(CNT_ERR_BUFFER_EMPTY);
result := #0;
end;
end;
function TTextBuffer.BOF: boolean;
begin
if not Empty then
result := FOffset high(FData);
end;
function TTextBuffer.NextLine: boolean;
begin
if Failed then
ClearLastError();
if not Empty then
begin
// Make sure we offset to a valid character
// in the buffer.
ConsumeJunk();
if not EOF then
begin
var ThisRow := self.FRow;
while Row = ThisRow do
begin
Next();
if EOF then
break;
end;
result := (Row ThisRow) and (not EOF);
end;
end;
end;
function TTextBuffer.ReadWord(var TextRead: string): boolean;
begin
if Failed then
ClearLastError();
TextRead := '';
if not Empty then
begin
// Make sure we offset to a valid character
// in the buffer.
ConsumeJunk();
// Not at the end of the file?
if not EOF then
begin
repeat
var el := Current;
if (el in
[ 'A'..'Z',
'a'..'z',
'0'..'9',
'_', '-' ]) then
TextRead := TextRead + el
else
break;
if not NextNoCrLf() then
break;
until EOF;
result := TextRead.Length > 0;
end else
SetLastError('Failed to read word, unexpected EOF');
end else
SetLastError('Failed to read word, buffer is empty error');
end;
function TTextBuffer.ReadCommaList(var cList: List): boolean;
var
LTemp: String;
LValue: String;
begin
if cList = nil then
cList := new List
else
cList.Clear();
if not Empty then
begin
ConsumeJunk();
While not EOF do
begin
case Current of
#09:
begin
// tab, just skip
end;
#13, #10:
begin
// CR+LF, consume and continue;
ConsumeCRLF();
end;
#0:
begin
// Unexpected EOL
break;
end;
';':
begin
//Perfectly sound ending
result := true;
break;
end;
'"':
begin
LValue := ReadQuotedString;
if LValue.Length > 0 then
begin
cList.add(LValue);
LValue := '';
end;
end;
',':
begin
LTemp := LTemp.Trim();
if LTemp.Length>0 then
begin
cList.add(LTemp);
LTemp := '';
end;
end;
else
begin
LTemp := LTemp + Current;
end;
end;
if not Next() then
break;
end;
if LTemp.Length > 0 then
cList.add(LTemp);
result := cList.Count > 0;
end;
end;
function TTextBuffer.ReadQuotedString: string;
begin
if not Empty then
begin
if not EOF then
begin
// Make sure we are on the " entry quote
if Current '"' then
begin
SetLastError('Failed to read quoted string, expected index on " character error');
exit;
end;
// Skip the entry char
if not NextNoCrLf() then
begin
SetLastError('Failed to skip initial " character error');
exit;
end;
while not EOF do
begin
// Read char from buffer
var TempChar := Current;
// Closing of string? Exit
if TempChar = '"' then
begin
if not NextNoCrLf then
SetLastError('failed to skip final " character in string error');
break;
end;
result := result + TempChar;
if not NextNoCrLf() then
break;
end;
end;
end;
end;
//##########################################################################
// TParserModelObject
//##########################################################################
constructor TParserModelObject.Create(const AParent:TParserModelObject);
begin
inherited Create;
FParent := AParent;
FChildren := new List;
end;
function TParserModelObject.GetParent:TParserModelObject;
begin
result := FParent;
end;
procedure TParserModelObject.Clear;
begin
FChildren.Clear();
end;
function TParserModelObject.ChildGetCount: integer;
begin
result := FChildren.Count;
end;
function TParserModelObject.ChildGetItem(const Index: integer): TParserModelObject;
begin
result := TParserModelObject(FChildren[Index]);
end;
function TParserModelObject.ChildAdd(const Instance: TParserModelObject): TParserModelObject;
begin
if FChildren.IndexOf(Instance) < 0 then
FChildren.add(Instance);
result := Instance;
end;
//###########################################################################
// TParserContext
//###########################################################################
constructor TParserContext.Create(const SourceCode: string);
begin
inherited Create;
FBuffer := TTextBuffer.Create(SourceCode);
FStack := new Stack;
end;
procedure TParserContext.Push(const ModelObj: TParserModelObject);
begin
if Failed then
ClearLastError();
try
FStack.Push(ModelObj);
except
on e: Exception do
SetLastError('Internal error:' + e.Message);
end;
end;
function TParserContext.Pop: TParserModelObject;
begin
if Failed then
ClearLastError();
try
result := FStack.Pop();
except
on e: Exception do
SetLastError('Internal error:' + e.Message);
end;
end;
function TParserContext.Peek: TParserModelObject;
begin
if Failed then
ClearLastError();
try
result := FStack.Peek();
except
on e: Exception do
SetLastError('Internal error:' + e.Message);
end;
end;
procedure TParserContext.ClearStack;
begin
if Failed then
ClearLastError();
try
FStack.Clear();
except
on e: Exception do
SetLastError('Internal error:' + e.Message);
end;
end;
//###########################################################################
// TCustomParser
//###########################################################################
constructor TCustomParser.Create(const ParseContext: TParserContext);
begin
inherited Create;
FContext := ParseContext;
end;
function TCustomParser.Parse: boolean;
begin
result := false;
SetLastErrorF('No parser implemented for class %s',[ClassName]);
end;
procedure TCustomParser.SetContext(const NewContext: TParserContext);
begin
FContext := NewContext;
end;
end.
Share this:
Comments (0)
Trackbacks (0)
Leave a comment
Trackback
