program FlashPascal;
{ Pascal for Flash compiler (c)2008 by Paul TOTH <tothpaul -at- free -dot- fr> }
{
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
{ 2008-06-14 : version 0.1 - Proof of concept ! }
{$APPTYPE CONSOLE}
{%file 'Hello.pas'}
//----------------------------------------------------------------------------//
// the SWF code part is based on Sphing (Swf with PHp without mING)
// Project homepage: http://sphing.sourceforge.net/
// Copyright 2002 Igor Clukas <igor -at- clukas -dot- de>
const
acEndAction =#$00;
acPop =#$17;
acGetVariable=#$1C;
acSetVariable=#$1D;
acGetMember =#$4E;
acSetMember =#$4F;
function SWFshort(value:word):string;
begin
SetLength(Result,SizeOf(Value));
move(value,Result[1],SizeOf(value));
end;
function SWFlong(value:integer):string;
begin
SetLength(Result,SizeOf(Value));
move(value,Result[1],SizeOf(value));
end;
function SWFPushBoolean(Value:boolean):string;
begin
Result:=#$96+SWFshort(2)+#$05+chr(ord(Value));
end;
function SWFPushInteger(Value:integer):string;
begin
Result:=#$96+SWFshort(5)+#$07+SWFlong(value);
end;
function SWFPushString(const Str:string):string;
begin
Result:=#$96+SWFshort(Length(Str)+2)+#0+Str+#0;
end;
function SWFGetVariable(const name:string):string;
begin
Result:=SWFPushString(name)+#$1C;
end;
function SWFCallMethod(const name:string):string;
begin
Result:=SWFPushString(name)+#$52;
end;
function SWFNewObject(const name:string):string;
begin
Result:=SWFPushString(name)+#$40;
end;
function SWFSetMember(const name:string):string;
begin
Result:=SWFPushString(name)+#$4F;
end;
function SWFlhead(id, length:cardinal):string;
begin
Result:=SWFshort((id shl 6) or $3f)+SWFlong(length);
end;
function SWFshead(id,length:cardinal):string;
begin
Result:=SWFshort((id shl 6) or (length and $3f));
end;
function SWFDoAction(const Actions:string):string;
begin
Result:=SWFlhead(12,Length(Actions))+Actions;
end;
function SWFAttributes(Flags:cardinal):string;
begin
Result:=SWFshead(69,4)+SWFlong(Flags);
end;
function SWFBackground(r,g,b:byte):string;
begin
Result:=SWFshead(9, 3) + chr(r) + chr(g) + chr(b);
end;
function SWFEndTag:string;
begin
Result:=SWFshead(0,0);
end;
function SWFbin(const bin:string):string;
var
i,v,b:integer;
begin
Result:='';
v:=0;
b:=0;
for i:=1 to length(bin) do begin
v:=v shl 1;
if bin[i]='1' then inc(v);
inc(b);
if b=8 then begin
Result:=Result+chr(v);
v:=0;
b:=0;
end;
end;
if b>0 then Result:=Result+chr(v shl (8-b));
end;
function SWFval2bin(v, bits:integer):string;
var
i:integer;
begin
SetLength(Result,bits);
for i:=bits downto 1 do begin
if odd(v) then Result[i]:='1' else Result[i]:='0';
v:=v shr 1;
end;
end;
function SWFval2bin2(v, bits:cardinal):string;
var
i:integer;
begin
SetLength(Result,bits);
for i:=bits downto 1 do begin
if odd(v) then Result[i]:='1' else Result[i]:='0';
v:=v shr 1;
end;
while v>0 do begin
if odd(v) then Result:='1'+Result else Result:='0'+Result;
v:=v shr 1;
end;
end;
function SWFrect(x1, y1, x2, y2:integer):string;
var
bits:integer;
begin
if (abs(x1)<$1fff)and(abs(y1)<$1fff)and(abs(x2)<$1fff)and(abs(y2)<$1fff) then bits:=14 else bits:=16;
Result:=SWFbin(SWFval2bin2(bits,5)
+SWFval2bin(x1,bits)
+SWFval2bin(x2,bits)
+SWFval2bin(y1,bits)
+SWFval2bin(y2,bits));
end;
function SWFHeader(ver, fsize, w, h, rate, frames:cardinal):string;
begin
Result:=SWFrect(0,0,w*20,h*20)+#0+chr(rate)+SWFshort(frames);
inc(fsize , length(result) + 8);
Result:='FWS' + chr(ver) + SWFlong(fsize) + Result;
end;
//----------------------------------------------------------------------------//
type
TToken=(
// Pascal keywords
tkProgram,
tkVar, tkType, tkConst,
tkBegin, tkEnd,
tkProcedure,
tkExternal,
tkClass, tkConstructor, tkAs,
tkProperty,
tkNil,
tkDiv,
tkTrue,tkFalse,
// user defined symbol
tk_Symbol,
// Symbols, etc...
tk_Equal,
tk_Add, tk_Sub, tk_Mul, tk_Slash,
tk_Assign, tk_Comma, tk_Colon, tk_SemiColon, tk_Dot,
tk_LParen, tk_RParen,
tk_String, tk_Number, tk_Float, tk_Ident,
tk_LComment1, tk_RComment1, tk_Comment2,
tk_Switch1
);
//----------------------------------------------------------------------------//
var
Source :TextFile; // source file
Line :integer; // current line
Index :integer; // current char in line
Src :string; // current readed line
SrcToken :string; // current token
LastChar :char; // last readed char
NextChar :char; // current readed char (next in token)
Token :string; // current token (uppercase for keywords, without quotes for litteral strings)
TokenType:TToken; // what kind of token is it ?
FrameWidth :word; // SWF frame properties
FrameHeight:word;
FrameRate :byte;
//----------------------------------------------------------------------------//
type
TSymbol=class
name :string; // upper case name
realName :string; // the real name as in type or var definition
NextSymbol:TSymbol;
end;
TVariable=class(TSymbol)
Kind :TSymbol;
end;
TParam=class(TSymbol)
IsConst:boolean; // not used for now
ByRef :boolean;
Kind :TSymbol;
NextParam:TParam;
end;
TMethod=class(TSymbol)
count :integer;
params:TParam;
Kind :TSymbol; // function result
alias :string; // alias used for MovieClip.createTextField()
Parent:TParam; // MovieClip is this case
end;
TProperty=class(TSymbol)
Kind : TSymbol;
end;
TClass=class(TSymbol)
_constructor: TMethod;
_symbols : TSymbol;
end;
var
Symbols :TSymbol; // chained list of symbols
SymName :string; // parsed symbol name
Symbol :TSymbol; // token symbol
_Root :TVariable; // hidden symbol
_String :TSymbol; // Flash String
_Integer :TSymbol; // base type integer
_Boolean :TSymbol; // base type boolean
//----------------------------------------------------------------------------//
procedure Error(const Msg:string);
var
i:integer;
begin
WriteLn('Error on line ',line,' at char ',index,' on ',SrcToken);
WriteLn(Src);
for i:=1 to Index-Length(SrcToken)-1 do Write(' ');
for i:=1 to Length(SrcToken) do Write('^');
WriteLn;
WriteLn(Msg);
ReadLn;
Halt;
end;
function IntToStr(i:integer):string;
begin
Str(i,Result);
end;
// convert Str to an integer
function StrToInt(const Str:string):integer;
var
e:integer;
begin
Val(Str,Result,e);
if e>0 then Error('Invalid number '+str);
end;
// compare two litteral integers
function StrLess(const Str,Value:string):boolean;
var
i,l:integer;
begin
l:=Length(Str);
if l=Length(Value) then begin
for i:=1 to l do begin
if Str[i]>Value[i] then begin
Result:=False;
exit;
end;
end;
Result:=True;
end else begin
Result:=l<Length(Value);
end;
end;
// how many bits to store this numeric ?
function BitsCount(const Str:string):integer;
begin
case Length(Str) of
0 : Error('Invalid number');
1..2 : Result:=8;
3 : if StrLess(Str,'255') then Result:=8 else Result:=16;
4 : Result:=16;
5 : if StrLess(Str,'65535') then Result:=16 else Result:=32;
else if StrLess(Str,'4294967295') then Result:=32 else Error('cardinal overflow');
end;
end;
// read one char
function ReadChar:char;
begin
SrcToken:=SrcToken+NextChar;
LastChar:=NextChar;
Result:=NextChar;
if Eof(Source) then Error('Unexpected end of file');
Read(Source,NextChar);
if NextChar=#13 then inc(Line) else
if NextChar=#10 then Index:=0 else begin
inc(Index);
if Index=1 then Src:=NextChar else Src:=Src+NextChar;
end;
end;
// skip one char ?
function SkipChar(c:char):boolean;
begin
Result:=NextChar=c;
if Result then ReadChar;
end;
// read an alpha token
procedure AlphaToken;
begin
TokenType:=tk_Ident;
while upcase(NextChar) in ['_','A'..'Z','0'..'9'] do begin
Token:=Token+upcase(ReadChar);
end;
// check for reserved keyword
if Token='PROGRAM' then TokenType:=tkProgram else
if Token='VAR' then TokenType:=tkVar else
if Token='TYPE' then TokenType:=tkType else
if Token='CONST' then TokenType:=tkConst else
if Token='BEGIN' then TokenType:=tkBegin else
if Token='END' then TokenType:=tkEnd else
if Token='PROCEDURE' then TokenType:=tkProcedure else
if Token='NIL' then TokenType:=tkNil else
if Token='DIV' then TokenType:=tkDiv else
if Token='TRUE' then TokenType:=tkTrue else
if Token='FALSE' then TokenType:=tkFalse else
if Token='EXTERNAL' then TokenType:=tkExternal else
if Token='CLASS' then TokenType:=tkClass else
if Token='CONSTRUCTOR' then TokenType:=tkConstructor else
if Token='AS' then TokenType:=tkAs else
if Token='PROPERTY' then TokenType:=tkProperty else
begin
// look for user defined symbol
Symbol:=Symbols;
while Symbol<>nil do begin
if Symbol.name=Token then begin
TokenType:=tk_Symbol;
exit;
end;
Symbol:=Symbol.NextSymbol;
end;
end;
end;
// read a numeric token
procedure NumericToken;
begin
TokenType:=tk_Number;
while NextChar in ['0'..'9'] do begin
Token:=Token+ReadChar;
end;
if NextChar='.' then begin
TokenType:=tk_Float;
Token:=Token+ReadChar;
while NextChar in ['0'..'9'] do begin
Token:=Token+ReadChar;
end;
end;
end;
// read a quoted string
function StringConst:string;
var
done:boolean;
begin
ReadChar; // ''''
Result:='';
repeat
while NextChar<>'''' do begin
if NextChar=#13 then Error('Open string');
Result:=Result+ReadChar;
end;
ReadChar; // ''''
if NextChar='''' then begin
Result:=Result+ReadChar;
done:=False;
end else begin
done:=True;
end;
until done;
end;
// read an ascii char value (#xxx)
function AsciiChar:string;
begin
ReadChar; // #
Result:='';
while NextChar in ['0'..'9'] do Result:=Result+ReadChar;
if BitsCount(Result)>8 then Error('byte overflow');
Result:=chr(StrToInt(Result));
end;
// read a string made of litterals ans ascii chars
procedure StringToken;
begin
TokenType:=tk_String;
while NextChar in ['#',''''] do begin
if NextChar='#' then
Token:=Token+AsciiChar
else
Token:=Token+StringConst;
end;
end;
// get a special symbol
procedure SymbolToken;
begin
case ReadChar of
'=' : TokenType:=tk_Equal;
'+' : TokenType:=tk_Add;
'-' : TokenType:=tk_Sub;
'*' : TokenType:=tk_Mul;
'.' : TokenType:=tk_Dot;
',' : TokenType:=tk_Comma;
':' : if SkipChar('=') then TokenType:=tk_Assign else TokenType:=tk_Colon;
';' : TokenType:=tk_SemiColon;
'(' : TokenType:=tk_LParen;
')' : TokenType:=tk_RParen;
'{' : if SkipChar('$') then TokenType:=tk_Switch1 else TokenType:=tk_LComment1;
'}' : TokenType:=tk_RComment1;
'/' : if SkipChar('/') then Tokentype:=tk_Comment2 else TokenType:=tk_Slash;
else Error('Unknow symbol '+LastChar);
end;
end;
// get an hexadecimal number
procedure HexaToken;
begin
TokenType:=tk_Number;
Token:=ReadChar;
while upcase(NextChar) in ['0'..'9','A'..'F'] do begin
Token:=Token+upcase(ReadChar);
end;
if Length(Token)>9 then Error('Ordinal overflow');
end;
// get the next token
procedure GetToken;
begin
while NextChar<=#32 do ReadChar;
SrcToken:='';
Token:='';
case upcase(NextChar) of
'_','A'..'Z' : AlphaToken;
'0'..'9' : NumericToken;
'$' : HexaToken;
'#','''' : StringToken;
else SymbolToken;
end;
end;
// requiered token
procedure DropToken(Token:TToken); forward;
// deal with Frame properties
procedure CompilerSwitch(StopToken:TToken);
var
s:string;
switch:(sFrameWidth,sFrameHeight,sFrameRate);
b:integer;
begin
s:='';
while upcase(NextChar) in ['A'..'Z','_'] do s:=s+upcase(ReadChar);
if s='FRAME_WIDTH' then switch:=sFrameWidth else
if s='FRAME_HEIGHT' then switch:=sFrameHeight else
if s='FRAME_RATE' then switch:=sFrameRate else error('Unknow switch '+s);
GetToken;
if TokenType<>tk_Number then Error('Integer expected');
b:=BitsCount(Token);
if switch=sFrameRate then begin
if b>8 then Error('Byte overflow');
end else begin
if b>16 then Error('Word overflow');
end;
case switch of
sFrameWidth : FrameWidth :=StrToInt(Token);
sFrameHeight : FrameHeight:=StrToInt(Token);
sFrameRate : FrameRate :=StrToInt(Token);
end;
GetToken;
DropToken(StopToken);
end;
// get the next token, handle compiler switch & comments
procedure NextToken;
begin
GetToken;
case TokenType of
tk_LComment1 : begin
repeat until ReadChar='}';
NextToken;
end;
tk_Comment2 : begin
repeat until ReadChar in [#10,#13];
NextToken;
end;
tk_Switch1 : CompilerSwitch(tk_RComment1);
end;
end;
// skip a token
function SkipToken(Token:TToken):boolean;
begin
Result:=TokenType=Token;
if Result then NextToken;
end;
// request a token
procedure DropToken(Token:TToken);
begin
if not Skiptoken(Token) then Error('Unexpected token');
end;
// request an ident
function GetIdent:string;
begin
if TokenType<>tk_Ident then Error('Ident expected');
Result:=Token;
NextToken;
end;
//----------------------------------------------------------------------------//
// NB: Flash do not use typed variable, but we are Pascal programmers :D
function GetType:TSymbol;
begin
if TokenType=tk_Symbol then begin
if (Symbol=_String) or (Symbol=_Integer) or (Symbol=_Boolean) or (Symbol is TClass) then begin
Result:=Symbol;
NextToken;
end else begin
Error('type expected');
end;
end else begin
Error('type expected');
end;
end;
// var declaration
procedure DeclareVar;
var
v:TVariable;
begin
v:=TVariable.Create;
v.realName:=SrcToken;
v.name:=GetIdent;
v.NextSymbol:=Symbols;
Symbols:=v;
DropToken(tk_Colon);
v.Kind:=GetType;
DropToken(tk_SemiColon);
end;
// one method parameter
function GetParam(Method:TMethod; Prev:TParam):TParam;
var
p:TParam;
begin
Result:=TParam.Create;
// param1,param2 : type
if Prev=nil then begin
if SkipToken(tkConst) then Result.IsConst:=True else
if SkipToken(tkVar) then Result.ByRef:=True;
end else begin
Result.IsConst:=Prev.IsConst;
Result.ByRef:=Prev.ByRef;
end;
// param name
Result.name:=GetIdent;
// check for duplicates
p:=Method.params;
while p<>nil do begin
if p.name=Result.name then Error('Duplicate param name');
p:=p.NextParam;
end;
// add the parameter to the method
Result.NextParam:=Method.params;
Method.params:=Result;
inc(Method.count);
// one more ?
if SkipToken(tk_Comma) then begin
p:=GetParam(Method,Result);
Result.Kind:=p.Kind;
end else begin
// get type
DropToken(tk_Colon);
Result.Kind:=GetType;
end;
end;
// return last parameter of a method
function LastParm(Method:TMethod):TParam;
begin
Result:=Method.params;
if Result<>nil then begin
while Result.NextParam<>nil do Result:=Result.NextParam;
end;
end;
// read a class method
function GetMethod(AClass:TClass; void:boolean):TMethod;
var
m:TMethod;
p:TParam;
begin
m:=TMethod.Create;
m.realName:=SrcToken;
m.name:=GetIdent;
if SkipToken(tk_LParen) then begin
while not SkipToken(tk_RParen) do begin
p:=GetParam(m,nil);
if TokenType<>tk_RParen then DropToken(tk_SemiColon);
end;
end;
if not void then begin
// function method
DropToken(tk_Colon);
m.Kind:=GetType;
end;
m.NextSymbol:=AClass._symbols;
AClass._symbols:=m;
Result:=m;
end;
// we use a special syntax to define a pseudo constructor for "MovieClip.createTextField(instanceName,...)"
// constructor Create(Parent:MovieClip,...) as Parent.createTextField
procedure ConstructorAlias(m:TMethod);
var
p:TParam;
begin
// Last parm is the first one (reversed chained list)
p:=LastParm(m);
// we need one
if (p=nil) then Error('method alias need at least one parameter');
// need to be a class
if (p.Kind=nil)or(not(p.Kind is TClass)) then Error('method alias need a parent class parameter');
// skip it name
if GetIdent<>p.name then Error(p.name+' expected');
// dot
DropToken(tk_Dot);
// get alias
m.alias:=SrcToken;
GetIdent;
// save the parent
m.Parent:=p;
// remove it from param list
if m.params=p then
m.params:=nil
else begin
p:=m.params;
while p.NextParam<>m.Parent do p:=p.NextParam;
p.NextParam:=nil;
end;
end;
// read class property
procedure GetProperty(AClass:TClass);
var
p:TProperty;
begin
p:=TProperty.Create;
p.realName:=SrcToken;
p.name:=GetIdent;
p.NextSymbol:=AClass._symbols;
AClass._symbols:=p;
DropToken(tk_Colon);
p.Kind:=GetType;
end;
// define an external class : a Flash class
procedure ExternalFlashClass(const ClassName, SymbolName:string);
var
ss:TSymbol;
cl:TClass;
begin
DropToken(tkClass);
cl:=TClass.Create;
// we nee a case sensitive name !
cl.realName:=ClassName;
cl.name:=SymbolName;
cl.NextSymbol:=Symbols;
Symbols:=cl;
ss:=Symbols;
while not SkipToken(tkEnd) do begin
// todo: support multiple constructor ?
if SkipToken(tkConstructor) then begin
if cl._constructor<>nil then Error('duplicate constructor');
cl._constructor:=GetMethod(cl,true);
if SkipToken(tkAs) then ConstructorAlias(cl._constructor);
end else
// todo: support for function :)
if SkipToken(tkProcedure) then begin
GetMethod(cl,true);
end else
// todo: readonly, writeonly attributes
if SkipToken(tkProperty) then begin
GetProperty(cl);
end else
Error('unexpected');
if TokenType<>tkEnd then DropToken(tk_SemiColon);
end;
end;
// declare a new type
procedure DeclareType;
var
cname:string;
uname:string;
begin
cname:=SrcToken;
uname:=GetIdent;
DropToken(tk_Equal);
if SkipToken(tkExternal) then begin
ExternalFlashClass(cname,uname);
end else
// todo: user defined class, record ?
Error('type expected');
DropToken(tk_SemiColon);
end;
//----------------------------------------------------------------------------//
// get a variable reference
function DropVariable:TVariable;
begin
if not (Symbol is TVariable) then error('Variable expected');
Result:=TVariable(Symbol);
DropToken(tk_Symbol);
end;
// push a string
// todo: multiple push optimization
function PushString:string;
begin
if TokenType=tk_String then begin
Result:=SWFPushString(Token);
NextToken;
end else Error('PushString : '+Token);
end;
// push integer expression
function PushInteger2:string;
var
neg:boolean;
val:integer;
begin
SkipToken(tk_Add);
neg:=SkipToken(tk_Sub);
if TokenType=tk_Number then begin
if BitsCount(Token)>32 then Error('integer overflow');
val:=StrToInt(Token);
if neg then val:=-val;
Result:=SWFPushInteger(val);
NextToken;
end else Error('PushInteger : '+Token);
end;
function PushInteger1:string;
var
op:TToken;
begin
Result:=PushInteger2;
while TokenType in [tk_Mul,tkDiv] do begin
op:=TokenType;
NextToken;
Result:=Result+PushInteger2;
if op=tk_Mul then Result:=Result+#$C7#00#00 else Result:=Result+#$A3#00#00;
end;
end;
function PushInteger:string;
var
op:TToken;
begin
Result:=PushInteger1;
while TokenType in [tk_Add,tk_Sub] do begin
op:=TokenType;
NextToken;
Result:=Result+PushInteger1;
if op=tk_Add then Result:=Result+#$C5#00#00 else Result:=Result+#$C6#00#00;
end;
end;
// todo: boolean expression
function PushBoolean:string;
begin
if SkipToken(tkTrue) then Result:=SWFPushBoolean(True) else
if SkipToken(tkFalse) then Result:=SWFPushBoolean(False) else
error('Unknow boolean');
end;
function PushInstance:string;
var
v:TVariable;
begin
v:=DropVariable;
Result:=SWFGetVariable(v.realName);
end;
//----------------------------------------------------------------------------//
function PushKind(Kind:TSymbol):string;
begin
if Kind=_String then Result:=PushString else
if Kind=_Integer then Result:=PushInteger else
if Kind=_Boolean then Result:=PushBoolean else
if Kind is TClass then Result:=PushInstance else
Error('unknown param type '+Kind.ClassName+' '+Kind.Name);
end;
function PushParams(Param:TParam):string;
begin
Result:='';
if Param<>nil then begin
if Param.NextParam<>nil then begin
Result:=PushParams(Param.NextParam);
DropToken(tk_Comma);
end;
Result:=PushKind(Param.Kind)+Result;
end;
end;
function ConstructClass(instance:TVariable; aclass:TClass):string;
var
parent:TVariable;
begin
if instance.Kind<>aclass then Error('class mismatch');
NextToken;
DropToken(tk_Dot);
if Token<>aclass._constructor.name then Error('Constructor expected');
NextToken;
Result:='';
if aclass._constructor.alias<>'' then begin
// call a parent method to create the new instance
// Parent.create('instance',...)
DropToken(tk_LParen);
// nil parent is _root !
if SkipToken(tkNil) then parent:=_Root else parent:=DropVariable;
if SkipToken(tk_Comma) then begin
Result:=PushParams(aclass._constructor.params);
end else begin
if aclass._constructor.params<>nil then Error('parameter expected');
end;
DropToken(tk_RParen);
Result:=Result
+SWFPushString(instance.realName)
+SWFPushInteger(aclass._constructor.count)
+SWFGetVariable(parent.realName)
+SWFCallMethod(aclass._constructor.alias);
if parent=_Root then begin
// just drop the result
Result:=Result+acPop;
end else begin
// set also a global var of that name
Result:=SWFPushString(instance.realName)
+Result
+acSetVariable;
end;
end else begin
// instance=new Class(...)
if SkipToken(tk_LParen) then begin
Result:=PushParams(aclass._constructor.params);
DropToken(tk_RParen);
end else begin
if aclass._constructor.params<>nil then Error('parameter expected');
end;
Result:=SWFPushString(instance.realName)
+Result
+SWFPushInteger(aclass._constructor.count)
+SWFNewObject(aclass.realName)
+acSetVariable;
end;
end;
// todo: a lot of things !
function AssignStatement(target:TVariable):string;
begin
DropToken(tk_Assign);
if target.Kind is TClass then begin
if (TokenType=tk_Symbol)and(Symbol is TClass) then
Result:=ConstructClass(target,TClass(Symbol))
else
Error('Assign class')
end else
Error('Assign');
end;
function GetSymbol(List:TSymbol):TSymbol;
begin
while List<>nil do begin
if List.name=Token then begin
NextToken;
Result:=List;
exit;
end;
List:=List.NextSymbol;
end;
Error('unknow symbol');
end;
function SetProperty(target:TVariable; prop:TProperty):string;
begin
DropToken(tk_Assign);
Result:=SWFGetVariable(target.realName)
+SWFPushString(prop.realName)
+PushKind(prop.Kind)
+acSetMember;
end;
function CallMethod(target:TVariable; method:TMethod):string;
begin
Result:='';
if SkipToken(tk_LParen) then begin
Result:=PushParams(method.params);
DropToken(tk_RParen);
end;
Result:=Result+SWFPushInteger(method.count)
+SWFGetVariable(target.realName)
+SWFCallMethod(method.realName)
+acPop;
end;
function VariableSuffix:string;
var
target:TVariable;
suffix:TSymbol;
begin
target:=DropVariable;
if SkipToken(tk_Dot) then begin
if target.Kind is TClass then begin
suffix:=GetSymbol(TClass(target.Kind)._symbols);
if suffix is TProperty then Result:=SetProperty(target,TProperty(suffix)) else
if suffix is TMethod then Result:=CallMethod(target,TMethod(suffix)) else
Error('suffix '+suffix.ClassName);
end else begin
Error('suffix ?');
end;
end else begin
Result:=AssignStatement(target);
end;
end;
// statement -or- begin statement1; statement2; end;
function Statement:string;
begin
Result:='';
case TokenType of
tkBegin: begin
NextToken;
SkipToken(tk_SemiColon);
while not SkipToken(tkEnd) do begin
Result:=Result+Statement;
if TokenType<>tkEnd then DropToken(tk_SemiColon) else SkipToken(tk_SemiColon);
end;
end;
tk_Symbol : begin
if Symbol is TVariable then
Result:=VariableSuffix
else
Error('Unexpected symbol');
end;
else Error('Unexpected token');
end;
end;
procedure Compile;
var
name:string;
code:string;
f:file;
begin
DropToken(tkProgram);
name:=SrcToken+'.swf';
GetIdent;
DropToken(tk_SemiColon);
code:='';
while not SkipToken(tkBegin) do begin
case TokenType of
tkVar : begin
NextToken;
repeat DeclareVar until TokenType<>tk_Ident;
end;
tkType : begin
NextToken;
repeat DeclareType until TokenType<>tk_Ident;
end;
else Error('Unexpected token');
end;
end;
while not SkipToken(tkEnd) do begin
code:=code+Statement;
if TokenType<>tkEnd then DropToken(tk_SemiColon) else SkipToken(tk_SemiColon);
end;
if TokenType<>tk_Dot then Error('Expected .');
// todo: SWF GZCompression
code:=SWFAttributes(0)
// +SWFBackground(128,0,255)
+SWFDoAction(code+acEndAction)
+SWFEndTag;
code:=SWFHeader(8,Length(code),FrameWidth,FrameHeight,FrameRate,1)+code;
AssignFile(f,name);
Rewrite(f,1);
BlockWrite(f,code[1],Length(code));
CloseFile(f);
end;
//----------------------------------------------------------------------------//
function AddSymbol(const Name:string):TSymbol;
begin
Result:=TSymbol.Create;
Result.name:=Name;
Result.NextSymbol:=Symbols;
Symbols:=Result;
end;
begin
// init symbols
Symbols :=nil;
_Root :=TVariable.Create;
_Root.realName:='_root';
_String :=AddSymbol('STRING');
_Integer:=AddSymbol('INTEGER');
_Boolean:=AddSymbol('BOOLEAN');
FrameWidth :=800;
FrameHeight:=600;
FrameRate :=32;
// AssignFile(Source,ParamStr(1));
AssignFile(Source,'Hello.pas');
Reset(Source);
Src :='';
Line :=1;
Index:=0;
ReadChar;
NextToken;
Compile;
CloseFile(Source);
WriteLn('OK');
ReadLn;
end.