1 { 2 Copyright (c) 1998-2002 by Florian Klaempfl 3 4 This unit implements the scanner part and handling of the switches 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 unit scanner; 23 24 {$i fpcdefs.inc} 25 26 interface 27 28 uses 29 cclasses, 30 globtype,globals,constexp,version,tokens, 31 verbose,comphook, 32 finput, 33 widestr; 34 35 const 36 max_include_nesting=32; 37 max_macro_nesting=16; 38 preprocbufsize=32*1024; 39 40 41 type 42 tcommentstyle = (comment_none,comment_tp,comment_oldtp,comment_delphi,comment_c); 43 44 tscannerfile = class; 45 46 preproctyp = (pp_ifdef,pp_ifndef,pp_if,pp_ifopt,pp_else,pp_elseif); 47 48 tpreprocstack = class 49 typ : preproctyp; 50 accept : boolean; 51 next : tpreprocstack; 52 name : TIDString; 53 line_nb : longint; 54 fileindex : longint; 55 constructor Create(atyp:preproctyp;a:boolean;n:tpreprocstack); 56 end; 57 58 tdirectiveproc=procedure; 59 60 tdirectiveitem = class(TFPHashObject) 61 public 62 is_conditional : boolean; 63 proc : tdirectiveproc; 64 constructor Create(AList:TFPHashObjectList;const n:string;p:tdirectiveproc); 65 constructor CreateCond(AList:TFPHashObjectList;const n:string;p:tdirectiveproc); 66 end; 67 68 // stack for replay buffers 69 treplaystack = class 70 token : ttoken; 71 idtoken : ttoken; 72 orgpattern, 73 pattern : string; 74 cstringpattern: ansistring; 75 patternw : pcompilerwidestring; 76 settings : tsettings; 77 tokenbuf : tdynamicarray; 78 tokenbuf_needs_swapping : boolean; 79 next : treplaystack; 80 constructor Create(atoken: ttoken;aidtoken:ttoken; 81 const aorgpattern,apattern:string;const acstringpattern:ansistring; 82 apatternw:pcompilerwidestring;asettings:tsettings; 83 atokenbuf:tdynamicarray;change_endian:boolean;anext:treplaystack); 84 destructor destroy;override; 85 end; 86 arnull87 tcompile_time_predicate = function(var valuedescr: String) : Boolean; 88 89 tspecialgenerictoken = 90 (ST_LOADSETTINGS, 91 ST_LINE, 92 ST_COLUMN, 93 ST_FILEINDEX, 94 ST_LOADMESSAGES); 95 96 { tscannerfile } 97 tscannerfile = class 98 private 99 procedure do_gettokenpos(out tokenpos: longint; out filepos: tfileposinfo); 100 procedure cachenexttokenpos; 101 procedure setnexttoken; 102 procedure savetokenpos; 103 procedure restoretokenpos; 104 procedure writetoken(t: ttoken); readtokennull105 function readtoken : ttoken; 106 public 107 inputfile : tinputfile; { current inputfile list } 108 inputfilecount : longint; 109 110 inputbuffer, { input buffer } 111 inputpointer : pchar; 112 inputstart : longint; 113 114 line_no, { line } 115 lastlinepos : longint; 116 117 lasttokenpos, 118 nexttokenpos : longint; { token } 119 lasttoken, 120 nexttoken : ttoken; 121 122 oldlasttokenpos : longint; { temporary saving/restoring tokenpos } 123 oldcurrent_filepos, 124 oldcurrent_tokenpos : tfileposinfo; 125 126 127 replaytokenbuf, 128 recordtokenbuf : tdynamicarray; 129 130 { last settings we stored } 131 last_settings : tsettings; 132 last_message : pmessagestaterecord; 133 { last filepos we stored } 134 last_filepos, 135 { if nexttoken<>NOTOKEN, then nexttokenpos holds its filepos } 136 next_filepos : tfileposinfo; 137 138 comment_level, 139 yylexcount : longint; 140 ignoredirectives : TFPHashList; { ignore directives, used to give warnings only once } 141 preprocstack : tpreprocstack; 142 replaystack : treplaystack; 143 144 preproc_pattern : string; 145 preproc_token : ttoken; 146 147 { true, if we are parsing preprocessor expressions } 148 in_preproc_comp_expr : boolean; 149 { true if tokens must be converted to opposite endianess} 150 change_endian_for_replay : boolean; 151 152 constructor Create(const fn:string; is_macro: boolean = false); 153 destructor Destroy;override; 154 { File buffer things } openinputfilenull155 function openinputfile:boolean; 156 procedure closeinputfile; tempopeninputfilenull157 function tempopeninputfile:boolean; 158 procedure tempcloseinputfile; 159 procedure saveinputfile; 160 procedure restoreinputfile; 161 procedure firstfile; 162 procedure nextfile; 163 procedure addfile(hp:tinputfile); 164 procedure reload; 165 { replaces current token with the text in p } 166 procedure substitutemacro(const macname:string;p:pchar;len,line,fileindex:longint); 167 { Scanner things } 168 procedure gettokenpos; 169 procedure inc_comment_level; 170 procedure dec_comment_level; 171 procedure illegal_char(c:char); 172 procedure end_of_file; 173 procedure checkpreprocstack; 174 procedure poppreprocstack; 175 procedure ifpreprocstack(atyp:preproctyp;compile_time_predicate:tcompile_time_predicate;messid:longint); 176 procedure elseifpreprocstack(compile_time_predicate:tcompile_time_predicate); 177 procedure elsepreprocstack; 178 procedure popreplaystack; replay_stack_depthnull179 function replay_stack_depth:longint; 180 procedure handleconditional(p:tdirectiveitem); 181 procedure handledirectives; 182 procedure linebreak; 183 procedure recordtoken; 184 procedure startrecordtokens(buf:tdynamicarray); 185 procedure stoprecordtokens; is_recording_tokensnull186 function is_recording_tokens:boolean; 187 procedure replaytoken; 188 procedure startreplaytokens(buf:tdynamicarray; change_endian:boolean); 189 { bit length asizeint is target depend } 190 procedure tokenwritesizeint(val : asizeint); 191 procedure tokenwritelongint(val : longint); 192 procedure tokenwritelongword(val : longword); 193 procedure tokenwriteword(val : word); 194 procedure tokenwriteshortint(val : shortint); 195 procedure tokenwriteset(var b;size : longint); 196 procedure tokenwriteenum(var b;size : longint); tokenreadsizeintnull197 function tokenreadsizeint : asizeint; 198 procedure tokenwritesettings(var asettings : tsettings; var size : asizeint); 199 { longword/longint are 32 bits on all targets } 200 { word/smallint are 16-bits on all targest } tokenreadlongwordnull201 function tokenreadlongword : longword; tokenreadwordnull202 function tokenreadword : word; tokenreadlongintnull203 function tokenreadlongint : longint; tokenreadsmallintnull204 function tokenreadsmallint : smallint; 205 { short int is one a signed byte } tokenreadshortintnull206 function tokenreadshortint : shortint; tokenreadbytenull207 function tokenreadbyte : byte; 208 { This one takes the set size as an parameter } 209 procedure tokenreadset(var b;size : longint); tokenreadenumnull210 function tokenreadenum(size : longint) : longword; 211 212 procedure tokenreadsettings(var asettings : tsettings; expected_size : asizeint); 213 procedure readchar; 214 procedure readstring; 215 procedure readnumber; readidnull216 function readid:string; readvalnull217 function readval:longint; readcommentnull218 function readcomment:string; readquotedstringnull219 function readquotedstring:string; readstatenull220 function readstate:char; readoptionalstatenull221 function readoptionalstate(fallback:char):char; readstatedefaultnull222 function readstatedefault:char; 223 procedure skipspace; 224 procedure skipuntildirective; 225 procedure skipcomment(read_first_char:boolean); 226 procedure skipdelphicomment; 227 procedure skipoldtpcomment(read_first_char:boolean); 228 procedure readtoken(allowrecordtoken:boolean); readpreprocnull229 function readpreproc:ttoken; readpreprocintnull230 function readpreprocint(var value:int64;const place:string):boolean; asmgetcharnull231 function asmgetchar:char; 232 end; 233 234 {$ifdef PREPROCWRITE} 235 tpreprocfile=class 236 f : text; 237 buf : pointer; 238 spacefound, 239 eolfound : boolean; 240 constructor create(const fn:string); 241 destructor destroy; override; 242 procedure Add(const s:string); 243 procedure AddSpace; 244 end; 245 {$endif PREPROCWRITE} 246 247 var 248 { read strings } 249 c : char; 250 orgpattern, 251 pattern : string; 252 cstringpattern : ansistring; 253 patternw : pcompilerwidestring; 254 255 { token } 256 token, { current token being parsed } 257 idtoken : ttoken; { holds the token if the pattern is a known word } 258 259 current_scanner : tscannerfile; { current scanner in use } 260 261 current_commentstyle : tcommentstyle; { needed to use read_comment from directives } 262 {$ifdef PREPROCWRITE} 263 preprocfile : tpreprocfile; { used with only preprocessing } 264 {$endif PREPROCWRITE} 265 266 type 267 tdirectivemode = (directive_all, directive_turbo, directive_mac); 268 269 procedure AddDirective(const s:string; dm: tdirectivemode; p:tdirectiveproc); 270 procedure AddConditional(const s:string; dm: tdirectivemode; p:tdirectiveproc); 271 272 procedure InitScanner; 273 procedure DoneScanner; 274 275 { To be called when the language mode is finally determined } SetCompileModenull276 Function SetCompileMode(const s:string; changeInit: boolean):boolean; SetCompileModeSwitchnull277 Function SetCompileModeSwitch(s:string; changeInit: boolean):boolean; 278 procedure SetAppType(NewAppType:tapptype); 279 280 implementation 281 282 uses 283 SysUtils, 284 cutils,cfileutl, 285 systems, 286 switches, 287 symbase,symtable,symtype,symsym,symconst,symdef,defutil, 288 { This is needed for tcputype } 289 cpuinfo, 290 fmodule,fppu, 291 { this is needed for $I %CURRENTROUTINE%} 292 procinfo 293 {$if FPC_FULLVERSION<20700} 294 ,ccharset 295 {$endif} 296 ; 297 298 var 299 { dictionaries with the supported directives } 300 turbo_scannerdirectives : TFPHashObjectList; { for other modes } 301 mac_scannerdirectives : TFPHashObjectList; { for mode mac } 302 303 304 {***************************************************************************** 305 Helper routines 306 *****************************************************************************} 307 308 const 309 { use any special name that is an invalid file name to avoid problems } 310 preprocstring : array [preproctyp] of string[7] 311 = ('$IFDEF','$IFNDEF','$IF','$IFOPT','$ELSE','$ELSEIF'); 312 is_keywordnull313 function is_keyword(const s:string):boolean; 314 var 315 low,high,mid : longint; 316 begin 317 if not (length(s) in [tokenlenmin..tokenlenmax]) or 318 not (s[1] in ['a'..'z','A'..'Z']) then 319 begin 320 is_keyword:=false; 321 exit; 322 end; 323 low:=ord(tokenidx^[length(s),s[1]].first); 324 high:=ord(tokenidx^[length(s),s[1]].last); 325 while low<high do 326 begin 327 mid:=(high+low+1) shr 1; 328 if pattern<tokeninfo^[ttoken(mid)].str then 329 high:=mid-1 330 else 331 low:=mid; 332 end; 333 is_keyword:=(pattern=tokeninfo^[ttoken(high)].str) and 334 ((tokeninfo^[ttoken(high)].keyword*current_settings.modeswitches)<>[]); 335 end; 336 337 338 Procedure HandleModeSwitches(switch: tmodeswitch; changeInit: boolean); 339 begin 340 { turn ansi/unicodestrings on by default ? (only change when this 341 particular setting is changed, so that a random modeswitch won't 342 change the state of $h+/$h-) } 343 if switch in [m_none,m_default_ansistring,m_default_unicodestring] then 344 begin 345 if ([m_default_ansistring,m_default_unicodestring]*current_settings.modeswitches)<>[] then 346 begin 347 { can't have both ansistring and unicodestring as default } 348 if switch=m_default_ansistring then 349 begin 350 exclude(current_settings.modeswitches,m_default_unicodestring); 351 if changeinit then 352 exclude(init_settings.modeswitches,m_default_unicodestring); 353 end 354 else if switch=m_default_unicodestring then 355 begin 356 exclude(current_settings.modeswitches,m_default_ansistring); 357 if changeinit then 358 exclude(init_settings.modeswitches,m_default_ansistring); 359 end; 360 { enable $h+ } 361 include(current_settings.localswitches,cs_refcountedstrings); 362 if changeinit then 363 include(init_settings.localswitches,cs_refcountedstrings); 364 if m_default_unicodestring in current_settings.modeswitches then 365 begin 366 def_system_macro('FPC_UNICODESTRINGS'); 367 def_system_macro('UNICODE'); 368 end; 369 end 370 else 371 begin 372 exclude(current_settings.localswitches,cs_refcountedstrings); 373 if changeinit then 374 exclude(init_settings.localswitches,cs_refcountedstrings); 375 undef_system_macro('FPC_UNICODESTRINGS'); 376 undef_system_macro('UNICODE'); 377 end; 378 end; 379 380 { turn inline on by default ? } 381 if switch in [m_none,m_default_inline] then 382 begin 383 if (m_default_inline in current_settings.modeswitches) then 384 begin 385 include(current_settings.localswitches,cs_do_inline); 386 if changeinit then 387 include(init_settings.localswitches,cs_do_inline); 388 end 389 else 390 begin 391 exclude(current_settings.localswitches,cs_do_inline); 392 if changeinit then 393 exclude(init_settings.localswitches,cs_do_inline); 394 end; 395 end; 396 397 { turn on system codepage by default } 398 if switch in [m_none,m_systemcodepage] then 399 begin 400 { both m_systemcodepage and specifying a code page via -FcXXX or 401 "$codepage XXX" change current_settings.sourcecodepage. If 402 we used -FcXXX and then have a sourcefile with "$mode objfpc", 403 this routine will be called to disable m_systemcodepage (to ensure 404 it's off in case it would have been set on the command line, or 405 by a previous mode(switch). 406 407 In that case, we have to ensure that we don't overwrite 408 current_settings.sourcecodepage, as that would cancel out the 409 -FcXXX. This is why we use two separate module switches 410 (cs_explicit_codepage and cs_system_codepage) for the same setting 411 (current_settings.sourcecodepage) 412 } 413 if m_systemcodepage in current_settings.modeswitches then 414 begin 415 { m_systemcodepage gets enabled -> disable any -FcXXX and 416 "codepage XXX" settings (exclude cs_explicit_codepage), and 417 overwrite the sourcecode page } 418 current_settings.sourcecodepage:=DefaultSystemCodePage; 419 if (current_settings.sourcecodepage<>CP_UTF8) and not cpavailable(current_settings.sourcecodepage) then 420 begin 421 Message2(scan_w_unavailable_system_codepage,IntToStr(current_settings.sourcecodepage),IntToStr(default_settings.sourcecodepage)); 422 current_settings.sourcecodepage:=default_settings.sourcecodepage; 423 end; 424 exclude(current_settings.moduleswitches,cs_explicit_codepage); 425 include(current_settings.moduleswitches,cs_system_codepage); 426 if changeinit then 427 begin 428 init_settings.sourcecodepage:=current_settings.sourcecodepage; 429 exclude(init_settings.moduleswitches,cs_explicit_codepage); 430 include(init_settings.moduleswitches,cs_system_codepage); 431 end; 432 end 433 else 434 begin 435 { m_systemcodepage gets disabled -> reset sourcecodepage only if 436 cs_explicit_codepage is not set (it may be set in the scenario 437 where -FcXXX was passed on the command line and then "$mode 438 fpc" is used, because then the caller of this routine will 439 set the "$mode fpc" modeswitches (which don't include 440 m_systemcodepage) and call this routine with m_none). 441 442 Or it can happen if -FcXXX was passed, and the sourcefile 443 contains "$modeswitch systemcodepage-" statement. 444 445 Since we unset cs_system_codepage if m_systemcodepage gets 446 activated, we will revert to the default code page if you 447 set a source file code page, then enable the systemcode page 448 and finally disable it again. We don't keep a stack of 449 settings, by design. The only thing we have to ensure is that 450 disabling m_systemcodepage if it wasn't on in the first place 451 doesn't overwrite the sourcecodepage } 452 exclude(current_settings.moduleswitches,cs_system_codepage); 453 if not(cs_explicit_codepage in current_settings.moduleswitches) then 454 current_settings.sourcecodepage:=default_settings.sourcecodepage; 455 if changeinit then 456 begin 457 exclude(init_settings.moduleswitches,cs_system_codepage); 458 if not(cs_explicit_codepage in init_settings.moduleswitches) then 459 init_settings.sourcecodepage:=default_settings.sourcecodepage; 460 end; 461 end; 462 end; 463 end; 464 465 SetCompileModenull466 Function SetCompileMode(const s:string; changeInit: boolean):boolean; 467 var 468 b : boolean; 469 oldmodeswitches : tmodeswitches; 470 begin 471 oldmodeswitches:=current_settings.modeswitches; 472 473 b:=true; 474 if s='DEFAULT' then 475 current_settings.modeswitches:=fpcmodeswitches 476 else 477 if s='DELPHI' then 478 current_settings.modeswitches:=delphimodeswitches 479 else 480 if s='DELPHIUNICODE' then 481 current_settings.modeswitches:=delphiunicodemodeswitches 482 else 483 if s='TP' then 484 current_settings.modeswitches:=tpmodeswitches 485 else 486 if s='FPC' then begin 487 current_settings.modeswitches:=fpcmodeswitches; 488 { TODO: enable this for 2.3/2.9 } 489 // include(current_settings.localswitches, cs_typed_addresses); 490 end else 491 if s='OBJFPC' then begin 492 current_settings.modeswitches:=objfpcmodeswitches; 493 { TODO: enable this for 2.3/2.9 } 494 // include(current_settings.localswitches, cs_typed_addresses); 495 end 496 {$ifdef gpc_mode} 497 else if s='GPC' then 498 current_settings.modeswitches:=gpcmodeswitches 499 {$endif} 500 else 501 if s='MACPAS' then 502 current_settings.modeswitches:=macmodeswitches 503 else 504 if s='ISO' then 505 current_settings.modeswitches:=isomodeswitches 506 else 507 if s='EXTENDEDPASCAL' then 508 current_settings.modeswitches:=extpasmodeswitches 509 else 510 b:=false; 511 512 {$ifdef jvm} 513 { enable final fields by default for the JVM targets } 514 include(current_settings.modeswitches,m_final_fields); 515 {$endif jvm} 516 517 if b and changeInit then 518 init_settings.modeswitches := current_settings.modeswitches; 519 520 if b then 521 begin 522 { resolve all postponed switch changes } 523 flushpendingswitchesstate; 524 525 HandleModeSwitches(m_none,changeinit); 526 527 { turn on bitpacking for mode macpas and iso pascal as well as extended pascal } 528 if ([m_mac,m_iso,m_extpas] * current_settings.modeswitches <> []) then 529 begin 530 include(current_settings.localswitches,cs_bitpacking); 531 if changeinit then 532 include(init_settings.localswitches,cs_bitpacking); 533 end; 534 535 { support goto/label by default in delphi/tp7/mac/iso/extpas modes } 536 if ([m_delphi,m_tp7,m_mac,m_iso,m_extpas] * current_settings.modeswitches <> []) then 537 begin 538 include(current_settings.moduleswitches,cs_support_goto); 539 if changeinit then 540 include(init_settings.moduleswitches,cs_support_goto); 541 end; 542 543 { support pointer math by default in fpc/objfpc modes } 544 if ([m_fpc,m_objfpc] * current_settings.modeswitches <> []) then 545 begin 546 include(current_settings.localswitches,cs_pointermath); 547 if changeinit then 548 include(init_settings.localswitches,cs_pointermath); 549 end 550 else 551 begin 552 exclude(current_settings.localswitches,cs_pointermath); 553 if changeinit then 554 exclude(init_settings.localswitches,cs_pointermath); 555 end; 556 557 { Default enum and set packing for delphi/tp7 } 558 if (m_tp7 in current_settings.modeswitches) or 559 (m_delphi in current_settings.modeswitches) then 560 begin 561 current_settings.packenum:=1; 562 current_settings.setalloc:=1; 563 end 564 else if (m_mac in current_settings.modeswitches) then 565 { compatible with Metrowerks Pascal } 566 current_settings.packenum:=2 567 else 568 current_settings.packenum:=4; 569 if changeinit then 570 begin 571 init_settings.packenum:=current_settings.packenum; 572 init_settings.setalloc:=current_settings.setalloc; 573 end; 574 {$if defined(i386) or defined(i8086)} 575 { Default to intel assembler for delphi/tp7 on i386/i8086 } 576 if (m_delphi in current_settings.modeswitches) or 577 (m_tp7 in current_settings.modeswitches) then 578 begin 579 {$ifdef i8086} 580 current_settings.asmmode:=asmmode_i8086_intel; 581 {$else i8086} 582 current_settings.asmmode:=asmmode_i386_intel; 583 {$endif i8086} 584 if changeinit then 585 init_settings.asmmode:=current_settings.asmmode; 586 end; 587 {$endif i386 or i8086} 588 589 { Exception support explicitly turned on (mainly for macpas, to } 590 { compensate for lack of interprocedural goto support) } 591 if (cs_support_exceptions in current_settings.globalswitches) then 592 include(current_settings.modeswitches,m_except); 593 594 { Default strict string var checking in TP/Delphi modes } 595 if ([m_delphi,m_tp7] * current_settings.modeswitches <> []) then 596 begin 597 include(current_settings.localswitches,cs_strict_var_strings); 598 if changeinit then 599 include(init_settings.localswitches,cs_strict_var_strings); 600 end; 601 602 { Undefine old symbol } 603 if (m_delphi in oldmodeswitches) then 604 undef_system_macro('FPC_DELPHI') 605 else if (m_tp7 in oldmodeswitches) then 606 undef_system_macro('FPC_TP') 607 else if (m_objfpc in oldmodeswitches) then 608 undef_system_macro('FPC_OBJFPC') 609 {$ifdef gpc_mode} 610 else if (m_gpc in oldmodeswitches) then 611 undef_system_macro('FPC_GPC') 612 {$endif} 613 else if (m_mac in oldmodeswitches) then 614 undef_system_macro('FPC_MACPAS') 615 else if (m_iso in oldmodeswitches) then 616 undef_system_macro('FPC_ISO') 617 else if (m_extpas in oldmodeswitches) then 618 undef_system_macro('FPC_EXTENDEDPASCAL'); 619 620 { define new symbol in delphi,objfpc,tp,gpc,macpas mode } 621 if (m_delphi in current_settings.modeswitches) then 622 def_system_macro('FPC_DELPHI') 623 else if (m_tp7 in current_settings.modeswitches) then 624 def_system_macro('FPC_TP') 625 else if (m_objfpc in current_settings.modeswitches) then 626 def_system_macro('FPC_OBJFPC') 627 {$ifdef gpc_mode} 628 else if (m_gpc in current_settings.modeswitches) then 629 def_system_macro('FPC_GPC') 630 {$endif} 631 else if (m_mac in current_settings.modeswitches) then 632 def_system_macro('FPC_MACPAS') 633 else if (m_iso in current_settings.modeswitches) then 634 def_system_macro('FPC_ISO') 635 else if (m_extpas in current_settings.modeswitches) then 636 def_system_macro('FPC_EXTENDEDPASCAL'); 637 end; 638 639 SetCompileMode:=b; 640 end; 641 642 SetCompileModeSwitchnull643 Function SetCompileModeSwitch(s:string; changeInit: boolean):boolean; 644 var 645 i : tmodeswitch; 646 doinclude : boolean; 647 begin 648 s:=upper(s); 649 650 { on/off? } 651 doinclude:=true; 652 case s[length(s)] of 653 '+': 654 s:=copy(s,1,length(s)-1); 655 '-': 656 begin 657 s:=copy(s,1,length(s)-1); 658 doinclude:=false; 659 end; 660 end; 661 662 Result:=false; 663 for i:=m_class to high(tmodeswitch) do 664 if s=modeswitchstr[i] then 665 begin 666 { Objective-C is currently only supported for Darwin targets } 667 if doinclude and 668 (i in [m_objectivec1,m_objectivec2]) and 669 not(target_info.system in systems_objc_supported) then 670 begin 671 Message1(option_unsupported_target_for_feature,'Objective-C'); 672 break; 673 end; 674 675 { Blocks supported? } 676 if doinclude and 677 (i = m_blocks) and 678 not(target_info.system in systems_blocks_supported) then 679 begin 680 Message1(option_unsupported_target_for_feature,'Blocks'); 681 break; 682 end; 683 684 if changeInit then 685 current_settings.modeswitches:=init_settings.modeswitches; 686 Result:=true; 687 if doinclude then 688 begin 689 include(current_settings.modeswitches,i); 690 { Objective-C 2.0 support implies 1.0 support } 691 if (i=m_objectivec2) then 692 include(current_settings.modeswitches,m_objectivec1); 693 if (i in [m_objectivec1,m_objectivec2]) then 694 include(current_settings.modeswitches,m_class); 695 end 696 else 697 begin 698 exclude(current_settings.modeswitches,i); 699 { Objective-C 2.0 support implies 1.0 support } 700 if (i=m_objectivec2) then 701 exclude(current_settings.modeswitches,m_objectivec1); 702 if (i in [m_objectivec1,m_objectivec2]) and 703 ([m_delphi,m_objfpc]*current_settings.modeswitches=[]) then 704 exclude(current_settings.modeswitches,m_class); 705 end; 706 707 { set other switches depending on changed mode switch } 708 HandleModeSwitches(i,changeinit); 709 710 if changeInit then 711 init_settings.modeswitches:=current_settings.modeswitches; 712 713 break; 714 end; 715 end; 716 717 procedure SetAppType(NewAppType:tapptype); 718 begin 719 {$ifdef i8086} 720 if (target_info.system in [system_i8086_msdos,system_i8086_embedded]) and (apptype<>NewAppType) then 721 begin 722 if NewAppType=app_com then 723 begin 724 targetinfos[target_info.system]^.exeext:='.com'; 725 target_info.exeext:='.com'; 726 end 727 else 728 begin 729 targetinfos[target_info.system]^.exeext:='.exe'; 730 target_info.exeext:='.exe'; 731 end; 732 end; 733 {$endif i8086} 734 if apptype in [app_cui,app_com] then 735 undef_system_macro('CONSOLE'); 736 apptype:=NewAppType; 737 if apptype in [app_cui,app_com] then 738 def_system_macro('CONSOLE'); 739 end; 740 {***************************************************************************** 741 Conditional Directives 742 *****************************************************************************} 743 744 procedure dir_else; 745 begin 746 current_scanner.elsepreprocstack; 747 end; 748 749 750 procedure dir_endif; 751 begin 752 current_scanner.poppreprocstack; 753 end; 754 isdefnull755 function isdef(var valuedescr: String): Boolean; 756 var 757 hs : string; 758 begin 759 current_scanner.skipspace; 760 hs:=current_scanner.readid; 761 valuedescr:= hs; 762 if hs='' then 763 Message(scan_e_error_in_preproc_expr); 764 isdef:=defined_macro(hs); 765 end; 766 767 procedure dir_ifdef; 768 begin 769 current_scanner.ifpreprocstack(pp_ifdef,@isdef,scan_c_ifdef_found); 770 end; 771 isnotdefnull772 function isnotdef(var valuedescr: String): Boolean; 773 var 774 hs : string; 775 begin 776 current_scanner.skipspace; 777 hs:=current_scanner.readid; 778 valuedescr:= hs; 779 if hs='' then 780 Message(scan_e_error_in_preproc_expr); 781 isnotdef:=not defined_macro(hs); 782 end; 783 784 procedure dir_ifndef; 785 begin 786 current_scanner.ifpreprocstack(pp_ifndef,@isnotdef,scan_c_ifndef_found); 787 end; 788 opt_checknull789 function opt_check(var valuedescr: String): Boolean; 790 var 791 hs : string; 792 state : char; 793 begin 794 opt_check:= false; 795 current_scanner.skipspace; 796 hs:=current_scanner.readid; 797 valuedescr:= hs; 798 if (length(hs)>1) then 799 Message1(scan_w_illegal_switch,hs) 800 else 801 begin 802 state:=current_scanner.ReadState; 803 if state in ['-','+'] then 804 opt_check:=CheckSwitch(hs[1],state) 805 else 806 Message(scan_e_error_in_preproc_expr); 807 end; 808 end; 809 810 procedure dir_ifopt; 811 begin 812 flushpendingswitchesstate; 813 current_scanner.ifpreprocstack(pp_ifopt,@opt_check,scan_c_ifopt_found); 814 end; 815 816 procedure dir_libprefix; 817 var 818 s : string; 819 begin 820 current_scanner.skipspace; 821 if c <> '''' then 822 Message2(scan_f_syn_expected, '''', c); 823 s := current_scanner.readquotedstring; 824 stringdispose(outputprefix); 825 outputprefix := stringdup(s); 826 with current_module do 827 setfilename(paramfn, paramallowoutput); 828 end; 829 830 procedure dir_libsuffix; 831 var 832 s : string; 833 begin 834 current_scanner.skipspace; 835 if c <> '''' then 836 Message2(scan_f_syn_expected, '''', c); 837 s := current_scanner.readquotedstring; 838 stringdispose(outputsuffix); 839 outputsuffix := stringdup(s); 840 with current_module do 841 setfilename(paramfn, paramallowoutput); 842 end; 843 844 procedure dir_extension; 845 var 846 s : string; 847 begin 848 current_scanner.skipspace; 849 if c <> '''' then 850 Message2(scan_f_syn_expected, '''', c); 851 s := current_scanner.readquotedstring; 852 if OutputFileName='' then 853 OutputFileName:=InputFileName; 854 OutputFileName:=ChangeFileExt(OutputFileName,'.'+s); 855 with current_module do 856 setfilename(paramfn, paramallowoutput); 857 end; 858 859 { 860 Compile time expression type check 861 ---------------------------------- 862 Each subexpression returns its type to the caller, which then can 863 do type check. Since data types of compile time expressions is 864 not well defined, the type system does a best effort. The drawback is 865 that some errors might not be detected. 866 867 Instead of returning a particular data type, a set of possible data types 868 are returned. This way ambigouos types can be handled. For instance a 869 value of 1 can be both a boolean and and integer. 870 871 Booleans 872 -------- 873 874 The following forms of boolean values are supported: 875 * C coded, that is 0 is false, non-zero is true. 876 * TRUE/FALSE for mac style compile time variables 877 878 Thus boolean mac compile time variables are always stored as TRUE/FALSE. 879 When a compile time expression is evaluated, they are then translated 880 to C coded booleans (0/1), to simplify for the expression evaluator. 881 882 Note that this scheme then also of support mac compile time variables which 883 are 0/1 but with a boolean meaning. 884 885 The TRUE/FALSE format is new from 22 august 2005, but the above scheme 886 means that units which is not recompiled, and thus stores 887 compile time variables as the old format (0/1), continue to work. 888 889 Short circuit evaluation 890 ------------------------ 891 For this to work, the part of a compile time expression which is short 892 circuited, should not be evaluated, while it still should be parsed. 893 Therefor there is a parameter eval, telling whether evaluation is needed. 894 In case not, the value returned can be arbitrary. 895 } 896 897 type 898 899 { texprvalue } 900 901 texprvalue = class 902 private 903 { we can't use built-in defs since they 904 may be not created at the moment } 905 class var 906 sintdef,uintdef,booldef,strdef,setdef,realdef: tdef; 907 class constructor createdefs; 908 class destructor destroydefs; 909 public 910 consttyp: tconsttyp; 911 value: tconstvalue; 912 def: tdef; 913 constructor create_const(c:tconstsym); 914 constructor create_error; 915 constructor create_ord(v: Tconstexprint); 916 constructor create_int(v: int64); 917 constructor create_uint(v: qword); 918 constructor create_bool(b: boolean); 919 constructor create_str(s: string); 920 constructor create_set(ns: tnormalset); 921 constructor create_real(r: bestreal); try_parse_numbernull922 class function try_parse_number(s:string):texprvalue; static; try_parse_realnull923 class function try_parse_real(s:string):texprvalue; static; evaluatenull924 function evaluate(v:texprvalue;op:ttoken):texprvalue; 925 procedure error(expecteddef, place: string); isBooleannull926 function isBoolean: Boolean; isIntnull927 function isInt: Boolean; asBoolnull928 function asBool: Boolean; asIntnull929 function asInt: Integer; asInt64null930 function asInt64: Int64; asStrnull931 function asStr: String; 932 destructor destroy; override; 933 end; 934 935 class constructor texprvalue.createdefs; 936 begin 937 { do not use corddef etc here: this code is executed before those 938 variables are initialised. Since these types are only used for 939 compile-time evaluation of conditional expressions, it doesn't matter 940 that we use the base types instead of the cpu-specific ones. } 941 sintdef:=torddef.create(s64bit,low(int64),high(int64),false); 942 uintdef:=torddef.create(u64bit,low(qword),high(qword),false); 943 booldef:=torddef.create(pasbool1,0,1,false); 944 strdef:=tstringdef.createansi(0,false); 945 setdef:=tsetdef.create(sintdef,0,255,false); 946 realdef:=tfloatdef.create(s80real,false); 947 end; 948 949 class destructor texprvalue.destroydefs; 950 begin 951 setdef.free; 952 sintdef.free; 953 uintdef.free; 954 booldef.free; 955 strdef.free; 956 realdef.free; 957 end; 958 959 constructor texprvalue.create_const(c: tconstsym); 960 begin 961 consttyp:=c.consttyp; 962 def:=c.constdef; 963 case consttyp of 964 conststring, 965 constresourcestring: 966 begin 967 value.len:=c.value.len; 968 getmem(value.valueptr,value.len+1); 969 move(c.value.valueptr^,value.valueptr^,value.len+1); 970 end; 971 constwstring: 972 begin 973 initwidestring(value.valueptr); 974 copywidestring(c.value.valueptr,value.valueptr); 975 end; 976 constreal: 977 begin 978 new(pbestreal(value.valueptr)); 979 pbestreal(value.valueptr)^:=pbestreal(c.value.valueptr)^; 980 end; 981 constset: 982 begin 983 new(pnormalset(value.valueptr)); 984 pnormalset(value.valueptr)^:=pnormalset(c.value.valueptr)^; 985 end; 986 constguid: 987 begin 988 new(pguid(value.valueptr)); 989 pguid(value.valueptr)^:=pguid(c.value.valueptr)^; 990 end; 991 else 992 value:=c.value; 993 end; 994 end; 995 996 constructor texprvalue.create_error; 997 begin 998 fillchar(value,sizeof(value),#0); 999 consttyp:=constnone; 1000 def:=generrordef; 1001 end; 1002 1003 constructor texprvalue.create_ord(v: Tconstexprint); 1004 begin 1005 fillchar(value,sizeof(value),#0); 1006 consttyp:=constord; 1007 value.valueord:=v; 1008 if v.signed then 1009 def:=sintdef 1010 else 1011 def:=uintdef; 1012 end; 1013 1014 constructor texprvalue.create_int(v: int64); 1015 begin 1016 fillchar(value,sizeof(value),#0); 1017 consttyp:=constord; 1018 value.valueord:=v; 1019 def:=sintdef; 1020 end; 1021 1022 constructor texprvalue.create_uint(v: qword); 1023 begin 1024 fillchar(value,sizeof(value),#0); 1025 consttyp:=constord; 1026 value.valueord:=v; 1027 def:=uintdef; 1028 end; 1029 1030 constructor texprvalue.create_bool(b: boolean); 1031 begin 1032 fillchar(value,sizeof(value),#0); 1033 consttyp:=constord; 1034 value.valueord:=ord(b); 1035 def:=booldef; 1036 end; 1037 1038 constructor texprvalue.create_str(s: string); 1039 var 1040 sp: pansichar; 1041 len: integer; 1042 begin 1043 fillchar(value,sizeof(value),#0); 1044 consttyp:=conststring; 1045 len:=length(s); 1046 getmem(sp,len+1); 1047 move(s[1],sp^,len+1); 1048 value.valueptr:=sp; 1049 value.len:=len; 1050 def:=strdef; 1051 end; 1052 1053 constructor texprvalue.create_set(ns: tnormalset); 1054 begin 1055 fillchar(value,sizeof(value),#0); 1056 consttyp:=constset; 1057 new(pnormalset(value.valueptr)); 1058 pnormalset(value.valueptr)^:=ns; 1059 def:=setdef; 1060 end; 1061 1062 constructor texprvalue.create_real(r: bestreal); 1063 begin 1064 fillchar(value,sizeof(value),#0); 1065 consttyp:=constreal; 1066 new(pbestreal(value.valueptr)); 1067 pbestreal(value.valueptr)^:=r; 1068 def:=realdef; 1069 end; 1070 texprvalue.try_parse_numbernull1071 class function texprvalue.try_parse_number(s:string):texprvalue; 1072 var 1073 ic: int64; 1074 qc: qword; 1075 code: integer; 1076 begin 1077 { try int64 } 1078 val(s,ic,code); 1079 if code=0 then 1080 result:=texprvalue.create_int(ic) 1081 else 1082 begin 1083 { try qword } 1084 val(s,qc,code); 1085 if code=0 then 1086 result:=texprvalue.create_uint(qc) 1087 else 1088 result:=try_parse_real(s); 1089 end; 1090 end; 1091 texprvalue.try_parse_realnull1092 class function texprvalue.try_parse_real(s:string):texprvalue; 1093 var 1094 d: bestreal; 1095 code: integer; 1096 begin 1097 val(s,d,code); 1098 if code=0 then 1099 result:=texprvalue.create_real(d) 1100 else 1101 result:=nil; 1102 end; 1103 texprvalue.evaluatenull1104 function texprvalue.evaluate(v:texprvalue;op:ttoken):texprvalue; 1105 check_compatbilenull1106 function check_compatbile: boolean; 1107 begin 1108 result:=( 1109 (is_ordinal(v.def) or is_fpu(v.def)) and 1110 (is_ordinal(def) or is_fpu(def)) 1111 ) or 1112 (is_stringlike(v.def) and is_stringlike(def)); 1113 if not result then 1114 Message2(type_e_incompatible_types,def.typename,v.def.typename); 1115 end; 1116 var 1117 lv,rv: tconstexprint; 1118 lvd,rvd: bestreal; 1119 lvs,rvs: string; 1120 begin 1121 case op of 1122 _OP_IN: 1123 begin 1124 if not is_set(v.def) then 1125 begin 1126 v.error('Set', 'IN'); 1127 result:=texprvalue.create_error; 1128 end 1129 else 1130 if not is_ordinal(def) then 1131 begin 1132 error('Ordinal', 'IN'); 1133 result:=texprvalue.create_error; 1134 end 1135 else 1136 if value.valueord.signed then 1137 result:=texprvalue.create_bool(value.valueord.svalue in pnormalset(v.value.valueptr)^) 1138 else 1139 result:=texprvalue.create_bool(value.valueord.uvalue in pnormalset(v.value.valueptr)^); 1140 end; 1141 _OP_NOT: 1142 begin 1143 if isBoolean then 1144 result:=texprvalue.create_bool(not asBool) 1145 else if is_ordinal(def) then 1146 begin 1147 result:=texprvalue.create_ord(value.valueord); 1148 result.def:=def; 1149 calc_not_ordvalue(result.value.valueord,result.def); 1150 end 1151 else 1152 begin 1153 error('Boolean', 'NOT'); 1154 result:=texprvalue.create_error; 1155 end; 1156 end; 1157 _OP_OR: 1158 begin 1159 if isBoolean then 1160 if v.isBoolean then 1161 result:=texprvalue.create_bool(asBool or v.asBool) 1162 else 1163 begin 1164 v.error('Boolean','OR'); 1165 result:=texprvalue.create_error; 1166 end 1167 else if is_ordinal(def) then 1168 if is_ordinal(v.def) then 1169 result:=texprvalue.create_ord(value.valueord or v.value.valueord) 1170 else 1171 begin 1172 v.error('Ordinal','OR'); 1173 result:=texprvalue.create_error; 1174 end 1175 else 1176 begin 1177 error('Boolean','OR'); 1178 result:=texprvalue.create_error; 1179 end; 1180 end; 1181 _OP_XOR: 1182 begin 1183 if isBoolean then 1184 if v.isBoolean then 1185 result:=texprvalue.create_bool(asBool xor v.asBool) 1186 else 1187 begin 1188 v.error('Boolean','XOR'); 1189 result:=texprvalue.create_error; 1190 end 1191 else if is_ordinal(def) then 1192 if is_ordinal(v.def) then 1193 result:=texprvalue.create_ord(value.valueord xor v.value.valueord) 1194 else 1195 begin 1196 v.error('Ordinal','XOR'); 1197 result:=texprvalue.create_error; 1198 end 1199 else 1200 begin 1201 error('Boolean','XOR'); 1202 result:=texprvalue.create_error; 1203 end; 1204 end; 1205 _OP_AND: 1206 begin 1207 if isBoolean then 1208 if v.isBoolean then 1209 result:=texprvalue.create_bool(asBool and v.asBool) 1210 else 1211 begin 1212 v.error('Boolean','AND'); 1213 result:=texprvalue.create_error; 1214 end 1215 else if is_ordinal(def) then 1216 if is_ordinal(v.def) then 1217 result:=texprvalue.create_ord(value.valueord and v.value.valueord) 1218 else 1219 begin 1220 v.error('Ordinal','AND'); 1221 result:=texprvalue.create_error; 1222 end 1223 else 1224 begin 1225 error('Boolean','AND'); 1226 result:=texprvalue.create_error; 1227 end; 1228 end; 1229 _EQ,_NE,_LT,_GT,_GTE,_LTE,_PLUS,_MINUS,_STAR,_SLASH,_OP_DIV,_OP_MOD,_OP_SHL,_OP_SHR: 1230 if check_compatbile then 1231 begin 1232 if (is_ordinal(def) and is_ordinal(v.def)) then 1233 begin 1234 lv:=value.valueord; 1235 rv:=v.value.valueord; 1236 case op of 1237 _EQ: 1238 result:=texprvalue.create_bool(lv=rv); 1239 _NE: 1240 result:=texprvalue.create_bool(lv<>rv); 1241 _LT: 1242 result:=texprvalue.create_bool(lv<rv); 1243 _GT: 1244 result:=texprvalue.create_bool(lv>rv); 1245 _GTE: 1246 result:=texprvalue.create_bool(lv>=rv); 1247 _LTE: 1248 result:=texprvalue.create_bool(lv<=rv); 1249 _PLUS: 1250 result:=texprvalue.create_ord(lv+rv); 1251 _MINUS: 1252 result:=texprvalue.create_ord(lv-rv); 1253 _STAR: 1254 result:=texprvalue.create_ord(lv*rv); 1255 _SLASH: 1256 result:=texprvalue.create_real(lv/rv); 1257 _OP_DIV: 1258 result:=texprvalue.create_ord(lv div rv); 1259 _OP_MOD: 1260 result:=texprvalue.create_ord(lv mod rv); 1261 _OP_SHL: 1262 result:=texprvalue.create_ord(lv shl rv); 1263 _OP_SHR: 1264 result:=texprvalue.create_ord(lv shr rv); 1265 else 1266 begin 1267 { actually we should never get here but this avoids a warning } 1268 Message(parser_e_illegal_expression); 1269 result:=texprvalue.create_error; 1270 end; 1271 end; 1272 end 1273 else 1274 if (is_fpu(def) or is_ordinal(def)) and 1275 (is_fpu(v.def) or is_ordinal(v.def)) then 1276 begin 1277 if is_fpu(def) then 1278 lvd:=pbestreal(value.valueptr)^ 1279 else 1280 lvd:=value.valueord; 1281 if is_fpu(v.def) then 1282 rvd:=pbestreal(v.value.valueptr)^ 1283 else 1284 rvd:=v.value.valueord; 1285 case op of 1286 _EQ: 1287 result:=texprvalue.create_bool(lvd=rvd); 1288 _NE: 1289 result:=texprvalue.create_bool(lvd<>rvd); 1290 _LT: 1291 result:=texprvalue.create_bool(lvd<rvd); 1292 _GT: 1293 result:=texprvalue.create_bool(lvd>rvd); 1294 _GTE: 1295 result:=texprvalue.create_bool(lvd>=rvd); 1296 _LTE: 1297 result:=texprvalue.create_bool(lvd<=rvd); 1298 _PLUS: 1299 result:=texprvalue.create_real(lvd+rvd); 1300 _MINUS: 1301 result:=texprvalue.create_real(lvd-rvd); 1302 _STAR: 1303 result:=texprvalue.create_real(lvd*rvd); 1304 _SLASH: 1305 result:=texprvalue.create_real(lvd/rvd); 1306 else 1307 begin 1308 Message(parser_e_illegal_expression); 1309 result:=texprvalue.create_error; 1310 end; 1311 end; 1312 end 1313 else 1314 begin 1315 lvs:=asStr; 1316 rvs:=v.asStr; 1317 case op of 1318 _EQ: 1319 result:=texprvalue.create_bool(lvs=rvs); 1320 _NE: 1321 result:=texprvalue.create_bool(lvs<>rvs); 1322 _LT: 1323 result:=texprvalue.create_bool(lvs<rvs); 1324 _GT: 1325 result:=texprvalue.create_bool(lvs>rvs); 1326 _GTE: 1327 result:=texprvalue.create_bool(lvs>=rvs); 1328 _LTE: 1329 result:=texprvalue.create_bool(lvs<=rvs); 1330 _PLUS: 1331 result:=texprvalue.create_str(lvs+rvs); 1332 else 1333 begin 1334 Message(parser_e_illegal_expression); 1335 result:=texprvalue.create_error; 1336 end; 1337 end; 1338 end; 1339 end 1340 else 1341 result:=texprvalue.create_error; 1342 else 1343 result:=texprvalue.create_error; 1344 end; 1345 end; 1346 1347 procedure texprvalue.error(expecteddef, place: string); 1348 begin 1349 Message3(scan_e_compile_time_typeerror, 1350 expecteddef, 1351 def.typename, 1352 place 1353 ); 1354 end; 1355 texprvalue.isBooleannull1356 function texprvalue.isBoolean: Boolean; 1357 var 1358 i: int64; 1359 begin 1360 result:=is_boolean(def); 1361 if not result and is_integer(def) then 1362 begin 1363 i:=asInt64; 1364 result:=(i=0)or(i=1); 1365 end; 1366 end; 1367 texprvalue.isIntnull1368 function texprvalue.isInt: Boolean; 1369 begin 1370 result:=is_integer(def); 1371 end; 1372 texprvalue.asBoolnull1373 function texprvalue.asBool: Boolean; 1374 begin 1375 result:=value.valueord<>0; 1376 end; 1377 texprvalue.asIntnull1378 function texprvalue.asInt: Integer; 1379 begin 1380 result:=value.valueord.svalue; 1381 end; 1382 texprvalue.asInt64null1383 function texprvalue.asInt64: Int64; 1384 begin 1385 result:=value.valueord.svalue; 1386 end; 1387 texprvalue.asStrnull1388 function texprvalue.asStr: String; 1389 var 1390 b:byte; 1391 begin 1392 case consttyp of 1393 constord: 1394 result:=tostr(value.valueord); 1395 conststring, 1396 constresourcestring: 1397 SetString(result,pchar(value.valueptr),value.len); 1398 constreal: 1399 str(pbestreal(value.valueptr)^,result); 1400 constset: 1401 begin 1402 result:=','; 1403 for b:=0 to 255 do 1404 if b in pconstset(value.valueptr)^ then 1405 result:=result+tostr(b)+','; 1406 end; 1407 { error values } 1408 constnone: 1409 result:=''; 1410 else 1411 internalerror(2013112801); 1412 end; 1413 end; 1414 1415 destructor texprvalue.destroy; 1416 begin 1417 case consttyp of 1418 conststring, 1419 constresourcestring : 1420 freemem(value.valueptr,value.len+1); 1421 constwstring : 1422 donewidestring(pcompilerwidestring(value.valueptr)); 1423 constreal : 1424 dispose(pbestreal(value.valueptr)); 1425 constset : 1426 dispose(pnormalset(value.valueptr)); 1427 constguid : 1428 dispose(pguid(value.valueptr)); 1429 constord, 1430 { error values } 1431 constnone: 1432 ; 1433 else 1434 internalerror(2013112802); 1435 end; 1436 inherited destroy; 1437 end; 1438 1439 const 1440 preproc_operators=[_EQ,_NE,_LT,_GT,_LTE,_GTE,_MINUS,_PLUS,_STAR,_SLASH,_OP_DIV,_OP_MOD,_OP_SHL,_OP_SHR,_OP_IN,_OP_AND,_OP_OR,_OP_XOR]; 1441 preproc_comp_exprnull1442 function preproc_comp_expr:texprvalue; 1443 1444 function preproc_sub_expr(pred_level:Toperator_precedence;eval:Boolean):texprvalue; forward; 1445 1446 procedure preproc_consume(t:ttoken); 1447 begin 1448 if t<>current_scanner.preproc_token then 1449 Message(scan_e_preproc_syntax_error); 1450 current_scanner.preproc_token:=current_scanner.readpreproc; 1451 end; 1452 try_consume_unitsymnull1453 function try_consume_unitsym(var srsym:tsym;var srsymtable:TSymtable;out tokentoconsume:ttoken):boolean; 1454 var 1455 hmodule: tmodule; 1456 ns:ansistring; 1457 nssym:tsym; 1458 begin 1459 result:=false; 1460 tokentoconsume:=_ID; 1461 1462 if assigned(srsym) and (srsym.typ in [unitsym,namespacesym]) then 1463 begin 1464 if not(srsym.owner.symtabletype in [staticsymtable,globalsymtable]) then 1465 internalerror(200501154); 1466 { only allow unit.symbol access if the name was 1467 found in the current module 1468 we can use iscurrentunit because generic specializations does not 1469 change current_unit variable } 1470 hmodule:=find_module_from_symtable(srsym.Owner); 1471 if not Assigned(hmodule) then 1472 internalerror(201001120); 1473 if hmodule.unit_index=current_filepos.moduleindex then 1474 begin 1475 preproc_consume(_POINT); 1476 current_scanner.skipspace; 1477 if srsym.typ=namespacesym then 1478 begin 1479 ns:=srsym.name; 1480 nssym:=srsym; 1481 while assigned(srsym) and (srsym.typ=namespacesym) do 1482 begin 1483 { we have a namespace. the next identifier should be either a namespace or a unit } 1484 searchsym_in_module(hmodule,ns+'.'+current_scanner.preproc_pattern,srsym,srsymtable); 1485 if assigned(srsym) and (srsym.typ in [namespacesym,unitsym]) then 1486 begin 1487 ns:=ns+'.'+current_scanner.preproc_pattern; 1488 nssym:=srsym; 1489 preproc_consume(_ID); 1490 current_scanner.skipspace; 1491 preproc_consume(_POINT); 1492 current_scanner.skipspace; 1493 end; 1494 end; 1495 { check if there is a hidden unit with this pattern in the namespace } 1496 if not assigned(srsym) and 1497 assigned(nssym) and (nssym.typ=namespacesym) and assigned(tnamespacesym(nssym).unitsym) then 1498 srsym:=tnamespacesym(nssym).unitsym; 1499 if assigned(srsym) and (srsym.typ<>unitsym) then 1500 internalerror(201108260); 1501 if not assigned(srsym) then 1502 begin 1503 result:=true; 1504 srsymtable:=nil; 1505 exit; 1506 end; 1507 end; 1508 case current_scanner.preproc_token of 1509 _ID: 1510 { system.char? (char=widechar comes from the implicit 1511 uuchar unit -> override) } 1512 if (current_scanner.preproc_pattern='CHAR') and 1513 (tmodule(tunitsym(srsym).module).globalsymtable=systemunit) then 1514 begin 1515 if m_default_unicodestring in current_settings.modeswitches then 1516 searchsym_in_module(tunitsym(srsym).module,'WIDECHAR',srsym,srsymtable) 1517 else 1518 searchsym_in_module(tunitsym(srsym).module,'ANSICHAR',srsym,srsymtable) 1519 end 1520 else 1521 searchsym_in_module(tunitsym(srsym).module,current_scanner.preproc_pattern,srsym,srsymtable); 1522 _STRING: 1523 begin 1524 { system.string? } 1525 if tmodule(tunitsym(srsym).module).globalsymtable=systemunit then 1526 begin 1527 if cs_refcountedstrings in current_settings.localswitches then 1528 begin 1529 if m_default_unicodestring in current_settings.modeswitches then 1530 searchsym_in_module(tunitsym(srsym).module,'UNICODESTRING',srsym,srsymtable) 1531 else 1532 searchsym_in_module(tunitsym(srsym).module,'ANSISTRING',srsym,srsymtable) 1533 end 1534 else 1535 searchsym_in_module(tunitsym(srsym).module,'SHORTSTRING',srsym,srsymtable); 1536 tokentoconsume:=_STRING; 1537 end; 1538 end 1539 end; 1540 end 1541 else 1542 begin 1543 srsym:=nil; 1544 srsymtable:=nil; 1545 end; 1546 result:=true; 1547 end; 1548 end; 1549 1550 procedure try_consume_nestedsym(var srsym:tsym;var srsymtable:TSymtable); 1551 var 1552 def:tdef; 1553 tokentoconsume:ttoken; 1554 found:boolean; 1555 begin 1556 found:=try_consume_unitsym(srsym,srsymtable,tokentoconsume); 1557 if found then 1558 begin 1559 preproc_consume(tokentoconsume); 1560 current_scanner.skipspace; 1561 end; 1562 while (current_scanner.preproc_token=_POINT) do 1563 begin 1564 if assigned(srsym)and(srsym.typ=typesym) then 1565 begin 1566 def:=ttypesym(srsym).typedef; 1567 if is_class_or_object(def) or is_record(def) or is_java_class_or_interface(def) then 1568 begin 1569 preproc_consume(_POINT); 1570 current_scanner.skipspace; 1571 if def.typ=objectdef then 1572 found:=searchsym_in_class(tobjectdef(def),tobjectdef(def),current_scanner.preproc_pattern,srsym,srsymtable,[ssf_search_helper]) 1573 else 1574 found:=searchsym_in_record(trecorddef(def),current_scanner.preproc_pattern,srsym,srsymtable); 1575 if not found then 1576 begin 1577 Message1(sym_e_id_not_found,current_scanner.preproc_pattern); 1578 exit; 1579 end; 1580 preproc_consume(_ID); 1581 current_scanner.skipspace; 1582 end 1583 else 1584 begin 1585 Message(sym_e_type_must_be_rec_or_object_or_class); 1586 exit; 1587 end; 1588 end 1589 else 1590 begin 1591 Message(type_e_type_id_expected); 1592 exit; 1593 end; 1594 end; 1595 end; 1596 preproc_substitutedtokennull1597 function preproc_substitutedtoken(searchstr:string;eval:Boolean):texprvalue; 1598 { Currently this parses identifiers as well as numbers. 1599 The result from this procedure can either be that the token 1600 itself is a value, or that it is a compile time variable/macro, 1601 which then is substituted for another value (for macros 1602 recursivelly substituted).} 1603 1604 var 1605 hs: string; 1606 mac: tmacro; 1607 macrocount, 1608 len: integer; 1609 begin 1610 if not eval then 1611 begin 1612 result:=texprvalue.create_str(searchstr); 1613 exit; 1614 end; 1615 1616 mac:=nil; 1617 { Substitue macros and compiler variables with their content/value. 1618 For real macros also do recursive substitution. } 1619 macrocount:=0; 1620 repeat 1621 mac:=tmacro(search_macro(searchstr)); 1622 1623 inc(macrocount); 1624 if macrocount>max_macro_nesting then 1625 begin 1626 Message(scan_w_macro_too_deep); 1627 break; 1628 end; 1629 1630 if assigned(mac) and mac.defined then 1631 if assigned(mac.buftext) then 1632 begin 1633 if mac.buflen>255 then 1634 begin 1635 len:=255; 1636 Message(scan_w_macro_cut_after_255_chars); 1637 end 1638 else 1639 len:=mac.buflen; 1640 hs[0]:=char(len); 1641 move(mac.buftext^,hs[1],len); 1642 searchstr:=upcase(hs); 1643 mac.is_used:=true; 1644 end 1645 else 1646 begin 1647 Message1(scan_e_error_macro_lacks_value,searchstr); 1648 break; 1649 end 1650 else 1651 break; 1652 1653 if mac.is_compiler_var then 1654 break; 1655 until false; 1656 1657 { At this point, result do contain the value. Do some decoding and 1658 determine the type.} 1659 result:=texprvalue.try_parse_number(searchstr); 1660 if not assigned(result) then 1661 begin 1662 if assigned(mac) and (searchstr='FALSE') then 1663 result:=texprvalue.create_bool(false) 1664 else if assigned(mac) and (searchstr='TRUE') then 1665 result:=texprvalue.create_bool(true) 1666 else if (m_mac in current_settings.modeswitches) and 1667 (not assigned(mac) or not mac.defined) and 1668 (macrocount = 1) then 1669 begin 1670 {Errors in mode mac is issued here. For non macpas modes there is 1671 more liberty, but the error will eventually be caught at a later stage.} 1672 Message1(scan_e_error_macro_undefined,searchstr); 1673 result:=texprvalue.create_str(searchstr); { just to have something } 1674 end 1675 else 1676 result:=texprvalue.create_str(searchstr); 1677 end; 1678 end; 1679 preproc_factornull1680 function preproc_factor(eval: Boolean):texprvalue; 1681 var 1682 hs,countstr,storedpattern: string; 1683 mac: tmacro; 1684 srsym : tsym; 1685 srsymtable : TSymtable; 1686 hdef : TDef; 1687 l : longint; 1688 hasKlammer: Boolean; 1689 exprvalue:texprvalue; 1690 ns:tnormalset; 1691 begin 1692 result:=nil; 1693 hasKlammer:=false; 1694 if current_scanner.preproc_token=_ID then 1695 begin 1696 if current_scanner.preproc_pattern='DEFINED' then 1697 begin 1698 preproc_consume(_ID); 1699 current_scanner.skipspace; 1700 if current_scanner.preproc_token =_LKLAMMER then 1701 begin 1702 preproc_consume(_LKLAMMER); 1703 current_scanner.skipspace; 1704 hasKlammer:= true; 1705 end 1706 else if (m_mac in current_settings.modeswitches) then 1707 hasKlammer:= false 1708 else 1709 Message(scan_e_error_in_preproc_expr); 1710 1711 if current_scanner.preproc_token =_ID then 1712 begin 1713 hs := current_scanner.preproc_pattern; 1714 mac := tmacro(search_macro(hs)); 1715 if assigned(mac) and mac.defined then 1716 begin 1717 result:=texprvalue.create_bool(true); 1718 mac.is_used:=true; 1719 end 1720 else 1721 result:=texprvalue.create_bool(false); 1722 preproc_consume(_ID); 1723 current_scanner.skipspace; 1724 end 1725 else 1726 Message(scan_e_error_in_preproc_expr); 1727 1728 if hasKlammer then 1729 if current_scanner.preproc_token =_RKLAMMER then 1730 preproc_consume(_RKLAMMER) 1731 else 1732 Message(scan_e_error_in_preproc_expr); 1733 end 1734 else 1735 if (m_mac in current_settings.modeswitches) and (current_scanner.preproc_pattern='UNDEFINED') then 1736 begin 1737 preproc_consume(_ID); 1738 current_scanner.skipspace; 1739 if current_scanner.preproc_token =_ID then 1740 begin 1741 hs := current_scanner.preproc_pattern; 1742 mac := tmacro(search_macro(hs)); 1743 if assigned(mac) then 1744 begin 1745 result:=texprvalue.create_bool(false); 1746 mac.is_used:=true; 1747 end 1748 else 1749 result:=texprvalue.create_bool(true); 1750 preproc_consume(_ID); 1751 current_scanner.skipspace; 1752 end 1753 else 1754 Message(scan_e_error_in_preproc_expr); 1755 end 1756 else 1757 if (m_mac in current_settings.modeswitches) and (current_scanner.preproc_pattern='OPTION') then 1758 begin 1759 preproc_consume(_ID); 1760 current_scanner.skipspace; 1761 if current_scanner.preproc_token =_LKLAMMER then 1762 begin 1763 preproc_consume(_LKLAMMER); 1764 current_scanner.skipspace; 1765 end 1766 else 1767 Message(scan_e_error_in_preproc_expr); 1768 1769 if not (current_scanner.preproc_token = _ID) then 1770 Message(scan_e_error_in_preproc_expr); 1771 1772 hs:=current_scanner.preproc_pattern; 1773 if (length(hs) > 1) then 1774 {This is allowed in Metrowerks Pascal} 1775 Message(scan_e_error_in_preproc_expr) 1776 else 1777 begin 1778 if CheckSwitch(hs[1],'+') then 1779 result:=texprvalue.create_bool(true) 1780 else 1781 result:=texprvalue.create_bool(false); 1782 end; 1783 1784 preproc_consume(_ID); 1785 current_scanner.skipspace; 1786 if current_scanner.preproc_token =_RKLAMMER then 1787 preproc_consume(_RKLAMMER) 1788 else 1789 Message(scan_e_error_in_preproc_expr); 1790 end 1791 else 1792 if current_scanner.preproc_pattern='SIZEOF' then 1793 begin 1794 preproc_consume(_ID); 1795 current_scanner.skipspace; 1796 if current_scanner.preproc_token =_LKLAMMER then 1797 begin 1798 preproc_consume(_LKLAMMER); 1799 current_scanner.skipspace; 1800 end 1801 else 1802 Message(scan_e_preproc_syntax_error); 1803 1804 storedpattern:=current_scanner.preproc_pattern; 1805 preproc_consume(_ID); 1806 current_scanner.skipspace; 1807 1808 if eval then 1809 if searchsym(storedpattern,srsym,srsymtable) then 1810 begin 1811 try_consume_nestedsym(srsym,srsymtable); 1812 l:=0; 1813 if assigned(srsym) then 1814 case srsym.typ of 1815 staticvarsym, 1816 localvarsym, 1817 paravarsym : 1818 l:=tabstractvarsym(srsym).getsize; 1819 typesym: 1820 l:=ttypesym(srsym).typedef.size; 1821 else 1822 Message(scan_e_error_in_preproc_expr); 1823 end; 1824 result:=texprvalue.create_int(l); 1825 end 1826 else 1827 Message1(sym_e_id_not_found,storedpattern); 1828 1829 if current_scanner.preproc_token =_RKLAMMER then 1830 preproc_consume(_RKLAMMER) 1831 else 1832 Message(scan_e_preproc_syntax_error); 1833 end 1834 else 1835 if current_scanner.preproc_pattern='HIGH' then 1836 begin 1837 preproc_consume(_ID); 1838 current_scanner.skipspace; 1839 if current_scanner.preproc_token =_LKLAMMER then 1840 begin 1841 preproc_consume(_LKLAMMER); 1842 current_scanner.skipspace; 1843 end 1844 else 1845 Message(scan_e_preproc_syntax_error); 1846 1847 storedpattern:=current_scanner.preproc_pattern; 1848 preproc_consume(_ID); 1849 current_scanner.skipspace; 1850 1851 if eval then 1852 if searchsym(storedpattern,srsym,srsymtable) then 1853 begin 1854 try_consume_nestedsym(srsym,srsymtable); 1855 hdef:=nil; 1856 hs:=''; 1857 l:=0; 1858 if assigned(srsym) then 1859 case srsym.typ of 1860 staticvarsym, 1861 localvarsym, 1862 paravarsym : 1863 hdef:=tabstractvarsym(srsym).vardef; 1864 typesym: 1865 hdef:=ttypesym(srsym).typedef; 1866 else 1867 Message(scan_e_error_in_preproc_expr); 1868 end; 1869 if assigned(hdef) then 1870 begin 1871 if hdef.typ=setdef then 1872 hdef:=tsetdef(hdef).elementdef; 1873 case hdef.typ of 1874 orddef: 1875 with torddef(hdef).high do 1876 if signed then 1877 result:=texprvalue.create_int(svalue) 1878 else 1879 result:=texprvalue.create_uint(uvalue); 1880 enumdef: 1881 result:=texprvalue.create_int(tenumdef(hdef).maxval); 1882 arraydef: 1883 if is_open_array(hdef) or is_array_of_const(hdef) or is_dynamic_array(hdef) then 1884 Message(type_e_mismatch) 1885 else 1886 result:=texprvalue.create_int(tarraydef(hdef).highrange); 1887 stringdef: 1888 if is_open_string(hdef) or is_ansistring(hdef) or is_wide_or_unicode_string(hdef) then 1889 Message(type_e_mismatch) 1890 else 1891 result:=texprvalue.create_int(tstringdef(hdef).len); 1892 else 1893 Message(type_e_mismatch); 1894 end; 1895 end; 1896 end 1897 else 1898 Message1(sym_e_id_not_found,storedpattern); 1899 1900 if current_scanner.preproc_token =_RKLAMMER then 1901 preproc_consume(_RKLAMMER) 1902 else 1903 Message(scan_e_preproc_syntax_error); 1904 end 1905 else 1906 if current_scanner.preproc_pattern='DECLARED' then 1907 begin 1908 preproc_consume(_ID); 1909 current_scanner.skipspace; 1910 if current_scanner.preproc_token =_LKLAMMER then 1911 begin 1912 preproc_consume(_LKLAMMER); 1913 current_scanner.skipspace; 1914 end 1915 else 1916 Message(scan_e_error_in_preproc_expr); 1917 if current_scanner.preproc_token =_ID then 1918 begin 1919 hs := upper(current_scanner.preproc_pattern); 1920 preproc_consume(_ID); 1921 current_scanner.skipspace; 1922 if current_scanner.preproc_token in [_LT,_LSHARPBRACKET] then 1923 begin 1924 l:=1; 1925 preproc_consume(current_scanner.preproc_token); 1926 current_scanner.skipspace; 1927 while current_scanner.preproc_token=_COMMA do 1928 begin 1929 inc(l); 1930 preproc_consume(_COMMA); 1931 current_scanner.skipspace; 1932 end; 1933 if not (current_scanner.preproc_token in [_GT,_RSHARPBRACKET]) then 1934 Message(scan_e_error_in_preproc_expr) 1935 else 1936 preproc_consume(current_scanner.preproc_token); 1937 str(l,countstr); 1938 hs:=hs+'$'+countstr; 1939 end 1940 else 1941 { special case: <> } 1942 if current_scanner.preproc_token=_NE then 1943 begin 1944 hs:=hs+'$1'; 1945 preproc_consume(_NE); 1946 end; 1947 current_scanner.skipspace; 1948 if searchsym(hs,srsym,srsymtable) then 1949 begin 1950 { TSomeGeneric<...> also adds a TSomeGeneric symbol } 1951 if (sp_generic_dummy in srsym.symoptions) and 1952 (srsym.typ=typesym) and 1953 ( 1954 { mode delphi} 1955 (ttypesym(srsym).typedef.typ in [undefineddef,errordef]) or 1956 { non-delphi modes } 1957 (df_generic in ttypesym(srsym).typedef.defoptions) 1958 ) then 1959 result:=texprvalue.create_bool(false) 1960 else 1961 result:=texprvalue.create_bool(true); 1962 end 1963 else 1964 result:=texprvalue.create_bool(false); 1965 end 1966 else 1967 Message(scan_e_error_in_preproc_expr); 1968 if current_scanner.preproc_token =_RKLAMMER then 1969 preproc_consume(_RKLAMMER) 1970 else 1971 Message(scan_e_error_in_preproc_expr); 1972 end 1973 else 1974 if current_scanner.preproc_pattern='ORD' then 1975 begin 1976 preproc_consume(_ID); 1977 current_scanner.skipspace; 1978 if current_scanner.preproc_token =_LKLAMMER then 1979 begin 1980 preproc_consume(_LKLAMMER); 1981 current_scanner.skipspace; 1982 end 1983 else 1984 Message(scan_e_preproc_syntax_error); 1985 1986 exprvalue:=preproc_factor(eval); 1987 if eval then 1988 begin 1989 if is_ordinal(exprvalue.def) then 1990 result:=texprvalue.create_int(exprvalue.asInt) 1991 else 1992 begin 1993 exprvalue.error('Ordinal','ORD'); 1994 result:=texprvalue.create_int(0); 1995 end; 1996 end 1997 else 1998 result:=texprvalue.create_int(0); 1999 exprvalue.free; 2000 if current_scanner.preproc_token =_RKLAMMER then 2001 preproc_consume(_RKLAMMER) 2002 else 2003 Message(scan_e_error_in_preproc_expr); 2004 end 2005 else 2006 if current_scanner.preproc_pattern='NOT' then 2007 begin 2008 preproc_consume(_ID); 2009 exprvalue:=preproc_factor(eval); 2010 if eval then 2011 result:=exprvalue.evaluate(nil,_OP_NOT) 2012 else 2013 result:=texprvalue.create_bool(false); {Just to have something} 2014 exprvalue.free; 2015 end 2016 else 2017 if (current_scanner.preproc_pattern='TRUE') then 2018 begin 2019 result:=texprvalue.create_bool(true); 2020 preproc_consume(_ID); 2021 end 2022 else 2023 if (current_scanner.preproc_pattern='FALSE') then 2024 begin 2025 result:=texprvalue.create_bool(false); 2026 preproc_consume(_ID); 2027 end 2028 else 2029 begin 2030 storedpattern:=current_scanner.preproc_pattern; 2031 preproc_consume(_ID); 2032 current_scanner.skipspace; 2033 { first look for a macros/int/float } 2034 result:=preproc_substitutedtoken(storedpattern,eval); 2035 if eval and (result.consttyp=conststring) then 2036 begin 2037 if searchsym(storedpattern,srsym,srsymtable) then 2038 begin 2039 try_consume_nestedsym(srsym,srsymtable); 2040 if assigned(srsym) then 2041 case srsym.typ of 2042 constsym: 2043 begin 2044 result.free; 2045 result:=texprvalue.create_const(tconstsym(srsym)); 2046 end; 2047 enumsym: 2048 begin 2049 result.free; 2050 result:=texprvalue.create_int(tenumsym(srsym).value); 2051 end; 2052 end; 2053 end 2054 end 2055 { skip id(<expr>) if expression must not be evaluated } 2056 else if not(eval) and (result.consttyp=conststring) then 2057 begin 2058 if current_scanner.preproc_token =_LKLAMMER then 2059 begin 2060 preproc_consume(_LKLAMMER); 2061 current_scanner.skipspace; 2062 2063 result:=preproc_factor(false); 2064 if current_scanner.preproc_token =_RKLAMMER then 2065 preproc_consume(_RKLAMMER) 2066 else 2067 Message(scan_e_error_in_preproc_expr); 2068 end; 2069 end; 2070 end 2071 end 2072 else if current_scanner.preproc_token =_LKLAMMER then 2073 begin 2074 preproc_consume(_LKLAMMER); 2075 result:=preproc_sub_expr(opcompare,eval); 2076 preproc_consume(_RKLAMMER); 2077 end 2078 else if current_scanner.preproc_token = _LECKKLAMMER then 2079 begin 2080 preproc_consume(_LECKKLAMMER); 2081 ns:=[]; 2082 while current_scanner.preproc_token in [_ID,_INTCONST] do 2083 begin 2084 exprvalue:=preproc_factor(eval); 2085 include(ns,exprvalue.asInt); 2086 if current_scanner.preproc_token = _COMMA then 2087 preproc_consume(_COMMA); 2088 end; 2089 // TODO Add check of setElemType 2090 preproc_consume(_RECKKLAMMER); 2091 result:=texprvalue.create_set(ns); 2092 end 2093 else if current_scanner.preproc_token = _INTCONST then 2094 begin 2095 result:=texprvalue.try_parse_number(current_scanner.preproc_pattern); 2096 if not assigned(result) then 2097 begin 2098 Message(parser_e_invalid_integer); 2099 result:=texprvalue.create_int(1); 2100 end; 2101 preproc_consume(_INTCONST); 2102 end 2103 else if current_scanner.preproc_token = _CSTRING then 2104 begin 2105 result:=texprvalue.create_str(current_scanner.preproc_pattern); 2106 preproc_consume(_CSTRING); 2107 end 2108 else if current_scanner.preproc_token = _REALNUMBER then 2109 begin 2110 result:=texprvalue.try_parse_real(current_scanner.preproc_pattern); 2111 if not assigned(result) then 2112 begin 2113 Message(parser_e_error_in_real); 2114 result:=texprvalue.create_real(1.0); 2115 end; 2116 preproc_consume(_REALNUMBER); 2117 end 2118 else 2119 Message(scan_e_error_in_preproc_expr); 2120 if not assigned(result) then 2121 result:=texprvalue.create_error; 2122 end; 2123 preproc_sub_exprnull2124 function preproc_sub_expr(pred_level:Toperator_precedence;eval:Boolean): texprvalue; 2125 var 2126 hs1,hs2: texprvalue; 2127 op: ttoken; 2128 begin 2129 if pred_level=highest_precedence then 2130 result:=preproc_factor(eval) 2131 else 2132 result:=preproc_sub_expr(succ(pred_level),eval); 2133 repeat 2134 op:=current_scanner.preproc_token; 2135 if (op in preproc_operators) and 2136 (op in operator_levels[pred_level]) then 2137 begin 2138 hs1:=result; 2139 preproc_consume(op); 2140 if (op=_OP_OR) and hs1.isBoolean and hs1.asBool then 2141 begin 2142 { stop evaluation the rest of expression } 2143 result:=texprvalue.create_bool(true); 2144 if pred_level=highest_precedence then 2145 hs2:=preproc_factor(false) 2146 else 2147 hs2:=preproc_sub_expr(succ(pred_level),false); 2148 end 2149 else if (op=_OP_AND) and hs1.isBoolean and not hs1.asBool then 2150 begin 2151 { stop evaluation the rest of expression } 2152 result:=texprvalue.create_bool(false); 2153 if pred_level=highest_precedence then 2154 hs2:=preproc_factor(false) 2155 else 2156 hs2:=preproc_sub_expr(succ(pred_level),false); 2157 end 2158 else 2159 begin 2160 if pred_level=highest_precedence then 2161 hs2:=preproc_factor(eval) 2162 else 2163 hs2:=preproc_sub_expr(succ(pred_level),eval); 2164 if eval then 2165 result:=hs1.evaluate(hs2,op) 2166 else 2167 result:=texprvalue.create_bool(false); {Just to have something} 2168 end; 2169 hs1.free; 2170 hs2.free; 2171 end 2172 else 2173 break; 2174 until false; 2175 end; 2176 2177 begin 2178 current_scanner.in_preproc_comp_expr:=true; 2179 current_scanner.skipspace; 2180 { start preproc expression scanner } 2181 current_scanner.preproc_token:=current_scanner.readpreproc; 2182 preproc_comp_expr:=preproc_sub_expr(opcompare,true); 2183 current_scanner.in_preproc_comp_expr:=false; 2184 end; 2185 boolean_compile_time_exprnull2186 function boolean_compile_time_expr(var valuedescr: string): Boolean; 2187 var 2188 hs: texprvalue; 2189 begin 2190 hs:=preproc_comp_expr; 2191 if hs.isBoolean then 2192 result:=hs.asBool 2193 else 2194 begin 2195 hs.error('Boolean', 'IF or ELSEIF'); 2196 result:=false; 2197 end; 2198 valuedescr:=hs.asStr; 2199 hs.free; 2200 end; 2201 2202 procedure dir_if; 2203 begin 2204 current_scanner.ifpreprocstack(pp_if,@boolean_compile_time_expr, scan_c_if_found); 2205 end; 2206 2207 procedure dir_elseif; 2208 begin 2209 current_scanner.elseifpreprocstack(@boolean_compile_time_expr); 2210 end; 2211 2212 procedure dir_define_impl(macstyle: boolean); 2213 var 2214 hs : string; 2215 bracketcount : longint; 2216 mac : tmacro; 2217 macropos : longint; 2218 macrobuffer : pmacrobuffer; 2219 begin 2220 current_scanner.skipspace; 2221 hs:=current_scanner.readid; 2222 mac:=tmacro(search_macro(hs)); 2223 if not assigned(mac) or (mac.owner <> current_module.localmacrosymtable) then 2224 begin 2225 mac:=tmacro.create(hs); 2226 mac.defined:=true; 2227 current_module.localmacrosymtable.insert(mac); 2228 end 2229 else 2230 begin 2231 mac.defined:=true; 2232 mac.is_compiler_var:=false; 2233 { delete old definition } 2234 if assigned(mac.buftext) then 2235 begin 2236 freemem(mac.buftext,mac.buflen); 2237 mac.buftext:=nil; 2238 end; 2239 end; 2240 Message1(parser_c_macro_defined,mac.name); 2241 mac.is_used:=true; 2242 if (cs_support_macro in current_settings.moduleswitches) then 2243 begin 2244 current_scanner.skipspace; 2245 2246 if not macstyle then 2247 begin 2248 { may be a macro? } 2249 if c <> ':' then 2250 exit; 2251 current_scanner.readchar; 2252 if c <> '=' then 2253 exit; 2254 current_scanner.readchar; 2255 current_scanner.skipspace; 2256 end; 2257 2258 { key words are never substituted } 2259 if is_keyword(hs) then 2260 Message(scan_e_keyword_cant_be_a_macro); 2261 2262 new(macrobuffer); 2263 macropos:=0; 2264 { parse macro, brackets are counted so it's possible 2265 to have a $ifdef etc. in the macro } 2266 bracketcount:=0; 2267 repeat 2268 case c of 2269 '}' : 2270 if (bracketcount=0) then 2271 break 2272 else 2273 dec(bracketcount); 2274 '{' : 2275 inc(bracketcount); 2276 #10,#13 : 2277 current_scanner.linebreak; 2278 #26 : 2279 current_scanner.end_of_file; 2280 end; 2281 macrobuffer^[macropos]:=c; 2282 inc(macropos); 2283 if macropos>=maxmacrolen then 2284 Message(scan_f_macro_buffer_overflow); 2285 current_scanner.readchar; 2286 until false; 2287 2288 { free buffer of macro ?} 2289 if assigned(mac.buftext) then 2290 freemem(mac.buftext,mac.buflen); 2291 { get new mem } 2292 getmem(mac.buftext,macropos); 2293 mac.buflen:=macropos; 2294 { copy the text } 2295 move(macrobuffer^,mac.buftext^,macropos); 2296 dispose(macrobuffer); 2297 end 2298 else 2299 begin 2300 { check if there is an assignment, then we need to give a 2301 warning } 2302 current_scanner.skipspace; 2303 if c=':' then 2304 begin 2305 current_scanner.readchar; 2306 if c='=' then 2307 Message(scan_w_macro_support_turned_off); 2308 end; 2309 end; 2310 end; 2311 2312 procedure dir_define; 2313 begin 2314 dir_define_impl(false); 2315 end; 2316 2317 procedure dir_definec; 2318 begin 2319 dir_define_impl(true); 2320 end; 2321 2322 procedure dir_setc; 2323 var 2324 hs : string; 2325 mac : tmacro; 2326 exprvalue: texprvalue; 2327 begin 2328 current_scanner.skipspace; 2329 hs:=current_scanner.readid; 2330 mac:=tmacro(search_macro(hs)); 2331 if not assigned(mac) or 2332 (mac.owner <> current_module.localmacrosymtable) then 2333 begin 2334 mac:=tmacro.create(hs); 2335 mac.defined:=true; 2336 mac.is_compiler_var:=true; 2337 current_module.localmacrosymtable.insert(mac); 2338 end 2339 else 2340 begin 2341 mac.defined:=true; 2342 mac.is_compiler_var:=true; 2343 { delete old definition } 2344 if assigned(mac.buftext) then 2345 begin 2346 freemem(mac.buftext,mac.buflen); 2347 mac.buftext:=nil; 2348 end; 2349 end; 2350 Message1(parser_c_macro_defined,mac.name); 2351 mac.is_used:=true; 2352 2353 { key words are never substituted } 2354 if is_keyword(hs) then 2355 Message(scan_e_keyword_cant_be_a_macro); 2356 2357 { macro assignment can be both := and = } 2358 current_scanner.skipspace; 2359 if c=':' then 2360 current_scanner.readchar; 2361 if c='=' then 2362 begin 2363 current_scanner.readchar; 2364 exprvalue:=preproc_comp_expr; 2365 if not is_boolean(exprvalue.def) and 2366 not is_integer(exprvalue.def) then 2367 exprvalue.error('Boolean, Integer', 'SETC'); 2368 hs:=exprvalue.asStr; 2369 2370 if length(hs) <> 0 then 2371 begin 2372 {If we are absolutely shure it is boolean, translate 2373 to TRUE/FALSE to increase possibility to do future type check} 2374 if exprvalue.isBoolean then 2375 begin 2376 if exprvalue.asBool then 2377 hs:='TRUE' 2378 else 2379 hs:='FALSE'; 2380 end; 2381 Message2(parser_c_macro_set_to,mac.name,hs); 2382 { free buffer of macro ?} 2383 if assigned(mac.buftext) then 2384 freemem(mac.buftext,mac.buflen); 2385 { get new mem } 2386 getmem(mac.buftext,length(hs)); 2387 mac.buflen:=length(hs); 2388 { copy the text } 2389 move(hs[1],mac.buftext^,mac.buflen); 2390 end 2391 else 2392 Message(scan_e_preproc_syntax_error); 2393 exprvalue.free; 2394 end 2395 else 2396 Message(scan_e_preproc_syntax_error); 2397 end; 2398 2399 2400 procedure dir_undef; 2401 var 2402 hs : string; 2403 mac : tmacro; 2404 begin 2405 current_scanner.skipspace; 2406 hs:=current_scanner.readid; 2407 mac:=tmacro(search_macro(hs)); 2408 if not assigned(mac) or 2409 (mac.owner <> current_module.localmacrosymtable) then 2410 begin 2411 mac:=tmacro.create(hs); 2412 mac.defined:=false; 2413 current_module.localmacrosymtable.insert(mac); 2414 end 2415 else 2416 begin 2417 mac.defined:=false; 2418 mac.is_compiler_var:=false; 2419 { delete old definition } 2420 if assigned(mac.buftext) then 2421 begin 2422 freemem(mac.buftext,mac.buflen); 2423 mac.buftext:=nil; 2424 end; 2425 end; 2426 Message1(parser_c_macro_undefined,mac.name); 2427 mac.is_used:=true; 2428 end; 2429 2430 procedure dir_include; 2431 findincludefilenull2432 function findincludefile(const path,name:TCmdStr;var foundfile:TCmdStr):boolean; 2433 var 2434 found : boolean; 2435 hpath : TCmdStr; 2436 begin 2437 (* look for the include file 2438 If path was absolute and specified as part of {$I } then 2439 1. specified path 2440 else 2441 1. path of current inputfile,current dir 2442 2. local includepath 2443 3. global includepath 2444 2445 -- Check mantis #13461 before changing this *) 2446 found:=false; 2447 foundfile:=''; 2448 hpath:=''; 2449 if path_absolute(path) then 2450 begin 2451 found:=FindFile(name,path,true,foundfile); 2452 end 2453 else 2454 begin 2455 hpath:=current_scanner.inputfile.path+';'+CurDirRelPath(source_info); 2456 found:=FindFile(path+name, hpath,true,foundfile); 2457 if not found then 2458 found:=current_module.localincludesearchpath.FindFile(path+name,true,foundfile); 2459 if not found then 2460 found:=includesearchpath.FindFile(path+name,true,foundfile); 2461 end; 2462 result:=found; 2463 end; 2464 2465 var 2466 foundfile : TCmdStr; 2467 path, 2468 name, 2469 hs : tpathstr; 2470 args : string; 2471 hp : tinputfile; 2472 found : boolean; 2473 macroIsString : boolean; 2474 begin 2475 current_scanner.skipspace; 2476 args:=current_scanner.readcomment; 2477 hs:=GetToken(args,' '); 2478 if hs='' then 2479 exit; 2480 if (hs[1]='%') then 2481 begin 2482 { case insensitive } 2483 hs:=upper(hs); 2484 { remove %'s } 2485 Delete(hs,1,1); 2486 if hs[length(hs)]='%' then 2487 Delete(hs,length(hs),1); 2488 { save old } 2489 path:=hs; 2490 { first check for internal macros } 2491 macroIsString:=true; 2492 case hs of 2493 'TIME': 2494 hs:=gettimestr; 2495 'DATE': 2496 hs:=getdatestr; 2497 'DATEYEAR': 2498 begin 2499 hs:=tostr(startsystime.Year); 2500 macroIsString:=false; 2501 end; 2502 'DATEMONTH': 2503 begin 2504 hs:=tostr(startsystime.Month); 2505 macroIsString:=false; 2506 end; 2507 'DATEDAY': 2508 begin 2509 hs:=tostr(startsystime.Day); 2510 macroIsString:=false; 2511 end; 2512 'TIMEHOUR': 2513 begin 2514 hs:=tostr(startsystime.Hour); 2515 macroIsString:=false; 2516 end; 2517 'TIMEMINUTE': 2518 begin 2519 hs:=tostr(startsystime.Minute); 2520 macroIsString:=false; 2521 end; 2522 'TIMESECOND': 2523 begin 2524 hs:=tostr(startsystime.Second); 2525 macroIsString:=false; 2526 end; 2527 'FILE': 2528 hs:=current_module.sourcefiles.get_file_name(current_filepos.fileindex); 2529 'LINE': 2530 hs:=tostr(current_filepos.line); 2531 'LINENUM': 2532 begin 2533 hs:=tostr(current_filepos.line); 2534 macroIsString:=false; 2535 end; 2536 'FPCVERSION': 2537 hs:=version_string; 2538 'FPCDATE': 2539 hs:=date_string; 2540 'FPCTARGET': 2541 hs:=target_cpu_string; 2542 'FPCTARGETCPU': 2543 hs:=target_cpu_string; 2544 'FPCTARGETOS': 2545 hs:=target_info.shortname; 2546 'CURRENTROUTINE': 2547 hs:=current_procinfo.procdef.procsym.RealName; 2548 else 2549 hs:=GetEnvironmentVariable(hs); 2550 end; 2551 if hs='' then 2552 Message1(scan_w_include_env_not_found,path); 2553 { make it a stringconst } 2554 if macroIsString then 2555 hs:=''''+hs+''''; 2556 current_scanner.substitutemacro(path,@hs[1],length(hs), 2557 current_scanner.line_no,current_scanner.inputfile.ref_index); 2558 end 2559 else 2560 begin 2561 hs:=FixFileName(hs); 2562 path:=ExtractFilePath(hs); 2563 name:=ExtractFileName(hs); 2564 { Special case for Delphi compatibility: '*' has to be replaced 2565 by the file name of the current source file. } 2566 if (length(name)>=1) and 2567 (name[1]='*') then 2568 name:=ChangeFileExt(current_module.sourcefiles.get_file_name(current_filepos.fileindex),'')+ExtractFileExt(name); 2569 2570 { try to find the file } 2571 found:=findincludefile(path,name,foundfile); 2572 if (not found) and (ExtractFileExt(name)='') then 2573 begin 2574 { try default extensions .inc , .pp and .pas } 2575 if (not found) then 2576 found:=findincludefile(path,ChangeFileExt(name,'.inc'),foundfile); 2577 if (not found) then 2578 found:=findincludefile(path,ChangeFileExt(name,sourceext),foundfile); 2579 if (not found) then 2580 found:=findincludefile(path,ChangeFileExt(name,pasext),foundfile); 2581 end; 2582 { if the name ends in dot, try without the dot } 2583 if (not found) and (ExtractFileExt(name)=ExtensionSeparator) and (Length(name)>=2) then 2584 found:=findincludefile(path,Copy(name,1,Length(name)-1),foundfile); 2585 if current_scanner.inputfilecount<max_include_nesting then 2586 begin 2587 inc(current_scanner.inputfilecount); 2588 { we need to reread the current char } 2589 dec(current_scanner.inputpointer); 2590 { reset c } 2591 c:=#0; 2592 { shutdown current file } 2593 current_scanner.tempcloseinputfile; 2594 { load new file } 2595 hp:=do_openinputfile(foundfile); 2596 hp.inc_path:=path; 2597 current_scanner.addfile(hp); 2598 current_module.sourcefiles.register_file(hp); 2599 if (not found) then 2600 Message1(scan_f_cannot_open_includefile,hs); 2601 if (not current_scanner.openinputfile) then 2602 Message1(scan_f_cannot_open_includefile,hs); 2603 Message1(scan_t_start_include_file,current_scanner.inputfile.path+current_scanner.inputfile.name); 2604 current_scanner.reload; 2605 end 2606 else 2607 Message(scan_f_include_deep_ten); 2608 end; 2609 end; 2610 2611 2612 {***************************************************************************** 2613 Preprocessor writing 2614 *****************************************************************************} 2615 2616 {$ifdef PREPROCWRITE} 2617 constructor tpreprocfile.create(const fn:string); 2618 begin 2619 inherited create; 2620 { open outputfile } 2621 assign(f,fn); 2622 {$push}{$I-} 2623 rewrite(f); 2624 {$pop} 2625 if ioresult<>0 then 2626 Comment(V_Fatal,'can''t create file '+fn); 2627 getmem(buf,preprocbufsize); 2628 settextbuf(f,buf^,preprocbufsize); 2629 { reset } 2630 eolfound:=false; 2631 spacefound:=false; 2632 end; 2633 2634 2635 destructor tpreprocfile.destroy; 2636 begin 2637 close(f); 2638 freemem(buf,preprocbufsize); 2639 end; 2640 2641 2642 procedure tpreprocfile.add(const s:string); 2643 begin 2644 write(f,s); 2645 end; 2646 2647 procedure tpreprocfile.addspace; 2648 begin 2649 if eolfound then 2650 begin 2651 writeln(f,''); 2652 eolfound:=false; 2653 spacefound:=false; 2654 end 2655 else 2656 if spacefound then 2657 begin 2658 write(f,' '); 2659 spacefound:=false; 2660 end; 2661 end; 2662 {$endif PREPROCWRITE} 2663 2664 2665 {***************************************************************************** 2666 TPreProcStack 2667 *****************************************************************************} 2668 2669 constructor tpreprocstack.create(atyp : preproctyp;a:boolean;n:tpreprocstack); 2670 begin 2671 accept:=a; 2672 typ:=atyp; 2673 next:=n; 2674 end; 2675 2676 {***************************************************************************** 2677 TReplayStack 2678 *****************************************************************************} 2679 constructor treplaystack.Create(atoken:ttoken;aidtoken:ttoken; 2680 const aorgpattern,apattern:string;const acstringpattern:ansistring; 2681 apatternw:pcompilerwidestring;asettings:tsettings; 2682 atokenbuf:tdynamicarray;change_endian:boolean;anext:treplaystack); 2683 begin 2684 token:=atoken; 2685 idtoken:=aidtoken; 2686 orgpattern:=aorgpattern; 2687 pattern:=apattern; 2688 cstringpattern:=acstringpattern; 2689 initwidestring(patternw); 2690 if assigned(apatternw) then 2691 begin 2692 setlengthwidestring(patternw,apatternw^.len); 2693 move(apatternw^.data^,patternw^.data^,apatternw^.len*sizeof(tcompilerwidechar)); 2694 end; 2695 settings:=asettings; 2696 tokenbuf:=atokenbuf; 2697 tokenbuf_needs_swapping:=change_endian; 2698 next:=anext; 2699 end; 2700 2701 2702 destructor treplaystack.destroy; 2703 begin 2704 donewidestring(patternw); 2705 end; 2706 2707 {***************************************************************************** 2708 TDirectiveItem 2709 *****************************************************************************} 2710 2711 constructor TDirectiveItem.Create(AList:TFPHashObjectList;const n:string;p:tdirectiveproc); 2712 begin 2713 inherited Create(AList,n); 2714 is_conditional:=false; 2715 proc:=p; 2716 end; 2717 2718 2719 constructor TDirectiveItem.CreateCond(AList:TFPHashObjectList;const n:string;p:tdirectiveproc); 2720 begin 2721 inherited Create(AList,n); 2722 is_conditional:=true; 2723 proc:=p; 2724 end; 2725 2726 {**************************************************************************** 2727 TSCANNERFILE 2728 ****************************************************************************} 2729 2730 constructor tscannerfile.create(const fn:string; is_macro: boolean = false); 2731 begin 2732 inputfile:=do_openinputfile(fn); 2733 if is_macro then 2734 inputfile.is_macro:=true; 2735 if assigned(current_module) then 2736 current_module.sourcefiles.register_file(inputfile); 2737 { reset localinput } 2738 c:=#0; 2739 inputbuffer:=nil; 2740 inputpointer:=nil; 2741 inputstart:=0; 2742 { reset scanner } 2743 preprocstack:=nil; 2744 replaystack:=nil; 2745 comment_level:=0; 2746 yylexcount:=0; 2747 block_type:=bt_general; 2748 line_no:=0; 2749 lastlinepos:=0; 2750 lasttokenpos:=0; 2751 nexttokenpos:=0; 2752 lasttoken:=NOTOKEN; 2753 nexttoken:=NOTOKEN; 2754 ignoredirectives:=TFPHashList.Create; 2755 change_endian_for_replay:=false; 2756 end; 2757 2758 2759 procedure tscannerfile.firstfile; 2760 begin 2761 { load block } 2762 if not openinputfile then 2763 Message1(scan_f_cannot_open_input,inputfile.name); 2764 reload; 2765 end; 2766 2767 2768 destructor tscannerfile.destroy; 2769 begin 2770 if assigned(current_module) and 2771 (current_module.state=ms_compiled) and 2772 (status.errorcount=0) then 2773 checkpreprocstack 2774 else 2775 begin 2776 while assigned(preprocstack) do 2777 poppreprocstack; 2778 end; 2779 while assigned(replaystack) do 2780 popreplaystack; 2781 if not inputfile.closed then 2782 closeinputfile; 2783 if inputfile.is_macro then 2784 inputfile.free; 2785 ignoredirectives.free; 2786 end; 2787 2788 tscannerfile.openinputfilenull2789 function tscannerfile.openinputfile:boolean; 2790 begin 2791 openinputfile:=inputfile.open; 2792 { load buffer } 2793 inputbuffer:=inputfile.buf; 2794 inputpointer:=inputfile.buf; 2795 inputstart:=inputfile.bufstart; 2796 { line } 2797 line_no:=0; 2798 lastlinepos:=0; 2799 lasttokenpos:=0; 2800 nexttokenpos:=0; 2801 end; 2802 2803 2804 procedure tscannerfile.closeinputfile; 2805 begin 2806 inputfile.close; 2807 { reset buffer } 2808 inputbuffer:=nil; 2809 inputpointer:=nil; 2810 inputstart:=0; 2811 { reset line } 2812 line_no:=0; 2813 lastlinepos:=0; 2814 lasttokenpos:=0; 2815 nexttokenpos:=0; 2816 end; 2817 2818 tscannerfile.tempopeninputfilenull2819 function tscannerfile.tempopeninputfile:boolean; 2820 begin 2821 tempopeninputfile:=false; 2822 if inputfile.is_macro then 2823 exit; 2824 tempopeninputfile:=inputfile.tempopen; 2825 { reload buffer } 2826 inputbuffer:=inputfile.buf; 2827 inputpointer:=inputfile.buf; 2828 inputstart:=inputfile.bufstart; 2829 end; 2830 2831 2832 procedure tscannerfile.tempcloseinputfile; 2833 begin 2834 if inputfile.closed or inputfile.is_macro then 2835 exit; 2836 inputfile.setpos(inputstart+(inputpointer-inputbuffer)); 2837 inputfile.tempclose; 2838 { reset buffer } 2839 inputbuffer:=nil; 2840 inputpointer:=nil; 2841 inputstart:=0; 2842 end; 2843 2844 2845 procedure tscannerfile.saveinputfile; 2846 begin 2847 inputfile.saveinputpointer:=inputpointer; 2848 inputfile.savelastlinepos:=lastlinepos; 2849 inputfile.saveline_no:=line_no; 2850 end; 2851 2852 2853 procedure tscannerfile.restoreinputfile; 2854 begin 2855 inputbuffer:=inputfile.buf; 2856 inputpointer:=inputfile.saveinputpointer; 2857 lastlinepos:=inputfile.savelastlinepos; 2858 line_no:=inputfile.saveline_no; 2859 if not inputfile.is_macro then 2860 parser_current_file:=inputfile.name; 2861 end; 2862 2863 2864 procedure tscannerfile.nextfile; 2865 var 2866 to_dispose : tinputfile; 2867 begin 2868 if assigned(inputfile.next) then 2869 begin 2870 if inputfile.is_macro then 2871 to_dispose:=inputfile 2872 else 2873 begin 2874 to_dispose:=nil; 2875 dec(inputfilecount); 2876 end; 2877 { we can allways close the file, no ? } 2878 inputfile.close; 2879 inputfile:=inputfile.next; 2880 if assigned(to_dispose) then 2881 to_dispose.free; 2882 restoreinputfile; 2883 end; 2884 end; 2885 2886 2887 procedure tscannerfile.startrecordtokens(buf:tdynamicarray); 2888 begin 2889 if not assigned(buf) then 2890 internalerror(200511172); 2891 if assigned(recordtokenbuf) then 2892 internalerror(200511173); 2893 recordtokenbuf:=buf; 2894 fillchar(last_settings,sizeof(last_settings),0); 2895 last_message:=nil; 2896 fillchar(last_filepos,sizeof(last_filepos),0); 2897 end; 2898 2899 2900 procedure tscannerfile.stoprecordtokens; 2901 begin 2902 if not assigned(recordtokenbuf) then 2903 internalerror(200511174); 2904 recordtokenbuf:=nil; 2905 end; 2906 tscannerfile.is_recording_tokensnull2907 function tscannerfile.is_recording_tokens: boolean; 2908 begin 2909 result:=assigned(recordtokenbuf); 2910 end; 2911 2912 2913 procedure tscannerfile.writetoken(t : ttoken); 2914 var 2915 b : byte; 2916 begin 2917 if ord(t)>$7f then 2918 begin 2919 b:=(ord(t) shr 8) or $80; 2920 recordtokenbuf.write(b,1); 2921 end; 2922 b:=ord(t) and $ff; 2923 recordtokenbuf.write(b,1); 2924 end; 2925 2926 procedure tscannerfile.tokenwritesizeint(val : asizeint); 2927 begin 2928 recordtokenbuf.write(val,sizeof(asizeint)); 2929 end; 2930 2931 procedure tscannerfile.tokenwritelongint(val : longint); 2932 begin 2933 recordtokenbuf.write(val,sizeof(longint)); 2934 end; 2935 2936 procedure tscannerfile.tokenwriteshortint(val : shortint); 2937 begin 2938 recordtokenbuf.write(val,sizeof(shortint)); 2939 end; 2940 2941 procedure tscannerfile.tokenwriteword(val : word); 2942 begin 2943 recordtokenbuf.write(val,sizeof(word)); 2944 end; 2945 2946 procedure tscannerfile.tokenwritelongword(val : longword); 2947 begin 2948 recordtokenbuf.write(val,sizeof(longword)); 2949 end; 2950 tscannerfile.tokenreadsizeintnull2951 function tscannerfile.tokenreadsizeint : asizeint; 2952 var 2953 val : asizeint; 2954 begin 2955 replaytokenbuf.read(val,sizeof(asizeint)); 2956 if change_endian_for_replay then 2957 val:=swapendian(val); 2958 result:=val; 2959 end; 2960 tscannerfile.tokenreadlongwordnull2961 function tscannerfile.tokenreadlongword : longword; 2962 var 2963 val : longword; 2964 begin 2965 replaytokenbuf.read(val,sizeof(longword)); 2966 if change_endian_for_replay then 2967 val:=swapendian(val); 2968 result:=val; 2969 end; 2970 tscannerfile.tokenreadlongintnull2971 function tscannerfile.tokenreadlongint : longint; 2972 var 2973 val : longint; 2974 begin 2975 replaytokenbuf.read(val,sizeof(longint)); 2976 if change_endian_for_replay then 2977 val:=swapendian(val); 2978 result:=val; 2979 end; 2980 tscannerfile.tokenreadshortintnull2981 function tscannerfile.tokenreadshortint : shortint; 2982 var 2983 val : shortint; 2984 begin 2985 replaytokenbuf.read(val,sizeof(shortint)); 2986 result:=val; 2987 end; 2988 tscannerfile.tokenreadbytenull2989 function tscannerfile.tokenreadbyte : byte; 2990 var 2991 val : byte; 2992 begin 2993 replaytokenbuf.read(val,sizeof(byte)); 2994 result:=val; 2995 end; 2996 tscannerfile.tokenreadsmallintnull2997 function tscannerfile.tokenreadsmallint : smallint; 2998 var 2999 val : smallint; 3000 begin 3001 replaytokenbuf.read(val,sizeof(smallint)); 3002 if change_endian_for_replay then 3003 val:=swapendian(val); 3004 result:=val; 3005 end; 3006 tscannerfile.tokenreadwordnull3007 function tscannerfile.tokenreadword : word; 3008 var 3009 val : word; 3010 begin 3011 replaytokenbuf.read(val,sizeof(word)); 3012 if change_endian_for_replay then 3013 val:=swapendian(val); 3014 result:=val; 3015 end; 3016 tscannerfile.tokenreadenumnull3017 function tscannerfile.tokenreadenum(size : longint) : longword; 3018 begin 3019 if size=1 then 3020 result:=tokenreadbyte 3021 else if size=2 then 3022 result:=tokenreadword 3023 else if size=4 then 3024 result:=tokenreadlongword 3025 else 3026 internalerror(2013112901); 3027 end; 3028 3029 procedure tscannerfile.tokenreadset(var b;size : longint); 3030 var 3031 i : longint; 3032 begin 3033 replaytokenbuf.read(b,size); 3034 if change_endian_for_replay then 3035 for i:=0 to size-1 do 3036 Pbyte(@b)[i]:=reverse_byte(Pbyte(@b)[i]); 3037 end; 3038 3039 procedure tscannerfile.tokenwriteenum(var b;size : longint); 3040 begin 3041 recordtokenbuf.write(b,size); 3042 end; 3043 3044 procedure tscannerfile.tokenwriteset(var b;size : longint); 3045 begin 3046 recordtokenbuf.write(b,size); 3047 end; 3048 3049 3050 procedure tscannerfile.tokenreadsettings(var asettings : tsettings; expected_size : asizeint); 3051 3052 { This procedure 3053 needs to be changed whenever 3054 globals.tsettings type is changed, 3055 the problem is that no error will appear 3056 before tests with generics are tested. PM } 3057 3058 var 3059 startpos, endpos : longword; 3060 begin 3061 { WARNING all those fields need to be in the correct 3062 order otherwise cross_endian PPU reading will fail } 3063 startpos:=replaytokenbuf.pos; 3064 with asettings do 3065 begin 3066 alignment.procalign:=tokenreadlongint; 3067 alignment.loopalign:=tokenreadlongint; 3068 alignment.jumpalign:=tokenreadlongint; 3069 alignment.constalignmin:=tokenreadlongint; 3070 alignment.constalignmax:=tokenreadlongint; 3071 alignment.varalignmin:=tokenreadlongint; 3072 alignment.varalignmax:=tokenreadlongint; 3073 alignment.localalignmin:=tokenreadlongint; 3074 alignment.localalignmax:=tokenreadlongint; 3075 alignment.recordalignmin:=tokenreadlongint; 3076 alignment.recordalignmax:=tokenreadlongint; 3077 alignment.maxCrecordalign:=tokenreadlongint; 3078 tokenreadset(globalswitches,sizeof(globalswitches)); 3079 tokenreadset(targetswitches,sizeof(targetswitches)); 3080 tokenreadset(moduleswitches,sizeof(moduleswitches)); 3081 tokenreadset(localswitches,sizeof(localswitches)); 3082 tokenreadset(modeswitches,sizeof(modeswitches)); 3083 tokenreadset(optimizerswitches,sizeof(optimizerswitches)); 3084 tokenreadset(genwpoptimizerswitches,sizeof(genwpoptimizerswitches)); 3085 tokenreadset(dowpoptimizerswitches,sizeof(dowpoptimizerswitches)); 3086 tokenreadset(debugswitches,sizeof(debugswitches)); 3087 { 0: old behaviour for sets <=256 elements 3088 >0: round to this size } 3089 setalloc:=tokenreadshortint; 3090 packenum:=tokenreadshortint; 3091 3092 packrecords:=tokenreadshortint; 3093 maxfpuregisters:=tokenreadshortint; 3094 3095 3096 cputype:=tcputype(tokenreadenum(sizeof(tcputype))); 3097 optimizecputype:=tcputype(tokenreadenum(sizeof(tcputype))); 3098 fputype:=tfputype(tokenreadenum(sizeof(tfputype))); 3099 asmmode:=tasmmode(tokenreadenum(sizeof(tasmmode))); 3100 interfacetype:=tinterfacetypes(tokenreadenum(sizeof(tinterfacetypes))); 3101 defproccall:=tproccalloption(tokenreadenum(sizeof(tproccalloption))); 3102 { tstringencoding is word type, 3103 thus this should be OK here } 3104 sourcecodepage:=tstringEncoding(tokenreadword); 3105 3106 minfpconstprec:=tfloattype(tokenreadenum(sizeof(tfloattype))); 3107 3108 disabledircache:=boolean(tokenreadbyte); 3109 { TH: Since the field was conditional originally, it was not stored in PPUs. } 3110 { While adding ControllerSupport constant, I decided not to store ct_none } 3111 { on targets not supporting controllers, but this might be changed here and } 3112 { in tokenwritesettings in the future to unify the PPU structure and handling } 3113 { of this field in the compiler. } 3114 {$PUSH} 3115 {$WARN 6018 OFF} (* Unreachable code due to compile time evaluation *) 3116 if ControllerSupport then 3117 controllertype:=tcontrollertype(tokenreadenum(sizeof(tcontrollertype))) 3118 else 3119 ControllerType:=ct_none; 3120 {$POP} 3121 endpos:=replaytokenbuf.pos; 3122 if endpos-startpos<>expected_size then 3123 Comment(V_Error,'Wrong size of Settings read-in'); 3124 end; 3125 end; 3126 3127 procedure tscannerfile.tokenwritesettings(var asettings : tsettings; var size : asizeint); 3128 3129 { This procedure 3130 needs to be changed whenever 3131 globals.tsettings type is changed, 3132 the problem is that no error will appear 3133 before tests with generics are tested. PM } 3134 3135 var 3136 sizepos, startpos, endpos : longword; 3137 begin 3138 { WARNING all those fields need to be in the correct 3139 order otherwise cross_endian PPU reading will fail } 3140 sizepos:=recordtokenbuf.pos; 3141 size:=0; 3142 tokenwritesizeint(size); 3143 startpos:=recordtokenbuf.pos; 3144 with asettings do 3145 begin 3146 tokenwritelongint(alignment.procalign); 3147 tokenwritelongint(alignment.loopalign); 3148 tokenwritelongint(alignment.jumpalign); 3149 tokenwritelongint(alignment.constalignmin); 3150 tokenwritelongint(alignment.constalignmax); 3151 tokenwritelongint(alignment.varalignmin); 3152 tokenwritelongint(alignment.varalignmax); 3153 tokenwritelongint(alignment.localalignmin); 3154 tokenwritelongint(alignment.localalignmax); 3155 tokenwritelongint(alignment.recordalignmin); 3156 tokenwritelongint(alignment.recordalignmax); 3157 tokenwritelongint(alignment.maxCrecordalign); 3158 tokenwriteset(globalswitches,sizeof(globalswitches)); 3159 tokenwriteset(targetswitches,sizeof(targetswitches)); 3160 tokenwriteset(moduleswitches,sizeof(moduleswitches)); 3161 tokenwriteset(localswitches,sizeof(localswitches)); 3162 tokenwriteset(modeswitches,sizeof(modeswitches)); 3163 tokenwriteset(optimizerswitches,sizeof(optimizerswitches)); 3164 tokenwriteset(genwpoptimizerswitches,sizeof(genwpoptimizerswitches)); 3165 tokenwriteset(dowpoptimizerswitches,sizeof(dowpoptimizerswitches)); 3166 tokenwriteset(debugswitches,sizeof(debugswitches)); 3167 { 0: old behaviour for sets <=256 elements 3168 >0: round to this size } 3169 tokenwriteshortint(setalloc); 3170 tokenwriteshortint(packenum); 3171 tokenwriteshortint(packrecords); 3172 tokenwriteshortint(maxfpuregisters); 3173 3174 tokenwriteenum(cputype,sizeof(tcputype)); 3175 tokenwriteenum(optimizecputype,sizeof(tcputype)); 3176 tokenwriteenum(fputype,sizeof(tfputype)); 3177 tokenwriteenum(asmmode,sizeof(tasmmode)); 3178 tokenwriteenum(interfacetype,sizeof(tinterfacetypes)); 3179 tokenwriteenum(defproccall,sizeof(tproccalloption)); 3180 { tstringencoding is word type, 3181 thus this should be OK here } 3182 tokenwriteword(sourcecodepage); 3183 3184 tokenwriteenum(minfpconstprec,sizeof(tfloattype)); 3185 3186 recordtokenbuf.write(byte(disabledircache),1); 3187 { TH: See note about controllertype field in tokenreadsettings. } 3188 {$PUSH} 3189 {$WARN 6018 OFF} (* Unreachable code due to compile time evaluation *) 3190 if ControllerSupport then 3191 tokenwriteenum(controllertype,sizeof(tcontrollertype)); 3192 {$POP} 3193 endpos:=recordtokenbuf.pos; 3194 size:=endpos-startpos; 3195 recordtokenbuf.seek(sizepos); 3196 tokenwritesizeint(size); 3197 recordtokenbuf.seek(endpos); 3198 end; 3199 end; 3200 3201 3202 procedure tscannerfile.recordtoken; 3203 var 3204 t : ttoken; 3205 s : tspecialgenerictoken; 3206 len,msgnb,copy_size : asizeint; 3207 val : longint; 3208 b : byte; 3209 pmsg : pmessagestaterecord; 3210 begin 3211 if not assigned(recordtokenbuf) then 3212 internalerror(200511176); 3213 t:=_GENERICSPECIALTOKEN; 3214 { settings changed? } 3215 { last field pmessage is handled separately below in 3216 ST_LOADMESSAGES } 3217 if CompareByte(current_settings,last_settings, 3218 sizeof(current_settings)-sizeof(pointer))<>0 then 3219 begin 3220 { use a special token to record it } 3221 s:=ST_LOADSETTINGS; 3222 writetoken(t); 3223 recordtokenbuf.write(s,1); 3224 copy_size:=sizeof(current_settings)-sizeof(pointer); 3225 tokenwritesettings(current_settings,copy_size); 3226 last_settings:=current_settings; 3227 end; 3228 3229 if current_settings.pmessage<>last_message then 3230 begin 3231 { use a special token to record it } 3232 s:=ST_LOADMESSAGES; 3233 writetoken(t); 3234 recordtokenbuf.write(s,1); 3235 msgnb:=0; 3236 pmsg:=current_settings.pmessage; 3237 while assigned(pmsg) do 3238 begin 3239 if msgnb=high(asizeint) then 3240 { Too many messages } 3241 internalerror(2011090401); 3242 inc(msgnb); 3243 pmsg:=pmsg^.next; 3244 end; 3245 tokenwritesizeint(msgnb); 3246 pmsg:=current_settings.pmessage; 3247 while assigned(pmsg) do 3248 begin 3249 { What about endianess here?} 3250 { SB: this is handled by tokenreadlongint } 3251 val:=pmsg^.value; 3252 tokenwritelongint(val); 3253 val:=ord(pmsg^.state); 3254 tokenwritelongint(val); 3255 pmsg:=pmsg^.next; 3256 end; 3257 last_message:=current_settings.pmessage; 3258 end; 3259 3260 { file pos changes? } 3261 if current_tokenpos.line<>last_filepos.line then 3262 begin 3263 s:=ST_LINE; 3264 writetoken(t); 3265 recordtokenbuf.write(s,1); 3266 tokenwritelongint(current_tokenpos.line); 3267 last_filepos.line:=current_tokenpos.line; 3268 end; 3269 if current_tokenpos.column<>last_filepos.column then 3270 begin 3271 s:=ST_COLUMN; 3272 writetoken(t); 3273 { can the column be written packed? } 3274 if current_tokenpos.column<$80 then 3275 begin 3276 b:=$80 or current_tokenpos.column; 3277 recordtokenbuf.write(b,1); 3278 end 3279 else 3280 begin 3281 recordtokenbuf.write(s,1); 3282 tokenwriteword(current_tokenpos.column); 3283 end; 3284 last_filepos.column:=current_tokenpos.column; 3285 end; 3286 if current_tokenpos.fileindex<>last_filepos.fileindex then 3287 begin 3288 s:=ST_FILEINDEX; 3289 writetoken(t); 3290 recordtokenbuf.write(s,1); 3291 tokenwriteword(current_tokenpos.fileindex); 3292 last_filepos.fileindex:=current_tokenpos.fileindex; 3293 end; 3294 3295 writetoken(token); 3296 if token<>_GENERICSPECIALTOKEN then 3297 writetoken(idtoken); 3298 case token of 3299 _CWCHAR, 3300 _CWSTRING : 3301 begin 3302 tokenwritesizeint(patternw^.len); 3303 if patternw^.len>0 then 3304 recordtokenbuf.write(patternw^.data^,patternw^.len*sizeof(tcompilerwidechar)); 3305 end; 3306 _CSTRING: 3307 begin 3308 len:=length(cstringpattern); 3309 tokenwritesizeint(len); 3310 if len>0 then 3311 recordtokenbuf.write(cstringpattern[1],len); 3312 end; 3313 _CCHAR, 3314 _INTCONST, 3315 _REALNUMBER : 3316 begin 3317 { pexpr.pas messes with pattern in case of negative integer consts, 3318 see around line 2562 the comment of JM; remove the - before recording it 3319 (FK) 3320 } 3321 if (token=_INTCONST) and (pattern[1]='-') then 3322 delete(pattern,1,1); 3323 recordtokenbuf.write(pattern[0],1); 3324 recordtokenbuf.write(pattern[1],length(pattern)); 3325 end; 3326 _ID : 3327 begin 3328 recordtokenbuf.write(orgpattern[0],1); 3329 recordtokenbuf.write(orgpattern[1],length(orgpattern)); 3330 end; 3331 end; 3332 end; 3333 3334 3335 procedure tscannerfile.startreplaytokens(buf:tdynamicarray; change_endian:boolean); 3336 begin 3337 if not assigned(buf) then 3338 internalerror(200511175); 3339 3340 { save current scanner state } 3341 replaystack:=treplaystack.create(token,idtoken,orgpattern,pattern, 3342 cstringpattern,patternw,current_settings,replaytokenbuf,change_endian_for_replay,replaystack); 3343 if assigned(inputpointer) then 3344 dec(inputpointer); 3345 { install buffer } 3346 replaytokenbuf:=buf; 3347 3348 { Initialize value of change_endian_for_replay variable } 3349 change_endian_for_replay:=change_endian; 3350 3351 { reload next token } 3352 replaytokenbuf.seek(0); 3353 replaytoken; 3354 end; 3355 3356 tscannerfile.readtokennull3357 function tscannerfile.readtoken: ttoken; 3358 var 3359 b,b2 : byte; 3360 begin 3361 replaytokenbuf.read(b,1); 3362 if (b and $80)<>0 then 3363 begin 3364 replaytokenbuf.read(b2,1); 3365 result:=ttoken(((b and $7f) shl 8) or b2); 3366 end 3367 else 3368 result:=ttoken(b); 3369 end; 3370 3371 3372 procedure tscannerfile.replaytoken; 3373 var 3374 wlen,mesgnb,copy_size : asizeint; 3375 specialtoken : tspecialgenerictoken; 3376 i : byte; 3377 pmsg,prevmsg : pmessagestaterecord; 3378 begin 3379 if not assigned(replaytokenbuf) then 3380 internalerror(200511177); 3381 { End of replay buffer? Then load the next char from the file again } 3382 if replaytokenbuf.pos>=replaytokenbuf.size then 3383 begin 3384 token:=replaystack.token; 3385 idtoken:=replaystack.idtoken; 3386 pattern:=replaystack.pattern; 3387 orgpattern:=replaystack.orgpattern; 3388 setlengthwidestring(patternw,replaystack.patternw^.len); 3389 move(replaystack.patternw^.data^,patternw^.data^,replaystack.patternw^.len*sizeof(tcompilerwidechar)); 3390 cstringpattern:=replaystack.cstringpattern; 3391 replaytokenbuf:=replaystack.tokenbuf; 3392 change_endian_for_replay:=replaystack.tokenbuf_needs_swapping; 3393 { restore compiler settings } 3394 current_settings:=replaystack.settings; 3395 popreplaystack; 3396 if assigned(inputpointer) then 3397 begin 3398 c:=inputpointer^; 3399 inc(inputpointer); 3400 end; 3401 exit; 3402 end; 3403 repeat 3404 { load token from the buffer } 3405 token:=readtoken; 3406 if token<>_GENERICSPECIALTOKEN then 3407 idtoken:=readtoken 3408 else 3409 idtoken:=_NOID; 3410 case token of 3411 _CWCHAR, 3412 _CWSTRING : 3413 begin 3414 wlen:=tokenreadsizeint; 3415 setlengthwidestring(patternw,wlen); 3416 if wlen>0 then 3417 replaytokenbuf.read(patternw^.data^,patternw^.len*sizeof(tcompilerwidechar)); 3418 orgpattern:=''; 3419 pattern:=''; 3420 cstringpattern:=''; 3421 end; 3422 _CSTRING: 3423 begin 3424 wlen:=tokenreadsizeint; 3425 if wlen>0 then 3426 begin 3427 setlength(cstringpattern,wlen); 3428 replaytokenbuf.read(cstringpattern[1],wlen); 3429 end 3430 else 3431 cstringpattern:=''; 3432 orgpattern:=''; 3433 pattern:=''; 3434 end; 3435 _CCHAR, 3436 _INTCONST, 3437 _REALNUMBER : 3438 begin 3439 replaytokenbuf.read(pattern[0],1); 3440 replaytokenbuf.read(pattern[1],length(pattern)); 3441 orgpattern:=''; 3442 end; 3443 _ID : 3444 begin 3445 replaytokenbuf.read(orgpattern[0],1); 3446 replaytokenbuf.read(orgpattern[1],length(orgpattern)); 3447 pattern:=upper(orgpattern); 3448 end; 3449 _GENERICSPECIALTOKEN: 3450 begin 3451 replaytokenbuf.read(specialtoken,1); 3452 { packed column? } 3453 if (ord(specialtoken) and $80)<>0 then 3454 begin 3455 current_tokenpos.column:=ord(specialtoken) and $7f; 3456 current_filepos:=current_tokenpos; 3457 end 3458 else 3459 case specialtoken of 3460 ST_LOADSETTINGS: 3461 begin 3462 copy_size:=tokenreadsizeint; 3463 //if copy_size <> sizeof(current_settings)-sizeof(pointer) then 3464 // internalerror(2011090501); 3465 { 3466 replaytokenbuf.read(current_settings,copy_size); 3467 } 3468 tokenreadsettings(current_settings,copy_size); 3469 end; 3470 ST_LOADMESSAGES: 3471 begin 3472 current_settings.pmessage:=nil; 3473 mesgnb:=tokenreadsizeint; 3474 prevmsg:=nil; 3475 for i:=1 to mesgnb do 3476 begin 3477 new(pmsg); 3478 if i=1 then 3479 current_settings.pmessage:=pmsg 3480 else 3481 prevmsg^.next:=pmsg; 3482 pmsg^.value:=tokenreadlongint; 3483 pmsg^.state:=tmsgstate(tokenreadlongint); 3484 pmsg^.next:=nil; 3485 prevmsg:=pmsg; 3486 end; 3487 end; 3488 ST_LINE: 3489 begin 3490 current_tokenpos.line:=tokenreadlongint; 3491 current_filepos:=current_tokenpos; 3492 end; 3493 ST_COLUMN: 3494 begin 3495 current_tokenpos.column:=tokenreadword; 3496 current_filepos:=current_tokenpos; 3497 end; 3498 ST_FILEINDEX: 3499 begin 3500 current_tokenpos.fileindex:=tokenreadword; 3501 current_filepos:=current_tokenpos; 3502 end; 3503 else 3504 internalerror(2006103010); 3505 end; 3506 continue; 3507 end; 3508 end; 3509 break; 3510 until false; 3511 end; 3512 3513 3514 procedure tscannerfile.addfile(hp:tinputfile); 3515 begin 3516 saveinputfile; 3517 { add to list } 3518 hp.next:=inputfile; 3519 inputfile:=hp; 3520 { load new inputfile } 3521 restoreinputfile; 3522 end; 3523 3524 3525 procedure tscannerfile.reload; 3526 begin 3527 with inputfile do 3528 begin 3529 { when nothing more to read then leave immediatly, so we 3530 don't change the current_filepos and leave it point to the last 3531 char } 3532 if (c=#26) and (not assigned(next)) then 3533 exit; 3534 repeat 3535 { still more to read?, then change the #0 to a space so its seen 3536 as a seperator, this can't be used for macro's which can change 3537 the place of the #0 in the buffer with tempopen } 3538 if (c=#0) and (bufsize>0) and 3539 not(inputfile.is_macro) and 3540 (inputpointer-inputbuffer<bufsize) then 3541 begin 3542 c:=' '; 3543 inc(inputpointer); 3544 exit; 3545 end; 3546 { can we read more from this file ? } 3547 if (c<>#26) and (not endoffile) then 3548 begin 3549 readbuf; 3550 inputpointer:=buf; 3551 inputbuffer:=buf; 3552 inputstart:=bufstart; 3553 { first line? } 3554 if line_no=0 then 3555 begin 3556 c:=inputpointer^; 3557 { eat utf-8 signature? } 3558 if (ord(inputpointer^)=$ef) and 3559 (ord((inputpointer+1)^)=$bb) and 3560 (ord((inputpointer+2)^)=$bf) then 3561 begin 3562 (* we don't support including files with an UTF-8 bom 3563 inside another file that wasn't encoded as UTF-8 3564 already (we don't support {$codepage xxx} switches in 3565 the middle of a file either) *) 3566 if (current_settings.sourcecodepage<>CP_UTF8) and 3567 not current_module.in_global then 3568 Message(scanner_f_illegal_utf8_bom); 3569 inc(inputpointer,3); 3570 message(scan_c_switching_to_utf8); 3571 current_settings.sourcecodepage:=CP_UTF8; 3572 exclude(current_settings.moduleswitches,cs_system_codepage); 3573 include(current_settings.moduleswitches,cs_explicit_codepage); 3574 end; 3575 3576 line_no:=1; 3577 if cs_asm_source in current_settings.globalswitches then 3578 inputfile.setline(line_no,inputstart+inputpointer-inputbuffer); 3579 end; 3580 end 3581 else 3582 begin 3583 { load eof position in tokenpos/current_filepos } 3584 gettokenpos; 3585 { close file } 3586 closeinputfile; 3587 { no next module, than EOF } 3588 if not assigned(inputfile.next) then 3589 begin 3590 c:=#26; 3591 exit; 3592 end; 3593 { load next file and reopen it } 3594 nextfile; 3595 tempopeninputfile; 3596 { status } 3597 Message1(scan_t_back_in,inputfile.name); 3598 end; 3599 { load next char } 3600 c:=inputpointer^; 3601 inc(inputpointer); 3602 until c<>#0; { if also end, then reload again } 3603 end; 3604 end; 3605 3606 3607 procedure tscannerfile.substitutemacro(const macname:string;p:pchar;len,line,fileindex:longint); 3608 var 3609 hp : tinputfile; 3610 begin 3611 { save old postion } 3612 dec(inputpointer); 3613 tempcloseinputfile; 3614 { create macro 'file' } 3615 { use special name to dispose after !! } 3616 hp:=do_openinputfile('_Macro_.'+macname); 3617 addfile(hp); 3618 with inputfile do 3619 begin 3620 setmacro(p,len); 3621 { local buffer } 3622 inputbuffer:=buf; 3623 inputpointer:=buf; 3624 inputstart:=bufstart; 3625 ref_index:=fileindex; 3626 end; 3627 { reset line } 3628 line_no:=line; 3629 lastlinepos:=0; 3630 lasttokenpos:=0; 3631 nexttokenpos:=0; 3632 { load new c } 3633 c:=inputpointer^; 3634 inc(inputpointer); 3635 end; 3636 3637 3638 procedure tscannerfile.do_gettokenpos(out tokenpos: longint; out filepos: tfileposinfo); 3639 begin 3640 tokenpos:=inputstart+(inputpointer-inputbuffer); 3641 filepos.line:=line_no; 3642 filepos.column:=tokenpos-lastlinepos; 3643 filepos.fileindex:=inputfile.ref_index; 3644 filepos.moduleindex:=current_module.unit_index; 3645 end; 3646 3647 3648 procedure tscannerfile.gettokenpos; 3649 { load the values of tokenpos and lasttokenpos } 3650 begin 3651 do_gettokenpos(lasttokenpos,current_tokenpos); 3652 current_filepos:=current_tokenpos; 3653 end; 3654 3655 3656 procedure tscannerfile.cachenexttokenpos; 3657 begin 3658 do_gettokenpos(nexttokenpos,next_filepos); 3659 end; 3660 3661 3662 procedure tscannerfile.setnexttoken; 3663 begin 3664 token:=nexttoken; 3665 nexttoken:=NOTOKEN; 3666 lasttokenpos:=nexttokenpos; 3667 current_tokenpos:=next_filepos; 3668 current_filepos:=current_tokenpos; 3669 nexttokenpos:=0; 3670 end; 3671 3672 3673 procedure tscannerfile.savetokenpos; 3674 begin 3675 oldlasttokenpos:=lasttokenpos; 3676 oldcurrent_filepos:=current_filepos; 3677 oldcurrent_tokenpos:=current_tokenpos; 3678 end; 3679 3680 3681 procedure tscannerfile.restoretokenpos; 3682 begin 3683 lasttokenpos:=oldlasttokenpos; 3684 current_filepos:=oldcurrent_filepos; 3685 current_tokenpos:=oldcurrent_tokenpos; 3686 end; 3687 3688 3689 procedure tscannerfile.inc_comment_level; 3690 begin 3691 if (m_nested_comment in current_settings.modeswitches) then 3692 inc(comment_level) 3693 else 3694 comment_level:=1; 3695 if (comment_level>1) then 3696 begin 3697 savetokenpos; 3698 gettokenpos; { update for warning } 3699 Message1(scan_w_comment_level,tostr(comment_level)); 3700 restoretokenpos; 3701 end; 3702 end; 3703 3704 3705 procedure tscannerfile.dec_comment_level; 3706 begin 3707 if (m_nested_comment in current_settings.modeswitches) then 3708 dec(comment_level) 3709 else 3710 comment_level:=0; 3711 end; 3712 3713 3714 procedure tscannerfile.linebreak; 3715 var 3716 cur : char; 3717 begin 3718 with inputfile do 3719 begin 3720 if (byte(inputpointer^)=0) and not(endoffile) then 3721 begin 3722 cur:=c; 3723 reload; 3724 if byte(cur)+byte(c)<>23 then 3725 dec(inputpointer); 3726 end 3727 else 3728 begin 3729 { Support all combination of #10 and #13 as line break } 3730 if (byte(inputpointer^)+byte(c)=23) then 3731 inc(inputpointer); 3732 end; 3733 { Always return #10 as line break } 3734 c:=#10; 3735 { increase line counters } 3736 lastlinepos:=inputstart+(inputpointer-inputbuffer); 3737 inc(line_no); 3738 { update linebuffer } 3739 if cs_asm_source in current_settings.globalswitches then 3740 inputfile.setline(line_no,lastlinepos); 3741 { update for status and call the show status routine, 3742 but don't touch current_filepos ! } 3743 savetokenpos; 3744 gettokenpos; { update for v_status } 3745 inc(status.compiledlines); 3746 ShowStatus; 3747 restoretokenpos; 3748 end; 3749 end; 3750 3751 3752 procedure tscannerfile.illegal_char(c:char); 3753 var 3754 s : string; 3755 begin 3756 if c in [#32..#255] then 3757 s:=''''+c+'''' 3758 else 3759 s:='#'+tostr(ord(c)); 3760 Message2(scan_f_illegal_char,s,'$'+hexstr(ord(c),2)); 3761 end; 3762 3763 3764 procedure tscannerfile.end_of_file; 3765 begin 3766 checkpreprocstack; 3767 Message(scan_f_end_of_file); 3768 end; 3769 3770 {------------------------------------------- 3771 IF Conditional Handling 3772 -------------------------------------------} 3773 3774 procedure tscannerfile.checkpreprocstack; 3775 begin 3776 { check for missing ifdefs } 3777 while assigned(preprocstack) do 3778 begin 3779 Message4(scan_e_endif_expected,preprocstring[preprocstack.typ],preprocstack.name, 3780 current_module.sourcefiles.get_file_name(preprocstack.fileindex), 3781 tostr(preprocstack.line_nb)); 3782 poppreprocstack; 3783 end; 3784 end; 3785 3786 3787 procedure tscannerfile.poppreprocstack; 3788 var 3789 hp : tpreprocstack; 3790 begin 3791 if assigned(preprocstack) then 3792 begin 3793 Message1(scan_c_endif_found,preprocstack.name); 3794 hp:=preprocstack.next; 3795 preprocstack.free; 3796 preprocstack:=hp; 3797 end 3798 else 3799 Message(scan_e_endif_without_if); 3800 end; 3801 3802 3803 procedure tscannerfile.ifpreprocstack(atyp:preproctyp;compile_time_predicate:tcompile_time_predicate;messid:longint); 3804 var 3805 condition: Boolean; 3806 valuedescr: String; 3807 begin 3808 if (preprocstack=nil) or preprocstack.accept then 3809 condition:=compile_time_predicate(valuedescr) 3810 else 3811 begin 3812 condition:= false; 3813 valuedescr:= ''; 3814 end; 3815 preprocstack:=tpreprocstack.create(atyp, condition, preprocstack); 3816 preprocstack.name:=valuedescr; 3817 preprocstack.line_nb:=line_no; 3818 preprocstack.fileindex:=current_filepos.fileindex; 3819 if preprocstack.accept then 3820 Message2(messid,preprocstack.name,'accepted') 3821 else 3822 Message2(messid,preprocstack.name,'rejected'); 3823 end; 3824 3825 procedure tscannerfile.elsepreprocstack; 3826 begin 3827 if assigned(preprocstack) and 3828 (preprocstack.typ<>pp_else) then 3829 begin 3830 if (preprocstack.typ=pp_elseif) then 3831 preprocstack.accept:=false 3832 else 3833 if (not(assigned(preprocstack.next)) or (preprocstack.next.accept)) then 3834 preprocstack.accept:=not preprocstack.accept; 3835 preprocstack.typ:=pp_else; 3836 preprocstack.line_nb:=line_no; 3837 preprocstack.fileindex:=current_filepos.fileindex; 3838 if preprocstack.accept then 3839 Message2(scan_c_else_found,preprocstack.name,'accepted') 3840 else 3841 Message2(scan_c_else_found,preprocstack.name,'rejected'); 3842 end 3843 else 3844 Message(scan_e_endif_without_if); 3845 end; 3846 3847 procedure tscannerfile.elseifpreprocstack(compile_time_predicate:tcompile_time_predicate); 3848 var 3849 valuedescr: String; 3850 begin 3851 if assigned(preprocstack) and 3852 (preprocstack.typ in [pp_if,pp_elseif]) then 3853 begin 3854 { when the branch is accepted we use pp_elseif so we know that 3855 all the next branches need to be rejected. when this branch is still 3856 not accepted then leave it at pp_if } 3857 if (preprocstack.typ=pp_elseif) then 3858 preprocstack.accept:=false 3859 else if (preprocstack.typ=pp_if) and preprocstack.accept then 3860 begin 3861 preprocstack.accept:=false; 3862 preprocstack.typ:=pp_elseif; 3863 end 3864 else if (not(assigned(preprocstack.next)) or (preprocstack.next.accept)) 3865 and compile_time_predicate(valuedescr) then 3866 begin 3867 preprocstack.name:=valuedescr; 3868 preprocstack.accept:=true; 3869 preprocstack.typ:=pp_elseif; 3870 end; 3871 3872 preprocstack.line_nb:=line_no; 3873 preprocstack.fileindex:=current_filepos.fileindex; 3874 if preprocstack.accept then 3875 Message2(scan_c_else_found,preprocstack.name,'accepted') 3876 else 3877 Message2(scan_c_else_found,preprocstack.name,'rejected'); 3878 end 3879 else 3880 Message(scan_e_endif_without_if); 3881 end; 3882 3883 3884 procedure tscannerfile.popreplaystack; 3885 var 3886 hp : treplaystack; 3887 begin 3888 if assigned(replaystack) then 3889 begin 3890 hp:=replaystack.next; 3891 replaystack.free; 3892 replaystack:=hp; 3893 end; 3894 end; 3895 3896 tscannerfile.replay_stack_depthnull3897 function tscannerfile.replay_stack_depth:longint; 3898 var 3899 tmp: treplaystack; 3900 begin 3901 result:=0; 3902 tmp:=replaystack; 3903 while assigned(tmp) do 3904 begin 3905 inc(result); 3906 tmp:=tmp.next; 3907 end; 3908 end; 3909 3910 procedure tscannerfile.handleconditional(p:tdirectiveitem); 3911 begin 3912 savetokenpos; 3913 repeat 3914 current_scanner.gettokenpos; 3915 Message1(scan_d_handling_switch,'$'+p.name); 3916 p.proc(); 3917 { accept the text ? } 3918 if (current_scanner.preprocstack=nil) or current_scanner.preprocstack.accept then 3919 break 3920 else 3921 begin 3922 current_scanner.gettokenpos; 3923 Message(scan_c_skipping_until); 3924 repeat 3925 current_scanner.skipuntildirective; 3926 if not (m_mac in current_settings.modeswitches) then 3927 p:=tdirectiveitem(turbo_scannerdirectives.Find(current_scanner.readid)) 3928 else 3929 p:=tdirectiveitem(mac_scannerdirectives.Find(current_scanner.readid)); 3930 until assigned(p) and (p.is_conditional); 3931 current_scanner.gettokenpos; 3932 end; 3933 until false; 3934 restoretokenpos; 3935 end; 3936 3937 3938 procedure tscannerfile.handledirectives; 3939 var 3940 t : tdirectiveitem; 3941 hs : string; 3942 begin 3943 gettokenpos; 3944 readchar; {Remove the $} 3945 hs:=readid; 3946 { handle empty directive } 3947 if hs='' then 3948 begin 3949 Message1(scan_w_illegal_switch,'$'); 3950 exit; 3951 end; 3952 {$ifdef PREPROCWRITE} 3953 if parapreprocess then 3954 begin 3955 if not (m_mac in current_settings.modeswitches) then 3956 t:=tdirectiveitem(turbo_scannerdirectives.Find(hs)) 3957 else 3958 t:=tdirectiveitem(mac_scannerdirectives.Find(hs)); 3959 if assigned(t) and not(t.is_conditional) then 3960 begin 3961 preprocfile.AddSpace; 3962 preprocfile.Add('{$'+hs+current_scanner.readcomment+'}'); 3963 exit; 3964 end; 3965 end; 3966 {$endif PREPROCWRITE} 3967 { skip this directive? } 3968 if (ignoredirectives.find(hs)<>nil) then 3969 begin 3970 if (comment_level>0) then 3971 readcomment; 3972 { we've read the whole comment } 3973 current_commentstyle:=comment_none; 3974 exit; 3975 end; 3976 { Check for compiler switches } 3977 while (length(hs)=1) and (c in ['-','+']) do 3978 begin 3979 Message1(scan_d_handling_switch,'$'+hs+c); 3980 HandleSwitch(hs[1],c); 3981 current_scanner.readchar; {Remove + or -} 3982 if c=',' then 3983 begin 3984 current_scanner.readchar; {Remove , } 3985 { read next switch, support $v+,$+} 3986 hs:=current_scanner.readid; 3987 if (hs='') then 3988 begin 3989 if (c='$') and (m_fpc in current_settings.modeswitches) then 3990 begin 3991 current_scanner.readchar; { skip $ } 3992 hs:=current_scanner.readid; 3993 end; 3994 if (hs='') then 3995 Message1(scan_w_illegal_directive,'$'+c); 3996 end; 3997 end 3998 else 3999 hs:=''; 4000 end; 4001 { directives may follow switches after a , } 4002 if hs<>'' then 4003 begin 4004 if not (m_mac in current_settings.modeswitches) then 4005 t:=tdirectiveitem(turbo_scannerdirectives.Find(hs)) 4006 else 4007 t:=tdirectiveitem(mac_scannerdirectives.Find(hs)); 4008 4009 if assigned(t) then 4010 begin 4011 if t.is_conditional then 4012 handleconditional(t) 4013 else 4014 begin 4015 Message1(scan_d_handling_switch,'$'+hs); 4016 t.proc(); 4017 end; 4018 end 4019 else 4020 begin 4021 current_scanner.ignoredirectives.Add(hs,nil); 4022 Message1(scan_w_illegal_directive,'$'+hs); 4023 end; 4024 { conditionals already read the comment } 4025 if (current_scanner.comment_level>0) then 4026 current_scanner.readcomment; 4027 { we've read the whole comment } 4028 current_commentstyle:=comment_none; 4029 end; 4030 end; 4031 4032 4033 procedure tscannerfile.readchar; 4034 begin 4035 c:=inputpointer^; 4036 if c=#0 then 4037 reload 4038 else 4039 inc(inputpointer); 4040 end; 4041 4042 4043 procedure tscannerfile.readstring; 4044 var 4045 i : longint; 4046 err : boolean; 4047 begin 4048 err:=false; 4049 i:=0; 4050 repeat 4051 case c of 4052 '_', 4053 '0'..'9', 4054 'A'..'Z' : 4055 begin 4056 if i<255 then 4057 begin 4058 inc(i); 4059 orgpattern[i]:=c; 4060 pattern[i]:=c; 4061 end 4062 else 4063 begin 4064 if not err then 4065 begin 4066 Message(scan_e_string_exceeds_255_chars); 4067 err:=true; 4068 end; 4069 end; 4070 c:=inputpointer^; 4071 inc(inputpointer); 4072 end; 4073 'a'..'z' : 4074 begin 4075 if i<255 then 4076 begin 4077 inc(i); 4078 orgpattern[i]:=c; 4079 pattern[i]:=chr(ord(c)-32) 4080 end 4081 else 4082 begin 4083 if not err then 4084 begin 4085 Message(scan_e_string_exceeds_255_chars); 4086 err:=true; 4087 end; 4088 end; 4089 c:=inputpointer^; 4090 inc(inputpointer); 4091 end; 4092 #0 : 4093 reload; 4094 else 4095 break; 4096 end; 4097 until false; 4098 orgpattern[0]:=chr(i); 4099 pattern[0]:=chr(i); 4100 end; 4101 4102 4103 procedure tscannerfile.readnumber; 4104 var 4105 base, 4106 i : longint; 4107 begin 4108 case c of 4109 '%' : 4110 begin 4111 readchar; 4112 base:=2; 4113 pattern[1]:='%'; 4114 i:=1; 4115 end; 4116 '&' : 4117 begin 4118 readchar; 4119 base:=8; 4120 pattern[1]:='&'; 4121 i:=1; 4122 end; 4123 '$' : 4124 begin 4125 readchar; 4126 base:=16; 4127 pattern[1]:='$'; 4128 i:=1; 4129 end; 4130 else 4131 begin 4132 base:=10; 4133 i:=0; 4134 end; 4135 end; 4136 while ((base>=10) and (c in ['0'..'9'])) or 4137 ((base=16) and (c in ['A'..'F','a'..'f'])) or 4138 ((base=8) and (c in ['0'..'7'])) or 4139 ((base=2) and (c in ['0'..'1'])) do 4140 begin 4141 if i<255 then 4142 begin 4143 inc(i); 4144 pattern[i]:=c; 4145 end; 4146 readchar; 4147 end; 4148 pattern[0]:=chr(i); 4149 end; 4150 4151 tscannerfile.readidnull4152 function tscannerfile.readid:string; 4153 begin 4154 readstring; 4155 readid:=pattern; 4156 end; 4157 4158 tscannerfile.readvalnull4159 function tscannerfile.readval:longint; 4160 var 4161 l : longint; 4162 w : integer; 4163 begin 4164 readnumber; 4165 val(pattern,l,w); 4166 readval:=l; 4167 end; 4168 4169 tscannerfile.readcommentnull4170 function tscannerfile.readcomment:string; 4171 var 4172 i : longint; 4173 begin 4174 i:=0; 4175 repeat 4176 case c of 4177 '{' : 4178 begin 4179 if current_commentstyle=comment_tp then 4180 inc_comment_level; 4181 end; 4182 '}' : 4183 begin 4184 if current_commentstyle=comment_tp then 4185 begin 4186 readchar; 4187 dec_comment_level; 4188 if comment_level=0 then 4189 break 4190 else 4191 continue; 4192 end; 4193 end; 4194 '*' : 4195 begin 4196 if current_commentstyle=comment_oldtp then 4197 begin 4198 readchar; 4199 if c=')' then 4200 begin 4201 readchar; 4202 dec_comment_level; 4203 break; 4204 end 4205 else 4206 { Add both characters !!} 4207 if (i<255) then 4208 begin 4209 inc(i); 4210 readcomment[i]:='*'; 4211 if (i<255) then 4212 begin 4213 inc(i); 4214 readcomment[i]:=c; 4215 end; 4216 end; 4217 end 4218 else 4219 { Not old TP comment, so add...} 4220 begin 4221 if (i<255) then 4222 begin 4223 inc(i); 4224 readcomment[i]:='*'; 4225 end; 4226 end; 4227 end; 4228 #10,#13 : 4229 linebreak; 4230 #26 : 4231 end_of_file; 4232 else 4233 begin 4234 if (i<255) then 4235 begin 4236 inc(i); 4237 readcomment[i]:=c; 4238 end; 4239 end; 4240 end; 4241 readchar; 4242 until false; 4243 readcomment[0]:=chr(i); 4244 end; 4245 4246 tscannerfile.readquotedstringnull4247 function tscannerfile.readquotedstring:string; 4248 var 4249 i : longint; 4250 msgwritten : boolean; 4251 begin 4252 i:=0; 4253 msgwritten:=false; 4254 if (c='''') then 4255 begin 4256 repeat 4257 readchar; 4258 case c of 4259 #26 : 4260 end_of_file; 4261 #10,#13 : 4262 Message(scan_f_string_exceeds_line); 4263 '''' : 4264 begin 4265 readchar; 4266 if c<>'''' then 4267 break; 4268 end; 4269 end; 4270 if i<255 then 4271 begin 4272 inc(i); 4273 result[i]:=c; 4274 end 4275 else 4276 begin 4277 if not msgwritten then 4278 begin 4279 Message(scan_e_string_exceeds_255_chars); 4280 msgwritten:=true; 4281 end; 4282 end; 4283 until false; 4284 end; 4285 result[0]:=chr(i); 4286 end; 4287 4288 tscannerfile.readstatenull4289 function tscannerfile.readstate:char; 4290 var 4291 state : char; 4292 begin 4293 state:=' '; 4294 if c=' ' then 4295 begin 4296 current_scanner.skipspace; 4297 current_scanner.readid; 4298 if pattern='ON' then 4299 state:='+' 4300 else 4301 if pattern='OFF' then 4302 state:='-'; 4303 end 4304 else 4305 state:=c; 4306 if not (state in ['+','-']) then 4307 Message(scan_e_wrong_switch_toggle); 4308 readstate:=state; 4309 end; 4310 4311 tscannerfile.readoptionalstatenull4312 function tscannerfile.readoptionalstate(fallback:char):char; 4313 var 4314 state : char; 4315 begin 4316 state:=' '; 4317 if c=' ' then 4318 begin 4319 current_scanner.skipspace; 4320 if c in ['*','}'] then 4321 state:=fallback 4322 else 4323 begin 4324 current_scanner.readid; 4325 if pattern='ON' then 4326 state:='+' 4327 else 4328 if pattern='OFF' then 4329 state:='-'; 4330 end; 4331 end 4332 else 4333 if c in ['*','}'] then 4334 state:=fallback 4335 else 4336 state:=c; 4337 if not (state in ['+','-']) then 4338 Message(scan_e_wrong_switch_toggle); 4339 readoptionalstate:=state; 4340 end; 4341 4342 tscannerfile.readstatedefaultnull4343 function tscannerfile.readstatedefault:char; 4344 var 4345 state : char; 4346 begin 4347 state:=' '; 4348 if c=' ' then 4349 begin 4350 current_scanner.skipspace; 4351 current_scanner.readid; 4352 if pattern='ON' then 4353 state:='+' 4354 else 4355 if pattern='OFF' then 4356 state:='-' 4357 else 4358 if pattern='DEFAULT' then 4359 state:='*'; 4360 end 4361 else 4362 state:=c; 4363 if not (state in ['+','-','*']) then 4364 Message(scan_e_wrong_switch_toggle_default); 4365 readstatedefault:=state; 4366 end; 4367 4368 4369 procedure tscannerfile.skipspace; 4370 begin 4371 repeat 4372 case c of 4373 #26 : 4374 begin 4375 reload; 4376 if (c=#26) and not assigned(inputfile.next) then 4377 break; 4378 continue; 4379 end; 4380 #10, 4381 #13 : 4382 linebreak; 4383 #9,#11,#12,' ' : 4384 ; 4385 else 4386 break; 4387 end; 4388 readchar; 4389 until false; 4390 end; 4391 4392 4393 procedure tscannerfile.skipuntildirective; 4394 var 4395 found : longint; 4396 next_char_loaded : boolean; 4397 begin 4398 found:=0; 4399 next_char_loaded:=false; 4400 repeat 4401 case c of 4402 #10, 4403 #13 : 4404 linebreak; 4405 #26 : 4406 begin 4407 reload; 4408 if (c=#26) and not assigned(inputfile.next) then 4409 end_of_file; 4410 continue; 4411 end; 4412 '{' : 4413 begin 4414 if (current_commentstyle in [comment_tp,comment_none]) then 4415 begin 4416 current_commentstyle:=comment_tp; 4417 if (comment_level=0) then 4418 found:=1; 4419 inc_comment_level; 4420 end; 4421 end; 4422 '*' : 4423 begin 4424 if (current_commentstyle=comment_oldtp) then 4425 begin 4426 readchar; 4427 if c=')' then 4428 begin 4429 dec_comment_level; 4430 found:=0; 4431 current_commentstyle:=comment_none; 4432 end 4433 else 4434 next_char_loaded:=true; 4435 end 4436 else 4437 found := 0; 4438 end; 4439 '}' : 4440 begin 4441 if (current_commentstyle=comment_tp) then 4442 begin 4443 dec_comment_level; 4444 if (comment_level=0) then 4445 current_commentstyle:=comment_none; 4446 found:=0; 4447 end; 4448 end; 4449 '$' : 4450 begin 4451 if found=1 then 4452 found:=2; 4453 end; 4454 '''' : 4455 if (current_commentstyle=comment_none) then 4456 begin 4457 repeat 4458 readchar; 4459 case c of 4460 #26 : 4461 end_of_file; 4462 #10,#13 : 4463 break; 4464 '''' : 4465 begin 4466 readchar; 4467 if c<>'''' then 4468 begin 4469 next_char_loaded:=true; 4470 break; 4471 end; 4472 end; 4473 end; 4474 until false; 4475 end; 4476 '(' : 4477 begin 4478 if (current_commentstyle=comment_none) then 4479 begin 4480 readchar; 4481 if c='*' then 4482 begin 4483 readchar; 4484 if c='$' then 4485 begin 4486 found:=2; 4487 inc_comment_level; 4488 current_commentstyle:=comment_oldtp; 4489 end 4490 else 4491 begin 4492 skipoldtpcomment(false); 4493 next_char_loaded:=true; 4494 end; 4495 end 4496 else 4497 next_char_loaded:=true; 4498 end 4499 else 4500 found:=0; 4501 end; 4502 '/' : 4503 begin 4504 if (current_commentstyle=comment_none) then 4505 begin 4506 readchar; 4507 if c='/' then 4508 skipdelphicomment; 4509 next_char_loaded:=true; 4510 end 4511 else 4512 found:=0; 4513 end; 4514 else 4515 found:=0; 4516 end; 4517 if next_char_loaded then 4518 next_char_loaded:=false 4519 else 4520 readchar; 4521 until (found=2); 4522 end; 4523 4524 4525 {**************************************************************************** 4526 Comment Handling 4527 ****************************************************************************} 4528 4529 procedure tscannerfile.skipcomment(read_first_char:boolean); 4530 begin 4531 current_commentstyle:=comment_tp; 4532 if read_first_char then 4533 readchar; 4534 inc_comment_level; 4535 { handle compiler switches } 4536 if (c='$') then 4537 handledirectives; 4538 { handle_switches can dec comment_level, } 4539 while (comment_level>0) do 4540 begin 4541 case c of 4542 '{' : 4543 inc_comment_level; 4544 '}' : 4545 dec_comment_level; 4546 #10,#13 : 4547 linebreak; 4548 #26 : 4549 begin 4550 reload; 4551 if (c=#26) and not assigned(inputfile.next) then 4552 end_of_file; 4553 continue; 4554 end; 4555 end; 4556 readchar; 4557 end; 4558 current_commentstyle:=comment_none; 4559 end; 4560 4561 4562 procedure tscannerfile.skipdelphicomment; 4563 begin 4564 current_commentstyle:=comment_delphi; 4565 inc_comment_level; 4566 readchar; 4567 { this is not supported } 4568 if c='$' then 4569 Message(scan_w_wrong_styled_switch); 4570 { skip comment } 4571 while not (c in [#10,#13,#26]) do 4572 readchar; 4573 dec_comment_level; 4574 current_commentstyle:=comment_none; 4575 end; 4576 4577 4578 procedure tscannerfile.skipoldtpcomment(read_first_char:boolean); 4579 var 4580 found : longint; 4581 begin 4582 current_commentstyle:=comment_oldtp; 4583 inc_comment_level; 4584 { only load a char if last already processed, 4585 was cause of bug1634 PM } 4586 if read_first_char then 4587 readchar; 4588 { this is now supported } 4589 if (c='$') then 4590 handledirectives; 4591 { skip comment } 4592 while (comment_level>0) do 4593 begin 4594 found:=0; 4595 repeat 4596 case c of 4597 #26 : 4598 begin 4599 reload; 4600 if (c=#26) and not assigned(inputfile.next) then 4601 end_of_file; 4602 continue; 4603 end; 4604 #10,#13 : 4605 begin 4606 if found=4 then 4607 inc_comment_level; 4608 linebreak; 4609 found:=0; 4610 end; 4611 '*' : 4612 begin 4613 if found=3 then 4614 found:=4 4615 else 4616 begin 4617 if found=4 then 4618 inc_comment_level; 4619 found:=1; 4620 end; 4621 end; 4622 ')' : 4623 begin 4624 if found in [1,4] then 4625 begin 4626 dec_comment_level; 4627 if comment_level=0 then 4628 found:=2 4629 else 4630 found:=0; 4631 end 4632 else 4633 found:=0; 4634 end; 4635 '(' : 4636 begin 4637 if found=4 then 4638 inc_comment_level; 4639 found:=3; 4640 end; 4641 else 4642 begin 4643 if found=4 then 4644 inc_comment_level; 4645 found:=0; 4646 end; 4647 end; 4648 readchar; 4649 until (found=2); 4650 end; 4651 current_commentstyle:=comment_none; 4652 end; 4653 4654 4655 4656 {**************************************************************************** 4657 Token Scanner 4658 ****************************************************************************} 4659 4660 procedure tscannerfile.readtoken(allowrecordtoken:boolean); 4661 var 4662 code : integer; 4663 d : cardinal; 4664 len, 4665 low,high,mid : longint; 4666 w : word; 4667 m : longint; 4668 mac : tmacro; 4669 asciinr : string[33]; 4670 iswidestring : boolean; 4671 label 4672 exit_label; 4673 begin 4674 flushpendingswitchesstate; 4675 4676 { record tokens? } 4677 if allowrecordtoken and 4678 assigned(recordtokenbuf) then 4679 recordtoken; 4680 4681 { replay tokens? } 4682 if assigned(replaytokenbuf) then 4683 begin 4684 replaytoken; 4685 goto exit_label; 4686 end; 4687 4688 { was there already a token read, then return that token } 4689 if nexttoken<>NOTOKEN then 4690 begin 4691 setnexttoken; 4692 goto exit_label; 4693 end; 4694 4695 { Skip all spaces and comments } 4696 repeat 4697 case c of 4698 '{' : 4699 skipcomment(true); 4700 #26 : 4701 begin 4702 reload; 4703 if (c=#26) and not assigned(inputfile.next) then 4704 break; 4705 end; 4706 ' ',#9..#13 : 4707 begin 4708 {$ifdef PREPROCWRITE} 4709 if parapreprocess then 4710 begin 4711 if c=#10 then 4712 preprocfile.eolfound:=true 4713 else 4714 preprocfile.spacefound:=true; 4715 end; 4716 {$endif PREPROCWRITE} 4717 skipspace; 4718 end 4719 else 4720 break; 4721 end; 4722 until false; 4723 4724 { Save current token position, for EOF its already loaded } 4725 if c<>#26 then 4726 gettokenpos; 4727 4728 { Check first for a identifier/keyword, this is 20+% faster (PFV) } 4729 if c in ['A'..'Z','a'..'z','_'] then 4730 begin 4731 readstring; 4732 token:=_ID; 4733 idtoken:=_ID; 4734 { keyword or any other known token, 4735 pattern is always uppercased } 4736 if (pattern[1]<>'_') and (length(pattern) in [tokenlenmin..tokenlenmax]) then 4737 begin 4738 low:=ord(tokenidx^[length(pattern),pattern[1]].first); 4739 high:=ord(tokenidx^[length(pattern),pattern[1]].last); 4740 while low<high do 4741 begin 4742 mid:=(high+low+1) shr 1; 4743 if pattern<tokeninfo^[ttoken(mid)].str then 4744 high:=mid-1 4745 else 4746 low:=mid; 4747 end; 4748 with tokeninfo^[ttoken(high)] do 4749 if pattern=str then 4750 begin 4751 if (keyword*current_settings.modeswitches)<>[] then 4752 if op=NOTOKEN then 4753 token:=ttoken(high) 4754 else 4755 token:=op; 4756 idtoken:=ttoken(high); 4757 end; 4758 end; 4759 { Only process identifiers and not keywords } 4760 if token=_ID then 4761 begin 4762 { this takes some time ... } 4763 if (cs_support_macro in current_settings.moduleswitches) then 4764 begin 4765 mac:=tmacro(search_macro(pattern)); 4766 if assigned(mac) and (not mac.is_compiler_var) and (assigned(mac.buftext)) then 4767 begin 4768 if yylexcount<max_macro_nesting then 4769 begin 4770 mac.is_used:=true; 4771 inc(yylexcount); 4772 substitutemacro(pattern,mac.buftext,mac.buflen, 4773 mac.fileinfo.line,mac.fileinfo.fileindex); 4774 { handle empty macros } 4775 if c=#0 then 4776 reload; 4777 readtoken(false); 4778 { that's all folks } 4779 dec(yylexcount); 4780 exit; 4781 end 4782 else 4783 Message(scan_w_macro_too_deep); 4784 end; 4785 end; 4786 end; 4787 { return token } 4788 goto exit_label; 4789 end 4790 else 4791 begin 4792 idtoken:=_NOID; 4793 case c of 4794 4795 '$' : 4796 begin 4797 readnumber; 4798 token:=_INTCONST; 4799 goto exit_label; 4800 end; 4801 4802 '%' : 4803 begin 4804 if not(m_fpc in current_settings.modeswitches) then 4805 Illegal_Char(c) 4806 else 4807 begin 4808 readnumber; 4809 token:=_INTCONST; 4810 goto exit_label; 4811 end; 4812 end; 4813 4814 '&' : 4815 begin 4816 if [m_fpc,m_delphi] * current_settings.modeswitches <> [] then 4817 begin 4818 readnumber; 4819 if length(pattern)=1 then 4820 begin 4821 { does really an identifier follow? } 4822 if not (c in ['_','A'..'Z','a'..'z']) then 4823 message2(scan_f_syn_expected,tokeninfo^[_ID].str,c); 4824 readstring; 4825 token:=_ID; 4826 idtoken:=_ID; 4827 end 4828 else 4829 token:=_INTCONST; 4830 goto exit_label; 4831 end 4832 else if m_mac in current_settings.modeswitches then 4833 begin 4834 readchar; 4835 token:=_AMPERSAND; 4836 goto exit_label; 4837 end 4838 else 4839 Illegal_Char(c); 4840 end; 4841 4842 '0'..'9' : 4843 begin 4844 readnumber; 4845 if (c in ['.','e','E']) then 4846 begin 4847 { first check for a . } 4848 if c='.' then 4849 begin 4850 cachenexttokenpos; 4851 readchar; 4852 { is it a .. from a range? } 4853 case c of 4854 '.' : 4855 begin 4856 readchar; 4857 token:=_INTCONST; 4858 nexttoken:=_POINTPOINT; 4859 goto exit_label; 4860 end; 4861 ')' : 4862 begin 4863 readchar; 4864 token:=_INTCONST; 4865 nexttoken:=_RECKKLAMMER; 4866 goto exit_label; 4867 end; 4868 '0'..'9' : 4869 begin 4870 { insert the number after the . } 4871 pattern:=pattern+'.'; 4872 while c in ['0'..'9'] do 4873 begin 4874 pattern:=pattern+c; 4875 readchar; 4876 end; 4877 end; 4878 else 4879 begin 4880 token:=_INTCONST; 4881 nexttoken:=_POINT; 4882 goto exit_label; 4883 end; 4884 end; 4885 end; 4886 { E can also follow after a point is scanned } 4887 if c in ['e','E'] then 4888 begin 4889 pattern:=pattern+'E'; 4890 readchar; 4891 if c in ['-','+'] then 4892 begin 4893 pattern:=pattern+c; 4894 readchar; 4895 end; 4896 if not(c in ['0'..'9']) then 4897 Illegal_Char(c); 4898 while c in ['0'..'9'] do 4899 begin 4900 pattern:=pattern+c; 4901 readchar; 4902 end; 4903 end; 4904 token:=_REALNUMBER; 4905 goto exit_label; 4906 end; 4907 token:=_INTCONST; 4908 goto exit_label; 4909 end; 4910 4911 ';' : 4912 begin 4913 readchar; 4914 token:=_SEMICOLON; 4915 goto exit_label; 4916 end; 4917 4918 '[' : 4919 begin 4920 readchar; 4921 token:=_LECKKLAMMER; 4922 goto exit_label; 4923 end; 4924 4925 ']' : 4926 begin 4927 readchar; 4928 token:=_RECKKLAMMER; 4929 goto exit_label; 4930 end; 4931 4932 '(' : 4933 begin 4934 readchar; 4935 case c of 4936 '*' : 4937 begin 4938 skipoldtpcomment(true); 4939 readtoken(false); 4940 exit; 4941 end; 4942 '.' : 4943 begin 4944 readchar; 4945 token:=_LECKKLAMMER; 4946 goto exit_label; 4947 end; 4948 end; 4949 token:=_LKLAMMER; 4950 goto exit_label; 4951 end; 4952 4953 ')' : 4954 begin 4955 readchar; 4956 token:=_RKLAMMER; 4957 goto exit_label; 4958 end; 4959 4960 '+' : 4961 begin 4962 readchar; 4963 if (c='=') and (cs_support_c_operators in current_settings.moduleswitches) then 4964 begin 4965 readchar; 4966 token:=_PLUSASN; 4967 goto exit_label; 4968 end; 4969 token:=_PLUS; 4970 goto exit_label; 4971 end; 4972 4973 '-' : 4974 begin 4975 readchar; 4976 if (c='=') and (cs_support_c_operators in current_settings.moduleswitches) then 4977 begin 4978 readchar; 4979 token:=_MINUSASN; 4980 goto exit_label; 4981 end; 4982 token:=_MINUS; 4983 goto exit_label; 4984 end; 4985 4986 ':' : 4987 begin 4988 readchar; 4989 if c='=' then 4990 begin 4991 readchar; 4992 token:=_ASSIGNMENT; 4993 goto exit_label; 4994 end; 4995 token:=_COLON; 4996 goto exit_label; 4997 end; 4998 4999 '*' : 5000 begin 5001 readchar; 5002 if (c='=') and (cs_support_c_operators in current_settings.moduleswitches) then 5003 begin 5004 readchar; 5005 token:=_STARASN; 5006 end 5007 else 5008 if c='*' then 5009 begin 5010 readchar; 5011 token:=_STARSTAR; 5012 end 5013 else 5014 token:=_STAR; 5015 goto exit_label; 5016 end; 5017 5018 '/' : 5019 begin 5020 readchar; 5021 case c of 5022 '=' : 5023 begin 5024 if (cs_support_c_operators in current_settings.moduleswitches) then 5025 begin 5026 readchar; 5027 token:=_SLASHASN; 5028 goto exit_label; 5029 end; 5030 end; 5031 '/' : 5032 begin 5033 skipdelphicomment; 5034 readtoken(false); 5035 exit; 5036 end; 5037 end; 5038 token:=_SLASH; 5039 goto exit_label; 5040 end; 5041 5042 '|' : 5043 if m_mac in current_settings.modeswitches then 5044 begin 5045 readchar; 5046 token:=_PIPE; 5047 goto exit_label; 5048 end 5049 else 5050 Illegal_Char(c); 5051 5052 '=' : 5053 begin 5054 readchar; 5055 token:=_EQ; 5056 goto exit_label; 5057 end; 5058 5059 '.' : 5060 begin 5061 readchar; 5062 case c of 5063 '.' : 5064 begin 5065 readchar; 5066 case c of 5067 '.' : 5068 begin 5069 readchar; 5070 token:=_POINTPOINTPOINT; 5071 goto exit_label; 5072 end; 5073 else 5074 begin 5075 token:=_POINTPOINT; 5076 goto exit_label; 5077 end; 5078 end; 5079 end; 5080 ')' : 5081 begin 5082 readchar; 5083 token:=_RECKKLAMMER; 5084 goto exit_label; 5085 end; 5086 end; 5087 token:=_POINT; 5088 goto exit_label; 5089 end; 5090 5091 '@' : 5092 begin 5093 readchar; 5094 token:=_KLAMMERAFFE; 5095 goto exit_label; 5096 end; 5097 5098 ',' : 5099 begin 5100 readchar; 5101 token:=_COMMA; 5102 goto exit_label; 5103 end; 5104 5105 '''','#','^' : 5106 begin 5107 len:=0; 5108 cstringpattern:=''; 5109 iswidestring:=false; 5110 if c='^' then 5111 begin 5112 readchar; 5113 c:=upcase(c); 5114 if (block_type in [bt_type,bt_const_type,bt_var_type]) or 5115 (lasttoken=_ID) or (lasttoken=_NIL) or (lasttoken=_OPERATOR) or 5116 (lasttoken=_RKLAMMER) or (lasttoken=_RECKKLAMMER) or (lasttoken=_CARET) then 5117 begin 5118 token:=_CARET; 5119 goto exit_label; 5120 end 5121 else 5122 begin 5123 inc(len); 5124 setlength(cstringpattern,256); 5125 if c<#64 then 5126 cstringpattern[len]:=chr(ord(c)+64) 5127 else 5128 cstringpattern[len]:=chr(ord(c)-64); 5129 readchar; 5130 end; 5131 end; 5132 repeat 5133 case c of 5134 '#' : 5135 begin 5136 readchar; { read # } 5137 case c of 5138 '$': 5139 begin 5140 readchar; { read leading $ } 5141 asciinr:='$'; 5142 while (upcase(c) in ['A'..'F','0'..'9']) and (length(asciinr)<=7) do 5143 begin 5144 asciinr:=asciinr+c; 5145 readchar; 5146 end; 5147 end; 5148 '&': 5149 begin 5150 readchar; { read leading $ } 5151 asciinr:='&'; 5152 while (upcase(c) in ['0'..'7']) and (length(asciinr)<=8) do 5153 begin 5154 asciinr:=asciinr+c; 5155 readchar; 5156 end; 5157 end; 5158 '%': 5159 begin 5160 readchar; { read leading $ } 5161 asciinr:='%'; 5162 while (upcase(c) in ['0','1']) and (length(asciinr)<=22) do 5163 begin 5164 asciinr:=asciinr+c; 5165 readchar; 5166 end; 5167 end; 5168 else 5169 begin 5170 asciinr:=''; 5171 while (c in ['0'..'9']) and (length(asciinr)<=8) do 5172 begin 5173 asciinr:=asciinr+c; 5174 readchar; 5175 end; 5176 end; 5177 end; 5178 val(asciinr,m,code); 5179 if (asciinr='') or (code<>0) then 5180 Message(scan_e_illegal_char_const) 5181 else if (m<0) or (m>255) or (length(asciinr)>3) then 5182 begin 5183 if (m>=0) and (m<=$10FFFF) then 5184 begin 5185 if not iswidestring then 5186 begin 5187 if len>0 then 5188 ascii2unicode(@cstringpattern[1],len,current_settings.sourcecodepage,patternw) 5189 else 5190 ascii2unicode(nil,len,current_settings.sourcecodepage,patternw); 5191 iswidestring:=true; 5192 len:=0; 5193 end; 5194 if m<=$FFFF then 5195 concatwidestringchar(patternw,tcompilerwidechar(m)) 5196 else 5197 begin 5198 { split into surrogate pair } 5199 dec(m,$10000); 5200 concatwidestringchar(patternw,tcompilerwidechar((m shr 10) + $D800)); 5201 concatwidestringchar(patternw,tcompilerwidechar((m and $3FF) + $DC00)); 5202 end; 5203 end 5204 else 5205 Message(scan_e_illegal_char_const) 5206 end 5207 else if iswidestring then 5208 concatwidestringchar(patternw,asciichar2unicode(char(m))) 5209 else 5210 begin 5211 if len>=length(cstringpattern) then 5212 setlength(cstringpattern,length(cstringpattern)+256); 5213 inc(len); 5214 cstringpattern[len]:=chr(m); 5215 end; 5216 end; 5217 '''' : 5218 begin 5219 repeat 5220 readchar; 5221 case c of 5222 #26 : 5223 end_of_file; 5224 #10,#13 : 5225 Message(scan_f_string_exceeds_line); 5226 '''' : 5227 begin 5228 readchar; 5229 if c<>'''' then 5230 break; 5231 end; 5232 end; 5233 { interpret as utf-8 string? } 5234 if (ord(c)>=$80) and (current_settings.sourcecodepage=CP_UTF8) then 5235 begin 5236 { convert existing string to an utf-8 string } 5237 if not iswidestring then 5238 begin 5239 if len>0 then 5240 ascii2unicode(@cstringpattern[1],len,current_settings.sourcecodepage,patternw) 5241 else 5242 ascii2unicode(nil,len,current_settings.sourcecodepage,patternw); 5243 iswidestring:=true; 5244 len:=0; 5245 end; 5246 { four chars } 5247 if (ord(c) and $f0)=$f0 then 5248 begin 5249 { this always represents a surrogate pair, so 5250 read as 32-bit value and then split into 5251 the corresponding pair of two wchars } 5252 d:=ord(c) and $f; 5253 readchar; 5254 if (ord(c) and $c0)<>$80 then 5255 message(scan_e_utf8_malformed); 5256 d:=(d shl 6) or (ord(c) and $3f); 5257 readchar; 5258 if (ord(c) and $c0)<>$80 then 5259 message(scan_e_utf8_malformed); 5260 d:=(d shl 6) or (ord(c) and $3f); 5261 readchar; 5262 if (ord(c) and $c0)<>$80 then 5263 message(scan_e_utf8_malformed); 5264 d:=(d shl 6) or (ord(c) and $3f); 5265 if d<$10000 then 5266 message(scan_e_utf8_malformed); 5267 d:=d-$10000; 5268 { high surrogate } 5269 w:=$d800+(d shr 10); 5270 concatwidestringchar(patternw,w); 5271 { low surrogate } 5272 w:=$dc00+(d and $3ff); 5273 concatwidestringchar(patternw,w); 5274 end 5275 { three chars } 5276 else if (ord(c) and $e0)=$e0 then 5277 begin 5278 w:=ord(c) and $f; 5279 readchar; 5280 if (ord(c) and $c0)<>$80 then 5281 message(scan_e_utf8_malformed); 5282 w:=(w shl 6) or (ord(c) and $3f); 5283 readchar; 5284 if (ord(c) and $c0)<>$80 then 5285 message(scan_e_utf8_malformed); 5286 w:=(w shl 6) or (ord(c) and $3f); 5287 concatwidestringchar(patternw,w); 5288 end 5289 { two chars } 5290 else if (ord(c) and $c0)<>0 then 5291 begin 5292 w:=ord(c) and $1f; 5293 readchar; 5294 if (ord(c) and $c0)<>$80 then 5295 message(scan_e_utf8_malformed); 5296 w:=(w shl 6) or (ord(c) and $3f); 5297 concatwidestringchar(patternw,w); 5298 end 5299 { illegal } 5300 else if (ord(c) and $80)<>0 then 5301 message(scan_e_utf8_malformed) 5302 else 5303 concatwidestringchar(patternw,tcompilerwidechar(c)) 5304 end 5305 else if iswidestring then 5306 begin 5307 if current_settings.sourcecodepage=CP_UTF8 then 5308 concatwidestringchar(patternw,ord(c)) 5309 else 5310 concatwidestringchar(patternw,asciichar2unicode(c)) 5311 end 5312 else 5313 begin 5314 if len>=length(cstringpattern) then 5315 setlength(cstringpattern,length(cstringpattern)+256); 5316 inc(len); 5317 cstringpattern[len]:=c; 5318 end; 5319 until false; 5320 end; 5321 '^' : 5322 begin 5323 readchar; 5324 c:=upcase(c); 5325 if c<#64 then 5326 c:=chr(ord(c)+64) 5327 else 5328 c:=chr(ord(c)-64); 5329 5330 if iswidestring then 5331 concatwidestringchar(patternw,asciichar2unicode(c)) 5332 else 5333 begin 5334 if len>=length(cstringpattern) then 5335 setlength(cstringpattern,length(cstringpattern)+256); 5336 inc(len); 5337 cstringpattern[len]:=c; 5338 end; 5339 5340 readchar; 5341 end; 5342 else 5343 break; 5344 end; 5345 until false; 5346 { strings with length 1 become const chars } 5347 if iswidestring then 5348 begin 5349 if patternw^.len=1 then 5350 token:=_CWCHAR 5351 else 5352 token:=_CWSTRING; 5353 end 5354 else 5355 begin 5356 setlength(cstringpattern,len); 5357 if length(cstringpattern)=1 then 5358 begin 5359 token:=_CCHAR; 5360 pattern:=cstringpattern; 5361 end 5362 else 5363 token:=_CSTRING; 5364 end; 5365 goto exit_label; 5366 end; 5367 5368 '>' : 5369 begin 5370 readchar; 5371 if (block_type in [bt_type,bt_var_type,bt_const_type]) then 5372 token:=_RSHARPBRACKET 5373 else 5374 begin 5375 case c of 5376 '=' : 5377 begin 5378 readchar; 5379 token:=_GTE; 5380 goto exit_label; 5381 end; 5382 '>' : 5383 begin 5384 readchar; 5385 token:=_OP_SHR; 5386 goto exit_label; 5387 end; 5388 '<' : 5389 begin { >< is for a symetric diff for sets } 5390 readchar; 5391 token:=_SYMDIF; 5392 goto exit_label; 5393 end; 5394 end; 5395 token:=_GT; 5396 end; 5397 goto exit_label; 5398 end; 5399 5400 '<' : 5401 begin 5402 readchar; 5403 if (block_type in [bt_type,bt_var_type,bt_const_type]) then 5404 token:=_LSHARPBRACKET 5405 else 5406 begin 5407 case c of 5408 '>' : 5409 begin 5410 readchar; 5411 token:=_NE; 5412 goto exit_label; 5413 end; 5414 '=' : 5415 begin 5416 readchar; 5417 token:=_LTE; 5418 goto exit_label; 5419 end; 5420 '<' : 5421 begin 5422 readchar; 5423 token:=_OP_SHL; 5424 goto exit_label; 5425 end; 5426 end; 5427 token:=_LT; 5428 end; 5429 goto exit_label; 5430 end; 5431 5432 #26 : 5433 begin 5434 token:=_EOF; 5435 checkpreprocstack; 5436 goto exit_label; 5437 end; 5438 else 5439 Illegal_Char(c); 5440 end; 5441 end; 5442 exit_label: 5443 lasttoken:=token; 5444 end; 5445 5446 tscannerfile.readpreprocnull5447 function tscannerfile.readpreproc:ttoken; 5448 var 5449 low,high,mid: longint; 5450 optoken: ttoken; 5451 begin 5452 skipspace; 5453 case c of 5454 '_', 5455 'A'..'Z', 5456 'a'..'z' : 5457 begin 5458 readstring; 5459 optoken:=_ID; 5460 if (pattern[1]<>'_') and (length(pattern) in [tokenlenmin..tokenlenmax]) then 5461 begin 5462 low:=ord(tokenidx^[length(pattern),pattern[1]].first); 5463 high:=ord(tokenidx^[length(pattern),pattern[1]].last); 5464 while low<high do 5465 begin 5466 mid:=(high+low+1) shr 1; 5467 if pattern<tokeninfo^[ttoken(mid)].str then 5468 high:=mid-1 5469 else 5470 low:=mid; 5471 end; 5472 with tokeninfo^[ttoken(high)] do 5473 if pattern=str then 5474 begin 5475 if (keyword*current_settings.modeswitches)<>[] then 5476 if op=NOTOKEN then 5477 optoken:=ttoken(high) 5478 else 5479 optoken:=op; 5480 end; 5481 if not (optoken in preproc_operators) then 5482 optoken:=_ID; 5483 end; 5484 current_scanner.preproc_pattern:=pattern; 5485 readpreproc:=optoken; 5486 end; 5487 '''' : 5488 begin 5489 readquotedstring; 5490 current_scanner.preproc_pattern:=cstringpattern; 5491 readpreproc:=_CSTRING; 5492 end; 5493 '0'..'9' : 5494 begin 5495 readnumber; 5496 if (c in ['.','e','E']) then 5497 begin 5498 { first check for a . } 5499 if c='.' then 5500 begin 5501 readchar; 5502 if c in ['0'..'9'] then 5503 begin 5504 { insert the number after the . } 5505 pattern:=pattern+'.'; 5506 while c in ['0'..'9'] do 5507 begin 5508 pattern:=pattern+c; 5509 readchar; 5510 end; 5511 end 5512 else 5513 Illegal_Char(c); 5514 end; 5515 { E can also follow after a point is scanned } 5516 if c in ['e','E'] then 5517 begin 5518 pattern:=pattern+'E'; 5519 readchar; 5520 if c in ['-','+'] then 5521 begin 5522 pattern:=pattern+c; 5523 readchar; 5524 end; 5525 if not(c in ['0'..'9']) then 5526 Illegal_Char(c); 5527 while c in ['0'..'9'] do 5528 begin 5529 pattern:=pattern+c; 5530 readchar; 5531 end; 5532 end; 5533 readpreproc:=_REALNUMBER; 5534 end 5535 else 5536 readpreproc:=_INTCONST; 5537 current_scanner.preproc_pattern:=pattern; 5538 end; 5539 '$','%': 5540 begin 5541 readnumber; 5542 current_scanner.preproc_pattern:=pattern; 5543 readpreproc:=_INTCONST; 5544 end; 5545 '&' : 5546 begin 5547 readnumber; 5548 if length(pattern)=1 then 5549 begin 5550 readstring; 5551 readpreproc:=_ID; 5552 end 5553 else 5554 readpreproc:=_INTCONST; 5555 current_scanner.preproc_pattern:=pattern; 5556 end; 5557 '.' : 5558 begin 5559 readchar; 5560 readpreproc:=_POINT; 5561 end; 5562 ',' : 5563 begin 5564 readchar; 5565 readpreproc:=_COMMA; 5566 end; 5567 '}' : 5568 begin 5569 readpreproc:=_END; 5570 end; 5571 '(' : 5572 begin 5573 readchar; 5574 readpreproc:=_LKLAMMER; 5575 end; 5576 ')' : 5577 begin 5578 readchar; 5579 readpreproc:=_RKLAMMER; 5580 end; 5581 '[' : 5582 begin 5583 readchar; 5584 readpreproc:=_LECKKLAMMER; 5585 end; 5586 ']' : 5587 begin 5588 readchar; 5589 readpreproc:=_RECKKLAMMER; 5590 end; 5591 '+' : 5592 begin 5593 readchar; 5594 readpreproc:=_PLUS; 5595 end; 5596 '-' : 5597 begin 5598 readchar; 5599 readpreproc:=_MINUS; 5600 end; 5601 '*' : 5602 begin 5603 readchar; 5604 readpreproc:=_STAR; 5605 end; 5606 '/' : 5607 begin 5608 readchar; 5609 readpreproc:=_SLASH; 5610 end; 5611 '=' : 5612 begin 5613 readchar; 5614 readpreproc:=_EQ; 5615 end; 5616 '>' : 5617 begin 5618 readchar; 5619 if c='=' then 5620 begin 5621 readchar; 5622 readpreproc:=_GTE; 5623 end 5624 else 5625 readpreproc:=_GT; 5626 end; 5627 '<' : 5628 begin 5629 readchar; 5630 case c of 5631 '>' : 5632 begin 5633 readchar; 5634 readpreproc:=_NE; 5635 end; 5636 '=' : 5637 begin 5638 readchar; 5639 readpreproc:=_LTE; 5640 end; 5641 else 5642 readpreproc:=_LT; 5643 end; 5644 end; 5645 #26 : 5646 begin 5647 readpreproc:=_EOF; 5648 checkpreprocstack; 5649 end; 5650 else 5651 begin 5652 Illegal_Char(c); 5653 readpreproc:=NOTOKEN; 5654 end; 5655 end; 5656 end; 5657 5658 tscannerfile.readpreprocintnull5659 function tscannerfile.readpreprocint(var value:int64;const place:string):boolean; 5660 var 5661 hs : texprvalue; 5662 begin 5663 hs:=preproc_comp_expr; 5664 if hs.isInt then 5665 begin 5666 value:=hs.asInt64; 5667 result:=true; 5668 end 5669 else 5670 begin 5671 hs.error('Integer',place); 5672 result:=false; 5673 end; 5674 hs.free; 5675 end; 5676 5677 tscannerfile.asmgetcharnull5678 function tscannerfile.asmgetchar : char; 5679 begin 5680 readchar; 5681 repeat 5682 case c of 5683 #26 : 5684 begin 5685 reload; 5686 if (c=#26) and not assigned(inputfile.next) then 5687 end_of_file; 5688 continue; 5689 end; 5690 else 5691 begin 5692 asmgetchar:=c; 5693 exit; 5694 end; 5695 end; 5696 until false; 5697 end; 5698 5699 5700 {***************************************************************************** 5701 Helpers 5702 *****************************************************************************} 5703 5704 procedure AddDirective(const s:string; dm: tdirectivemode; p:tdirectiveproc); 5705 begin 5706 if dm in [directive_all, directive_turbo] then 5707 tdirectiveitem.create(turbo_scannerdirectives,s,p); 5708 if dm in [directive_all, directive_mac] then 5709 tdirectiveitem.create(mac_scannerdirectives,s,p); 5710 end; 5711 5712 procedure AddConditional(const s:string; dm: tdirectivemode; p:tdirectiveproc); 5713 begin 5714 if dm in [directive_all, directive_turbo] then 5715 tdirectiveitem.createcond(turbo_scannerdirectives,s,p); 5716 if dm in [directive_all, directive_mac] then 5717 tdirectiveitem.createcond(mac_scannerdirectives,s,p); 5718 end; 5719 5720 {***************************************************************************** 5721 Initialization 5722 *****************************************************************************} 5723 5724 procedure InitScanner; 5725 begin 5726 InitWideString(patternw); 5727 turbo_scannerdirectives:=TFPHashObjectList.Create; 5728 mac_scannerdirectives:=TFPHashObjectList.Create; 5729 5730 { Common directives and conditionals } 5731 AddDirective('I',directive_all, @dir_include); 5732 AddDirective('DEFINE',directive_all, @dir_define); 5733 AddDirective('UNDEF',directive_all, @dir_undef); 5734 5735 AddConditional('IF',directive_all, @dir_if); 5736 AddConditional('IFDEF',directive_all, @dir_ifdef); 5737 AddConditional('IFNDEF',directive_all, @dir_ifndef); 5738 AddConditional('ELSE',directive_all, @dir_else); 5739 AddConditional('ELSEIF',directive_all, @dir_elseif); 5740 AddConditional('ENDIF',directive_all, @dir_endif); 5741 5742 { Directives and conditionals for all modes except mode macpas} 5743 AddDirective('INCLUDE',directive_turbo, @dir_include); 5744 AddDirective('LIBPREFIX',directive_turbo, @dir_libprefix); 5745 AddDirective('LIBSUFFIX',directive_turbo, @dir_libsuffix); 5746 AddDirective('EXTENSION',directive_turbo, @dir_extension); 5747 5748 AddConditional('IFEND',directive_turbo, @dir_endif); 5749 AddConditional('IFOPT',directive_turbo, @dir_ifopt); 5750 5751 { Directives and conditionals for mode macpas: } 5752 AddDirective('SETC',directive_mac, @dir_setc); 5753 AddDirective('DEFINEC',directive_mac, @dir_definec); 5754 AddDirective('UNDEFC',directive_mac, @dir_undef); 5755 5756 AddConditional('IFC',directive_mac, @dir_if); 5757 AddConditional('ELSEC',directive_mac, @dir_else); 5758 AddConditional('ELIFC',directive_mac, @dir_elseif); 5759 AddConditional('ENDC',directive_mac, @dir_endif); 5760 end; 5761 5762 5763 procedure DoneScanner; 5764 begin 5765 turbo_scannerdirectives.Free; 5766 mac_scannerdirectives.Free; 5767 DoneWideString(patternw); 5768 end; 5769 5770 end. 5771