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.