Skip to content

Commit 19a3889

Browse files
slackydevslackydev
committed
more pascal parser stuff
1 parent 2d81166 commit 19a3889

8 files changed

Lines changed: 654 additions & 46 deletions

File tree

‎compiler/extra/xpr.pascalparser.pas‎

Lines changed: 174 additions & 42 deletions
Original file line numberDiff line numberDiff line change
@@ -109,7 +109,7 @@ TPascalParser = class(TObject)
109109
// -- routines ----------------------------------------------------------
110110
function ParseRoutine(IsFunction: Boolean; IsConstructor: Boolean = False;
111111
ForceForward: Boolean = False;
112-
ClsName: string = ''): XTree_Function;
112+
ClsName: string = ''): XTree_Node;
113113

114114
// -- statements --------------------------------------------------------
115115
function ParseBlock(): XTree_ExprList;
@@ -164,12 +164,32 @@ function ParsePascal(Tokenizer: TTokenizer; ctx: TCompilerContext = nil): XTree_
164164
ctx.AddType('longword', ctx.GetType(xtUInt32));
165165
ctx.AddType('word', ctx.GetType(xtUInt32));
166166
ctx.AddType('byte', ctx.GetType(xtUInt8));
167+
ctx.AddType('boolean', ctx.GetType(xtBool));
167168

168169
Parser := TPascalParser.Create(Tokenizer, ctx);
169170
Result := Parser.ParseProgram();
170171
Parser.Free();
171172
end;
172173

174+
175+
function CompoundToBinaryOp(CompOp: EOperator): EOperator;
176+
begin
177+
case CompOp of
178+
op_AsgnADD: Result := op_Add;
179+
op_AsgnSUB: Result := op_Sub;
180+
op_AsgnMUL: Result := op_Mul;
181+
op_AsgnDIV: Result := op_Div;
182+
op_AsgnMOD: Result := op_Mod;
183+
op_AsgnBND: Result := op_BND;
184+
op_AsgnBOR: Result := op_BOR;
185+
op_AsgnXOR: Result := op_XOR;
186+
op_AsgnSHL: Result := op_SHL;
187+
op_AsgnSHR: Result := op_SHR;
188+
else
189+
Result := op_Unknown;
190+
end;
191+
end;
192+
173193
// -----------------------------------------------------------------------------
174194
// Constructor / basic navigation
175195
// -----------------------------------------------------------------------------
@@ -253,8 +273,10 @@ function TPascalParser.GetPascalPrecedence(Token: ETokenKind): Int8;
253273
tkPLUS, tkMINUS,
254274
tkOR, tkXOR: Result := 4;
255275
tkEQ, tkNE, tkLT, tkLTE,
256-
tkGT, tkGTE, tkIN, tkKW_IS: Result := 3;
276+
tkGT, tkGTE, tkIN, tkKW_IS: Result := 3;
257277
tkASGN: Result := 2;
278+
tkPLUS_ASGN, tkMINUS_ASGN, tkMUL_ASGN, tkDIV_ASGN:
279+
Result := 2;
258280
else
259281
Result := -1;
260282
end;
@@ -548,7 +570,7 @@ function TPascalParser.ParseProgram(): XTree_Node;
548570

549571
function TPascalParser.ParseDeclarations(): XNodeArray;
550572
var
551-
FuncNode: XTree_Function;
573+
FuncNode: XTree_Node;
552574
S: string;
553575
begin
554576
Result := nil;
@@ -701,6 +723,11 @@ function TPascalParser.ParseTypeDefinition(): XType;
701723
TypeName, MangledName: string;
702724
ExplicitTypes: XTypeArray;
703725
i: Int32;
726+
IsFunc, IsRef: Boolean;
727+
ArgTypes: XTypeArray;
728+
ArgPass: TPassArgsBy;
729+
RetType, PType: XType;
730+
Idents: TStringArray;
704731
begin
705732
if Current.Token = tkKW_RECORD then
706733
begin
@@ -731,6 +758,69 @@ function TPascalParser.ParseTypeDefinition(): XType;
731758
begin
732759
FContext.RaiseException('Specialize var not yet implemented', DocPos);
733760
end
761+
else if (Current.Token = tkKW_FUNC) or
762+
((Current.Token = tkIDENT) and
763+
((XprCase(Current.Value) = 'function') or (XprCase(Current.Value) = 'procedure'))) then
764+
begin
765+
// Inline function pointer type: function(a, b: Int32): String;
766+
IsFunc := (Current.Token = tkKW_FUNC) or (XprCase(Current.Value) = 'function');
767+
Next(); // consume 'function' or 'procedure'
768+
769+
SetLength(ArgTypes, 0);
770+
SetLength(ArgPass, 0);
771+
RetType := nil;
772+
773+
if NextIf(tkLPARENTHESES) then
774+
begin
775+
while Current.Token <> tkRPARENTHESES do
776+
begin
777+
IsRef := NextIf(tkKW_VAR) or NextIf(tkKW_REF) or NextIfIdent('out');
778+
if NextIfIdent('const') then IsRef := False;
779+
780+
// Differentiate between named args "n: Int32" and unnamed args "Int32"
781+
if (Current.Token = tkIDENT) and (Peek(1).Token in [tkCOMMA, tkCOLON]) then
782+
begin
783+
SetLength(Idents, 0);
784+
repeat
785+
Idents += Current.Value;
786+
Consume(tkIDENT);
787+
until not NextIf(tkCOMMA);
788+
789+
Consume(tkCOLON);
790+
PType := ParseTypeDefinition();
791+
792+
for i := 0 to High(Idents) do
793+
begin
794+
ArgTypes += PType;
795+
if IsRef then ArgPass += pbRef else ArgPass += pbCopy;
796+
end;
797+
end
798+
else
799+
begin
800+
PType := ParseTypeDefinition();
801+
ArgTypes += PType;
802+
if IsRef then ArgPass += pbRef else ArgPass += pbCopy;
803+
end;
804+
805+
// Arguments can be separated by ';' or ',' in function signatures
806+
if not (NextIf(tkSEMI) or NextIf(tkCOMMA)) then Break;
807+
end;
808+
Consume(tkRPARENTHESES);
809+
end;
810+
811+
if IsFunc then
812+
begin
813+
Consume(tkCOLON);
814+
RetType := ParseTypeDefinition();
815+
end;
816+
817+
// Silently skip common Pascal modifiers: 'of object' or 'is nested'
818+
if NextIfIdent('of') then Consume(tkIDENT);
819+
if NextIfIdent('is') then Consume(tkIDENT);
820+
821+
Result := XType_Method.Create('', ArgTypes, ArgPass, RetType, False);
822+
FContext.AddManagedType(Result);
823+
end
734824
else if Current.Token = tkIDENT then
735825
begin
736826
// Handle qualified names (System.Integer etc.) – just take the last part
@@ -775,7 +865,7 @@ function TPascalParser.ParseEnum(const TypeName: string): XNodeArray;
775865
Doc: TDocPos;
776866
ET: XType_Enum;
777867
begin
778-
SetLength(Result, 0);
868+
Result := nil;
779869
Doc := DocPos;
780870
Consume(tkLPARENTHESES);
781871
EnumIdx := 0;
@@ -881,7 +971,7 @@ function TPascalParser.ParseClassDecl(const ClsName, GenericParams: string): XTr
881971
var
882972
Param, ParentName: string;
883973
Fields, TypeDecls, Methods: XNodeArray;
884-
FuncNode: XTree_Function;
974+
FuncNode: XTree_Node;
885975
IdentList: XIdentNodeList;
886976
FieldType: XType;
887977
Doc: TDocPos;
@@ -1129,7 +1219,7 @@ function TPascalParser.ParseVarBlock(IsConst: Boolean): XNodeArray;
11291219

11301220
function TPascalParser.ParseRoutine(IsFunction: Boolean; IsConstructor: Boolean = False;
11311221
ForceForward: Boolean = False;
1132-
ClsName: string = ''): XTree_Function;
1222+
ClsName: string = ''): XTree_Node;
11331223
var
11341224
FuncName, TypePrefix: string;
11351225
ArgsNames: TStringArray;
@@ -1166,6 +1256,7 @@ function TPascalParser.ParseRoutine(IsFunction: Boolean; IsConstructor: Boolean
11661256
FullMName, SavedMods: string;
11671257
j: Int32;
11681258
SplitMods: TStringArray;
1259+
S: string;
11691260
begin
11701261
Doc := DocPos;
11711262
IsDestructor := (not IsConstructor) and
@@ -1304,18 +1395,19 @@ function TPascalParser.ParseRoutine(IsFunction: Boolean; IsConstructor: Boolean
13041395
if IsForward then
13051396
begin
13061397
Result := XTree_Function.Create(FuncName, ArgsNames, ArgsPass, ArgsTypes, RetType, nil, FContext, Doc);
1307-
Result.isConstructor := IsConstructor;
1308-
Result.TypeParams := TypeParams;
1309-
Result.Annotations := Annotations;
1310-
Result.IsForwardDecl := True;
1398+
(Result as XTree_Function).isConstructor := IsConstructor;
1399+
(Result as XTree_Function).TypeParams := TypeParams;
1400+
SetLength((Result as XTree_Function).TypeConstraints, Length((Result as XTree_Function).TypeParams));
1401+
(Result as XTree_Function).Annotations := Annotations;
1402+
(Result as XTree_Function).IsForwardDecl := True;
13111403
if TypePrefix <> '' then
13121404
begin
1313-
Result.SelfType := FContext.GetType(TypePrefix);
1314-
if Result.SelfType = nil then
1405+
(Result as XTree_Function).SelfType := FContext.GetType(TypePrefix);
1406+
if (Result as XTree_Function).SelfType = nil then
13151407
begin
1316-
Result.SelfType := XType.Create(xtUnknown);
1317-
Result.SelfType.Name := TypePrefix;
1318-
FContext.AddManagedType(Result.SelfType);
1408+
(Result as XTree_Function).SelfType := XType.Create(xtUnknown);
1409+
(Result as XTree_Function).SelfType.Name := TypePrefix;
1410+
FContext.AddManagedType((Result as XTree_Function).SelfType);
13191411
end;
13201412
end;
13211413
Exit(Result);
@@ -1324,23 +1416,37 @@ function TPascalParser.ParseRoutine(IsFunction: Boolean; IsConstructor: Boolean
13241416
// -- Body -----------------------------------------------------------------
13251417
Body := XTree_ExprList.Create(FContext, DocPos);
13261418

1327-
// Local declarations (var / const / type / label)
1328-
while Current.Token in [tkKW_VAR, tkKW_TYPE, tkKW_CONST] do
1329-
begin
1330-
LocalDecls := ParseDeclarations();
1331-
for i := 0 to High(LocalDecls) do Body.List += LocalDecls[i];
1332-
end;
1333-
1334-
// Label declarations inside a function
1335-
if (Current.Token = tkIDENT) and (XprCase(Current.Value) = 'label') then
1419+
// Local declarations (var / const / type / label / nested routines)
1420+
while True do
13361421
begin
1337-
Next();
1338-
while Current.Token = tkIDENT do
1422+
if Current.Token in [tkKW_VAR, tkKW_TYPE, tkKW_CONST, tkKW_FUNC] then
13391423
begin
1340-
Next();
1341-
if not NextIf(tkCOMMA) then Break;
1342-
end;
1343-
NextIf(tkSEMI);
1424+
LocalDecls := ParseDeclarations();
1425+
for i := 0 to High(LocalDecls) do Body.List += LocalDecls[i];
1426+
end
1427+
else if Current.Token = tkIDENT then
1428+
begin
1429+
S := XprCase(Current.Value);
1430+
if (S = 'procedure') or (S = 'function') or (S = 'constructor') or (S = 'destructor') then
1431+
begin
1432+
LocalDecls := ParseDeclarations();
1433+
for i := 0 to High(LocalDecls) do Body.List += LocalDecls[i];
1434+
end
1435+
else if S = 'label' then
1436+
begin
1437+
Next();
1438+
while Current.Token = tkIDENT do
1439+
begin
1440+
Next();
1441+
if not NextIf(tkCOMMA) then Break;
1442+
end;
1443+
NextIf(tkSEMI);
1444+
end
1445+
else
1446+
Break; // Reached 'begin' or other statement, break out
1447+
end
1448+
else
1449+
Break;
13441450
end;
13451451

13461452
if TypePrefix <> '' then
@@ -1357,26 +1463,30 @@ function TPascalParser.ParseRoutine(IsFunction: Boolean; IsConstructor: Boolean
13571463
// -- Assemble -------------------------------------------------------------
13581464
Result := XTree_Function.Create(FuncName, ArgsNames, ArgsPass, ArgsTypes,
13591465
RetType, Body, FContext, Doc);
1360-
Result.isConstructor := IsConstructor;
1361-
Result.TypeParams := TypeParams;
1362-
Result.Annotations := Annotations;
1466+
(Result as XTree_Function).isConstructor := IsConstructor;
1467+
(Result as XTree_Function).TypeParams := TypeParams;
1468+
SetLength((Result as XTree_Function).TypeConstraints, Length((Result as XTree_Function).TypeParams));
1469+
(Result as XTree_Function).Annotations := Annotations;
13631470

13641471
// Type-bound method
13651472
if TypePrefix <> '' then
13661473
begin
1367-
Result.SelfType := FContext.GetType(TypePrefix);
1368-
if Result.SelfType = nil then
1474+
(Result as XTree_Function).SelfType := FContext.GetType(TypePrefix);
1475+
if (Result as XTree_Function).SelfType = nil then
13691476
begin
1370-
Result.SelfType := XType.Create(xtUnknown);
1371-
Result.SelfType.Name := TypePrefix;
1372-
FContext.AddManagedType(Result.SelfType);
1373-
FContext.AddType(TypePrefix, Result.SelfType, False); // Make sure it's known!
1477+
(Result as XTree_Function).SelfType := XType.Create(xtUnknown);
1478+
(Result as XTree_Function).SelfType.Name := TypePrefix;
1479+
FContext.AddManagedType((Result as XTree_Function).SelfType);
13741480
end;
13751481
end;
13761482

13771483
// If it's a method body bound to a class (and not ForceForward), it's the implementation!
13781484
if (TypePrefix <> '') and (not ForceForward) then
1379-
Result.IsImplementation := True;
1485+
(Result as XTree_Function).IsImplementation := True;
1486+
1487+
// Wrap in XTree_GenericFunction when type params are declared
1488+
if Length(TypeParams) > 0 then
1489+
Result := XTree_GenericFunction.Create(Result, FContext, Doc);
13801490
end;
13811491

13821492
// -----------------------------------------------------------------------------
@@ -1919,8 +2029,17 @@ function TPascalParser.ParsePrimary(): XTree_Node;
19192029
if IsPascalUnary(Current.Token) then
19202030
begin
19212031
op := Current; Next();
2032+
2033+
// Manually map Pascal unary operators to Express AST operators
2034+
// to bypass AsOperator raising an exception for unmapped tokens like tkAT.
2035+
if op.Token = tkAT then StepOp := op_Addr
2036+
else if op.Token = tkNOT then StepOp := op_NOT
2037+
else if op.Token = tkMINUS then StepOp := op_Sub
2038+
else if op.Token = tkPLUS then StepOp := op_Add
2039+
else StepOp := AsOperator(op.Token);
2040+
19222041
Result := XTree_UnaryOp.Create(
1923-
AsOperator(op.Token),
2042+
StepOp,
19242043
RHSExpr(ParsePrimary(), 8),
19252044
FContext, Doc);
19262045
end else
@@ -1935,6 +2054,7 @@ function TPascalParser.RHSExpr(Left: XTree_Node;
19352054
precedence, nextPrecedence: Int8;
19362055
Right: XTree_Node;
19372056
op: TToken;
2057+
binOp, CurrentOP: EOperator;
19382058
Doc: TDocPos;
19392059
clsName: string;
19402060
cArgs: XNodeArray;
@@ -1993,7 +2113,8 @@ function TPascalParser.RHSExpr(Left: XTree_Node;
19932113
Right := RHSExpr(Right, precedence + GetPascalAssoc(op.Token));
19942114
end;
19952115

1996-
case AsOperator(op.Token) of
2116+
CurrentOP := AsOperator(op.Token);
2117+
case CurrentOP of
19972118
op_Dot:
19982119
begin
19992120
if (Right is XTree_Identifier) and (XprCase(XTree_Identifier(Right).Name) = 'create') then
@@ -2020,6 +2141,17 @@ function TPascalParser.RHSExpr(Left: XTree_Node;
20202141
Left := XTree_Field.Create(Left, Right, FContext, Doc);
20212142
end;
20222143
op_Asgn: Left := XTree_Assign.Create(op_Asgn, Left, Right, FContext, Doc);
2144+
op_AsgnAdd..op_AsgnXOR:
2145+
begin
2146+
binOp := CompoundToBinaryOp(CurrentOP);
2147+
if binOp = op_Unknown then
2148+
FContext.RaiseExceptionFmt('Unsupported compound assignment operator: %s',
2149+
[OperatorToStr(CurrentOP)], DocPos);
2150+
Left := XTree_Assign.Create(
2151+
op_Asgn, Left,
2152+
XTree_BinaryOp.Create(binOp, Left, Right, FContext, DocPos),
2153+
FContext, DocPos);
2154+
end
20232155
else
20242156
Left := XTree_BinaryOp.Create(AsOperator(op.Token), Left, Right, FContext, Doc);
20252157
end;

‎compiler/extra/xpr.pascaltokenizer.pas‎

Lines changed: 16 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -139,12 +139,26 @@ function TokenizePascal(filename, script: string): TTokenizer;
139139
']': Result.AppendInc(tkRSQUARE, ']', 1);
140140

141141
// -- arithmetic --
142-
'+': Result.AppendInc(tkPLUS, '+', 1);
143-
'-': Result.AppendInc(tkMINUS, '-', 1);
142+
'+':
143+
if Result.Test('+=') then
144+
Result.AppendInc(tkPLUS_ASGN, '+=', 2)
145+
else
146+
Result.AppendInc(tkPLUS, '+', 1);
147+
'-':
148+
if Result.Test('-=') then
149+
Result.AppendInc(tkMINUS_ASGN, '¨-=', 2)
150+
else
151+
Result.AppendInc(tkMINUS, '-', 1);
144152
'*':
153+
if Result.Test('*=') then
154+
Result.AppendInc(tkMUL_ASGN, '*=', 2)
155+
else
145156
if Result.Test('**') then Result.AppendInc(tkPOW, '**', 2)
146157
else Result.AppendInc(tkMUL, '*', 1);
147158
'/':
159+
if Result.Test('/=') then
160+
Result.AppendInc(tkDIV_ASGN, '/=', 2)
161+
else
148162
if Result.Test('//') then Result.HandleComment()
149163
else Result.AppendInc(tkDIV, '/', 1);
150164

0 commit comments

Comments
 (0)