unit1.pas

示范利用 Delphi 制作 BASIC 程序语言解释器

Unit Unit1;
Interface
Uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
Type
	TForm1 =
		Class(TForm)
			Procedure FormCreate(Sender:TObject);
		Private
		Public
		End;
Var Form1:TForm1;
Implementation
{$R *.DFM}
Procedure RunBasic(Source:TStringList);
	Var
		ConstNames,Consts	:TStringList;
	Function ProcessCode:Boolean;
		Var
			Index,CNo,CNo2	:Integer;
			S,S2			:String;
		Label Rework;
		Begin
			Result := False;
			CNo := 0;
			For Index := 0 to Source.Count - 1 do Begin
				// Start
				S := Source[Index];

				// Remove comments
				If Pos('''',S) > 0 then
					S := Copy(S,1,Pos('''',S) - 1);

				// Trim
				S := Trim(S);

				// String constants
				Rework:
				For CNo := 1 to Length(S) do Begin
					If S[CNo] = '"' then Begin
						CNo2 := CNo;
						Repeat
							Inc(CNo2);
							If CNo2 > Length(S) then Begin
								MessageBox(0,PChar('Line ' + IntToStr(Index) + ': String never ending error.'),PChar(Application.Title),16);
								Exit;
							End;
						Until S[CNo2] = '"';
						S2 := 'instr_' + IntToHex(ConstNames.Count,8);
						ConstNames.Add(S2);
						Consts.Add(Copy(S,CNo + 1,CNo2 - CNo - 1));
						Delete(S,CNo,CNo2 - CNo + 1);
						Insert(S2,S,CNo);
						Goto Rework;
					End;
				End;

				// Uppercase
				S := AnsiUpperCase(S);
				
				// End
				Source[Index] := S;
			End;
			Result := True;
		End;
	Begin
		ConstNames := TStringList.Create;
		Consts := TStringList.Create;
		If ProcessCode then
			; // Here we should run the project
		Consts.SaveToFile('apa.consts.txt');
		ConstNames.Free;
		Consts.Free;
	End;
Procedure TForm1.FormCreate(Sender: TObject);
	Var Source:TStringList;
	Begin
		Source := TStringList.Create;
		Source.LoadFromFile('apa.bas');
		RunBasic(Source);
		Source.SaveToFile('apa.txt');
		Source.Free;
		Halt;
	End;
End.