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.
You must be logged in to post a comment.