Ghost of xmas past, or better known as the folder where old projects and abandoned ideas end up
I think everyone has a folder where they stuff old units, test projects and well – all those ideas that seemed awesome at the time, but you either discovered that it was crap, not enough time, or just forgot all about it. It happens. What can I say.
Yeah, I have one of those as well. And I also have those duplicate folders. You know, that time when you decided to make backups for everything – but then you got a new PC and now you dont have a clue which version to keep? And when you finally sit down with beyondcompare to get this sorted, you have managed to add to both copies.
Well, needless to say I had a day I just went apeshit about a year ago and sorted everything. And whatever did not fit into my neat new code-folder(s) was mercilessly stuffed into the dark, obscure folder known only as “stuff” or “misc”.
My first basic compiler, awwwww how cute
Well its not all rubbish! I did find a special version of my kitchen-sink research IDE, the IDE I use when trying out new code for DWScript, PaxCompiler and FreePascal. I think it has 4 compilers in it or something, yet its under 30 megabytes in size! Pretty neat 🙂
Visual Basic to Smart Pascal, awww…. just want to snuggle it 🙂
It also features a unified file-system! You can mount packages, FTP folders, network paths or local folders – the IDE could not care less, it is completely abstracted from the actual filesystem and relates only to symbols and identifiers. The actual storage is dealt with by the filesource classes.
Package, ftp, socket, local folder – the IDE could not care less
The Basic dialect here is essentially classical Visual Basic. The way you would write classes and deal with instances before dot net came along and forced all languages to look the same. I kinda like old visual basic, it had soul. It was completely useless except for scripting, and Delphi made it look like a joke – but as far as basic dialects go, it’s probably one of the cleanest and easiest to read.
DWScript, QTX Pascal (a custom fork of DWScript with a lot of cool features, some that Eric has added afterwards), Basic – and even freepascal! Thats the mother of all kitchen sinks!
The loss of QTX Pascal is a bit sad. I spent a couple of months doing my own fork of DWScript. Most of the features I added have now been included (although in another form) by Eric. But the codegen produced faster javascript. One of the things I spent some time on was optimization. Like getting rid of “variable = 0” type initialization if an assignment followed. I also added BeforeDestruction() and AfterConstruction() calls. This made an RTL a lot easier to write, but also more overhead. I was about to do conditional testing (so these would only be called if you actually used them) when I had to stop and work on Smart Mobile Studio again.
N++, exotic and functional!
This was one of my favorite language research projects. And dare I say, it is way ahead of it’s time. The idea is simple: with the future of computing being distributed, cloud based and powered by a multitude of computing modules from the US to South Africa — what would a programming language look like if built for 100% asyncronous, distributed execution?
Consider for instance, the execution of a procedure. Simple right? Well, in a truly distributed system – that procedure could execute anywhere. The whole point here is to utilize the combined power of each module (pc); which means a tasks could execute on different computers. A procedure could also be split up by the runtime environment and once again, be executed all over the place – with the dispatcher keeping track of when it’s done and whatever the result was (if any).
Only a spesific and generated on-demand “runtime context” would follow the task. This would contain things like variables it needs to execute, public symbols, basicaly just enough for the code to run successfully. This also includes resource forks (a term i used for accessing resources regardless of where they may be on the network).
The language design was actually done using Smart Mobile Studio (you can read more about the initial ideas here), and the first test modules ran on node.js (so no fancy graphics available sadly).
But it was incredibly fun to play with! But also time consuming to design a language for an execution model that havent really been invented yet. You can read more about some of my ideas for the execution model here.
I dont even think this execution model is out of the MIT labs yet — but it will once quantum compute models become commercially available (click here for a Berkley University published introduction to the basic computational models used in quantum information theory).
An N++ procedure (actually a microservice that consumed a WSDL service and calls it) looks like this:
program("service_test") {
handshake {
input {
/* Consume WSDL Web-Service Endpoint */
service1 @ service[URI:"http://www.test.com/SOAP/myService/WSDL/",
serviceType:SoapService];
}
output {
myProcess @ process("self");
stdio @ pipe("stdout");
}
}
/* Execute RPC call */
execute (stdio,service1) {
stdio:writeln("Calling webservice");
execute (*) {
var int32 result = 0;
set result = service1:getUserId("quartex","secret");
stdio:writelnF("UserID on server={0}", result);
} fail (e) {
stdio.writelnF("Calling soap service failed: {0}",e);
proceed;
}
}
/* Exit code for process */
set myProcess:exitCode = 0;
}
RML, Reduced markup language parser and runtime
Dont you just hate it when you lose the source-file for a programming language you made in a day, so now you dont have a clue what the syntax really was? I know, I know, but I honestly dont have the syntax or examples. It does with a disk ages ago.
RML was written to simplify generating HTML documents. There are a few things that you can optimize when it comes to HTML. First of all you know that the browser will read the document from top and downwards. This might not mean much at first glance, but it actually means that a language doesnt need the abillity to call emitter-code that has already executed (above). Think of it as being able to omit calls to procedure behind you in the source. That would be a mess for a language like delphi – but it doesnt impact a language that execute linear without any forms of jumps!
I seem to remember it looked something like this:
createobject(TRMLObject)
{
writestr("testing");
if(a=12)
{
readstr("mer testing");
}
}
createobject(TRMLHeading)
{
settitle("testing second object");
if(a=12)
{
writestr("heading object successfully done");
}
}
createobject(TRMLObject)
{
writestr("testing third object");
if(a=12)
{
readstr("mer testing from da third object");
}
}
The idea is ofcourse that you have some pre-defined objects, a bit like custom-controls in Smart Pascal, and you create and populate these in a top-down fashion.
Once defined, generating quite advanced HTML documents can be done extremely fast. Much faster than ASP, DWS or php since no jumps are involved.
Here is how you compile and run a small debug session (drop a memo and button on a form first):
var
FContext: TRMLParseContext;
FText: String;
begin
FText:= 'createobject(TRMLObject)'
+ '{'
+ ' writestr("testing");'
+ ' if(a=12)'
+ ' {'
+ ' readstr("mer testing");'
+ ' }'
+ '}'
+ 'createobject(TRMLHeading)'
+ '{'
+ ' settitle("testing second object");'
+ ' if(a=12)'
+ ' {'
+ ' writestr("heading object successfully done");'
+ ' }'
+ '}'
+ 'createobject(TRMLObject)'
+ '{'
+ ' writestr("testing third object");'
+ ' if(a=12)'
+ ' {'
+ ' readstr("mer testing from da third object");'
+ ' }'
+ '}';
// double the code, just to get some payload
FText := FText + FText;
memo1.text:='';
If RMLAllocContext(FContext,FText,[TRMLObject,TRMLHeading]) then
Begin
try
if RMLCompile(FContext) then
Begin
caption:='Compilation was a success';
If RMLExecute(FContext) then
Begin
Caption:='Executed successfully';
memo1.text:=FContext.pcOutput;
end;
end else
caption:=Format('compilation failed [%s]',[FContext.pcError]);
finally
RMLDisposeContext(FContext);
end;
end;
And here is the full code for the parser and runtime (still a few tidbits to work on, but its childs play). If you can make sense of it, knock yourself out 🙂
unit rml;
interface
uses sysutils, classes, dialogs;
type
TRMLObject = Class;
TRMLClass = Class of TRMLObject;
TRMLOperator = (opLess,opMore,opEquals,opNotEquals);
TRMLDataType = (daString,daNumber,daBoolean,daCustom);
TRMLEntryType = (etAssignment,etMethod,etRepeat,etCreate,etIf);
TRMLObjProc = Function (Const EntryData:Pointer):Boolean of Object;
(* represents a single condition in an IF statement *)
PRMLCondition = ^TRMLCondition;
TRMLCondition = Packed Record
coSource: String;
coTarget: String;
coOperator: TRMLOperator;
End;
(* represents a parsed code declaration *)
PRMLEntryDeclaration = ^TRMLEntryDeclaration;
TRMLEntryDeclaration = Packed Record
cxToken: String;
cxCondition: String;
End;
(* represents a compiled parameter *)
PRMLParameter = ^TRMLParameter;
TRMLParameter = Packed Record
prType: TRMLDataType;
prValue: Pointer;
prSize: Integer;
End;
(* represents a compiled code entry *)
PRMLEntryData = ^TRMLEntryData;
TRMLEntryData = Packed Record
edtype: TRMLEntryType;
edDeclaration: TRMLEntryDeclaration;
edObject: TRMLObject;
edParent: PRMLEntryData;
edMethod: TRMLObjProc;
edContext: Pointer;
edConditions: Array of PRMLCondition;
edParameters: Array of PRMLParameter;
edSubEntries: Array of PRMLEntryData;
End;
PRMLParseContext = ^TRMLParseContext;
TRMLParseContext = Packed Record
pcSignature: Integer;
pcCol: Integer;
pcRow: Integer;
pcPos: Integer;
pcLen: Integer;
pcData: String;
pcError: String;
pcOutput: String;
pcRoot: TRMLEntryData;
pcClasses: Array of TRMLClass;
End;
TRMLReadProc = Function (Var OutData;var Bytes:Integer):Boolean of Object;
TRMLWriteProc = Function (Var InData;Const Bytes:Integer):Boolean of Object;
TRMLProcEntry = Function (Const Entry:PRMLEntryData):Boolean of Object;
PRMLObjectIndex = ^TRMLObjectIndex;
TRMLObjectIndex = Packed Record
oiMethods: Array of record
omName: String;
omSyntax: Array of TRMLDataType;
omEntry: TRMLProcEntry;
end;
oiProperties: Array of record
oiName: String;
oiRead: TRMLReadProc;
oiWrite: TRMLWriteProc;
oiType: TRMLDataType;
end;
End;
TRMLObject = Class(TObject)
Private
FIndexData: TRMLObjectIndex;
FIndexPTR: PRMLObjectIndex;
Private
Function DoWriteStr(Const Entry:PRMLEntryData):Boolean;
Function DoReadStr(Const Entry:PRMLEntryData):Boolean;
protected
Procedure Output(Const Context:PRMLParseContext;Const Value:String);
Procedure RegisterProperty(Const Name:String;Const DataType:TRMLDataType;
Const _Read:TRMLReadProc;Const _Write:TRMLWriteProc);
Procedure RegisterMethod(Const Name:String;
Const Syntax: Array of TRMLDataType;
Const Entry: TRMLProcEntry);
Public
Property ObjectIndex:PRMLObjectIndex read FIndexPTR;
Constructor Create;virtual;
End;
TRMLHeading = Class(TRMLObject)
Private
FTitle: String;
Function DoSetTitle(Const Entry:PRMLEntryData):Boolean;
Function DoReadTitle(Var OutData;var Bytes:Integer):Boolean;
Function DoWriteTitle(Var InData;Const Bytes:Integer):Boolean;
Public
property Title:String read FTitle write FTitle;
Constructor Create;override;
End;
Function RMLAllocContext(var Context:TRMLParseContext;
Const Source:String;Const ClsBase:Array of TRMLClass):Boolean;
Function RMLDisposeContext(Var Context:TRMLParseContext):Boolean;
Function RMLCompile(Var Context:TRMLParseContext):Boolean;
Function RMLExecute(Const Context:TRMLParseContext):Boolean;
Function RMLParseEntry(Value:String;
var Declaration:TRMLEntryDeclaration;var Error:String):Boolean;
implementation
//###########################################################################
// TRMLHeading
//###########################################################################
Constructor TRMLHeading.Create;
Begin
inherited;
RegisterMethod('settitle',[daString],DoSetTitle);
RegisterProperty('title',daString,DoReadTitle,DoWriteTitle);
end;
Function TRMLHeading.DoSetTitle(Const Entry:PRMLEntryData):Boolean;
var
FTemp: String;
Begin
result:=length(Entry^.edParameters)>0;
If result and (Entry^.edParameters[0].prType=daString) then
DoWriteTitle(Entry^.edParameters[0].prValue^,
Entry^.edParameters[0].prSize);
end;
Function TRMLHeading.DoReadTitle(Var OutData;var Bytes:Integer):Boolean;
Begin
Bytes:=Length(FTitle);
If Bytes>0 then
move(FTitle[1],outData,Bytes);
end;
Function TRMLHeading.DoWriteTitle(Var InData;Const Bytes:Integer):Boolean;
Begin
SetLength(FTitle,bytes);
if Bytes>0 then
move(inData,FTitle[1],Bytes);
end;
//###########################################################################
// TRMLObject
//###########################################################################
Constructor TRMLObject.Create;
begin
inherited;
FIndexPTR:=@FIndexData;
RegisterMethod('writestr',[daString],DoWriteStr);
RegisterMethod('readstr',[daString],DoReadStr);
end;
Procedure TRMLObject.Output(Const Context:PRMLParseContext;
Const Value:String);
Begin
Context^.pcOutput:=Context^.pcOutput + Value;
end;
Function TRMLObject.DoReadStr(Const Entry:PRMLEntryData):Boolean;
var
FText: String;
Begin
result:=True;
With Entry^ do
Begin
FText:='Token: ' + edDeclaration.cxToken + #13#10;
FText:=FText + 'Condition: ' + edDeclaration.cxCondition + #13#10;
FText:=FText + #13#10;
Output(edContext,FText);
end;
end;
Function TRMLObject.DoWriteStr(Const Entry:PRMLEntryData):Boolean;
var
FText: String;
Begin
result:=True;
With Entry^ do
Begin
FText:='Token: ' + edDeclaration.cxToken + #13#10;
FText:=FText + 'Condition: ' + edDeclaration.cxCondition + #13#10;
FText:=FText + #13#10;
Output(edContext,FText);
end;
end;
Procedure TRMLObject.RegisterProperty(Const Name:String;
Const DataType:TRMLDataType;
Const _Read:TRMLReadProc;Const _Write:TRMLWriteProc);
var
FCount: Integer;
Begin
//FCount:=high(FIndexData.oiProperties) - Low(FIndexData.oiProperties) + 1;
FCount:=Length(FIndexData.oiProperties);
SetLength(FIndexData.oiProperties,FCount+1);
FIndexData.oiProperties[FCount].oiName:=Name;
FIndexData.oiProperties[FCount].oiRead:=_Read;
FIndexData.oiProperties[FCount].oiWrite:=_Write;
FIndexData.oiProperties[FCount].oiType:=DataType;
end;
Procedure TRMLObject.RegisterMethod(Const Name:String;
Const Syntax: Array of TRMLDataType;
Const Entry: TRMLProcEntry);
var
FCount: Integer;
FTemp: Integer;
Begin
//FCount:=high(FIndexData.oiMethods) - Low(FIndexData.oiMethods) + 1;
FCount:=Length(FIndexData.oiMethods);
SetLength(FIndexData.oiMethods,FCount+1);
FIndexData.oiMethods[FCount].omName:=Name;
FIndexData.oiMethods[FCount].omEntry:=Entry;
//FTemp:=high(Syntax) - Low(Syntax) + 1;
FTemp:=Length(Syntax);
If FTemp>0 then
Begin
SetLength(FIndexData.oiMethods[FCount].omSyntax,FTemp);
for FTemp:=low(syntax) to high(syntax) do
FIndexData.oiMethods[FCount].omSyntax[FTemp]:=Syntax[FTemp];
end;
end;
//###########################################################################
// RML util methods
//###########################################################################
Function RMLContainChars(Const Value:String;const Chars:String):Boolean;
var
x: Integer;
Begin
result:=True;
for x:=1 to length(chars) do
Begin
if pos(chars[x],Value)<1 then
Begin
result:=False;
Break;
end;
end;
end;
Function RMLScanFor(const Value:String;Const Target:CHAR;
Const Breakers:String;var Len:Integer):Boolean;
var
xpos: Integer;
Begin
result:=False;
Len:=-1;
xpos:=1;
while xpos<=Length(Value) do Begin If Value[xpos]=Target then Begin Len:=xpos-1; Result:=True; Break; end else Begin if pos(Value[xpos],Breakers)>0 then
Break;
end;
inc(xpos);
end;
end;
Function RMLisNumber(Const Value:String):Boolean;
const
CHARSET = '0123456789';
var
x: Integer;
Begin
Result:=True;
for x:=1 to length(Value) do
Begin
if pos(Value[x],CHARSET)<1 then
Begin
result:=False;
Break;
end;
end;
end;
Function RMLIsBoolean(Const Value:String):Boolean;
var
FTemp: String;
Begin
FTemp:=lowercase(trim(Value));
result:=(FTemp='false') or (FTemp='true');
end;
Function RMLisString(Const Value:String):Boolean;
var
x: Integer;
FLeft: Integer;
Begin
result:=False;
FLeft:=0;
(* check left side *)
for x:=1 to length(Value) do
Begin
if Value[x]='"' then
Begin
FLeft:=x;
Result:=True;
Break;
end else
if Value[x]<>#32 then
Break;
end;
(* check right side *)
If result then
Begin
for x:=Length(Value) downto 1 do
Begin
if Value[x]='"' then
Begin
If x>FLeft then
Break else
Begin
Result:=False;
Break;
end;
end else
if Value[x]<>#32 then
Break;
end;
end;
end;
Function RMLParseEntry(Value:String;
var Declaration:TRMLEntryDeclaration;
var Error:String):Boolean;
var
xpos: Integer;
Begin
fillchar(Declaration,SizeOf(Declaration),0);
Result:=RMLContainChars(value,'()');
if Result then
Begin
Result:=RMLScanFor(value,'(',')',xpos);
if result then
Begin
Declaration.cxToken:=trim(copy(value,1,xpos));
delete(value,1,xpos+1);
Result:=RMLScanFor(value,')','(',xpos);
if result then
Begin
Value:=TrimRight(Value);
Result:=xpos=(length(value)-1);
if result then
Declaration.cxCondition:=trim(Copy(Value,1,xpos));
end;
end;
end;
If not Result then
Error:='Invalid entry <' + value + '>';
end;
Function RMLAllocContext(var Context:TRMLParseContext;
Const Source:String;Const ClsBase:Array of TRMLClass):Boolean;
var
FCount: Integer;
Begin
If Context.pcSignature=SizeOf(Context) then
RMLDisposeContext(Context);
fillchar(Context,SizeOf(Context),#0);
Context.pcSignature:=SizeOf(Context);
Context.pcLen:=Length(Source);
Context.pcData:=Source;
FCount:=High(clsBase) - low(clsBase)+1;
If FCount>0 then
Begin
SetLength(Context.pcClasses,FCount);
for FCount:=Low(clsBase) to high(clsBase) do
Context.pcClasses[FCount]:=clsBase[FCount];
end;
result:=True;
end;
Procedure RMLDisposeEntryData(Const Data:PRMLEntryData);
var
FTemp: Integer;
x: Integer;
Begin
(* dispose of condition data *)
FTemp:=length(Data^.edConditions);
While FTemp>0 do
Begin
Dispose(Data^.edConditions[FTemp-1]);
dec(FTemp);
end;
SetLength(Data^.edConditions,0);
(* dispose of parameter data *)
FTemp:=length(Data^.edParameters);
While FTemp>0 do
Begin
If length(Data^.edParameters)>0 then
Begin
for x:=Low(Data^.edParameters) to high(Data^.edParameters) do
If Data^.edParameters[x]^.prSize>0 then
FreeMem(Data^.edParameters[x]^.prValue);
end;
Dispose(Data^.edParameters[FTemp-1]);
dec(FTemp);
end;
SetLength(Data^.edParameters,0);
(* dispose of sub entries *)
//Ftemp:=High(Data^.edSubEntries)-Low(Data^.edSubEntries)+1;
FTemp:=Length(Data^.edSubEntries);
While FTemp>0 do
Begin
RMLDisposeEntryData(Data^.edSubEntries[FTemp-1]);
Dec(FTemp);
end;
SetLength(Data^.edSubEntries,0);
(* dispose of script object *)
If not (Data^.edtype in [etIf,etRepeat,etMethod])
and (Data^.edObject<>NIL) then
Data^.edObject.free;
(* dispose of entry *)
Dispose(Data);
end;
Function RMLDisposeContext(Var Context:TRMLParseContext):Boolean;
var
FCount: Integer;
Begin
Result:=Context.pcSignature=SizeOf(Context);
If Result then
Begin
Context.pcSignature:=0;
Context.pcData:='';
Context.pcError:='';
FCount:=Length(Context.pcRoot.edSubEntries);
//FCount:=High(Context.pcRoot.edSubEntries)
//- Low(Context.pcRoot.edSubEntries) + 1;
While FCount>0 do
Begin
RMLDisposeEntryData(Context.pcRoot.edSubEntries[FCount-1]);
dec(FCount);
end;
SetLength(Context.pcRoot.edSubEntries,0);
end;
end;
//###########################################################################
// RML core methods
//###########################################################################
Function RMLImplements(Const MethodName:String;
Const obj:TRMLObject):Boolean;
var
FTable: PRMLObjectIndex;
FCount: Integer;
Begin
Result:=Obj<>NIL;
If result then
Begin
(* get object inex *)
FTable:=Obj.ObjectIndex;
//FCount:=High(FTable^.oiMethods) - low(FTable^.oiMethods) + 1;
FCount:=Length(FTable^.oiMethods);
Result:=FCount>0;
If Result then
Begin
for FCount:=low(FTable^.oiMethods) to high(FTable^.oiMethods) do
Begin
Result:=FTable^.oiMethods[FCount].omName=MethodName;
If Result then
Break;
end;
end;
end;
end;
Function RMLGetMethodEntry(Const MethodName:String;
Const obj:TRMLObject;var outEntry:TRMLObjProc):Boolean;
var
FTable: PRMLObjectIndex;
FCount: Integer;
Begin
Result:=Obj<>NIL;
If result then
Begin
(* get object inex *)
FTable:=Obj.ObjectIndex;
//FCount:=High(FTable^.oiMethods) - low(FTable^.oiMethods) + 1;
FCount:=Length(FTable^.oiMethods);
Result:=FCount>0;
If Result then
Begin
for FCount:=low(FTable^.oiMethods) to high(FTable^.oiMethods) do
Begin
Result:=FTable^.oiMethods[FCount].omName=MethodName;
If Result then
Begin
outEntry:=TRMLObjProc(FTable^.oiMethods[FCount].omEntry);
Break;
end;
end;
end;
end;
end;
Function RMLCreateObject(var Context:TRMLParseContext;
Const Objname:String;var outObject:TRMLObject;
var Error:String):Boolean;
var
FCount: Integer;
Begin
FCount:=High(Context.pcClasses) - Low(Context.pcClasses) + 1;
Result:=FCount>0;
if Result then
Begin
For FCount:=Low(Context.pcClasses) to high(Context.pcClasses) do
Begin
Result:=lowercase(Context.pcClasses[FCount].ClassName)=lowercase(objName);
If result then
Begin
outObject:=Context.pcClasses[FCount].Create;
Break;
end;
end;
end;
If not Result then
Error:='Unknown class <' + Objname + '>';
end;
Function RMLAddEntry(var Context:TRMLParseContext;
Var Declaration:TRMLEntryDeclaration;
Root:PRMLEntryData;var NewEntry:PRMLEntryData;
var Error:String):Boolean;
var
FCount: Integer;
x: Integer;
FTemp: String;
FLen: Integer;
FPar: PRMLParameter;
Begin
Result:=Root<>NIL;
If result then
Begin
(* create new entry *)
new(NewEntry);
(* Reset entry record *)
NewEntry^.edType:=etAssignment;
NewEntry^.edObject:=NIL;
NewEntry^.edMethod:=NIL;
SetLength(NewEntry^.edConditions,0);
SetLength(NewEntry^.edParameters,0);
SetLength(NewEntry^.edSubEntries,0);
(* Set basic values *)
NewEntry^.edParent:=Root;
NewEntry^.edContext:=@Context;
newEntry^.edDeclaration:=Declaration;
(* insert entry into parent *)
FCount:=Length(Root^.edSubEntries);
SetLength(Root^.edSubEntries,FCount+1);
Root^.edSubEntries[FCount]:=NewEntry;
(* tokenize *)
If declaration.cxToken='createobject' then
Begin
NewEntry^.edtype:=etCreate;
Result:=RMLCreateObject
(
Context,declaration.cxCondition,
NewEntry^.edObject,Error
);
end else
if declaration.cxToken='if' then
Begin
NewEntry^.edtype:=etIF;
NewEntry^.edObject:=NewEntry^.edParent.edObject;
end else
if declaration.cxToken='repeat' then
NewEntry^.edtype:=etRepeat else
Begin
(* method call? Make sure entry object supports this *)
Result:=NewEntry^.edParent.edObject<>NIL;
If Result then
Begin
(* check if object supports the method name *)
Result:=RMLImplements(declaration.cxToken,NewEntry^.edParent.edObject);
If Result then
Begin
(* Query object for method entry *)
Result:=RMLGetMethodEntry
(
declaration.cxToken,
NewEntry^.edParent.edObject,
NewEntry^.edMethod
);
If result then
Begin
NewEntry^.edtype:=etMethod;
NewEntry^.edObject:=NewEntry^.edParent.edObject;
(* now parse the parameter conditions *)
x:=0;
While x<Length(declaration.cxCondition) do Begin inc(x); If (declaration.cxCondition[x]=',') or (x=Length(declaration.cxCondition)) then Begin If x=Length(declaration.cxCondition) then FTemp:=FTemp + declaration.cxCondition[x]; FTemp:=trim(FTemp); If length(FTemp)>0 then
Begin
(* create a new parameter *)
FLen:=length(NewEntry^.edParameters);
setlength(NewEntry^.edParameters,FLen+1);
New(FPar);
If RMLIsString(FTemp) then
FPar^.prType:=daString else
if RMLIsNumber(FTemp) then
FPar^.prType:=daNumber else
if RMLIsBoolean(FTemp) then
FPar^.prType:=daBoolean else
FPar^.prType:=daCustom;
Case FPar^.prType of
daString:
Begin
Delete(FTemp,1,1);
Delete(FTemp,length(FTemp),1);
FPar^.prSize:=Length(FTemp);
FPar^.prValue:=AllocMem(FPar^.prSize);
move(FTemp[1],FPar^.prValue^,FPar^.prSize);
end;
daNumber:
Begin
FPar^.prSize:=SizeOf(Integer);
FPar^.prValue:=AllocMem(FPar^.prSize);
PInteger(FPar^.prValue)^:=StrToInt(FTemp);
end;
daBoolean:
Begin
end;
daCustom:
Begin
end;
end;
NewEntry^.edParameters[FLen]:=FPar;
FTemp:='';
end else
Begin
//Invalid parameter error
end;
end else
FTemp:=FTemp + declaration.cxCondition[x]
end;
{
Validate parameter datatypes here!
If (Length(NewEntry^.edParameters)>0) then
Begin
for x:=Low(NewEntry^.edParameters) to
high(NewEntry^.edParameters) do
Begin
newEntry^.edObject.
end;
end; }
end;
end else
Begin
// property assignment test here
end;
end;
end;
(* Failed to tokenize? *)
If not Result then
Begin
(* dispose of entry data *)
Dispose(NewEntry);
NewEntry:=NIL;
SetLength(Root^.edSubEntries,FCount);
Context.pcError:=Format('Invalid token "%s"',[declaration.cxToken]);
end;
end else
Error:='AddEntry failed, root can not be NIL';
end;
Function RMLParseObject(Var Context:TRMLParseContext;
Const Root:PRMLEntryData):Boolean;
var
FChar: Char;
FTemp: String;
FDeclaration: TRMLEntryDeclaration;
FNewEntry: PRMLEntryData;
Begin
Result:=Context.pcSignature=SizeOf(Context);
If result then
Begin
(* update cursor *)
inc(Context.pcPos);
inc(Context.pcCol);
while Result and (Context.pcPos<Context.pcLen) do
Begin
FChar:=Context.pcData[Context.pcPos];
Case FCHAR of
#13:
Begin
inc(Context.pcRow);
inc(Context.pcPos);
Context.pcCol:=0;
Continue;
end;
';':
Begin
Result:=RMLParseEntry(trim(FTemp),FDeclaration,Context.pcError);
If result then
Result:=RMLAddEntry
(
Context,
FDeclaration,
root,
FNewEntry,
Context.pcError
);
If Result then
Begin
inc(Context.pcPos);
inc(Context.pcCol);
If FNewEntry^.edtype=etIF then
Result:=RMLParseObject(Context,FNewEntry);
end;
FTemp:='';
end;
'{':
Begin
Result:=RMLParseEntry(FTemp,FDeclaration,Context.pcError);
If Result then
Begin
Result:=FDeclaration.cxToken='if';
If result then
Begin
Result:=RMLAddEntry
(
Context,
FDeclaration,
Root,
FNewEntry,
Context.pcError
);
If Result then
Result:=RMLParseObject(Context,FNewEntry);
end;
end;
FTemp:='';
end;
'}':
Begin
inc(Context.pcCol);
inc(Context.pcPos);
Break;
end;
else
Begin
FTemp:=FTemp + FChar;
inc(Context.pcCol);
inc(Context.pcPos);
end;
end;
end;
end;
end;
Function RMLExecute(Const Context:TRMLParseContext):Boolean;
Function RunEntry(Const Item:PRMLEntryData):Boolean;
var
FSubCount: Integer;
x: Integer;
Begin
result:=True;
Case Item^.edtype of
etCreate,
etAssignment:
Begin
FSubCount:=Length(Item^.edSubEntries);
for x:=1 to FSubCount do
Begin
result:=RunEntry(Item^.edSubEntries[x-1]);
If not result then
break;
end;
end;
etMethod:
Begin
{result:=RMLGetMethodEntry(Item^.edDeclaration.cxToken,
Item^.edObject,FEntry);
If result then
result:=FEntry(Item); }
Result:=TRMLProcEntry(Item^.edMethod)(Item);
end;
etRepeat:
Begin
//FSubCount:=Length(Item^.edSubEntries);
end;
etIf:
Begin
FSubCount:=Length(Item^.edSubEntries);
for x:=1 to FSubCount do
RunEntry(Item^.edSubEntries[x-1]);
end;
end;
End;
Begin
Result:=Context.pcSignature=SizeOf(Context);
If result then
Begin
result:=length(Context.pcError)<1;
If result then
result:=RunEntry(@Context.pcRoot);
end;
end;
Function RMLCompile(Var Context:TRMLParseContext):Boolean;
var
FChar: Char;
FTemp: String;
FDeclaration: TRMLEntryDeclaration;
FNewEntry: PRMLEntryData;
Begin
Result:=Context.pcSignature=SizeOf(Context);
If result then
Begin
Context.pcCol:=0;
Context.pcRow:=0;
Context.pcPos:=1;
Context.pcError:='';
while Result and (Context.pcPos<Context.pcLen) do
Begin
FChar:=Context.pcData[Context.pcPos];
Case FCHAR of
#13:
Begin
inc(Context.pcRow);
inc(Context.pcPos);
Context.pcCol:=0;
Continue;
end;
'{':
Begin
Result:=RMLParseEntry(FTemp,FDeclaration,Context.pcError);
If Result then
Begin
Result:=FDeclaration.cxToken='createobject';
If result then
Begin
Result:=RMLAddEntry
(
Context,
FDeclaration,
@Context.pcRoot,
FNewEntry,
Context.pcError
);
If Result then
Result:=RMLParseObject(Context,FNewEntry);
end;
end;
FTemp:='';
end;
'}':
Begin
end;
else
Begin
FTemp:=FTemp + FChar;
inc(Context.pcCol);
inc(Context.pcPos);
end;
end;
end;
end;
end;
end.
Jon L. Aasenden 
You must be logged in to post a comment.