Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

Parser.pas

Visit:

Last change on this file was 108, checked in by chronos, 8 years ago
*Modified: Better parsing of variable reference.
File size: 42.4 KB

Line
1	unit Parser;
2
3	{$mode delphi}
4
5	interface
6
7	uses
8	Source;
9
10	procedure ParseProgram(ProgramCode: PProgramCode);
11
12
13	type
14	TTextPos = record
15	Index: Integer;
16	X: Integer;
17	Y: Integer;
18	PrevX: Integer;
19	PrevY: Integer;
20	end;
21
22	var
23	InnerText: string;
24	InnerTextPos: TTextPos;
25
26	implementation
27
28	type
29	TTokenType = (ttNormal, ttSpecialSymbol, ttString, ttConstant, ttNumber, ttChar,
30	ttComment, ttLineComment);
31
32	var
33	InputText: string;
34	InputTextPos: TTextPos;
35	InputTextFileName: string;
36	LastTokenType: TTokenType;
37
38	MainProgram: PProgramCode;
39	FunctionContext: PFunction;
40	CurrentTypeList: PTypes;
41
42
43	function ParseIfThen(IfThenElse: PIfThenElse): Boolean; forward;
44	function ParseWhileDo(WhileDo: PWhileDo): Boolean; forward;
45	function ParseExecution(Execution: PExecution): Boolean; forward;
46	function ParseBeginEnd(BeginEnd: PBeginEnd): Boolean; forward;
47	function ParseGetValue(GetValue: PGetValue; NoExpression: Boolean = False): Boolean; forward;
48	function ParseAssignment(Assignment: PAssignment): Boolean; forward;
49	function ParseUses(UsesSection: PUses): Boolean; forward;
50	function ParseType(TypeItem: PType; AllowForward: Boolean): Boolean; forward;
51	function ParseTypeFunction(TypeItem: PType; WithName: Boolean = True): Boolean; forward;
52	function ParseTypeProcedure(TypeItem: PType; WithName: Boolean = True): Boolean; forward;
53	function ParseVariableRef(VariableRef: PVariableRef): Boolean; forward;
54	function ParseExpression(Expression: PExpression): Boolean; forward;
55
56
57	function IsWhiteSpace(C: Char): Boolean;
58	begin
59	Result := (C = ' ') or (C = #13) or (C = #10) or (C = #9);
60	end;
61
62	function IsDigit(C: Char): Boolean;
63	begin
64	Result := (C >= '0') and (C <= '9');
65	end;
66
67	function IsAlpha(C: Char): Boolean;
68	begin
69	Result := ((C >= 'a') and (C <= 'z')) or ((C >= 'A') and (C <= 'Z'));
70	end;
71
72	function IsAlphaNumeric(C: Char): Boolean;
73	begin
74	Result := IsDigit(C) or IsAlpha(C);
75	end;
76
77	function IsSpecialSymbol(C: Char): Boolean;
78	begin
79	Result := (C = ';') or (C = '(') or (C = ')') or (C = ':') or (C = '=') or
80	(C = '+') or (C = '-') or (C = ';') or (C = '.') or (C = '{') or (C = '}') or
81	(C = ',') or (C = '^') or (C = '/') or (C = '[') or (C = ']') or (C = '@');
82	end;
83
84	function IsSpecialSymbolLong(Text: string): Boolean;
85	begin
86	Result := (Text = ':=') or (Text = '<>') or (Text = '>=') or (Text = '<=') or
87	(Text = '{$') or (Text = '//') or (Text = '..');
88	end;
89
90	function IsKeyword(Name: string): Boolean;
91	var
92	I: Integer;
93	begin
94	Result := False;
95	I := 0;
96	while I < Length(Keywords) do begin
97	if Keywords[I] = Name then begin
98	Result := True;
99	Break;
100	end;
101	I := I + 1;
102	end;
103	end;
104
105	function IsIdent(Name: string): Boolean;
106	var
107	I: Integer;
108	begin
109	if (Length(Name) >= 1) and IsAlpha(Name[1]) then begin
110	Result := True;
111	I := 2;
112	while I < Length(Name) do begin
113	if not IsAlphaNumeric(Name[I]) then begin
114	Result := False;
115	Break;
116	end;
117	I := I + 1;
118	end;
119	end else Result := False;
120	end;
121
122	function IntToStr(Value: Integer): string;
123	begin
124	Result := '';
125	while Value > 0 do begin
126	Result := Chr(Ord('0') + Value mod 10) + Result;
127	Value := Value div 10;
128	end;
129	end;
130
131	function GetPosText: string;
132	begin
133	Result := InputTextFileName + ' (' + IntToStr(InputTextPos.Y) + ',' + IntToStr(InputTextPos.X) + ')';
134	end;
135
136	procedure ShowError(Text: string);
137	begin
138	WriteLn(GetPosText + ' ' + Text);
139	WriteLn(Copy(InputText, InputTextPos.Index, 50));
140	Halt;
141	end;
142
143	procedure ReadInputAll(var F: Text);
144	var
145	LastC: Char;
146	C: Char;
147	Inner: Boolean;
148	begin
149	LastC := #0;
150	InputTextPos.Index := 1;
151	InputTextPos.X := 1;
152	InputTextPos.Y := 1;
153	InputTextPos.PrevX := 1;
154	InputTextPos.PrevY := 1;
155	InputText := '';
156	InnerTextPos.Index := 1;
157	InnerTextPos.PrevX := 1;
158	InnerTextPos.PrevY := 1;
159	InnerText := '';
160	Inner := False;
161	while not Eof(F) do begin
162	Read(F, C);
163	if ((LastC = #0) or (LastC = #13) or (LastC = #10)) and (C = '\|') then begin
164	Inner := True;
165	LastC := C;
166	Continue;
167	end else
168	if ((LastC = #0) or (LastC = #13) or (LastC = #10)) and (C <> '\|') then begin
169	Inner := False;
170	end;
171	if Inner then InnerText := InnerText + C
172	else InputText := InputText + C;
173	LastC := C;
174	end;
175	end;
176
177	function ReadChar: Char;
178	begin
179	if InputTextPos.Index >= Length(InputText) then ShowError('Premature end of source');
180	Result := InputText[InputTextPos.Index];
181	InputTextPos.Index := InputTextPos.Index + 1;
182	InputTextPos.PrevX := InputTextPos.X;
183	InputTextPos.PrevY := InputTextPos.Y;
184	InputTextPos.X := InputTextPos.X + 1;
185	if Result = #10 then begin
186	InputTextPos.Y := InputTextPos.Y + 1;
187	InputTextPos.X := 1;
188	end;
189	end;
190
191	procedure InputTextPosSetPrev;
192	begin
193	InputTextPos.X := InputTextPos.PrevX;
194	InputTextPos.Y := InputTextPos.PrevY;
195	InputTextPos.Index := InputTextPos.Index - 1;
196	end;
197
198	function StrToInt(S: string): Integer;
199	var
200	I: Integer;
201	N: Integer;
202	begin
203	Result := 0;
204	N := 1;
205	I := Length(S);
206	while I >= 1 do begin
207	Result := Result + (Ord(S[I]) - Ord('0')) * N;
208	N := N * 10;
209	I := I - 1;
210	end;
211	end;
212
213	function ReadNextInternal: string;
214	var
215	C: Char;
216	NextC: Char;
217	begin
218	Result := '';
219	LastTokenType := ttNormal;
220	repeat
221	C := ReadChar;
222	if LastTokenType = ttString then begin
223	if C = '''' then begin
224	Break;
225	end else Result := Result + C;
226	end else
227	if LastTokenType = ttNumber then begin
228	if not IsDigit(C) then begin
229	if Result[1] = '#' then begin
230	Result := Chr(StrToInt(Copy(Result, 2, Length(Result))));
231	LastTokenType := ttChar;
232	end;
233	InputTextPosSetPrev;
234	Break;
235	end else Result := Result + C;
236	end else
237	if LastTokenType = ttComment then begin
238	if C = '}' then LastTokenType := ttNormal;
239	end else
240	if LastTokenType = ttLineComment then begin
241	if (C = #13) or (C = #10) then LastTokenType := ttNormal;
242	end else begin
243	if IsWhiteSpace(C) then begin
244	if Result = '' then Continue
245	else begin
246	Break;
247	end;
248	end else
249	if IsSpecialSymbol(C) then begin
250	if Result = '' then begin
251	LastTokenType := ttSpecialSymbol;
252	Result := Result + C;
253	NextC := ReadChar;
254	if IsSpecialSymbolLong(Result + NextC) then begin
255	Result := Result + NextC;
256	if Result = '//' then begin
257	Result := '';
258	LastTokenType := ttLineComment;
259	Continue;
260	end;
261	Break;
262	end else begin
263	if C = '{' then begin
264	Result := '';
265	LastTokenType := ttComment;
266	Continue;
267	end else InputTextPosSetPrev;
268	end;
269	Break;
270	end else begin
271	InputTextPosSetPrev;
272	Break;
273	end;
274	end else
275	if C = '#' then begin
276	Result := Result + '#';
277	LastTokenType := ttNumber;
278	end else
279	if IsDigit(C) then begin
280	Result := Result + C;
281	LastTokenType := ttNumber;
282	end else
283	if C = '''' then begin
284	LastTokenType := ttString;
285	end else begin
286	Result := Result + C;
287	end;
288	end;
289	until False;
290	end;
291
292	function ReadNext: string;
293	begin
294	Result := ReadNextInternal;
295	WriteLn(GetPosText + ' ReadNext: ' + Result);
296	end;
297
298	function CheckNext(Text: string): Boolean;
299	var
300	Next: string;
301	OldPos: TTextPos;
302	begin
303	OldPos := InputTextPos;
304	Next := ReadNextInternal;
305	Result := Next = Text;
306	InputTextPos := OldPos;
307	WriteLn(GetPosText + ' Check: ' + Next + ', ' + Text);
308	end;
309
310	procedure Expect(Text: string);
311	var
312	Next: string;
313	begin
314	Next := ReadNextInternal;
315	WriteLn(GetPosText + ' Expect: ' + Next + ', ' + Text);
316	if Next <> Text then
317	ShowError('Expected ' + Text + ' but found ' + Next);
318	end;
319
320	function CheckNextExpect(Text: string): Boolean;
321	var
322	Next: string;
323	OldPos: TTextPos;
324	begin
325	OldPos := InputTextPos;
326	Next := ReadNextInternal;
327	Result := Next = Text;
328	if not Result then InputTextPos := OldPos;
329	WriteLn(GetPosText + 'CheckExpect: ' + Next + ', ' + Text);
330	end;
331
332	function IsLogicOperator(Text: string): Boolean;
333	begin
334	Result := (Text = 'or') or (Text = 'and');
335	end;
336
337	function IsOperator(Text: string): Boolean;
338	begin
339	Result := (Text = '+') or (Text = '-') or
340	(Text = '=') or (Text = '<>') or (Text = '>') or (Text = '<') or
341	(Text = '<=') or (Text = '>=');
342	end;
343
344	procedure AssignGetValue(Dest, Source: PGetValue);
345	begin
346	Dest^.Value := Source^.Value;
347	Dest^.VariableRef := Source^.VariableRef;
348	Dest^.Constant := Source^.Constant;
349	Dest^.Expression := Source^.Expression;
350	Dest^.FunctionCall := Source^.FunctionCall;
351	Dest^.ReadType := Source^.ReadType;
352	end;
353
354	procedure AssignVariableRef(Dest, Source: PVariableRef);
355	begin
356	Dest^.Index := Source^.Index;
357	Dest^.Variable := Source^.Variable;
358	Dest^.Field := Source^.Field;
359	end;
360
361	function ParseVariableRef(VariableRef: PVariableRef): Boolean;
362	var
363	OldPos: TTextPos;
364	Next: string;
365	SelfVariable: PVariable;
366	IndexValue: TGetValue;
367	FieldType: PType;
368	Variable: PVariable;
369	begin
370	OldPos := InputTextPos;
371	repeat
372	Next := ReadNext;
373	if Assigned(VariableRef^.Variable) and (VariableRef^.Variable^.DataType^.BaseType = btRecord) then begin
374	VariableRef^.Field := VariableRef^.Variable^.DataType^.Fields^.GetByName(Next);
375	end else begin
376	if FunctionContext = nil then begin
377	Variable := MainProgram^.Variables.GetByName(Next);
378	VariableRef^.Variable := Variable;
379	end else begin
380	Variable := FunctionContext^.Variables.GetByName(Next);
381	if (Variable = nil) then begin
382	SelfVariable := FunctionContext^.Variables.GetByName('Self');
383	if (SelfVariable <> nil) and (SelfVariable^.Value.ValueRecord <> nil) then begin
384	Variable := SelfVariable^.Value.ValueRecord^.GetByName(Next);
385	if Variable <> nil then
386	VariableRef^.Variable := Variable;
387	end;
388	end else VariableRef^.Variable := Variable;
389	end;
390	end;
391	if VariableRef^.Variable <> nil then begin
392	Result := True;
393	if CheckNext('[') then begin
394	if VariableRef^.Variable^.DataType^.BaseType = btArray then begin
395	Expect('[');
396	if ParseGetValue(@IndexValue) then begin
397	VariableRef^.Index := GetMem(SizeOf(TGetValue));
398	AssignGetValue(VariableRef^.Index, @IndexValue);
399	end else ShowError('Expected index value but found ' + ReadNext);
400	Expect(']');
401	end else ShowError('Unexpected array index');
402	end;
403	if CheckNextExpect('.') then begin
404
405	Continue;
406	end else Break;
407	end else begin
408	Result := False;
409	InputTextPos := OldPos;
410	Break;
411	end;
412	until False;
413	end;
414
415	function ParseVariablePointer(Variable: PVariableRef): Boolean;
416	begin
417	Result := False;
418	if CheckNext('@') then begin
419	Expect('@');
420	Result := True;
421	ParseVariableRef(Variable);
422	end;
423	end;
424
425	function ParseConstant(out Constant: PConstant): Boolean;
426	var
427	OldPos: TTextPos;
428	Next: string;
429	begin
430	OldPos := InputTextPos;
431	Next := ReadNext;
432	Constant := MainProgram^.Constants.GetByName(Next);
433	if Constant <> nil then begin
434	Result := True;
435	end else begin
436	Result := False;
437	InputTextPos := OldPos;
438	end;
439	end;
440
441	function GetOperatorType(Name: string): TOperator;
442	var
443	I: Integer;
444	begin
445	I := 0;
446	while (I < Length(OperatorString)) and (OperatorString[TOperator(I)] <> Name) do Inc(I);
447	if I < Length(OperatorString) then Result := TOperator(I)
448	else Result := opNone;
449	end;
450
451	function ParseOperator(out ExpOperator: TOperator): Boolean;
452	var
453	OldPos: TTextPos;
454	OperatorName: string;
455	begin
456	OldPos := InputTextPos;
457	OperatorName := ReadNext;
458	ExpOperator := GetOperatorType(OperatorName);
459	if ExpOperator <> opNone then begin
460	Result := True;
461
462	end else begin
463	InputTextPos := OldPos;
464	Result := False;
465	end;
466	end;
467
468	function ParseValue(Value: PConstant): Boolean;
469	var
470	OldPos: TTextPos;
471	Text: string;
472	begin
473	Result := True;
474	OldPos := InputTextPos;
475	Text := ReadNext;
476	if LastTokenType = ttString then begin
477	Value.DataType := MainProgram.Types.GetByName('string');
478	Value.ValueString := Text;
479	end else
480	if LastTokenType = ttChar then begin
481	Value.DataType := MainProgram.Types.GetByName('Char');
482	Value.ValueChar := Text[1];
483	end else
484	if LastTokenType = ttNumber then begin
485	Value.DataType := MainProgram.Types.GetByName('Integer');
486	//Value.ValueInteger := StrToInt(Text);
487	end else begin
488	Result := False;
489	InputTextPos := OldPos;
490	end;
491	end;
492
493	procedure DeleteExpressionItem(Expression: PExpression; Index: Integer);
494	var
495	I: Integer;
496	begin
497	I := Index;
498	while (I + 1) < Length(Expression^.Items) do begin
499	Expression^.Items[I] := Expression^.Items[I + 1];
500	I := I + 1;
501	end;
502	SetLength(Expression^.Items, Length(Expression^.Items) - 1);
503	end;
504
505	function ParseExpression(Expression: PExpression): Boolean;
506	var
507	GetValue: TGetValue;
508	ExpOperator: TOperator;
509	SubExpression: TExpression;
510	I: Integer;
511	II: Integer;
512	FoundOperator: Boolean;
513	OldPos: TTextPos;
514	//E: TExpression;
515	begin
516	OldPos := InputTextPos;
517	Result := True;
518	FoundOperator := False;
519	repeat
520	FillChar(GetValue, SizeOf(TGetValue), 0);
521	if CheckNext('(') then begin
522	Expect('(');
523	SetLength(SubExpression.Items, 0);
524	if ParseExpression(@SubExpression) then begin
525	SetLength(Expression^.Items, Length(Expression^.Items) + 1);
526	Expression^.Items[Length(Expression^.Items) - 1] := SubExpression;
527	end;
528	Expect(')');
529	end else
530	if ParseOperator(ExpOperator) then begin
531	SetLength(Expression^.Items, Length(Expression^.Items) + 1);
532	Expression^.Items[Length(Expression^.Items) - 1].NodeType := ntOperator;
533	Expression^.Items[Length(Expression^.Items) - 1].OperatorType := ExpOperator;
534	FoundOperator := True;
535	end else
536	if ParseGetValue(@GetValue, True) then begin
537	SetLength(Expression^.Items, Length(Expression^.Items) + 1);
538	Expression^.Items[Length(Expression^.Items) - 1].NodeType := ntValue;
539	Expression^.Items[Length(Expression^.Items) - 1].Value := GetValue;
540	end else begin
541	Result:= True;
542	Break;
543	end;
544	//WriteLn('Items count: ' + IntToStr(Length(Expression^.Items)));
545	until False;
546	if not FoundOperator then begin
547	Result := False;
548	InputTextPos := OldPos;
549	Exit;
550	end;
551
552	if Length(Expression^.Items) > 0 then begin
553	// Build expression tree using operator precedence
554	for II := 0 to Length(OperatorPrecedence) - 1 do begin
555	I := 0;
556	while (I < Length(Expression^.Items) - 1) do begin
557	//E := TExpression(Expression^.Items[I]);
558	if (TExpression(Expression^.Items[I]).NodeType = ntOperator) and
559	not TExpression(Expression^.Items[I]).Associated and
560	(TExpression(Expression^.Items[I]).OperatorType = OperatorPrecedence[II]) then
561	begin
562	//WriteLn('Expression operator ' + OperatorString[OperatorPrecedence[II]]);
563	if Expression^.Items[I].OperatorType = opNot then begin
564	Expression^.Items[I].Associated := True;
565	SetLength(Expression^.Items[I].Items, 1);
566	Expression^.Items[I].Items[0] := Expression^.Items[I + 1];
567	DeleteExpressionItem(Expression, I + 1);
568	end else begin
569	Expression^.Items[I].Associated := True;
570	SetLength(Expression^.Items[I].Items, 2);
571	Expression^.Items[I].Items[0] := Expression^.Items[I - 1];
572	Expression^.Items[I].Items[1] := Expression^.Items[I + 1];
573	DeleteExpressionItem(Expression, I + 1);
574	DeleteExpressionItem(Expression, I - 1);
575	end;
576	end else Inc(I);
577	end;
578	end;
579
580	if Length(Expression^.Items) = 1 then begin
581	Expression^.NodeType := Expression^.Items[0].NodeType;
582	Expression^.OperatorType := Expression^.Items[0].OperatorType;
583	Expression^.Value := Expression^.Items[0].Value;
584	// Move subtitem one node up
585	SetLength(Expression^.Items, Length(Expression^.Items[0].Items));
586	I := Length(Expression^.Items) - 1;
587	while I >= 0 do begin
588	Expression^.Items[I] := Expression^.Items[0].Items[I];
589	I := I - 1;
590	end;
591	end else ShowError('Expression error. Items count: ' + IntToStr(Length(Expression^.Items)));
592	end;
593	end;
594
595	procedure AssignExpression(ExpDst, ExpSrc: PExpression);
596	var
597	I: Integer;
598	begin
599	ExpDst^.OperatorType := ExpSrc^.OperatorType;
600	ExpDst^.NodeType := ExpSrc^.NodeType;
601	ExpDst^.Associated := ExpSrc^.Associated;
602	ExpDst^.Value := ExpSrc^.Value;
603	SetLength(ExpDst^.Items, 1); //Length(ExpSrc^.Items));
604	for I := 0 to Length(ExpDst^.Items) - 1 do
605	ExpDst^.Items[I] := ExpSrc^.Items[I];
606	end;
607
608	function ParseGetValue(GetValue: PGetValue; NoExpression: Boolean = False): Boolean;
609	var
610	VariableRef: TVariableRef;
611	Constant: PConstant;
612	FunctionCall: TExecution;
613	Expression: TExpression;
614	Value: TConstant;
615	begin
616	FillChar(Expression, SizeOf(TExpression), 0);
617	FillChar(FunctionCall, SizeOf(TFunctionCall), 0);
618	FillChar(Value, SizeOf(TConstant), 0);
619	FillChar(VariableRef, SizeOf(TVariableRef), 0);
620
621	Result := True;
622	if not NoExpression and ParseExpression(@Expression) then begin
623	GetValue^.ReadType := rtExpression;
624	GetValue^.Expression := GetMem(SizeOf(TExpression));
625	FillChar(GetValue^.Expression^, SizeOf(TExpression), 0);
626	GetValue^.Expression^ := Expression;
627	//AssignExpression(GetValue^.Expression, @Expression);
628	end else
629	if ParseVariableRef(@VariableRef) then begin
630	GetValue^.ReadType := rtVariable;
631	GetValue^.VariableRef := GetMem(SizeOf(TVariableRef));
632	AssignVariableRef(GetValue^.VariableRef, @VariableRef);
633	end else
634	if ParseConstant(Constant) then begin
635	GetValue^.ReadType := rtConstant;
636	GetValue^.Constant := Constant;
637	end else
638	if ParseValue(@Value) then begin
639	GetValue^.ReadType := rtValue;
640	GetValue^.Value := Value;
641	end else
642	if ParseVariablePointer(@VariableRef) then begin
643	GetValue^.ReadType := rtValue;
644	GetValue^.VariableRef := GetMem(SizeOf(TVariableRef));
645	AssignVariableRef(GetValue^.VariableRef, @VariableRef);
646	end else
647	if ParseExecution(@FunctionCall) then begin
648	GetValue^.ReadType := rtFunctionCall;
649	GetValue^.FunctionCall := GetMem(SizeOf(TFunctionCall));
650	FillChar(GetValue^.FunctionCall^, SizeOf(TFunctionCall), 0);
651	GetValue^.FunctionCall^ := FunctionCall;
652	end else
653	Result := False;
654	end;
655
656	function ParseAssignment(Assignment: PAssignment): Boolean;
657	var
658	Variable: TVariableRef;
659	begin
660	FillChar(Variable, SizeOf(TVariableRef), 0);
661	if ParseVariableRef(@Variable) then begin
662	Result := True;
663	Assignment^.Destination := GetMem(SizeOf(TVariable));
664	AssignVariableRef(Assignment^.Destination, @Variable);
665	Expect(':=');
666	ParseGetValue(@Assignment^.Source);
667	end else begin
668	Result := False;
669	end;
670	end;
671
672	function ParseExecution(Execution: PExecution): Boolean;
673	var
674	OldPos: TTextPos;
675	Next: string;
676	Func: PFunction;
677	I: Integer;
678	begin
679	Result := True;
680	OldPos := InputTextPos;
681	Next := ReadNext;
682	Func := MainProgram.Functions.GetByName(Next);
683	if Func <> nil then begin
684	Execution^.Func := Func;
685	SetLength(Execution^.Parameters.Items, Length(Func^.Parameters.Items));
686	if Length(Func^.Parameters.Items) > 0 then begin
687	Expect('(');
688	I := 0;
689	while I < Length(Func^.Parameters.Items) do begin
690	if ParseGetValue(@Execution^.Parameters.Items[I]) then begin
691	end else ShowError('Value exprected but found ' + ReadNext);
692
693	if I < (Length(Func^.Parameters.Items) - 1) then Expect(',');
694	I := I + 1;
695	end;
696	Expect(')');
697	end;
698	end else begin
699	InputTextPos := OldPos;
700	Result := False;
701	end;
702	end;
703
704	function ParseCommand(Command: PCommand): Boolean;
705	var
706	IfThenElse: TIfThenElse;
707	WhileDo: TWhileDo;
708	BeginEnd: TBeginEnd;
709	Execution: TExecution;
710	Assignment: TAssignment;
711	begin
712	FillChar(IfThenElse, SizeOf(TIfThenElse), 0);
713	FillChar(WhileDo, SizeOf(TWhileDo), 0);
714	FillChar(BeginEnd, SizeOf(TBeginEnd), 0);
715	FillChar(Execution, SizeOf(TExecution), 0);
716	FillChar(Assignment, SizeOf(TAssignment), 0);
717
718	Result := True;
719	if ParseBeginEnd(@BeginEnd) then begin
720	Command^.BeginEnd := GetMem(SizeOf(TBeginEnd));
721	FillChar(Command^.BeginEnd^, SizeOf(TBeginEnd), 0);
722	Command^.BeginEnd^ := BeginEnd;
723	Command^.CmdType := ctBeginEnd;
724	end else
725	if ParseAssignment(@Assignment) then begin
726	Command^.Assignment := GetMem(SizeOf(TAssignment));
727	FillChar(Command^.Assignment^, SizeOf(TAssignment), 0);
728	Command^.Assignment^ := Assignment;
729	Command^.CmdType := ctAssignment;
730	end else
731	if ParseExecution(@Execution) then begin
732	Command^.Execution := GetMem(SizeOf(TExecution));
733	FillChar(Command^.Execution^, SizeOf(TExecution), 0);
734	Command^.Execution^ := Execution;
735	Command^.CmdType := ctExecution;
736	end else
737	if ParseIfThen(@IfThenElse) then begin
738	Command^.IfThenElse := GetMem(SizeOf(TIfThenElse));
739	FillChar(Command^.IfThenElse^, SizeOf(TIfThenElse), 0);
740	Command^.IfThenElse^ := IfThenElse;
741	Command^.CmdType := ctIfThenElse;
742	end else
743	if ParseWhileDo(@WhileDo) then begin
744	Command^.WhileDo := GetMem(SizeOf(TWhileDo));
745	FillChar(Command^.WhileDo^, SizeOf(TWhileDo), 0);
746	Command^.WhileDo^ := WhileDo;
747	Command^.CmdType := ctWhileDo;
748	end else Result := False;
749	end;
750
751	function ParseIfThen(IfThenElse: PIfThenElse): Boolean;
752	begin
753	if CheckNext('if') then begin
754	Result := True;
755	Expect('if');
756	ParseGetValue(@IfThenElse.Condition);
757	Expect('then');
758	ParseCommand(@IfThenElse^.DoThen);
759	if CheckNext('else') then begin
760	Expect('else');
761	ParseCommand(@IfThenElse^.DoElse);
762	end;
763	end else Result := False;
764	end;
765
766	function ParseWhileDo(WhileDo: PWhileDo): Boolean;
767	begin
768	if CheckNextExpect('while') then begin
769	Result := True;
770	ParseGetValue(@WhileDo.Condition);
771	Expect('do');
772	ParseCommand(@WhileDo^.Command);
773	end else Result := False;
774	end;
775
776	function ParseBeginEnd(BeginEnd: PBeginEnd): Boolean;
777	var
778	Command: TCommand;
779	begin
780	if CheckNextExpect('begin') then begin
781	Result := True;
782	SetLength(BeginEnd^.Commands, 0);
783	repeat
784	if ParseCommand(@Command) then begin
785	BeginEnd^.Add;
786	BeginEnd^.GetLast^ := Command;
787	Expect(';');
788	end else
789	if CheckNext('end') then begin
790	Expect('end');
791	Break;
792	end else ShowError('Expected command but found ' + ReadNext);
793	until False;
794	end else Result := False;
795	end;
796
797	function ParseParams(Params: PFunctionParameters): Boolean;
798	var
799	ParamNames: array of string;
800	ParamTypeName: string;
801	ParamType: PType;
802	I: Integer;
803	DefaultValue: string;
804	begin
805	if CheckNext('(') then begin
806	Result := True;
807	Expect('(');
808	repeat
809	SetLength(ParamNames, 0);
810	repeat
811	SetLength(ParamNames, Length(ParamNames) + 1);
812	ParamNames[Length(ParamNames) - 1] := ReadNext;
813	if CheckNext(',') then begin
814	Expect(',');
815	Continue;
816	end else
817	if CheckNext(':') then Break;
818	until False;
819	Expect(':');
820	ParamTypeName := ReadNext;
821	if CheckNext('=') then begin
822	Expect('=');
823	DefaultValue := ReadNext;
824	end;
825	if Params^.TypeList = nil then ParamType := nil
826	else ParamType := Params^.TypeList^.GetByName(ParamTypeName);
827	if ParamType <> nil then begin
828	I := 0;
829	while I < Length(ParamNames) do begin
830	Params^.Add(FunctionParameterCreate(ParamNames[I], ParamType));
831	FunctionContext^.Variables.Add(VariableCreate(ParamNames[I], ParamType));
832	I := I + 1;
833	end;
834	end else ShowError('Unknown parameter type ' + ParamTypeName);
835	if CheckNext(';') then begin
836	Expect(';');
837	Continue;
838	end else
839	if CheckNext(')') then Break
840	else ShowError('Expected ; or ) but Found ' + ReadNext);
841	until False;
842	Expect(')');
843	end else Result := False;
844	end;
845
846	function ParseVariableSection(Variables: PVariables): Boolean;
847	var
848	VarName: string;
849	VarType: PType;
850	OldPos: TTextPos;
851	Value: string;
852	I: Integer;
853	begin
854	if CheckNext('var') then begin
855	Result := True;
856	Expect('var');
857	repeat
858	OldPos := InputTextPos;
859	VarName := ReadNext;
860	if IsKeyword(VarName) then begin
861	InputTextPos := OldPos;
862	Break;
863	end else begin
864	Expect(':');
865	VarType := GetMem(SizeOf(TType));
866	FillChar(VarType^, SizeOf(TType), 0);
867	VarType^.TypeList := CurrentTypeList;
868	if ParseType(VarType, False) then begin
869	Variables^.Add(VariableCreate(VarName, VarType));
870	// Create subvariables for structured record type variable
871	if VarType^.BaseType = btRecord then begin
872	SetLength(Variables^.GetLast^.Value.ValueRecord.Items, 0);
873	I := 0;
874	while (I < Length(VarType^.Fields^.Items)) do begin
875	Variables^.GetLast^.Value.ValueRecord^.Add(
876	VariableCreate(VarType^.Fields^.Items[I].Name, @VarType^.Fields^.Items[I]));
877	I := I + 1;
878	end;
879	end;
880	end else ShowError('Unknown variable type ' + ReadNext);
881	if CheckNext('=') then begin
882	Expect('=');
883	Expect('(');
884	repeat
885	Value := ReadNext;
886	if CheckNext(',') then begin
887	Expect(',');
888	Continue;
889	end else
890	if CheckNext(')') then Break
891	else ShowError('Expected , or ) but found ' + ReadNext);
892	until False;
893	Expect(')');
894	end;
895	Expect(';');
896	end;
897	until False;
898	end else Result := False;
899	end;
900
901	function ParseConstantSection(Constants: PConstants): Boolean;
902	var
903	ConstName: string;
904	ConstType: PType;
905	OldPos: TTextPos;
906	Value: string;
907	begin
908	if CheckNext('const') then begin
909	Result := True;
910	Expect('const');
911	repeat
912	OldPos := InputTextPos;
913	ConstName := ReadNext;
914	if IsKeyword(ConstName) then begin
915	InputTextPos := OldPos;
916	Break;
917	end else begin
918	Expect(':');
919	ConstType := GetMem(SizeOf(TType));
920	FillChar(ConstType^, SizeOf(TType), 0);
921	ConstType^.TypeList := CurrentTypeList;
922	if ParseType(ConstType, False) then begin
923	Constants^.Add(ConstantCreate(ConstName, ConstType));
924	end else ShowError('Unknown variable type ' + ReadNext);
925	if CheckNext('=') then begin
926	Expect('=');
927	Expect('(');
928	repeat
929	Value := ReadNext;
930	if CheckNext(',') then begin
931	Expect(',');
932	Continue;
933	end else
934	if CheckNext(')') then Break
935	else ShowError('Expected , or ) but found ' + ReadNext);
936	until False;
937	Expect(')');
938	end;
939	Expect(';');
940	end;
941	until False;
942	end else Result := False;
943	end;
944
945	function ParseFunction(Func: PFunction): Boolean;
946	var
947	ReturnType: string;
948	DataType: PType;
949	I: Integer;
950	begin
951	if CheckNext('function') then begin
952	Result := True;
953	Expect('function');
954	FunctionContext := Func;
955	repeat
956	Func^.Name := ReadNext;
957	if CheckNext('.') then begin
958	Expect('.');
959	Func^.ParentRecord := Func^.Types.GetByName(Func^.Name);
960	Func^.Variables.Add(VariableCreate('Self', Func^.ParentRecord));
961	Func^.Variables.GetLast^.Value.ValueRecord := GetMem(SizeOf(TVariables));
962	FillChar(Func^.Variables.GetLast^.Value.ValueRecord^, SizeOf(TVariables), 0);
963	I := 0;
964	while I < Length(Func^.ParentRecord.Fields.Items) do begin
965	Func^.Variables.GetLast^.Value.ValueRecord^.Add(
966	VariableCreate(Func^.ParentRecord.Fields.Items[I].Name,
967	@(Func^.ParentRecord.Fields.Items[I])));
968	I := I + 1;
969	end;
970	Continue;
971	end else Break;
972	until False;
973	Func^.Parameters.TypeList := @Func^.Types;
974	ParseParams(@Func^.Parameters);
975	Expect(':');
976	ReturnType := ReadNext;
977	DataType := Func^.Types.GetByName(ReturnType);
978	if DataType <> nil then Func^.ReturnType := DataType
979	else ShowError('Unknown type ' + ReturnType);
980	Expect(';');
981	Func^.Variables.Add(VariableCreate('Result', Func^.ReturnType));
982	if ParseVariableSection(@Func^.Variables) then begin
983	end;
984	ParseBeginEnd(@Func^.BeginEnd);
985	FunctionContext := nil;
986	Expect(';');
987	end else Result := False;
988	end;
989
990	function ParseProcedure(Func: PFunction): Boolean;
991	var
992	I: Integer;
993	begin
994	if CheckNext('procedure') then begin
995	Result := True;
996	Expect('procedure');
997	FunctionContext := Func;
998	repeat
999	Func^.Name := ReadNext;
1000	if CheckNext('.') then begin
1001	Expect('.');
1002	Func^.ParentRecord := Func^.Types.GetByName(Func^.Name);
1003	Func^.Variables.Add(VariableCreate('Self', Func^.ParentRecord));
1004	Func^.Variables.GetLast^.Value.ValueRecord := GetMem(SizeOf(TVariables));
1005	FillChar(Func^.Variables.GetLast^.Value.ValueRecord^, SizeOf(TVariables), 0);
1006	I := 0;
1007	while I < Length(Func^.ParentRecord.Fields.Items) do begin
1008	Func^.Variables.GetLast^.Value.ValueRecord^.Add(
1009	VariableCreate(Func^.ParentRecord.Fields.Items[I].Name,
1010	@(Func^.ParentRecord.Fields.Items[I])));
1011	I := I + 1;
1012	end;
1013	Continue;
1014	end else Break;
1015	until False;
1016	Func^.Parameters.TypeList := @Func^.Types;
1017	ParseParams(@Func^.Parameters);
1018	Expect(';');
1019	if ParseVariableSection(@Func^.Variables) then begin
1020	end;
1021	ParseBeginEnd(@Func^.BeginEnd);
1022	FunctionContext := nil;
1023	Expect(';');
1024	end else Result := False;
1025	end;
1026
1027	function ParseDirective(Directive: PDirective): Boolean;
1028	begin
1029	if CheckNextExpect('{$') then begin
1030	Directive^.Name := ReadNext;
1031	Directive^.Value := ReadNext;
1032	Result := True;
1033	Expect('}');
1034	end else Result := False;
1035	end;
1036
1037	function ParseTypeEnumeration(TypeItem: PType): Boolean;
1038	var
1039	Name: string;
1040	begin
1041	if CheckNext('(') then begin
1042	Result := True;
1043	Expect('(');
1044	TypeItem^.BaseType := btEnumeration;
1045	TypeItem^.States := GetMem(SizeOf(TEnumerationStates));
1046	FillChar(TypeItem^.States^, SizeOf(TEnumerationStates), 0);
1047	repeat
1048	Name := ReadNext;
1049	SetLength(TypeItem^.States^.Items, Length(TypeItem^.States^.Items) + 1);
1050	TypeItem^.States^.Items[Length(TypeItem^.States^.Items) - 1] := Name;
1051	if CheckNext(',') then begin
1052	Expect(',');
1053	Continue;
1054	end else Break;
1055	until False;
1056	Expect(')');
1057	end else Result := False;
1058	end;
1059
1060	function ParseTypeArray(TypeItem: PType): Boolean;
1061	var
1062	IndexTypeName: string;
1063	RangeFrom: string;
1064	RangeTo: string;
1065	begin
1066	if CheckNext('array') then begin
1067	Result := True;
1068	Expect('array');
1069	if CheckNext('[') then begin
1070	Expect('[');
1071	IndexTypeName := ReadNext;
1072	if CheckNext('..') then begin
1073	Expect('..');
1074	RangeFrom := IndexTypeName;
1075	RangeTo := ReadNext;
1076	end;
1077	Expect(']');
1078	end;
1079	Expect('of');
1080	TypeItem^.BaseType := btArray;
1081	TypeItem^.ArrayItemType := GetMem(SizeOf(TType));
1082	FillChar(TypeItem^.ArrayItemType^, SizeOf(TType), 0);
1083	TypeItem^.ArrayItemType^.TypeList := TypeItem^.TypeList;
1084	if ParseType(TypeItem^.ArrayItemType, True) then begin
1085	end;
1086	end else Result := False;
1087	end;
1088
1089	function ParseTypeSimple(TypeItem: PType): Boolean;
1090	var
1091	OldPos: TTextPos;
1092	Name: string;
1093	T: PType;
1094	begin
1095	OldPos := InputTextPos;
1096	Name := ReadNext;
1097	T := TypeItem^.TypeList^.GetByName(Name);
1098	if T <> nil then begin
1099	Result := True;
1100	TypeItem^.BaseType := btSimple;
1101	TypeItem^.Simple := T;
1102	end else begin
1103	Result := False;
1104	InputTextPos := OldPos;
1105	end;
1106	end;
1107
1108	function ParseTypeSimpleForward(TypeItem: PType): Boolean;
1109	var
1110	OldPos: TTextPos;
1111	Name: string;
1112	begin
1113	OldPos := InputTextPos;
1114	Name := ReadNext;
1115	if IsIdent(Name) then begin
1116	Result := True;
1117	TypeItem^.BaseType := btSimpleForward;
1118	TypeItem^.ForwardType := Name;
1119	end else begin
1120	Result := False;
1121	InputTextPos := OldPos;
1122	end;
1123	end;
1124
1125	function ParseTypePointer(TypeItem: PType): Boolean;
1126	begin
1127	if CheckNext('^') then begin
1128	Result := True;
1129	Expect('^');
1130	TypeItem^.BaseType := btPointer;;
1131	TypeItem^.PointedType := GetMem(SizeOf(TType));
1132	FillChar(TypeItem^.PointedType^, SizeOf(TType), 0);
1133	TypeItem^.PointedType^.TypeList := TypeItem^.TypeList;
1134	if ParseType(@TypeItem^.PointedType, True) then begin
1135	end else
1136	end else Result := False;
1137	end;
1138
1139	function ParseTypeRecordCase(TypeItem: PType): Boolean;
1140	var
1141	NewType: TType;
1142	Name: string;
1143	Control: string;
1144	begin
1145	if CheckNext('case') then begin
1146	Result := True;
1147	Expect('case');
1148	Control := ReadNext;
1149	Expect('of');
1150
1151	TypeItem^.BaseType := btRecordCase;
1152	TypeItem^.CaseItems := GetMem(SizeOf(TTypes));;
1153	repeat
1154	FillChar(NewType, SizeOf(TType), 0);
1155	NewType.TypeList := TypeItem^.TypeList;
1156	Name := ReadNext;
1157	Expect(':');
1158	Expect('(');
1159
1160	NewType.Name := ReadNext;
1161	NewType.TypeList := TypeItem.TypeList;
1162	Expect(':');
1163	if ParseType(@NewType, False) then begin
1164	TypeItem^.CaseItems.Add(NewType);
1165	end;
1166	Expect(')');
1167	Expect(';');
1168	if CheckNext('end') then Break;
1169	until False;
1170	end else Result := False;
1171	end;
1172
1173	function ParseTypeRecord(TypeItem: PType): Boolean;
1174	var
1175	NewType: TType;
1176	Name: string;
1177	CaseActivated: Boolean;
1178	begin
1179	CaseActivated := False;
1180	if CheckNextExpect('record') then begin
1181	Result := True;
1182	TypeItem^.BaseType := btRecord;
1183	TypeItem^.Fields := GetMem(SizeOf(TTypes));;
1184	repeat
1185	FillChar(NewType, SizeOf(TType), 0);
1186	NewType.TypeList := TypeItem^.TypeList;
1187	if ParseTypeProcedure(@NewType) then begin
1188	TypeItem^.Fields.Add(NewType);
1189	end else
1190	if ParseTypeFunction(@NewType) then begin
1191	TypeItem^.Fields.Add(NewType);
1192	end else
1193	if ParseTypeRecordCase(@NewType) then begin
1194	TypeItem^.Fields.Add(NewType);
1195	CaseActivated := True;
1196	end else begin
1197	NewType.Name := ReadNext;
1198	NewType.TypeList := TypeItem.TypeList;
1199	Expect(':');
1200	if ParseType(@NewType, False) then begin
1201	TypeItem^.Fields.Add(NewType);
1202	end;
1203	end;
1204	if not CaseActivated then Expect(';');
1205	if CheckNext('end') then Break;
1206	until False;
1207	Expect('end');
1208	end else Result := False;
1209	end;
1210
1211	function ParseTypeFunction(TypeItem: PType; WithName: Boolean = True): Boolean;
1212	var
1213	ReturnType: string;
1214	DataType: PType;
1215	begin
1216	if CheckNext('function') then begin
1217	Result := True;
1218	Expect('function');
1219	TypeItem^.BaseType := btFunction;
1220	TypeItem^.Func := GetMem(SizeOf(TFunction));
1221	FillChar(TypeItem^.Func^, SizeOf(TFunction), 0);
1222	FunctionContext := TypeItem^.Func;
1223	if WithName then TypeItem^.Func^.Name := ReadNext;
1224	TypeItem^.Func^.Parameters.TypeList := TypeItem^.TypeList;
1225	ParseParams(@TypeItem^.Func^.Parameters);
1226	Expect(':');
1227	ReturnType := ReadNext;
1228	DataType := TypeItem^.TypeList.GetByName(ReturnType);
1229	if DataType <> nil then TypeItem^.Func^.ReturnType := DataType
1230	else ShowError('Unknown type ' + ReturnType);
1231	TypeItem^.Func^.Variables.Add(VariableCreate('Result', TypeItem^.Func^.ReturnType));
1232	FunctionContext := nil;
1233	end else Result := False;
1234	end;
1235
1236	function ParseTypeProcedure(TypeItem: PType; WithName: Boolean = True): Boolean;
1237	begin
1238	if CheckNext('procedure') then begin
1239	Result := True;
1240	Expect('procedure');
1241	TypeItem^.BaseType := btFunction;
1242	TypeItem^.Func := GetMem(SizeOf(TFunction));
1243	FillChar(TypeItem^.Func^, SizeOf(TFunction), 0);
1244	FunctionContext := TypeItem^.Func;
1245	TypeItem^.Func^.Parameters.TypeList := TypeItem^.TypeList;
1246	if WithName then TypeItem^.Func^.Name := ReadNext;
1247	ParseParams(@TypeItem^.Func^.Parameters);
1248	FunctionContext := nil;
1249	end else Result := False;
1250	end;
1251
1252	function ParseType(TypeItem: PType; AllowForward: Boolean): Boolean;
1253	begin
1254	Result := True;
1255	if ParseTypeProcedure(TypeItem, False) then begin
1256	end else
1257	if ParseTypeFunction(TypeItem, False) then begin
1258	end else
1259	if ParseTypeEnumeration(TypeItem) then begin
1260	end else
1261	if ParseTypeArray(TypeItem) then begin
1262	end else
1263	if ParseTypePointer(TypeItem) then begin
1264	end else
1265	if ParseTypeRecord(TypeItem) then begin
1266	end else
1267	if ParseTypeSimple(TypeItem) then begin
1268	end else
1269	if AllowForward and ParseTypeSimpleForward(TypeItem) then begin
1270	end else begin
1271	Result := False;
1272	end;
1273	end;
1274
1275	function ParseTypes(Types: PTypes): Boolean;
1276	var
1277	Name: string;
1278	TypeName: string;
1279	OldPos: TTextPos;
1280	NewType: TType;
1281	begin
1282	if CheckNext('type') then begin
1283	Result := True;
1284	Expect('type');
1285	repeat
1286	NewType.TypeList := Types;
1287	NewType.Name := ReadNext;
1288	Expect('=');
1289	if ParseType(@NewType, False) then begin
1290	Types^.Add(NewType);
1291	end;
1292	Expect(';');
1293
1294	OldPos := InputTextPos;
1295	Name := ReadNext;
1296	if IsKeyword(Name) then begin
1297	InputTextPos := OldPos;
1298	Break;
1299	end;
1300	InputTextPos := OldPos;
1301	until False;
1302
1303	end else Result := False;
1304	end;
1305
1306	function ParseUnit(UnitItem: PUnit; FileName, ShortFileName: string): Boolean;
1307	var
1308	OldInputText: string;
1309	OldInputTextPos: TTextPos;
1310	OldInputTextFileName: string;
1311	UnitFile: Text;
1312	Directive: TDirective;
1313	NewType: TType;
1314	NewFunc: TFunction;
1315	begin
1316	OldInputText := InputText;
1317	OldInputTextPos := InputTextPos;
1318	OldInputTextFileName := InputTextFileName;
1319
1320	InputTextFileName := ShortFileName;
1321
1322	AssignFile(UnitFile, FileName);
1323	Reset(UnitFile);
1324	ReadInputAll(UnitFile);
1325
1326	Expect('unit');
1327	UnitItem^.Name := ReadNext;
1328	Expect(';');
1329
1330	ParseDirective(@Directive);
1331
1332	Expect('interface');
1333	ParseUses(@UnitItem^.UsesSection);
1334	UnitItem^.Types.ParentList := @MainProgram.Types;
1335	NewType.TypeList := @UnitItem^.Types;
1336	CurrentTypeList := @UnitItem^.Types;
1337	repeat
1338	if ParseTypes(@UnitItem^.Types) then begin
1339	end else
1340	if ParseVariableSection(@UnitItem^.Variables) then begin
1341	end else
1342	if ParseConstantSection(@UnitItem^.Constants) then begin
1343	end else
1344	if ParseTypeProcedure(@NewType) then begin
1345	Expect(';');
1346	end else
1347	if ParseTypeFunction(@NewType) then begin
1348	Expect(';');
1349	end else
1350	if CheckNext('implementation') then Break;
1351	until False;
1352
1353	Expect('implementation');
1354
1355	repeat
1356	SetLength(NewFunc.Parameters.Items, 0);
1357	SetLength(NewFunc.Variables.Items, 0);
1358	NewFunc.Types.ParentList := @UnitItem^.Types;
1359	if ParseFunction(@NewFunc) then begin
1360	UnitItem.Functions.Add(NewFunc);
1361	end else
1362	if ParseProcedure(@NewFunc) then begin
1363	UnitItem.Functions.Add(NewFunc);
1364	end else Break;
1365	until False;
1366
1367	Expect('end');
1368	Expect('.');
1369
1370	CloseFile(UnitFile);
1371
1372	InputText := OldInputText;
1373	InputTextPos := OldInputTextPos;
1374	InputTextFileName := OldInputTextFileName;
1375	end;
1376
1377	function ParseUses(UsesSection: PUses): Boolean;
1378	var
1379	Next: string;
1380	UnitItem: PUnit;
1381	begin
1382	if CheckNextExpect('uses') then begin
1383	Result := True;
1384	repeat
1385	Next := ReadNext;
1386	SetLength(UsesSection^.Items, Length(UsesSection^.Items) + 1);
1387	UsesSection^.Items[Length(UsesSection^.Items) - 1] := Next;
1388
1389	UnitItem := MainProgram.Units.GetByName(Next);
1390	if UnitItem = nil then begin
1391	SetLength(MainProgram.Units.Items, Length(MainProgram.Units.Items) + 1);
1392	ParseUnit(@MainProgram.Units.Items[Length(MainProgram.Units.Items) - 1], MainProgram.BaseDir + '/' + Next + '.pas', Next + '.pas');
1393	end;
1394
1395	Next := ReadNext;
1396	if Next = ',' then Continue
1397	else if Next = ';' then Break
1398	else ShowError('Expected , or ; but found ' + Next);
1399	until False;
1400	end else Result := False;
1401	end;
1402
1403	procedure ParserInit(ProgramCode: PProgramCode);
1404	var
1405	TypeString: PType;
1406	TypeShortString: PType;
1407	TypeBoolean: PType;
1408	TypeInteger: PType;
1409	TypeChar: PType;
1410	TypeArray: PType;
1411	FuncWriteLn: PFunction;
1412	FuncLength: PFunction;
1413	FuncSetLength: PFunction;
1414	FuncRead: PFunction;
1415	begin
1416	SetLength(ProgramCode^.Types.Items, 0);
1417	ProgramCode^.Types.Add(TypeCreate('string', btShortString));
1418	TypeString := ProgramCode^.Types.GetLast;
1419	ProgramCode^.Types.Add(TypeCreate('Boolean', btBoolean));
1420	TypeBoolean := ProgramCode^.Types.GetLast;
1421	ProgramCode^.Types.Add(TypeCreate('Integer', btInteger));
1422	TypeInteger := ProgramCode^.Types.GetLast;
1423	ProgramCode^.Types.Add(TypeCreate('Char', btChar));
1424	TypeChar := ProgramCode^.Types.GetLast;
1425	ProgramCode^.Types.Add(TypeCreate('Array', btArray));
1426	TypeArray := ProgramCode^.Types.GetLast;
1427	ProgramCode^.Types.Add(TypeCreate('shortstring', btShortString));
1428	TypeShortString := ProgramCode^.Types.GetLast;
1429
1430	SetLength(ProgramCode^.Variables.Items, 0);
1431
1432	SetLength(ProgramCode^.Constants.Items, 0);
1433	ProgramCode^.Constants.Add(ConstantCreate('nil', nil));
1434
1435	SetLength(ProgramCode^.Functions.Items, 0);
1436	ProgramCode^.Functions.Add(FunctionCreate('Halt', nil));
1437	ProgramCode^.Functions.Add(FunctionCreate('WriteLn', nil));
1438	FuncWriteLn := ProgramCode^.Functions.GetLast;
1439	FuncWriteLn^.Parameters.Add(FunctionParameterCreate('Text', TypeString));
1440	FuncWriteLn^.Variables.Add(VariableCreate('Text', TypeString));
1441	ProgramCode^.Functions.Add(FunctionCreate('Read', nil));
1442	FuncRead := ProgramCode^.Functions.GetLast;
1443	FuncRead^.Parameters.Add(FunctionParameterCreate('Output', TypeChar, True));
1444	FuncRead^.Variables.Add(VariableCreate('Output', TypeChar));
1445	ProgramCode^.Functions.Add(FunctionCreate('Eof', TypeBoolean));
1446	ProgramCode^.Functions.Add(FunctionCreate('Length', TypeInteger));
1447	FuncLength := ProgramCode^.Functions.GetLast;
1448	FuncLength^.Parameters.Add(FunctionParameterCreate('Array', TypeArray));
1449	FuncLength^.Variables.Add(VariableCreate('Array', TypeArray));
1450	ProgramCode^.Functions.Add(FunctionCreate('SetLength', nil));
1451	FuncSetLength := ProgramCode^.Functions.GetLast;
1452	FuncSetLength^.Parameters.Add(FunctionParameterCreate('Array', TypeArray));
1453	FuncSetLength^.Variables.Add(VariableCreate('Array', TypeArray));
1454	FuncSetLength^.Parameters.Add(FunctionParameterCreate('Count', TypeInteger));
1455	FuncSetLength^.Variables.Add(VariableCreate('Count', TypeInteger));
1456	end;
1457
1458	procedure ParseProgram(ProgramCode: PProgramCode);
1459	var
1460	NewFunc: TFunction;
1461	Directive: TDirective;
1462	begin
1463	MainProgram := ProgramCode;
1464	ParserInit(ProgramCode);
1465	ReadInputAll(Input);
1466	InputTextFileName := 'Input';
1467	if CheckNextExpect('program') then begin
1468	ProgramCode.Name := ReadNext;
1469	Expect(';');
1470	end;
1471	ParseDirective(@Directive);
1472	ParseUses(@ProgramCode.UsesSection);
1473	repeat
1474	SetLength(NewFunc.Parameters.Items, 0);
1475	SetLength(NewFunc.Variables.Items, 0);
1476	NewFunc.Types.ParentList := @ProgramCode^.Types;
1477	if ParseFunction(@NewFunc) then begin
1478	ProgramCode.Functions.Add(NewFunc);
1479	end else
1480	if ParseProcedure(@NewFunc) then begin
1481	ProgramCode.Functions.Add(NewFunc);
1482	end else Break;
1483	until False;
1484	FunctionContext := nil;
1485	if ParseVariableSection(@ProgramCode.Variables) then begin
1486	end;
1487	ParseBeginEnd(@ProgramCode.BeginEnd);
1488	Expect('.');
1489	end;
1490
1491	end.
1492

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: branches/interpreter/interpreter4/Parser.pas

Download in other formats: