1 %{ 2 { 3 $Id$ 4 Copyright (c) 1993-98 by Florian Klaempfl 5 6 This program is free software; you can redistribute it and/or modify 7 it under the terms of the GNU General Public License as published by 8 the Free Software Foundation; either version 2 of the License, or 9 (at your option) any later version. 10 11 This program is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 GNU General Public License for more details. 15 16 You should have received a copy of the GNU General Public License 17 along with this program; if not, write to the Free Software 18 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 19 20 ****************************************************************************} 21 22 23 unit scan; 24 25 interface 26 27 uses 28 strings, 29 lexlib,yacclib; 30 31 type 32 Char=system.char; 33 ttyp = ( 34 t_id, 35 { p contains the string } 36 t_arraydef, 37 { } 38 t_pointerdef, 39 { p1 contains the definition 40 if in type overrider 41 or nothing for args 42 } 43 t_addrdef, 44 45 t_void, 46 { no field } 47 t_dec, 48 { } 49 t_declist, 50 { p1 is t_dec 51 next if exists } 52 t_memberdec, 53 { p1 is type specifier 54 p2 is declarator_list } 55 t_structdef, 56 { } 57 t_memberdeclist, 58 { p1 is memberdec 59 next is next if it exist } 60 t_procdef, 61 { } 62 t_uniondef, 63 { } 64 t_enumdef, 65 { } 66 t_enumlist, 67 { } 68 t_preop, 69 { p contains the operator string 70 p1 contains the right expr } 71 t_bop, 72 { p contains the operator string 73 p1 contains the left expr 74 p2 contains the right expr } 75 t_arg, 76 { 77 p1 contain the typedef 78 p2 the declarator (t_dec) 79 } 80 t_arglist, 81 { } 82 t_funexprlist, 83 { } 84 t_exprlist, 85 { p1 contains the expr 86 next contains the next if it exists } 87 t_ifexpr, 88 { p1 contains the condition expr 89 p2 contains the if branch 90 p3 contains the else branch } 91 t_funcname, 92 { p1 contains the function dname 93 p2 contains the funexprlist 94 p3 possibly contains the return type } 95 t_typespec, 96 { p1 is the type itself 97 p2 the typecast expr } 98 t_size_specifier, 99 { p1 expr for size } 100 t_default_value 101 { p1 expr for value } 102 ); 103 104 {tdtyp = (dt_id,dt_one,dt_two,dt_three,dt_no,dt_uop,dt_bop); 105 obsolete removed } 106 107 presobject = ^tresobject; 108 109 tresobject = object 110 typ : ttyp; 111 p : pchar; 112 next : presobject; 113 p1,p2,p3 : presobject; 114 { dtyp : tdtyp; } 115 constructor init_no(t : ttyp); 116 constructor init_one(t : ttyp;_p1 : presobject); 117 constructor init_two(t : ttyp;_p1,_p2 : presobject); 118 constructor init_three(t : ttyp;_p1,_p2,_p3 : presobject); 119 constructor init_id(const s : string); 120 constructor init_bop(const s : string;_p1,_p2 : presobject); 121 constructor init_preop(const s : string;_p1 : presobject); 122 function str : string; 123 function strlength : byte; 124 function get_copy : presobject; 125 { can this ve considered as a constant ? } 126 function is_const : boolean; 127 destructor done; 128 end; 129 130 tblocktype = (bt_type,bt_const,bt_var,bt_func,bt_no); 131 132 133 var 134 infile : string; 135 textinfile,outfile : text; 136 c : char; 137 aktspace : string; 138 block_type : tblocktype; 139 140 const 141 in_define : boolean = false; 142 { 1 after define; 2 after the ID to print the first 143 separating space } 144 in_space_define : byte = 0; 145 arglevel : longint = 0; 146 prev_line : string = ''; 147 last_source_line : string = 'Line number 0'; 148 149 function yylex : integer; 150 function act_token : string; 151 procedure internalerror(i : integer); 152 153 procedure next_line; 154 155 function strpnew(const s : string) : pchar; 156 157 implementation 158 uses options,converu; 159 160 procedure internalerror(i : integer); 161 begin 162 writeln('Internal error ',i,' in line ',line_no); 163 halt(1); 164 end; 165 166 { keep the last source line } 167 procedure next_line; 168 169 begin 170 inc(line_no); 171 prev_line:=last_source_line; 172 readln(textinfile,last_source_line); 173 end; 174 175 procedure commenteof; 176 begin 177 writeln('unexpected EOF inside comment at line ',line_no); 178 end; 179 180 var p : pchar; 181 function strpnew(const s : string) : pchar; 182 begin 183 getmem(p,length(s)+1); 184 strpcopy(p,s); 185 strpnew:=p; 186 end; 187 188 const 189 newline = #10; 190 191 constructor tresobject.init_preop(const s : string;_p1 : presobject); 192 begin 193 typ:=t_preop; 194 p:=strpnew(s); 195 p1:=_p1; 196 p2:=nil; 197 p3:=nil; 198 next:=nil; 199 end; 200 201 constructor tresobject.init_bop(const s : string;_p1,_p2 : presobject); 202 begin 203 typ:=t_bop; 204 p:=strpnew(s); 205 p1:=_p1; 206 p2:=_p2; 207 p3:=nil; 208 next:=nil; 209 end; 210 211 constructor tresobject.init_id(const s : string); 212 begin 213 typ:=t_id; 214 p:=strpnew(s); 215 p1:=nil; 216 p2:=nil; 217 p3:=nil; 218 next:=nil; 219 end; 220 221 constructor tresobject.init_two(t : ttyp;_p1,_p2 : presobject); 222 begin 223 typ:=t; 224 p1:=_p1; 225 p2:=_p2; 226 p3:=nil; 227 p:=nil; 228 next:=nil; 229 end; 230 231 constructor tresobject.init_three(t : ttyp;_p1,_p2,_p3 : presobject); 232 begin 233 typ:=t; 234 p1:=_p1; 235 p2:=_p2; 236 p3:=_p3; 237 p:=nil; 238 next:=nil; 239 end; 240 241 constructor tresobject.init_one(t : ttyp;_p1 : presobject); 242 begin 243 typ:=t; 244 p1:=_p1; 245 p2:=nil; 246 p3:=nil; 247 next:=nil; 248 p:=nil; 249 end; 250 251 constructor tresobject.init_no(t : ttyp); 252 begin 253 typ:=t; 254 p:=nil; 255 p1:=nil; 256 p2:=nil; 257 p3:=nil; 258 next:=nil; 259 end; 260 261 function tresobject.str : string; 262 263 begin 264 str:=strpas(p); 265 end; 266 267 function tresobject.strlength : byte; 268 269 begin 270 if assigned(p) then 271 strlength:=strlen(p) 272 else 273 strlength:=0; 274 end; 275 276 { can this ve considered as a constant ? } 277 function tresobject.is_const : boolean; 278 279 begin 280 case typ of 281 t_id,t_void : 282 is_const:=true; 283 t_preop : 284 is_const:= ((str='-') or (str=' not ')) and p1^.is_const; 285 t_bop : 286 is_const:= p2^.is_const and p1^.is_const; 287 else 288 is_const:=false; 289 end; 290 end; 291 292 function tresobject.get_copy : presobject; 293 var 294 newres : presobject; 295 begin 296 newres:=new(presobject,init_no(typ)); 297 if assigned(p) then 298 newres^.p:=strnew(p); 299 if assigned(p1) then 300 newres^.p1:=p1^.get_copy; 301 if assigned(p2) then 302 newres^.p2:=p2^.get_copy; 303 if assigned(p3) then 304 newres^.p3:=p3^.get_copy; 305 if assigned(next) then 306 newres^.next:=next^.get_copy; 307 get_copy:=newres; 308 end; 309 310 destructor tresobject.done; 311 begin 312 (* writeln('disposing ',byte(typ)); *) 313 if assigned(p)then strdispose(p); 314 if assigned(p1) then 315 dispose(p1,done); 316 if assigned(p2) then 317 dispose(p2,done); 318 if assigned(p3) then 319 dispose(p3,done); 320 if assigned(next) then 321 dispose(next,done); 322 end; 323 %} 324 325 D [0-9] 326 %% 327 328 "/*" begin 329 if not stripcomment then 330 write(outfile,aktspace,'{'); 331 repeat 332 c:=get_char; 333 case c of 334 '*' : begin 335 c:=get_char; 336 if c='/' then 337 begin 338 if not stripcomment then 339 writeln(outfile,' }'); 340 flush(outfile); 341 exit; 342 end 343 else 344 begin 345 if not stripcomment then 346 write(outfile,' '); 347 unget_char(c) 348 end; 349 end; 350 newline : begin 351 next_line; 352 if not stripcomment then 353 begin 354 writeln(outfile); 355 write(outfile,aktspace); 356 end; 357 end; 358 #0 : commenteof; 359 else if not stripcomment then 360 write(outfile,c); 361 end; 362 until false; 363 flush(outfile); 364 end; 365 366 "//" begin 367 If not stripcomment then 368 write(outfile,aktspace,'{'); 369 repeat 370 c:=get_char; 371 case c of 372 newline : begin 373 unget_char(c); 374 if not stripcomment then 375 writeln(outfile,' }'); 376 flush(outfile); 377 exit; 378 end; 379 #0 : commenteof; 380 else if not stripcomment then 381 write(outfile,c); 382 flush(outfile); 383 end; 384 until false; 385 flush(outfile); 386 end; 387 \"[^\"]*\" return(CSTRING); 388 \'[^\']*\' return(CSTRING); 389 "L"\"[^\"]*\" if win32headers then 390 return(CSTRING) 391 else 392 return(256); 393 "L"\'[^\']*\' if win32headers then 394 return(CSTRING) 395 else 396 return(256); 397 {D}*[U]?[L]? begin 398 if yytext[length(yytext)]='L' then 399 dec(byte(yytext[0])); 400 if yytext[length(yytext)]='U' then 401 dec(byte(yytext[0])); 402 return(NUMBER); 403 end; 404 "0x"[0-9A-Fa-f]*[U]?[L]? begin 405 (* handle pre- and postfixes *) 406 if copy(yytext,1,2)='0x' then 407 begin 408 delete(yytext,1,2); 409 yytext:='$'+yytext; 410 end; 411 if yytext[length(yytext)]='L' then 412 dec(byte(yytext[0])); 413 if yytext[length(yytext)]='U' then 414 dec(byte(yytext[0])); 415 return(NUMBER); 416 end; 417 418 {D}+(\.{D}+)?([Ee][+-]?{D}+)? 419 begin 420 return(NUMBER); 421 end; 422 423 "->" if in_define then 424 return(DEREF) 425 else 426 return(256); 427 "-" return(MINUS); 428 "==" return(EQUAL); 429 "!=" return(UNEQUAL); 430 ">=" return(GTE); 431 "<=" return(LTE); 432 ">>" return(_SHR); 433 "##" return(STICK); 434 "<<" return(_SHL); 435 ">" return(GT); 436 "<" return(LT); 437 "|" return(_OR); 438 "&" return(_AND); 439 "!" return(_NOT); 440 "/" return(_SLASH); 441 "+" return(_PLUS); 442 "?" return(QUESTIONMARK); 443 ":" return(COLON); 444 "," return(COMMA); 445 "[" return(LECKKLAMMER); 446 "]" return(RECKKLAMMER); 447 "(" begin 448 inc(arglevel); 449 return(LKLAMMER); 450 end; 451 ")" begin 452 dec(arglevel); 453 return(RKLAMMER); 454 end; 455 "*" return(STAR); 456 "..." return(ELLIPSIS); 457 "." if in_define then 458 return(POINT) 459 else 460 return(256); 461 "=" return(_ASSIGN); 462 "extern" return(EXTERN); 463 "STDCALL" if Win32headers then 464 return(STDCALL) 465 else 466 return(ID); 467 "CDECL" if not Win32headers then 468 return(ID) 469 else 470 return(CDECL); 471 "PASCAL" if not Win32headers then 472 return(ID) 473 else 474 return(PASCAL); 475 "PACKED" if not Win32headers then 476 return(ID) 477 else 478 return(_PACKED); 479 "WINAPI" if not Win32headers then 480 return(ID) 481 else 482 return(WINAPI); 483 "SYS_TRAP" if not palmpilot then 484 return(ID) 485 else 486 return(SYS_TRAP); 487 "WINGDIAPI" if not Win32headers then 488 return(ID) 489 else 490 return(WINGDIAPI); 491 "CALLBACK" if not Win32headers then 492 return(ID) 493 else 494 return(CALLBACK); 495 "EXPENTRY" if not Win32headers then 496 return(ID) 497 else 498 return(CALLBACK); 499 500 "void" return(VOID); 501 "VOID" return(VOID); 502 "#ifdef __cplusplus"[ \t]*\n"extern \"C\" {"\n"#endif" 503 writeln(outfile,'{ C++ extern C conditionnal removed }'); 504 "#ifdef __cplusplus"[ \t]*\n"}"\n"#endif" 505 writeln(outfile,'{ C++ end of extern C conditionnal removed }'); 506 507 "#else" begin 508 writeln(outfile,'{$else}'); 509 block_type:=bt_no; 510 flush(outfile); 511 end; 512 "#endif" begin 513 writeln(outfile,'{$endif}'); 514 block_type:=bt_no; 515 flush(outfile); 516 end; 517 "#elif" begin 518 write(outfile,'(*** was #elif ****)'); 519 write(outfile,'{$else'); 520 c:=get_char; 521 while c<>newline do 522 begin write(outfile,c);c:=get_char;end; 523 writeln(outfile,'}'); 524 block_type:=bt_no; 525 flush(outfile); 526 next_line; 527 end; 528 "#undef" begin 529 write(outfile,'{$undef'); 530 c:=get_char; 531 while c<>newline do 532 begin write(outfile,c);c:=get_char;end; 533 writeln(outfile,'}'); 534 flush(outfile); 535 next_line; 536 end; 537 "#error" begin 538 write(outfile,'{$error'); 539 c:=get_char; 540 while c<>newline do 541 begin 542 write(outfile,c); 543 c:=get_char; 544 end; 545 writeln(outfile,'}'); 546 flush(outfile); 547 next_line; 548 end; 549 550 "#include" begin 551 write(outfile,'{$include'); 552 c:=get_char; 553 while c<>newline do 554 begin write(outfile,c);c:=get_char;end; 555 writeln(outfile,'}'); 556 flush(outfile); 557 block_type:=bt_no; 558 next_line; 559 end; 560 "#if" begin 561 write(outfile,'{$if'); 562 c:=get_char; 563 while c<>newline do 564 begin write(outfile,c);c:=get_char;end; 565 writeln(outfile,'}'); 566 flush(outfile); 567 block_type:=bt_no; 568 next_line; 569 end; 570 "#pragma" begin 571 write(outfile,'(** unsupported pragma'); 572 write(outfile,'#pragma'); 573 c:=get_char; 574 while c<>newline do 575 begin write(outfile,c);c:=get_char;end; 576 writeln(outfile,'*)'); 577 flush(outfile); 578 block_type:=bt_no; 579 next_line; 580 end; 581 "#define" begin 582 in_define:=true; 583 in_space_define:=1; 584 return(DEFINE); 585 end; 586 "char" return(_CHAR); 587 "union" return(UNION); 588 "enum" return(ENUM); 589 "struct" return(STRUCT); 590 "{" return(LGKLAMMER); 591 "}" return(RGKLAMMER); 592 "typedef" return(TYPEDEF); 593 "int" return(INT); 594 "short" return(SHORT); 595 "long" return(LONG); 596 "unsigned" return(UNSIGNED); 597 "float" return(REAL); 598 "const" return(_CONST); 599 "CONST" return(_CONST); 600 "FAR" return(_FAR); 601 "far" return(_FAR); 602 "NEAR" return(_NEAR); 603 "near" return(_NEAR); 604 "HUGE" return(_HUGE); 605 "huge" return(_HUGE); 606 [A-Za-z_][A-Za-z0-9_]* begin 607 if in_space_define=1 then 608 in_space_define:=2; 609 return(ID); 610 end; 611 ";" return(SEMICOLON); 612 [ \f\t] if arglevel=0 then 613 if in_space_define=2 then 614 begin 615 in_space_define:=0; 616 return(SPACE_DEFINE); 617 end; 618 \\\n begin 619 next_line; 620 if arglevel=0 then 621 if in_space_define=2 then 622 begin 623 in_space_define:=0; 624 return(SPACE_DEFINE); 625 end; 626 end; 627 \n begin 628 next_line; 629 if in_define then 630 begin 631 in_define:=false; 632 in_space_define:=0; 633 return(NEW_LINE); 634 end; 635 end; 636 . begin 637 writeln('Illegal character in line ',line_no); 638 writeln(last_source_line); 639 return(256 { error }); 640 end; 641 %% 642 643 function act_token : string; 644 begin 645 act_token:=yytext; 646 end; 647 648 Function ForceExtension(Const HStr,ext:String):String; 649 { 650 Return a filename which certainly has the extension ext 651 (no dot in ext !!) 652 } 653 var 654 j : longint; 655 begin 656 j:=length(Hstr); 657 while (j>0) and (Hstr[j]<>'.') do 658 dec(j); 659 if j=0 then 660 j:=255; 661 ForceExtension:=Copy(Hstr,1,j-1)+'.'+Ext; 662 end; 663 664 begin 665 ProcessOptions; 666 line_no := 1; 667 assign(yyinput, inputfilename); 668 reset(yyinput); 669 assign(textinfile, inputfilename); 670 reset(textinfile); 671 readln(textinfile,last_source_line); 672 assign(outfile, outputfilename); 673 rewrite(outfile); 674 if not(includefile) then 675 begin 676 writeln(outfile,'unit ',unitname,';'); 677 writeln(outfile); 678 writeln(outfile,'{ Automatically converted by H2PAS.EXE from '+inputfilename); 679 writeln(outfile,' Utility made by Florian Klaempfl 25th-28th september 96'); 680 writeln(outfile,' Improvements made by Mark A. Malakanov 22nd-25th may 97 '); 681 writeln(outfile,' Further improvements by Michael Van Canneyt, April 1998 '); 682 writeln(outfile,' define handling and error recovery by Pierre Muller, June 1998 }'); 683 writeln(outfile); 684 writeln(outfile); 685 writeln(outfile,' interface'); 686 writeln(outfile); 687 writeln(outfile,' { C default packing is dword }'); 688 writeln(outfile); 689 writeln(outfile,'{$PACKRECORDS 4}'); 690 end; 691 if UsePPointers then 692 begin 693 { Define some pointers to basic pascal types } 694 writeln(outfile); 695 Writeln(outfile,' { Pointers to basic pascal types, inserted by h2pas conversion program.}'); 696 Writeln(outfile,' Type'); 697 Writeln(outfile,' PLongint = ^Longint;'); 698 Writeln(outfile,' PByte = ^Byte;'); 699 Writeln(outfile,' PWord = ^Word;'); 700 Writeln(outfile,' PInteger = ^Integer;'); 701 Writeln(outfile,' PCardinal = ^Cardinal;'); 702 Writeln(outfile,' PReal = ^Real;'); 703 Writeln(outfile,' PDouble = ^Double;'); 704 Writeln(outfile); 705 end; 706 end. 707 708