%{ { $Id$ Copyright (c) 1998-2000 by Florian Klaempfl 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., 675 Mass Ave, Cambridge, MA 02139, USA. ****************************************************************************} unit scan; interface uses strings, lexlib,yacclib; const version = '0.99.15'; type Char=system.char; ttyp = ( t_id, { p contains the string } t_arraydef, { } t_pointerdef, { p1 contains the definition if in type overrider or nothing for args } t_addrdef, t_void, { no field } t_dec, { } t_declist, { p1 is t_dec next if exists } t_memberdec, { p1 is type specifier p2 is declarator_list } t_structdef, { } t_memberdeclist, { p1 is memberdec next is next if it exist } t_procdef, { } t_uniondef, { } t_enumdef, { } t_enumlist, { } t_preop, { p contains the operator string p1 contains the right expr } t_bop, { p contains the operator string p1 contains the left expr p2 contains the right expr } t_arrayop, { p1 contains the array expr p2 contains the index expressions } t_callop, { p1 contains the proc expr p2 contains the index expressions } t_arg, { p1 contain the typedef p2 the declarator (t_dec) } t_arglist, { } t_funexprlist, { } t_exprlist, { p1 contains the expr next contains the next if it exists } t_ifexpr, { p1 contains the condition expr p2 contains the if branch p3 contains the else branch } t_funcname, { p1 contains the function dname p2 contains the funexprlist p3 possibly contains the return type } t_typespec, { p1 is the type itself p2 the typecast expr } t_size_specifier, { p1 expr for size } t_default_value { p1 expr for value } ); presobject = ^tresobject; tresobject = object typ : ttyp; p : pchar; next : presobject; p1,p2,p3 : presobject; { name of int/real, then no T prefix is required } intname : boolean; constructor init_no(t : ttyp); constructor init_one(t : ttyp;_p1 : presobject); constructor init_two(t : ttyp;_p1,_p2 : presobject); constructor init_three(t : ttyp;_p1,_p2,_p3 : presobject); constructor init_id(const s : string); constructor init_intid(const s : string); constructor init_bop(const s : string;_p1,_p2 : presobject); constructor init_preop(const s : string;_p1 : presobject); procedure setstr(const s:string); function str : string; function strlength : byte; function get_copy : presobject; { can this ve considered as a constant ? } function is_const : boolean; destructor done; end; tblocktype = (bt_type,bt_const,bt_var,bt_func,bt_no); var infile : string; outfile : text; c : char; aktspace : string; block_type : tblocktype; const in_define : boolean = false; { 1 after define; 2 after the ID to print the first separating space } in_space_define : byte = 0; arglevel : longint = 0; function yylex : integer; function act_token : string; procedure internalerror(i : integer); function strpnew(const s : string) : pchar; implementation uses options,converu; const newline = #10; procedure internalerror(i : integer); begin writeln('Internal error ',i,' in line ',yylineno); halt(1); end; procedure commenteof; begin writeln('unexpected EOF inside comment at line ',yylineno); end; procedure copy_until_eol; begin c:=get_char; while c<>newline do begin write(outfile,c); c:=get_char; end; end; procedure skip_until_eol; begin c:=get_char; while c<>newline do c:=get_char; end; function strpnew(const s : string) : pchar; var p : pchar; begin getmem(p,length(s)+1); strpcopy(p,s); strpnew:=p; end; constructor tresobject.init_preop(const s : string;_p1 : presobject); begin typ:=t_preop; p:=strpnew(s); p1:=_p1; p2:=nil; p3:=nil; next:=nil; intname:=false; end; constructor tresobject.init_bop(const s : string;_p1,_p2 : presobject); begin typ:=t_bop; p:=strpnew(s); p1:=_p1; p2:=_p2; p3:=nil; next:=nil; intname:=false; end; constructor tresobject.init_id(const s : string); begin typ:=t_id; p:=strpnew(s); p1:=nil; p2:=nil; p3:=nil; next:=nil; intname:=false; end; constructor tresobject.init_intid(const s : string); begin typ:=t_id; p:=strpnew(s); p1:=nil; p2:=nil; p3:=nil; next:=nil; intname:=true; end; constructor tresobject.init_two(t : ttyp;_p1,_p2 : presobject); begin typ:=t; p1:=_p1; p2:=_p2; p3:=nil; p:=nil; next:=nil; intname:=false; end; constructor tresobject.init_three(t : ttyp;_p1,_p2,_p3 : presobject); begin typ:=t; p1:=_p1; p2:=_p2; p3:=_p3; p:=nil; next:=nil; intname:=false; end; constructor tresobject.init_one(t : ttyp;_p1 : presobject); begin typ:=t; p1:=_p1; p2:=nil; p3:=nil; next:=nil; p:=nil; intname:=false; end; constructor tresobject.init_no(t : ttyp); begin typ:=t; p:=nil; p1:=nil; p2:=nil; p3:=nil; next:=nil; intname:=false; end; procedure tresobject.setstr(const s : string); begin if assigned(p) then strdispose(p); p:=strpnew(s); end; function tresobject.str : string; begin str:=strpas(p); end; function tresobject.strlength : byte; begin if assigned(p) then strlength:=strlen(p) else strlength:=0; end; { can this ve considered as a constant ? } function tresobject.is_const : boolean; begin case typ of t_id,t_void : is_const:=true; t_preop : is_const:= ((str='-') or (str=' not ')) and p1^.is_const; t_bop : is_const:= p2^.is_const and p1^.is_const; else is_const:=false; end; end; function tresobject.get_copy : presobject; var newres : presobject; begin newres:=new(presobject,init_no(typ)); newres^.intname:=intname; if assigned(p) then newres^.p:=strnew(p); if assigned(p1) then newres^.p1:=p1^.get_copy; if assigned(p2) then newres^.p2:=p2^.get_copy; if assigned(p3) then newres^.p3:=p3^.get_copy; if assigned(next) then newres^.next:=next^.get_copy; get_copy:=newres; end; destructor tresobject.done; begin (* writeln('disposing ',byte(typ)); *) if assigned(p)then strdispose(p); if assigned(p1) then dispose(p1,done); if assigned(p2) then dispose(p2,done); if assigned(p3) then dispose(p3,done); if assigned(next) then dispose(next,done); end; %} D [0-9] %% "/*" begin if not stripcomment then write(outfile,aktspace,'{'); repeat c:=get_char; case c of '*' : begin c:=get_char; if c='/' then begin if not stripcomment then writeln(outfile,' }'); flush(outfile); exit; end else begin if not stripcomment then write(outfile,' '); unget_char(c) end; end; newline : begin if not stripcomment then begin writeln(outfile); write(outfile,aktspace); end; end; #0 : commenteof; else if not stripcomment then write(outfile,c); end; until false; flush(outfile); end; "//" begin If not stripcomment then write(outfile,aktspace,'{'); repeat c:=get_char; case c of newline : begin unget_char(c); if not stripcomment then writeln(outfile,' }'); flush(outfile); exit; end; #0 : commenteof; else if not stripcomment then write(outfile,c); end; until false; flush(outfile); end; \"[^\"]*\" return(CSTRING); \'[^\']*\' return(CSTRING); "L"\"[^\"]*\" if win32headers then return(CSTRING) else return(256); "L"\'[^\']*\' if win32headers then return(CSTRING) else return(256); {D}+[Uu]?[Ll]? begin while yytext[length(yytext)] in ['L','U','l','u'] do Delete(yytext,length(yytext),1); return(NUMBER); end; "0x"[0-9A-Fa-f]*[Uu]?[Ll]? begin (* handle pre- and postfixes *) if copy(yytext,1,2)='0x' then begin delete(yytext,1,2); yytext:='$'+yytext; end; while yytext[length(yytext)] in ['L','U','l','u'] do Delete(yytext,length(yytext),1); return(NUMBER); end; {D}+(\.{D}+)?([Ee][+-]?{D}+)? begin return(NUMBER); end; "->" if in_define then return(DEREF) else return(256); "-" return(MINUS); "==" return(EQUAL); "!=" return(UNEQUAL); ">=" return(GTE); "<=" return(LTE); ">>" return(_SHR); "##" return(STICK); "<<" return(_SHL); ">" return(GT); "<" return(LT); "|" return(_OR); "&" return(_AND); "~" return(_NOT); (* inverse, but handled as not operation *) "!" return(_NOT); "/" return(_SLASH); "+" return(_PLUS); "?" return(QUESTIONMARK); ":" return(COLON); "," return(COMMA); "[" return(LECKKLAMMER); "]" return(RECKKLAMMER); "(" begin inc(arglevel); return(LKLAMMER); end; ")" begin dec(arglevel); return(RKLAMMER); end; "*" return(STAR); "..." return(ELLIPSIS); "." if in_define then return(POINT) else return(256); "=" return(_ASSIGN); "extern" return(EXTERN); "STDCALL" if Win32headers then return(STDCALL) else return(ID); "CDECL" if not Win32headers then return(ID) else return(CDECL); "PASCAL" if not Win32headers then return(ID) else return(PASCAL); "PACKED" if not Win32headers then return(ID) else return(_PACKED); "WINAPI" if not Win32headers then return(ID) else return(WINAPI); "SYS_TRAP" if not palmpilot then return(ID) else return(SYS_TRAP); "WINGDIAPI" if not Win32headers then return(ID) else return(WINGDIAPI); "CALLBACK" if not Win32headers then return(ID) else return(CALLBACK); "EXPENTRY" if not Win32headers then return(ID) else return(CALLBACK); "void" return(VOID); "VOID" return(VOID); "#ifdef __cplusplus"[ \t]*\n"extern \"C\" {"\n"#endif" begin if not stripinfo then writeln(outfile,'{ C++ extern C conditionnal removed }'); end; "#ifdef __cplusplus"[ \t]*\n"}"\n"#endif" begin if not stripinfo then writeln(outfile,'{ C++ end of extern C conditionnal removed }'); end; "#"[ \t]*"else" begin writeln(outfile,'{$else}'); block_type:=bt_no; flush(outfile); end; "#"[ \t]*"endif" begin writeln(outfile,'{$endif}'); block_type:=bt_no; flush(outfile); end; "#"[ \t]*"elif" begin if not stripinfo then write(outfile,'(*** was #elif ****)'); write(outfile,'{$else'); copy_until_eol; writeln(outfile,'}'); block_type:=bt_no; flush(outfile); end; "#"[ \t]*"undef" begin write(outfile,'{$undef'); copy_until_eol; writeln(outfile,'}'); flush(outfile); end; "#"[ \t]*"error" begin write(outfile,'{$error'); copy_until_eol; writeln(outfile,'}'); flush(outfile); end; "#"[ \t]*"include" begin write(outfile,'{$include'); copy_until_eol; writeln(outfile,'}'); flush(outfile); block_type:=bt_no; end; "#"[ \t]*"if" begin write(outfile,'{$if'); copy_until_eol; writeln(outfile,'}'); flush(outfile); block_type:=bt_no; end; "# "[0-9]+" " begin (* preprocessor line info *) repeat c:=get_char; case c of newline : begin unget_char(c); exit; end; #0 : commenteof; end; until false; end; "#"[ \t]*"pragma" begin if not stripinfo then begin write(outfile,'(** unsupported pragma'); write(outfile,'#pragma'); copy_until_eol; writeln(outfile,'*)'); flush(outfile); end else skip_until_eol; block_type:=bt_no; end; "#"[ \t]*"define" begin in_define:=true; in_space_define:=1; return(DEFINE); end; "char" return(_CHAR); "union" return(UNION); "enum" return(ENUM); "struct" return(STRUCT); "{" return(LGKLAMMER); "}" return(RGKLAMMER); "typedef" return(TYPEDEF); "int" return(INT); "short" return(SHORT); "long" return(LONG); "signed" return(SIGNED); "unsigned" return(UNSIGNED); "float" return(REAL); "const" return(_CONST); "CONST" return(_CONST); "FAR" return(_FAR); "far" return(_FAR); "NEAR" return(_NEAR); "near" return(_NEAR); "HUGE" return(_HUGE); "huge" return(_HUGE); [A-Za-z_][A-Za-z0-9_]* begin if in_space_define=1 then in_space_define:=2; return(ID); end; ";" return(SEMICOLON); [ \f\t] begin if (arglevel=0) and (in_space_define=2) then begin in_space_define:=0; return(SPACE_DEFINE); end; end; \n begin if in_define then begin in_define:=false; in_space_define:=0; return(NEW_LINE); end; end; . begin writeln('Illegal character in line ',yylineno); writeln('"',yyline,'"'); return(256); end; %% function act_token : string; begin act_token:=yytext; end; end.