scanner.pas 134 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156415741584159416041614162
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. This unit implements the scanner part and handling of the switches
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit scanner;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. cclasses,
  22. globtype,globals,constexp,version,tokens,
  23. verbose,comphook,
  24. finput,
  25. widestr;
  26. const
  27. max_include_nesting=32;
  28. max_macro_nesting=16;
  29. preprocbufsize=32*1024;
  30. type
  31. tcommentstyle = (comment_none,comment_tp,comment_oldtp,comment_delphi,comment_c);
  32. tscannerfile = class;
  33. preproctyp = (pp_ifdef,pp_ifndef,pp_if,pp_ifopt,pp_else,pp_elseif);
  34. tpreprocstack = class
  35. typ : preproctyp;
  36. accept : boolean;
  37. next : tpreprocstack;
  38. name : TIDString;
  39. line_nb : longint;
  40. owner : tscannerfile;
  41. constructor Create(atyp:preproctyp;a:boolean;n:tpreprocstack);
  42. end;
  43. tdirectiveproc=procedure;
  44. tdirectiveitem = class(TFPHashObject)
  45. public
  46. is_conditional : boolean;
  47. proc : tdirectiveproc;
  48. constructor Create(AList:TFPHashObjectList;const n:string;p:tdirectiveproc);
  49. constructor CreateCond(AList:TFPHashObjectList;const n:string;p:tdirectiveproc);
  50. end;
  51. tcompile_time_predicate = function(var valuedescr: String) : Boolean;
  52. tspecialgenerictoken = (ST_LOADSETTINGS,ST_LINE,ST_COLUMN,ST_FILEINDEX);
  53. tscannerfile = class
  54. public
  55. inputfile : tinputfile; { current inputfile list }
  56. inputfilecount : longint;
  57. inputbuffer, { input buffer }
  58. inputpointer : pchar;
  59. inputstart : longint;
  60. line_no, { line }
  61. lastlinepos : longint;
  62. lasttokenpos : longint; { token }
  63. lasttoken,
  64. nexttoken : ttoken;
  65. replaysavetoken : ttoken;
  66. replaytokenbuf,
  67. recordtokenbuf : tdynamicarray;
  68. { old settings, i.e. settings specialization was started }
  69. old_settings,
  70. { last settings we stored }
  71. last_settings : tsettings;
  72. { last filepos we stored }
  73. last_filepos : tfileposinfo;
  74. comment_level,
  75. yylexcount : longint;
  76. lastasmgetchar : char;
  77. ignoredirectives : TFPHashList; { ignore directives, used to give warnings only once }
  78. preprocstack : tpreprocstack;
  79. in_asm_string : boolean;
  80. preproc_pattern : string;
  81. preproc_token : ttoken;
  82. constructor Create(const fn:string);
  83. destructor Destroy;override;
  84. { File buffer things }
  85. function openinputfile:boolean;
  86. procedure closeinputfile;
  87. function tempopeninputfile:boolean;
  88. procedure tempcloseinputfile;
  89. procedure saveinputfile;
  90. procedure restoreinputfile;
  91. procedure firstfile;
  92. procedure nextfile;
  93. procedure addfile(hp:tinputfile);
  94. procedure reload;
  95. procedure insertmacro(const macname:string;p:pchar;len,line,fileindex:longint);
  96. { Scanner things }
  97. procedure gettokenpos;
  98. procedure inc_comment_level;
  99. procedure dec_comment_level;
  100. procedure illegal_char(c:char);
  101. procedure end_of_file;
  102. procedure checkpreprocstack;
  103. procedure poppreprocstack;
  104. procedure ifpreprocstack(atyp : preproctyp;compile_time_predicate:tcompile_time_predicate;messid:longint);
  105. procedure elseifpreprocstack(compile_time_predicate:tcompile_time_predicate);
  106. procedure elsepreprocstack;
  107. procedure handleconditional(p:tdirectiveitem);
  108. procedure handledirectives;
  109. procedure linebreak;
  110. procedure recordtoken;
  111. procedure startrecordtokens(buf:tdynamicarray);
  112. procedure stoprecordtokens;
  113. procedure replaytoken;
  114. procedure startreplaytokens(buf:tdynamicarray);
  115. procedure readchar;
  116. procedure readstring;
  117. procedure readnumber;
  118. function readid:string;
  119. function readval:longint;
  120. function readval_asstring:string;
  121. function readcomment:string;
  122. function readquotedstring:string;
  123. function readstate:char;
  124. function readstatedefault:char;
  125. procedure skipspace;
  126. procedure skipuntildirective;
  127. procedure skipcomment;
  128. procedure skipdelphicomment;
  129. procedure skipoldtpcomment;
  130. procedure readtoken(allowrecordtoken:boolean);
  131. function readpreproc:ttoken;
  132. function asmgetcharstart : char;
  133. function asmgetchar:char;
  134. end;
  135. {$ifdef PREPROCWRITE}
  136. tpreprocfile=class
  137. f : text;
  138. buf : pointer;
  139. spacefound,
  140. eolfound : boolean;
  141. constructor create(const fn:string);
  142. destructor destroy;
  143. procedure Add(const s:string);
  144. procedure AddSpace;
  145. end;
  146. {$endif PREPROCWRITE}
  147. var
  148. { read strings }
  149. c : char;
  150. orgpattern,
  151. pattern : string;
  152. patternw : pcompilerwidestring;
  153. { token }
  154. token, { current token being parsed }
  155. idtoken : ttoken; { holds the token if the pattern is a known word }
  156. current_scanner : tscannerfile; { current scanner in use }
  157. aktcommentstyle : tcommentstyle; { needed to use read_comment from directives }
  158. {$ifdef PREPROCWRITE}
  159. preprocfile : tpreprocfile; { used with only preprocessing }
  160. {$endif PREPROCWRITE}
  161. type
  162. tdirectivemode = (directive_all, directive_turbo, directive_mac);
  163. procedure AddDirective(const s:string; dm: tdirectivemode; p:tdirectiveproc);
  164. procedure AddConditional(const s:string; dm: tdirectivemode; p:tdirectiveproc);
  165. procedure InitScanner;
  166. procedure DoneScanner;
  167. {To be called when the language mode is finally determined}
  168. Function SetCompileMode(const s:string; changeInit: boolean):boolean;
  169. implementation
  170. uses
  171. SysUtils,
  172. cutils,cfileutl,
  173. systems,
  174. switches,
  175. symbase,symtable,symtype,symsym,symconst,symdef,defutil,
  176. fmodule;
  177. var
  178. { dictionaries with the supported directives }
  179. turbo_scannerdirectives : TFPHashObjectList; { for other modes }
  180. mac_scannerdirectives : TFPHashObjectList; { for mode mac }
  181. {*****************************************************************************
  182. Helper routines
  183. *****************************************************************************}
  184. const
  185. { use any special name that is an invalid file name to avoid problems }
  186. preprocstring : array [preproctyp] of string[7]
  187. = ('$IFDEF','$IFNDEF','$IF','$IFOPT','$ELSE','$ELSEIF');
  188. function is_keyword(const s:string):boolean;
  189. var
  190. low,high,mid : longint;
  191. begin
  192. if not (length(s) in [tokenlenmin..tokenlenmax]) or
  193. not (s[1] in ['a'..'z','A'..'Z']) then
  194. begin
  195. is_keyword:=false;
  196. exit;
  197. end;
  198. low:=ord(tokenidx^[length(s),s[1]].first);
  199. high:=ord(tokenidx^[length(s),s[1]].last);
  200. while low<high do
  201. begin
  202. mid:=(high+low+1) shr 1;
  203. if pattern<tokeninfo^[ttoken(mid)].str then
  204. high:=mid-1
  205. else
  206. low:=mid;
  207. end;
  208. is_keyword:=(pattern=tokeninfo^[ttoken(high)].str) and
  209. (tokeninfo^[ttoken(high)].keyword in current_settings.modeswitches);
  210. end;
  211. Function SetCompileMode(const s:string; changeInit: boolean):boolean;
  212. var
  213. b : boolean;
  214. oldmodeswitches : tmodeswitches;
  215. begin
  216. oldmodeswitches:=current_settings.modeswitches;
  217. b:=true;
  218. if s='DEFAULT' then
  219. current_settings.modeswitches:=fpcmodeswitches
  220. else
  221. if s='DELPHI' then
  222. current_settings.modeswitches:=delphimodeswitches
  223. else
  224. if s='TP' then
  225. current_settings.modeswitches:=tpmodeswitches
  226. else
  227. if s='FPC' then begin
  228. current_settings.modeswitches:=fpcmodeswitches;
  229. { TODO: enable this for 2.3/2.9 }
  230. // include(current_settings.localswitches, cs_typed_addresses);
  231. end else
  232. if s='OBJFPC' then begin
  233. current_settings.modeswitches:=objfpcmodeswitches;
  234. { TODO: enable this for 2.3/2.9 }
  235. // include(current_settings.localswitches, cs_typed_addresses);
  236. end
  237. {$ifdef gpc_mode}
  238. else if s='GPC' then
  239. current_settings.modeswitches:=gpcmodeswitches
  240. {$endif}
  241. else
  242. if s='MACPAS' then
  243. current_settings.modeswitches:=macmodeswitches
  244. else
  245. b:=false;
  246. if b and changeInit then
  247. init_settings.modeswitches := current_settings.modeswitches;
  248. if b then
  249. begin
  250. { resolve all postponed switch changes }
  251. if localswitcheschanged then
  252. begin
  253. current_settings.localswitches:=nextlocalswitches;
  254. localswitcheschanged:=false;
  255. end;
  256. { turn ansistrings on by default ? }
  257. if (m_default_ansistring in current_settings.modeswitches) then
  258. begin
  259. include(current_settings.localswitches,cs_ansistrings);
  260. if changeinit then
  261. include(init_settings.localswitches,cs_ansistrings);
  262. end
  263. else
  264. begin
  265. exclude(current_settings.localswitches,cs_ansistrings);
  266. if changeinit then
  267. exclude(init_settings.localswitches,cs_ansistrings);
  268. end;
  269. { turn inline on by default ? }
  270. if (m_default_inline in current_settings.modeswitches) then
  271. begin
  272. include(current_settings.localswitches,cs_do_inline);
  273. if changeinit then
  274. include(init_settings.localswitches,cs_do_inline);
  275. end
  276. else
  277. begin
  278. exclude(current_settings.localswitches,cs_ansistrings);
  279. if changeinit then
  280. exclude(init_settings.localswitches,cs_ansistrings);
  281. end;
  282. { turn on bitpacking for mode macpas }
  283. if (m_mac in current_settings.modeswitches) then
  284. begin
  285. include(current_settings.localswitches,cs_bitpacking);
  286. if changeinit then
  287. include(init_settings.localswitches,cs_bitpacking);
  288. end;
  289. { support goto/label by default in delphi/tp7/mac modes }
  290. if ([m_delphi,m_tp7,m_mac] * current_settings.modeswitches <> []) then
  291. begin
  292. include(current_settings.moduleswitches,cs_support_goto);
  293. if changeinit then
  294. include(init_settings.moduleswitches,cs_support_goto);
  295. end;
  296. { Default enum packing for delphi/tp7 }
  297. if (m_tp7 in current_settings.modeswitches) or
  298. (m_delphi in current_settings.modeswitches) then
  299. current_settings.packenum:=1
  300. else if (m_mac in current_settings.modeswitches) then
  301. { compatible with Metrowerks Pascal }
  302. current_settings.packenum:=2
  303. else
  304. current_settings.packenum:=4;
  305. if changeinit then
  306. init_settings.packenum:=current_settings.packenum;
  307. {$ifdef i386}
  308. { Default to intel assembler for delphi/tp7 on i386 }
  309. if (m_delphi in current_settings.modeswitches) or
  310. (m_tp7 in current_settings.modeswitches) then
  311. current_settings.asmmode:=asmmode_i386_intel;
  312. if changeinit then
  313. init_settings.asmmode:=current_settings.asmmode;
  314. {$endif i386}
  315. { Exception support explicitly turned on (mainly for macpas, to }
  316. { compensate for lack of interprocedural goto support) }
  317. if (cs_support_exceptions in current_settings.globalswitches) then
  318. include(current_settings.modeswitches,m_except);
  319. { Undefine old symbol }
  320. if (m_delphi in oldmodeswitches) then
  321. undef_system_macro('FPC_DELPHI')
  322. else if (m_tp7 in oldmodeswitches) then
  323. undef_system_macro('FPC_TP')
  324. else if (m_objfpc in oldmodeswitches) then
  325. undef_system_macro('FPC_OBJFPC')
  326. {$ifdef gpc_mode}
  327. else if (m_gpc in oldmodeswitches) then
  328. undef_system_macro('FPC_GPC')
  329. {$endif}
  330. else if (m_mac in oldmodeswitches) then
  331. undef_system_macro('FPC_MACPAS');
  332. { define new symbol in delphi,objfpc,tp,gpc,macpas mode }
  333. if (m_delphi in current_settings.modeswitches) then
  334. def_system_macro('FPC_DELPHI')
  335. else if (m_tp7 in current_settings.modeswitches) then
  336. def_system_macro('FPC_TP')
  337. else if (m_objfpc in current_settings.modeswitches) then
  338. def_system_macro('FPC_OBJFPC')
  339. {$ifdef gpc_mode}
  340. else if (m_gpc in current_settings.modeswitches) then
  341. def_system_macro('FPC_GPC')
  342. {$endif}
  343. else if (m_mac in current_settings.modeswitches) then
  344. def_system_macro('FPC_MACPAS');
  345. end;
  346. SetCompileMode:=b;
  347. end;
  348. {*****************************************************************************
  349. Conditional Directives
  350. *****************************************************************************}
  351. procedure dir_else;
  352. begin
  353. current_scanner.elsepreprocstack;
  354. end;
  355. procedure dir_endif;
  356. begin
  357. current_scanner.poppreprocstack;
  358. end;
  359. function isdef(var valuedescr: String): Boolean;
  360. var
  361. hs : string;
  362. mac : tmacro;
  363. begin
  364. current_scanner.skipspace;
  365. hs:=current_scanner.readid;
  366. valuedescr:= hs;
  367. if hs='' then
  368. Message(scan_e_error_in_preproc_expr);
  369. mac:=tmacro(search_macro(hs));
  370. if assigned(mac) then
  371. mac.is_used:=true;
  372. isdef:= assigned(mac) and mac.defined;
  373. end;
  374. procedure dir_ifdef;
  375. begin
  376. current_scanner.ifpreprocstack(pp_ifdef,@isdef,scan_c_ifdef_found);
  377. end;
  378. function isnotdef(var valuedescr: String): Boolean;
  379. var
  380. hs : string;
  381. mac : tmacro;
  382. begin
  383. current_scanner.skipspace;
  384. hs:=current_scanner.readid;
  385. valuedescr:= hs;
  386. if hs='' then
  387. Message(scan_e_error_in_preproc_expr);
  388. mac:=tmacro(search_macro(hs));
  389. if assigned(mac) then
  390. mac.is_used:=true;
  391. isnotdef:= not (assigned(mac) and mac.defined);
  392. end;
  393. procedure dir_ifndef;
  394. begin
  395. current_scanner.ifpreprocstack(pp_ifndef,@isnotdef,scan_c_ifndef_found);
  396. end;
  397. function opt_check(var valuedescr: String): Boolean;
  398. var
  399. hs : string;
  400. state : char;
  401. begin
  402. opt_check:= false;
  403. current_scanner.skipspace;
  404. hs:=current_scanner.readid;
  405. valuedescr:= hs;
  406. if (length(hs)>1) then
  407. Message1(scan_w_illegal_switch,hs)
  408. else
  409. begin
  410. state:=current_scanner.ReadState;
  411. if state in ['-','+'] then
  412. opt_check:=CheckSwitch(hs[1],state)
  413. else
  414. Message(scan_e_error_in_preproc_expr);
  415. end;
  416. end;
  417. procedure dir_ifopt;
  418. begin
  419. current_scanner.ifpreprocstack(pp_ifopt,@opt_check,scan_c_ifopt_found);
  420. end;
  421. procedure dir_libprefix;
  422. var
  423. s : string;
  424. begin
  425. current_scanner.skipspace;
  426. if c <> '''' then
  427. Message2(scan_f_syn_expected, '''', c);
  428. s := current_scanner.readquotedstring;
  429. stringdispose(outputprefix);
  430. outputprefix := stringdup(s);
  431. with current_module do
  432. setfilename(paramfn^, paramallowoutput);
  433. end;
  434. procedure dir_libsuffix;
  435. var
  436. s : string;
  437. begin
  438. current_scanner.skipspace;
  439. if c <> '''' then
  440. Message2(scan_f_syn_expected, '''', c);
  441. s := current_scanner.readquotedstring;
  442. stringdispose(outputsuffix);
  443. outputsuffix := stringdup(s);
  444. with current_module do
  445. setfilename(paramfn^, paramallowoutput);
  446. end;
  447. procedure dir_extension;
  448. var
  449. s : string;
  450. begin
  451. current_scanner.skipspace;
  452. if c <> '''' then
  453. Message2(scan_f_syn_expected, '''', c);
  454. s := current_scanner.readquotedstring;
  455. if OutputFileName='' then
  456. OutputFileName:=InputFileName;
  457. OutputFileName:=ChangeFileExt(OutputFileName,'.'+s);
  458. with current_module do
  459. setfilename(paramfn^, paramallowoutput);
  460. end;
  461. {
  462. Compile time expression type check
  463. ----------------------------------
  464. Each subexpression returns its type to the caller, which then can
  465. do type check. Since data types of compile time expressions is
  466. not well defined, the type system does a best effort. The drawback is
  467. that some errors might not be detected.
  468. Instead of returning a particular data type, a set of possible data types
  469. are returned. This way ambigouos types can be handled. For instance a
  470. value of 1 can be both a boolean and and integer.
  471. Booleans
  472. --------
  473. The following forms of boolean values are supported:
  474. * C coded, that is 0 is false, non-zero is true.
  475. * TRUE/FALSE for mac style compile time variables
  476. Thus boolean mac compile time variables are always stored as TRUE/FALSE.
  477. When a compile time expression is evaluated, they are then translated
  478. to C coded booleans (0/1), to simplify for the expression evaluator.
  479. Note that this scheme then also of support mac compile time variables which
  480. are 0/1 but with a boolean meaning.
  481. The TRUE/FALSE format is new from 22 august 2005, but the above scheme
  482. means that units which is not recompiled, and thus stores
  483. compile time variables as the old format (0/1), continue to work.
  484. Short circuit evaluation
  485. ------------------------
  486. For this to work, the part of a compile time expression which is short
  487. circuited, should not be evaluated, while it still should be parsed.
  488. Therefor there is a parameter eval, telling whether evaluation is needed.
  489. In case not, the value returned can be arbitrary.
  490. }
  491. type
  492. {Compile time expression types}
  493. TCTEType = (ctetBoolean, ctetInteger, ctetString, ctetSet);
  494. TCTETypeSet = set of TCTEType;
  495. const
  496. cteTypeNames : array[TCTEType] of string[10] = (
  497. 'BOOLEAN','INTEGER','STRING','SET');
  498. {Subset of types which can be elements in sets.}
  499. setelementdefs = [ctetBoolean, ctetInteger, ctetString];
  500. function GetCTETypeName(t: TCTETypeSet): String;
  501. var
  502. i: TCTEType;
  503. begin
  504. result:= '';
  505. for i:= Low(TCTEType) to High(TCTEType) do
  506. if i in t then
  507. if result = '' then
  508. result:= cteTypeNames[i]
  509. else
  510. result:= result + ' or ' + cteTypeNames[i];
  511. end;
  512. procedure CTEError(actType, desiredExprType: TCTETypeSet; place: String);
  513. begin
  514. Message3(scan_e_compile_time_typeerror,
  515. GetCTETypeName(desiredExprType),
  516. GetCTETypeName(actType),
  517. place
  518. );
  519. end;
  520. function parse_compiler_expr(var compileExprType: TCTETypeSet):string;
  521. function read_expr(var exprType: TCTETypeSet; eval : Boolean) : string; forward;
  522. procedure preproc_consume(t : ttoken);
  523. begin
  524. if t<>current_scanner.preproc_token then
  525. Message(scan_e_preproc_syntax_error);
  526. current_scanner.preproc_token:=current_scanner.readpreproc;
  527. end;
  528. function preproc_substitutedtoken(var macroType: TCTETypeSet; eval : Boolean): string;
  529. { Currently this parses identifiers as well as numbers.
  530. The result from this procedure can either be that the token
  531. itself is a value, or that it is a compile time variable/macro,
  532. which then is substituted for another value (for macros
  533. recursivelly substituted).}
  534. var
  535. hs: string;
  536. mac : tmacro;
  537. macrocount,
  538. len : integer;
  539. numres : longint;
  540. w: word;
  541. begin
  542. result := current_scanner.preproc_pattern;
  543. if not eval then
  544. exit;
  545. mac:= nil;
  546. { Substitue macros and compiler variables with their content/value.
  547. For real macros also do recursive substitution. }
  548. macrocount:=0;
  549. repeat
  550. mac:=tmacro(search_macro(result));
  551. inc(macrocount);
  552. if macrocount>max_macro_nesting then
  553. begin
  554. Message(scan_w_macro_too_deep);
  555. break;
  556. end;
  557. if assigned(mac) and mac.defined then
  558. if assigned(mac.buftext) then
  559. begin
  560. if mac.buflen>255 then
  561. begin
  562. len:=255;
  563. Message(scan_w_macro_cut_after_255_chars);
  564. end
  565. else
  566. len:=mac.buflen;
  567. hs[0]:=char(len);
  568. move(mac.buftext^,hs[1],len);
  569. result:=upcase(hs);
  570. mac.is_used:=true;
  571. end
  572. else
  573. begin
  574. Message1(scan_e_error_macro_lacks_value, result);
  575. break;
  576. end
  577. else
  578. begin
  579. break;
  580. end;
  581. if mac.is_compiler_var then
  582. break;
  583. until false;
  584. { At this point, result do contain the value. Do some decoding and
  585. determine the type.}
  586. val(result,numres,w);
  587. if (w=0) then {It is an integer}
  588. begin
  589. if (numres = 0) or (numres = 1) then
  590. macroType := [ctetInteger, ctetBoolean]
  591. else
  592. macroType := [ctetInteger];
  593. end
  594. else if assigned(mac) and (m_mac in current_settings.modeswitches) and (result='FALSE') then
  595. begin
  596. result:= '0';
  597. macroType:= [ctetBoolean];
  598. end
  599. else if assigned(mac) and (m_mac in current_settings.modeswitches) and (result='TRUE') then
  600. begin
  601. result:= '1';
  602. macroType:= [ctetBoolean];
  603. end
  604. else if (m_mac in current_settings.modeswitches) and
  605. (not assigned(mac) or not mac.defined) and
  606. (macrocount = 1) then
  607. begin
  608. {Errors in mode mac is issued here. For non macpas modes there is
  609. more liberty, but the error will eventually be caught at a later stage.}
  610. Message1(scan_e_error_macro_undefined, result);
  611. macroType:= [ctetString]; {Just to have something}
  612. end
  613. else
  614. macroType:= [ctetString];
  615. end;
  616. function read_factor(var factorType: TCTETypeSet; eval : Boolean) : string;
  617. var
  618. hs : string;
  619. mac: tmacro;
  620. srsym : tsym;
  621. srsymtable : TSymtable;
  622. hdef : TDef;
  623. l : longint;
  624. w : integer;
  625. hasKlammer: Boolean;
  626. setElemType : TCTETypeSet;
  627. begin
  628. if current_scanner.preproc_token=_ID then
  629. begin
  630. if current_scanner.preproc_pattern='DEFINED' then
  631. begin
  632. factorType:= [ctetBoolean];
  633. preproc_consume(_ID);
  634. current_scanner.skipspace;
  635. if current_scanner.preproc_token =_LKLAMMER then
  636. begin
  637. preproc_consume(_LKLAMMER);
  638. current_scanner.skipspace;
  639. hasKlammer:= true;
  640. end
  641. else if (m_mac in current_settings.modeswitches) then
  642. hasKlammer:= false
  643. else
  644. Message(scan_e_error_in_preproc_expr);
  645. if current_scanner.preproc_token =_ID then
  646. begin
  647. hs := current_scanner.preproc_pattern;
  648. mac := tmacro(search_macro(hs));
  649. if assigned(mac) and mac.defined then
  650. begin
  651. hs := '1';
  652. mac.is_used:=true;
  653. end
  654. else
  655. hs := '0';
  656. read_factor := hs;
  657. preproc_consume(_ID);
  658. current_scanner.skipspace;
  659. end
  660. else
  661. Message(scan_e_error_in_preproc_expr);
  662. if hasKlammer then
  663. if current_scanner.preproc_token =_RKLAMMER then
  664. preproc_consume(_RKLAMMER)
  665. else
  666. Message(scan_e_error_in_preproc_expr);
  667. end
  668. else
  669. if (m_mac in current_settings.modeswitches) and (current_scanner.preproc_pattern='UNDEFINED') then
  670. begin
  671. factorType:= [ctetBoolean];
  672. preproc_consume(_ID);
  673. current_scanner.skipspace;
  674. if current_scanner.preproc_token =_ID then
  675. begin
  676. hs := current_scanner.preproc_pattern;
  677. mac := tmacro(search_macro(hs));
  678. if assigned(mac) then
  679. begin
  680. hs := '0';
  681. mac.is_used:=true;
  682. end
  683. else
  684. hs := '1';
  685. read_factor := hs;
  686. preproc_consume(_ID);
  687. current_scanner.skipspace;
  688. end
  689. else
  690. Message(scan_e_error_in_preproc_expr);
  691. end
  692. else
  693. if (m_mac in current_settings.modeswitches) and (current_scanner.preproc_pattern='OPTION') then
  694. begin
  695. factorType:= [ctetBoolean];
  696. preproc_consume(_ID);
  697. current_scanner.skipspace;
  698. if current_scanner.preproc_token =_LKLAMMER then
  699. begin
  700. preproc_consume(_LKLAMMER);
  701. current_scanner.skipspace;
  702. end
  703. else
  704. Message(scan_e_error_in_preproc_expr);
  705. if not (current_scanner.preproc_token = _ID) then
  706. Message(scan_e_error_in_preproc_expr);
  707. hs:=current_scanner.preproc_pattern;
  708. if (length(hs) > 1) then
  709. {This is allowed in Metrowerks Pascal}
  710. Message(scan_e_error_in_preproc_expr)
  711. else
  712. begin
  713. if CheckSwitch(hs[1],'+') then
  714. read_factor := '1'
  715. else
  716. read_factor := '0';
  717. end;
  718. preproc_consume(_ID);
  719. current_scanner.skipspace;
  720. if current_scanner.preproc_token =_RKLAMMER then
  721. preproc_consume(_RKLAMMER)
  722. else
  723. Message(scan_e_error_in_preproc_expr);
  724. end
  725. else
  726. if current_scanner.preproc_pattern='SIZEOF' then
  727. begin
  728. factorType:= [ctetInteger];
  729. preproc_consume(_ID);
  730. current_scanner.skipspace;
  731. if current_scanner.preproc_token =_LKLAMMER then
  732. begin
  733. preproc_consume(_LKLAMMER);
  734. current_scanner.skipspace;
  735. end
  736. else
  737. Message(scan_e_preproc_syntax_error);
  738. if eval then
  739. if searchsym(current_scanner.preproc_pattern,srsym,srsymtable) then
  740. begin
  741. l:=0;
  742. case srsym.typ of
  743. staticvarsym,
  744. localvarsym,
  745. paravarsym :
  746. l:=tabstractvarsym(srsym).getsize;
  747. typesym:
  748. l:=ttypesym(srsym).typedef.size;
  749. else
  750. Message(scan_e_error_in_preproc_expr);
  751. end;
  752. str(l,read_factor);
  753. end
  754. else
  755. Message1(sym_e_id_not_found,current_scanner.preproc_pattern);
  756. preproc_consume(_ID);
  757. current_scanner.skipspace;
  758. if current_scanner.preproc_token =_RKLAMMER then
  759. preproc_consume(_RKLAMMER)
  760. else
  761. Message(scan_e_preproc_syntax_error);
  762. end
  763. else
  764. if current_scanner.preproc_pattern='HIGH' then
  765. begin
  766. factorType:= [ctetInteger];
  767. preproc_consume(_ID);
  768. current_scanner.skipspace;
  769. if current_scanner.preproc_token =_LKLAMMER then
  770. begin
  771. preproc_consume(_LKLAMMER);
  772. current_scanner.skipspace;
  773. end
  774. else
  775. Message(scan_e_preproc_syntax_error);
  776. if eval then
  777. if searchsym(current_scanner.preproc_pattern,srsym,srsymtable) then
  778. begin
  779. hdef:=nil;
  780. hs:='';
  781. l:=0;
  782. case srsym.typ of
  783. staticvarsym,
  784. localvarsym,
  785. paravarsym :
  786. hdef:=tabstractvarsym(srsym).vardef;
  787. typesym:
  788. hdef:=ttypesym(srsym).typedef;
  789. else
  790. Message(scan_e_error_in_preproc_expr);
  791. end;
  792. if hdef<>nil then
  793. begin
  794. if hdef.typ=setdef then
  795. hdef:=tsetdef(hdef).elementdef;
  796. case hdef.typ of
  797. orddef:
  798. with torddef(hdef).high do
  799. if signed then
  800. str(svalue,hs)
  801. else
  802. str(uvalue,hs);
  803. enumdef:
  804. l:=tenumdef(hdef).maxval;
  805. arraydef:
  806. if is_open_array(hdef) or is_array_of_const(hdef) or is_dynamic_array(hdef) then
  807. Message(type_e_mismatch)
  808. else
  809. l:=tarraydef(hdef).highrange;
  810. stringdef:
  811. if is_open_string(hdef) or is_ansistring(hdef) or is_widestring(hdef) then
  812. Message(type_e_mismatch)
  813. else
  814. l:=tstringdef(hdef).len;
  815. else
  816. Message(type_e_mismatch);
  817. end;
  818. end;
  819. if hs='' then
  820. str(l,read_factor)
  821. else
  822. read_factor:=hs;
  823. end
  824. else
  825. Message1(sym_e_id_not_found,current_scanner.preproc_pattern);
  826. preproc_consume(_ID);
  827. current_scanner.skipspace;
  828. if current_scanner.preproc_token =_RKLAMMER then
  829. preproc_consume(_RKLAMMER)
  830. else
  831. Message(scan_e_preproc_syntax_error);
  832. end
  833. else
  834. if current_scanner.preproc_pattern='DECLARED' then
  835. begin
  836. factorType:= [ctetBoolean];
  837. preproc_consume(_ID);
  838. current_scanner.skipspace;
  839. if current_scanner.preproc_token =_LKLAMMER then
  840. begin
  841. preproc_consume(_LKLAMMER);
  842. current_scanner.skipspace;
  843. end
  844. else
  845. Message(scan_e_error_in_preproc_expr);
  846. if current_scanner.preproc_token =_ID then
  847. begin
  848. hs := upper(current_scanner.preproc_pattern);
  849. if searchsym(hs,srsym,srsymtable) then
  850. hs := '1'
  851. else
  852. hs := '0';
  853. read_factor := hs;
  854. preproc_consume(_ID);
  855. current_scanner.skipspace;
  856. end
  857. else
  858. Message(scan_e_error_in_preproc_expr);
  859. if current_scanner.preproc_token =_RKLAMMER then
  860. preproc_consume(_RKLAMMER)
  861. else
  862. Message(scan_e_error_in_preproc_expr);
  863. end
  864. else
  865. if current_scanner.preproc_pattern='NOT' then
  866. begin
  867. factorType:= [ctetBoolean];
  868. preproc_consume(_ID);
  869. hs:=read_factor(factorType, eval);
  870. if eval then
  871. begin
  872. if not (ctetBoolean in factorType) then
  873. CTEError(factorType, [ctetBoolean], 'NOT');
  874. val(hs,l,w);
  875. if l<>0 then
  876. read_factor:='0'
  877. else
  878. read_factor:='1';
  879. end
  880. else
  881. read_factor:='0'; {Just to have something}
  882. end
  883. else
  884. if (m_mac in current_settings.modeswitches) and (current_scanner.preproc_pattern='TRUE') then
  885. begin
  886. factorType:= [ctetBoolean];
  887. preproc_consume(_ID);
  888. read_factor:='1';
  889. end
  890. else
  891. if (m_mac in current_settings.modeswitches) and (current_scanner.preproc_pattern='FALSE') then
  892. begin
  893. factorType:= [ctetBoolean];
  894. preproc_consume(_ID);
  895. read_factor:='0';
  896. end
  897. else
  898. begin
  899. hs:=preproc_substitutedtoken(factorType, eval);
  900. { Default is to return the original symbol }
  901. read_factor:=hs;
  902. if eval and ([m_delphi,m_objfpc]*current_settings.modeswitches<>[]) and (ctetString in factorType) then
  903. if searchsym(current_scanner.preproc_pattern,srsym,srsymtable) then
  904. begin
  905. case srsym.typ of
  906. constsym :
  907. begin
  908. with tconstsym(srsym) do
  909. begin
  910. case consttyp of
  911. constord :
  912. begin
  913. case constdef.typ of
  914. orddef:
  915. begin
  916. if is_integer(constdef) then
  917. begin
  918. read_factor:=tostr(value.valueord);
  919. factorType:= [ctetInteger];
  920. end
  921. else if is_boolean(constdef) then
  922. begin
  923. read_factor:=tostr(value.valueord);
  924. factorType:= [ctetBoolean];
  925. end
  926. else if is_char(constdef) then
  927. begin
  928. read_factor:=char(qword(value.valueord));
  929. factorType:= [ctetString];
  930. end
  931. end;
  932. enumdef:
  933. begin
  934. read_factor:=tostr(value.valueord);
  935. factorType:= [ctetInteger];
  936. end;
  937. end;
  938. end;
  939. conststring :
  940. begin
  941. read_factor := upper(pchar(value.valueptr));
  942. factorType:= [ctetString];
  943. end;
  944. constset :
  945. begin
  946. hs:=',';
  947. for l:=0 to 255 do
  948. if l in pconstset(tconstsym(srsym).value.valueptr)^ then
  949. hs:=hs+tostr(l)+',';
  950. read_factor := hs;
  951. factorType:= [ctetSet];
  952. end;
  953. end;
  954. end;
  955. end;
  956. enumsym :
  957. begin
  958. read_factor:=tostr(tenumsym(srsym).value);
  959. factorType:= [ctetInteger];
  960. end;
  961. end;
  962. end;
  963. preproc_consume(_ID);
  964. current_scanner.skipspace;
  965. end
  966. end
  967. else if current_scanner.preproc_token =_LKLAMMER then
  968. begin
  969. preproc_consume(_LKLAMMER);
  970. read_factor:=read_expr(factorType, eval);
  971. preproc_consume(_RKLAMMER);
  972. end
  973. else if current_scanner.preproc_token = _LECKKLAMMER then
  974. begin
  975. preproc_consume(_LECKKLAMMER);
  976. read_factor := ',';
  977. while current_scanner.preproc_token = _ID do
  978. begin
  979. read_factor := read_factor+read_factor(setElemType, eval)+',';
  980. if current_scanner.preproc_token = _COMMA then
  981. preproc_consume(_COMMA);
  982. end;
  983. // TODO Add check of setElemType
  984. preproc_consume(_RECKKLAMMER);
  985. factorType:= [ctetSet];
  986. end
  987. else
  988. Message(scan_e_error_in_preproc_expr);
  989. end;
  990. function read_term(var termType: TCTETypeSet; eval : Boolean) : string;
  991. var
  992. hs1,hs2 : string;
  993. l1,l2 : longint;
  994. w : integer;
  995. termType2: TCTETypeSet;
  996. begin
  997. hs1:=read_factor(termType, eval);
  998. repeat
  999. if (current_scanner.preproc_token<>_ID) then
  1000. break;
  1001. if current_scanner.preproc_pattern<>'AND' then
  1002. break;
  1003. val(hs1,l1,w);
  1004. if l1=0 then
  1005. eval:= false; {Short circuit evaluation of OR}
  1006. if eval then
  1007. begin
  1008. {Check if first expr is boolean. Must be done here, after we know
  1009. it is an AND expression.}
  1010. if not (ctetBoolean in termType) then
  1011. CTEError(termType, [ctetBoolean], 'AND');
  1012. termType:= [ctetBoolean];
  1013. end;
  1014. preproc_consume(_ID);
  1015. hs2:=read_factor(termType2, eval);
  1016. if eval then
  1017. begin
  1018. if not (ctetBoolean in termType2) then
  1019. CTEError(termType2, [ctetBoolean], 'AND');
  1020. val(hs2,l2,w);
  1021. if (l1<>0) and (l2<>0) then
  1022. hs1:='1'
  1023. else
  1024. hs1:='0';
  1025. end;
  1026. until false;
  1027. read_term:=hs1;
  1028. end;
  1029. function read_simple_expr(var simpleExprType: TCTETypeSet; eval : Boolean) : string;
  1030. var
  1031. hs1,hs2 : string;
  1032. l1,l2 : longint;
  1033. w : integer;
  1034. simpleExprType2: TCTETypeSet;
  1035. begin
  1036. hs1:=read_term(simpleExprType, eval);
  1037. repeat
  1038. if (current_scanner.preproc_token<>_ID) then
  1039. break;
  1040. if current_scanner.preproc_pattern<>'OR' then
  1041. break;
  1042. val(hs1,l1,w);
  1043. if l1<>0 then
  1044. eval:= false; {Short circuit evaluation of OR}
  1045. if eval then
  1046. begin
  1047. {Check if first expr is boolean. Must be done here, after we know
  1048. it is an OR expression.}
  1049. if not (ctetBoolean in simpleExprType) then
  1050. CTEError(simpleExprType, [ctetBoolean], 'OR');
  1051. simpleExprType:= [ctetBoolean];
  1052. end;
  1053. preproc_consume(_ID);
  1054. hs2:=read_term(simpleExprType2, eval);
  1055. if eval then
  1056. begin
  1057. if not (ctetBoolean in simpleExprType2) then
  1058. CTEError(simpleExprType2, [ctetBoolean], 'OR');
  1059. val(hs2,l2,w);
  1060. if (l1<>0) or (l2<>0) then
  1061. hs1:='1'
  1062. else
  1063. hs1:='0';
  1064. end;
  1065. until false;
  1066. read_simple_expr:=hs1;
  1067. end;
  1068. function read_expr(var exprType: TCTETypeSet; eval : Boolean) : string;
  1069. var
  1070. hs1,hs2 : string;
  1071. b : boolean;
  1072. op : ttoken;
  1073. w : integer;
  1074. l1,l2 : longint;
  1075. exprType2: TCTETypeSet;
  1076. begin
  1077. hs1:=read_simple_expr(exprType, eval);
  1078. op:=current_scanner.preproc_token;
  1079. if (op = _ID) and (current_scanner.preproc_pattern = 'IN') then
  1080. op := _IN;
  1081. if not (op in [_IN,_EQUAL,_UNEQUAL,_LT,_GT,_LTE,_GTE]) then
  1082. begin
  1083. read_expr:=hs1;
  1084. exit;
  1085. end;
  1086. if (op = _IN) then
  1087. preproc_consume(_ID)
  1088. else
  1089. preproc_consume(op);
  1090. hs2:=read_simple_expr(exprType2, eval);
  1091. if eval then
  1092. begin
  1093. if op = _IN then
  1094. begin
  1095. if exprType2 <> [ctetSet] then
  1096. CTEError(exprType2, [ctetSet], 'IN');
  1097. if exprType = [ctetSet] then
  1098. CTEError(exprType, setelementdefs, 'IN');
  1099. if is_number(hs1) and is_number(hs2) then
  1100. Message(scan_e_preproc_syntax_error)
  1101. else if hs2[1] = ',' then
  1102. b:=pos(','+hs1+',', hs2) > 0 { TODO For integer sets, perhaps check for numeric equivalence so that 0 = 00 }
  1103. else
  1104. Message(scan_e_preproc_syntax_error);
  1105. end
  1106. else
  1107. begin
  1108. if (exprType * exprType2) = [] then
  1109. CTEError(exprType2, exprType, tokeninfo^[op].str);
  1110. if is_number(hs1) and is_number(hs2) then
  1111. begin
  1112. val(hs1,l1,w);
  1113. val(hs2,l2,w);
  1114. case op of
  1115. _EQUAL :
  1116. b:=l1=l2;
  1117. _UNEQUAL :
  1118. b:=l1<>l2;
  1119. _LT :
  1120. b:=l1<l2;
  1121. _GT :
  1122. b:=l1>l2;
  1123. _GTE :
  1124. b:=l1>=l2;
  1125. _LTE :
  1126. b:=l1<=l2;
  1127. end;
  1128. end
  1129. else
  1130. begin
  1131. case op of
  1132. _EQUAL :
  1133. b:=hs1=hs2;
  1134. _UNEQUAL :
  1135. b:=hs1<>hs2;
  1136. _LT :
  1137. b:=hs1<hs2;
  1138. _GT :
  1139. b:=hs1>hs2;
  1140. _GTE :
  1141. b:=hs1>=hs2;
  1142. _LTE :
  1143. b:=hs1<=hs2;
  1144. end;
  1145. end;
  1146. end;
  1147. end
  1148. else
  1149. b:= false; {Just to have something}
  1150. if b then
  1151. read_expr:='1'
  1152. else
  1153. read_expr:='0';
  1154. exprType:= [ctetBoolean];
  1155. end;
  1156. begin
  1157. current_scanner.skipspace;
  1158. { start preproc expression scanner }
  1159. current_scanner.preproc_token:=current_scanner.readpreproc;
  1160. parse_compiler_expr:=read_expr(compileExprType, true);
  1161. end;
  1162. function boolean_compile_time_expr(var valuedescr: String): Boolean;
  1163. var
  1164. hs : string;
  1165. exprType: TCTETypeSet;
  1166. begin
  1167. hs:=parse_compiler_expr(exprType);
  1168. if (exprType * [ctetBoolean]) = [] then
  1169. CTEError(exprType, [ctetBoolean], 'IF or ELSEIF');
  1170. boolean_compile_time_expr:= hs <> '0';
  1171. valuedescr:= hs;
  1172. end;
  1173. procedure dir_if;
  1174. begin
  1175. current_scanner.ifpreprocstack(pp_if,@boolean_compile_time_expr, scan_c_if_found);
  1176. end;
  1177. procedure dir_elseif;
  1178. begin
  1179. current_scanner.elseifpreprocstack(@boolean_compile_time_expr);
  1180. end;
  1181. procedure dir_define_impl(macstyle: boolean);
  1182. var
  1183. hs : string;
  1184. bracketcount : longint;
  1185. mac : tmacro;
  1186. macropos : longint;
  1187. macrobuffer : pmacrobuffer;
  1188. begin
  1189. current_scanner.skipspace;
  1190. hs:=current_scanner.readid;
  1191. mac:=tmacro(search_macro(hs));
  1192. if not assigned(mac) or (mac.owner <> current_module.localmacrosymtable) then
  1193. begin
  1194. mac:=tmacro.create(hs);
  1195. mac.defined:=true;
  1196. current_module.localmacrosymtable.insert(mac);
  1197. end
  1198. else
  1199. begin
  1200. mac.defined:=true;
  1201. mac.is_compiler_var:=false;
  1202. { delete old definition }
  1203. if assigned(mac.buftext) then
  1204. begin
  1205. freemem(mac.buftext,mac.buflen);
  1206. mac.buftext:=nil;
  1207. end;
  1208. end;
  1209. Message1(parser_c_macro_defined,mac.name);
  1210. mac.is_used:=true;
  1211. if (cs_support_macro in current_settings.moduleswitches) then
  1212. begin
  1213. current_scanner.skipspace;
  1214. if not macstyle then
  1215. begin
  1216. { may be a macro? }
  1217. if c <> ':' then
  1218. exit;
  1219. current_scanner.readchar;
  1220. if c <> '=' then
  1221. exit;
  1222. current_scanner.readchar;
  1223. current_scanner.skipspace;
  1224. end;
  1225. { key words are never substituted }
  1226. if is_keyword(hs) then
  1227. Message(scan_e_keyword_cant_be_a_macro);
  1228. new(macrobuffer);
  1229. macropos:=0;
  1230. { parse macro, brackets are counted so it's possible
  1231. to have a $ifdef etc. in the macro }
  1232. bracketcount:=0;
  1233. repeat
  1234. case c of
  1235. '}' :
  1236. if (bracketcount=0) then
  1237. break
  1238. else
  1239. dec(bracketcount);
  1240. '{' :
  1241. inc(bracketcount);
  1242. #10,#13 :
  1243. current_scanner.linebreak;
  1244. #26 :
  1245. current_scanner.end_of_file;
  1246. end;
  1247. macrobuffer^[macropos]:=c;
  1248. inc(macropos);
  1249. if macropos>=maxmacrolen then
  1250. Message(scan_f_macro_buffer_overflow);
  1251. current_scanner.readchar;
  1252. until false;
  1253. { free buffer of macro ?}
  1254. if assigned(mac.buftext) then
  1255. freemem(mac.buftext,mac.buflen);
  1256. { get new mem }
  1257. getmem(mac.buftext,macropos);
  1258. mac.buflen:=macropos;
  1259. { copy the text }
  1260. move(macrobuffer^,mac.buftext^,macropos);
  1261. dispose(macrobuffer);
  1262. end
  1263. else
  1264. begin
  1265. { check if there is an assignment, then we need to give a
  1266. warning }
  1267. current_scanner.skipspace;
  1268. if c=':' then
  1269. begin
  1270. current_scanner.readchar;
  1271. if c='=' then
  1272. Message(scan_w_macro_support_turned_off);
  1273. end;
  1274. end;
  1275. end;
  1276. procedure dir_define;
  1277. begin
  1278. dir_define_impl(false);
  1279. end;
  1280. procedure dir_definec;
  1281. begin
  1282. dir_define_impl(true);
  1283. end;
  1284. procedure dir_setc;
  1285. var
  1286. hs : string;
  1287. mac : tmacro;
  1288. exprType: TCTETypeSet;
  1289. l : longint;
  1290. w : integer;
  1291. begin
  1292. current_scanner.skipspace;
  1293. hs:=current_scanner.readid;
  1294. mac:=tmacro(search_macro(hs));
  1295. if not assigned(mac) or
  1296. (mac.owner <> current_module.localmacrosymtable) then
  1297. begin
  1298. mac:=tmacro.create(hs);
  1299. mac.defined:=true;
  1300. mac.is_compiler_var:=true;
  1301. current_module.localmacrosymtable.insert(mac);
  1302. end
  1303. else
  1304. begin
  1305. mac.defined:=true;
  1306. mac.is_compiler_var:=true;
  1307. { delete old definition }
  1308. if assigned(mac.buftext) then
  1309. begin
  1310. freemem(mac.buftext,mac.buflen);
  1311. mac.buftext:=nil;
  1312. end;
  1313. end;
  1314. Message1(parser_c_macro_defined,mac.name);
  1315. mac.is_used:=true;
  1316. { key words are never substituted }
  1317. if is_keyword(hs) then
  1318. Message(scan_e_keyword_cant_be_a_macro);
  1319. { macro assignment can be both := and = }
  1320. current_scanner.skipspace;
  1321. if c=':' then
  1322. current_scanner.readchar;
  1323. if c='=' then
  1324. begin
  1325. current_scanner.readchar;
  1326. hs:= parse_compiler_expr(exprType);
  1327. if (exprType * [ctetBoolean, ctetInteger]) = [] then
  1328. CTEError(exprType, [ctetBoolean, ctetInteger], 'SETC');
  1329. if length(hs) <> 0 then
  1330. begin
  1331. {If we are absolutely shure it is boolean, translate
  1332. to TRUE/FALSE to increase possibility to do future type check}
  1333. if exprType = [ctetBoolean] then
  1334. begin
  1335. val(hs,l,w);
  1336. if l<>0 then
  1337. hs:='TRUE'
  1338. else
  1339. hs:='FALSE';
  1340. end;
  1341. Message2(parser_c_macro_set_to,mac.name,hs);
  1342. { free buffer of macro ?}
  1343. if assigned(mac.buftext) then
  1344. freemem(mac.buftext,mac.buflen);
  1345. { get new mem }
  1346. getmem(mac.buftext,length(hs));
  1347. mac.buflen:=length(hs);
  1348. { copy the text }
  1349. move(hs[1],mac.buftext^,mac.buflen);
  1350. end
  1351. else
  1352. Message(scan_e_preproc_syntax_error);
  1353. end
  1354. else
  1355. Message(scan_e_preproc_syntax_error);
  1356. end;
  1357. procedure dir_undef;
  1358. var
  1359. hs : string;
  1360. mac : tmacro;
  1361. begin
  1362. current_scanner.skipspace;
  1363. hs:=current_scanner.readid;
  1364. mac:=tmacro(search_macro(hs));
  1365. if not assigned(mac) or
  1366. (mac.owner <> current_module.localmacrosymtable) then
  1367. begin
  1368. mac:=tmacro.create(hs);
  1369. mac.defined:=false;
  1370. current_module.localmacrosymtable.insert(mac);
  1371. end
  1372. else
  1373. begin
  1374. mac.defined:=false;
  1375. mac.is_compiler_var:=false;
  1376. { delete old definition }
  1377. if assigned(mac.buftext) then
  1378. begin
  1379. freemem(mac.buftext,mac.buflen);
  1380. mac.buftext:=nil;
  1381. end;
  1382. end;
  1383. Message1(parser_c_macro_undefined,mac.name);
  1384. mac.is_used:=true;
  1385. end;
  1386. procedure dir_include;
  1387. function findincludefile(const path,name:TCmdStr;var foundfile:TCmdStr):boolean;
  1388. var
  1389. found : boolean;
  1390. hpath : TCmdStr;
  1391. begin
  1392. (* look for the include file
  1393. If path was specified as part of {$I } then
  1394. 1. specified path (expanded with path of inputfile if relative)
  1395. else
  1396. 1. path of current inputfile,current dir
  1397. 2. local includepath
  1398. 3. global includepath *)
  1399. found:=false;
  1400. foundfile:='';
  1401. hpath:='';
  1402. if path<>'' then
  1403. begin
  1404. if not path_absolute(path) then
  1405. hpath:=current_scanner.inputfile.path^+path
  1406. else
  1407. hpath:=path;
  1408. found:=FindFile(name, hpath,true,foundfile);
  1409. end
  1410. else
  1411. begin
  1412. hpath:=current_scanner.inputfile.path^+';'+CurDirRelPath(source_info);
  1413. found:=FindFile(name, hpath,true,foundfile);
  1414. if not found then
  1415. found:=current_module.localincludesearchpath.FindFile(name,true,foundfile);
  1416. if not found then
  1417. found:=includesearchpath.FindFile(name,true,foundfile);
  1418. end;
  1419. result:=found;
  1420. end;
  1421. var
  1422. foundfile : TCmdStr;
  1423. path,
  1424. name,
  1425. args,
  1426. hs : tpathstr;
  1427. hp : tinputfile;
  1428. found : boolean;
  1429. begin
  1430. current_scanner.skipspace;
  1431. args:=current_scanner.readcomment;
  1432. hs:=GetToken(args,' ');
  1433. if hs='' then
  1434. exit;
  1435. if (hs[1]='%') then
  1436. begin
  1437. { case insensitive }
  1438. hs:=upper(hs);
  1439. { remove %'s }
  1440. Delete(hs,1,1);
  1441. if hs[length(hs)]='%' then
  1442. Delete(hs,length(hs),1);
  1443. { save old }
  1444. path:=hs;
  1445. { first check for internal macros }
  1446. if hs='TIME' then
  1447. hs:=gettimestr
  1448. else
  1449. if hs='DATE' then
  1450. hs:=getdatestr
  1451. else
  1452. if hs='FILE' then
  1453. hs:=current_module.sourcefiles.get_file_name(current_filepos.fileindex)
  1454. else
  1455. if hs='LINE' then
  1456. hs:=tostr(current_filepos.line)
  1457. else
  1458. if hs='FPCVERSION' then
  1459. hs:=version_string
  1460. else
  1461. if hs='FPCDATE' then
  1462. hs:=date_string
  1463. else
  1464. if hs='FPCTARGET' then
  1465. hs:=target_cpu_string
  1466. else
  1467. if hs='FPCTARGETCPU' then
  1468. hs:=target_cpu_string
  1469. else
  1470. if hs='FPCTARGETOS' then
  1471. hs:=target_info.shortname
  1472. else
  1473. hs:=GetEnvironmentVariable(hs);
  1474. if hs='' then
  1475. Message1(scan_w_include_env_not_found,path);
  1476. { make it a stringconst }
  1477. hs:=''''+hs+'''';
  1478. current_scanner.insertmacro(path,@hs[1],length(hs),
  1479. current_scanner.line_no,current_scanner.inputfile.ref_index);
  1480. end
  1481. else
  1482. begin
  1483. hs:=FixFileName(hs);
  1484. path:=ExtractFilePath(hs);
  1485. name:=ExtractFileName(hs);
  1486. { try to find the file }
  1487. found:=findincludefile(path,name,foundfile);
  1488. if (ExtractFileExt(name)='') then
  1489. begin
  1490. { try default extensions .inc , .pp and .pas }
  1491. if (not found) then
  1492. found:=findincludefile(path,ChangeFileExt(name,'.inc'),foundfile);
  1493. if (not found) then
  1494. found:=findincludefile(path,ChangeFileExt(name,sourceext),foundfile);
  1495. if (not found) then
  1496. found:=findincludefile(path,ChangeFileExt(name,pasext),foundfile);
  1497. end;
  1498. if current_scanner.inputfilecount<max_include_nesting then
  1499. begin
  1500. inc(current_scanner.inputfilecount);
  1501. { we need to reread the current char }
  1502. dec(current_scanner.inputpointer);
  1503. { shutdown current file }
  1504. current_scanner.tempcloseinputfile;
  1505. { load new file }
  1506. hp:=do_openinputfile(foundfile);
  1507. current_scanner.addfile(hp);
  1508. current_module.sourcefiles.register_file(hp);
  1509. if (not found) then
  1510. Message1(scan_f_cannot_open_includefile,hs);
  1511. if (not current_scanner.openinputfile) then
  1512. Message1(scan_f_cannot_open_includefile,hs);
  1513. Message1(scan_t_start_include_file,current_scanner.inputfile.path^+current_scanner.inputfile.name^);
  1514. current_scanner.reload;
  1515. end
  1516. else
  1517. Message(scan_f_include_deep_ten);
  1518. end;
  1519. end;
  1520. {*****************************************************************************
  1521. Preprocessor writing
  1522. *****************************************************************************}
  1523. {$ifdef PREPROCWRITE}
  1524. constructor tpreprocfile.create(const fn:string);
  1525. begin
  1526. { open outputfile }
  1527. assign(f,fn);
  1528. {$I-}
  1529. rewrite(f);
  1530. {$I+}
  1531. if ioresult<>0 then
  1532. Comment(V_Fatal,'can''t create file '+fn);
  1533. getmem(buf,preprocbufsize);
  1534. settextbuf(f,buf^,preprocbufsize);
  1535. { reset }
  1536. eolfound:=false;
  1537. spacefound:=false;
  1538. end;
  1539. destructor tpreprocfile.destroy;
  1540. begin
  1541. close(f);
  1542. freemem(buf,preprocbufsize);
  1543. end;
  1544. procedure tpreprocfile.add(const s:string);
  1545. begin
  1546. write(f,s);
  1547. end;
  1548. procedure tpreprocfile.addspace;
  1549. begin
  1550. if eolfound then
  1551. begin
  1552. writeln(f,'');
  1553. eolfound:=false;
  1554. spacefound:=false;
  1555. end
  1556. else
  1557. if spacefound then
  1558. begin
  1559. write(f,' ');
  1560. spacefound:=false;
  1561. end;
  1562. end;
  1563. {$endif PREPROCWRITE}
  1564. {*****************************************************************************
  1565. TPreProcStack
  1566. *****************************************************************************}
  1567. constructor tpreprocstack.create(atyp : preproctyp;a:boolean;n:tpreprocstack);
  1568. begin
  1569. accept:=a;
  1570. typ:=atyp;
  1571. next:=n;
  1572. end;
  1573. {*****************************************************************************
  1574. TDirectiveItem
  1575. *****************************************************************************}
  1576. constructor TDirectiveItem.Create(AList:TFPHashObjectList;const n:string;p:tdirectiveproc);
  1577. begin
  1578. inherited Create(AList,n);
  1579. is_conditional:=false;
  1580. proc:=p;
  1581. end;
  1582. constructor TDirectiveItem.CreateCond(AList:TFPHashObjectList;const n:string;p:tdirectiveproc);
  1583. begin
  1584. inherited Create(AList,n);
  1585. is_conditional:=true;
  1586. proc:=p;
  1587. end;
  1588. {****************************************************************************
  1589. TSCANNERFILE
  1590. ****************************************************************************}
  1591. constructor tscannerfile.create(const fn:string);
  1592. begin
  1593. inputfile:=do_openinputfile(fn);
  1594. if assigned(current_module) then
  1595. current_module.sourcefiles.register_file(inputfile);
  1596. { reset localinput }
  1597. inputbuffer:=nil;
  1598. inputpointer:=nil;
  1599. inputstart:=0;
  1600. { reset scanner }
  1601. preprocstack:=nil;
  1602. comment_level:=0;
  1603. yylexcount:=0;
  1604. block_type:=bt_general;
  1605. line_no:=0;
  1606. lastlinepos:=0;
  1607. lasttokenpos:=0;
  1608. lasttoken:=NOTOKEN;
  1609. nexttoken:=NOTOKEN;
  1610. lastasmgetchar:=#0;
  1611. ignoredirectives:=TFPHashList.Create;
  1612. in_asm_string:=false;
  1613. end;
  1614. procedure tscannerfile.firstfile;
  1615. begin
  1616. { load block }
  1617. if not openinputfile then
  1618. Message1(scan_f_cannot_open_input,inputfile.name^);
  1619. reload;
  1620. end;
  1621. destructor tscannerfile.destroy;
  1622. begin
  1623. if assigned(current_module) and
  1624. (current_module.state=ms_compiled) and
  1625. (status.errorcount=0) then
  1626. checkpreprocstack
  1627. else
  1628. begin
  1629. while assigned(preprocstack) do
  1630. poppreprocstack;
  1631. end;
  1632. if not inputfile.closed then
  1633. closeinputfile;
  1634. ignoredirectives.free;
  1635. end;
  1636. function tscannerfile.openinputfile:boolean;
  1637. begin
  1638. openinputfile:=inputfile.open;
  1639. { load buffer }
  1640. inputbuffer:=inputfile.buf;
  1641. inputpointer:=inputfile.buf;
  1642. inputstart:=inputfile.bufstart;
  1643. { line }
  1644. line_no:=0;
  1645. lastlinepos:=0;
  1646. lasttokenpos:=0;
  1647. end;
  1648. procedure tscannerfile.closeinputfile;
  1649. begin
  1650. inputfile.close;
  1651. { reset buffer }
  1652. inputbuffer:=nil;
  1653. inputpointer:=nil;
  1654. inputstart:=0;
  1655. { reset line }
  1656. line_no:=0;
  1657. lastlinepos:=0;
  1658. lasttokenpos:=0;
  1659. end;
  1660. function tscannerfile.tempopeninputfile:boolean;
  1661. begin
  1662. if inputfile.is_macro then
  1663. exit;
  1664. tempopeninputfile:=inputfile.tempopen;
  1665. { reload buffer }
  1666. inputbuffer:=inputfile.buf;
  1667. inputpointer:=inputfile.buf;
  1668. inputstart:=inputfile.bufstart;
  1669. end;
  1670. procedure tscannerfile.tempcloseinputfile;
  1671. begin
  1672. if inputfile.closed or inputfile.is_macro then
  1673. exit;
  1674. inputfile.setpos(inputstart+(inputpointer-inputbuffer));
  1675. inputfile.tempclose;
  1676. { reset buffer }
  1677. inputbuffer:=nil;
  1678. inputpointer:=nil;
  1679. inputstart:=0;
  1680. end;
  1681. procedure tscannerfile.saveinputfile;
  1682. begin
  1683. inputfile.saveinputpointer:=inputpointer;
  1684. inputfile.savelastlinepos:=lastlinepos;
  1685. inputfile.saveline_no:=line_no;
  1686. end;
  1687. procedure tscannerfile.restoreinputfile;
  1688. begin
  1689. inputbuffer:=inputfile.buf;
  1690. inputpointer:=inputfile.saveinputpointer;
  1691. lastlinepos:=inputfile.savelastlinepos;
  1692. line_no:=inputfile.saveline_no;
  1693. if not inputfile.is_macro then
  1694. parser_current_file:=inputfile.name^;
  1695. end;
  1696. procedure tscannerfile.nextfile;
  1697. var
  1698. to_dispose : tinputfile;
  1699. begin
  1700. if assigned(inputfile.next) then
  1701. begin
  1702. if inputfile.is_macro then
  1703. to_dispose:=inputfile
  1704. else
  1705. begin
  1706. to_dispose:=nil;
  1707. dec(inputfilecount);
  1708. end;
  1709. { we can allways close the file, no ? }
  1710. inputfile.close;
  1711. inputfile:=inputfile.next;
  1712. if assigned(to_dispose) then
  1713. to_dispose.free;
  1714. restoreinputfile;
  1715. end;
  1716. end;
  1717. procedure tscannerfile.startrecordtokens(buf:tdynamicarray);
  1718. begin
  1719. if not assigned(buf) then
  1720. internalerror(200511172);
  1721. if assigned(recordtokenbuf) then
  1722. internalerror(200511173);
  1723. recordtokenbuf:=buf;
  1724. fillchar(last_settings,sizeof(last_settings),0);
  1725. fillchar(last_filepos,sizeof(last_filepos),0);
  1726. end;
  1727. procedure tscannerfile.stoprecordtokens;
  1728. begin
  1729. if not assigned(recordtokenbuf) then
  1730. internalerror(200511174);
  1731. recordtokenbuf:=nil;
  1732. end;
  1733. procedure tscannerfile.recordtoken;
  1734. begin
  1735. if not assigned(recordtokenbuf) then
  1736. internalerror(200511176);
  1737. { settings changed? }
  1738. if CompareByte(current_settings,last_settings,sizeof(current_settings))<>0 then
  1739. begin
  1740. { use a special token to record it }
  1741. recordtokenbuf.write(_GENERICSPECIALTOKEN,1);
  1742. recordtokenbuf.write(ST_LOADSETTINGS,1);
  1743. recordtokenbuf.write(current_settings,sizeof(current_settings));
  1744. last_settings:=current_settings;
  1745. end;
  1746. { file pos changes? }
  1747. if current_tokenpos.line<>last_filepos.line then
  1748. begin
  1749. recordtokenbuf.write(_GENERICSPECIALTOKEN,1);
  1750. recordtokenbuf.write(ST_LINE,1);
  1751. recordtokenbuf.write(current_tokenpos.line,sizeof(current_tokenpos.line));
  1752. last_filepos.line:=current_tokenpos.line;
  1753. end;
  1754. if current_tokenpos.column<>last_filepos.column then
  1755. begin
  1756. recordtokenbuf.write(_GENERICSPECIALTOKEN,1);
  1757. recordtokenbuf.write(ST_COLUMN,1);
  1758. recordtokenbuf.write(current_tokenpos.column,sizeof(current_tokenpos.column));
  1759. last_filepos.column:=current_tokenpos.column;
  1760. end;
  1761. if current_tokenpos.fileindex<>last_filepos.fileindex then
  1762. begin
  1763. recordtokenbuf.write(_GENERICSPECIALTOKEN,1);
  1764. recordtokenbuf.write(ST_FILEINDEX,1);
  1765. recordtokenbuf.write(current_tokenpos.fileindex,sizeof(current_tokenpos.fileindex));
  1766. last_filepos.fileindex:=current_tokenpos.fileindex;
  1767. end;
  1768. recordtokenbuf.write(token,1);
  1769. if token=_ID then
  1770. recordtokenbuf.write(idtoken,1);
  1771. case token of
  1772. _CWCHAR,
  1773. _CWSTRING :
  1774. begin
  1775. recordtokenbuf.write(patternw^.len,sizeof(sizeint));
  1776. recordtokenbuf.write(patternw^.data^,patternw^.len*sizeof(tcompilerwidechar));
  1777. end;
  1778. _CCHAR,
  1779. _CSTRING,
  1780. _INTCONST,
  1781. _REALNUMBER :
  1782. begin
  1783. { pexpr.pas messes with pattern in case of negative integer consts,
  1784. see around line 2562 the comment of JM; remove the - before recording it
  1785. (FK)
  1786. }
  1787. if (token=_INTCONST) and (pattern[1]='-') then
  1788. delete(pattern,1,1);
  1789. recordtokenbuf.write(pattern[0],1);
  1790. recordtokenbuf.write(pattern[1],length(pattern));
  1791. end;
  1792. _ID :
  1793. begin
  1794. recordtokenbuf.write(orgpattern[0],1);
  1795. recordtokenbuf.write(orgpattern[1],length(orgpattern));
  1796. end;
  1797. end;
  1798. end;
  1799. procedure tscannerfile.startreplaytokens(buf:tdynamicarray);
  1800. begin
  1801. if not assigned(buf) then
  1802. internalerror(200511175);
  1803. { save current token }
  1804. if token in [_CWCHAR,_CWSTRING,_CCHAR,_CSTRING,_INTCONST,_REALNUMBER,_ID] then
  1805. internalerror(200511178);
  1806. replaysavetoken:=token;
  1807. old_settings:=current_settings;
  1808. if assigned(inputpointer) then
  1809. dec(inputpointer);
  1810. { install buffer }
  1811. replaytokenbuf:=buf;
  1812. { reload next token }
  1813. replaytokenbuf.seek(0);
  1814. replaytoken;
  1815. end;
  1816. procedure tscannerfile.replaytoken;
  1817. var
  1818. wlen : sizeint;
  1819. specialtoken : tspecialgenerictoken;
  1820. begin
  1821. if not assigned(replaytokenbuf) then
  1822. internalerror(200511177);
  1823. { End of replay buffer? Then load the next char from the file again }
  1824. if replaytokenbuf.pos>=replaytokenbuf.size then
  1825. begin
  1826. replaytokenbuf:=nil;
  1827. if assigned(inputpointer) then
  1828. begin
  1829. c:=inputpointer^;
  1830. inc(inputpointer);
  1831. end;
  1832. token:=replaysavetoken;
  1833. { restore compiler settings }
  1834. current_settings:=old_settings;
  1835. exit;
  1836. end;
  1837. repeat
  1838. { load token from the buffer }
  1839. replaytokenbuf.read(token,1);
  1840. if token=_ID then
  1841. replaytokenbuf.read(idtoken,1)
  1842. else
  1843. idtoken:=_NOID;
  1844. case token of
  1845. _CWCHAR,
  1846. _CWSTRING :
  1847. begin
  1848. replaytokenbuf.read(wlen,sizeof(SizeInt));
  1849. setlengthwidestring(patternw,wlen);
  1850. replaytokenbuf.read(patternw^.data^,patternw^.len*sizeof(tcompilerwidechar));
  1851. pattern:='';
  1852. end;
  1853. _CCHAR,
  1854. _CSTRING,
  1855. _INTCONST,
  1856. _REALNUMBER :
  1857. begin
  1858. replaytokenbuf.read(pattern[0],1);
  1859. replaytokenbuf.read(pattern[1],length(pattern));
  1860. orgpattern:='';
  1861. end;
  1862. _ID :
  1863. begin
  1864. replaytokenbuf.read(orgpattern[0],1);
  1865. replaytokenbuf.read(orgpattern[1],length(orgpattern));
  1866. pattern:=upper(orgpattern);
  1867. end;
  1868. _GENERICSPECIALTOKEN:
  1869. begin
  1870. replaytokenbuf.read(specialtoken,1);
  1871. case specialtoken of
  1872. ST_LOADSETTINGS:
  1873. replaytokenbuf.read(current_settings,sizeof(current_settings));
  1874. ST_LINE:
  1875. begin
  1876. replaytokenbuf.read(current_tokenpos.line,sizeof(current_tokenpos.line));
  1877. current_filepos:=current_tokenpos;
  1878. end;
  1879. ST_COLUMN:
  1880. begin
  1881. replaytokenbuf.read(current_tokenpos.column,sizeof(current_tokenpos.column));
  1882. current_filepos:=current_tokenpos;
  1883. end;
  1884. ST_FILEINDEX:
  1885. begin
  1886. replaytokenbuf.read(current_tokenpos.fileindex,sizeof(current_tokenpos.fileindex));
  1887. current_filepos:=current_tokenpos;
  1888. end;
  1889. else
  1890. internalerror(2006103010);
  1891. end;
  1892. continue;
  1893. end;
  1894. end;
  1895. break;
  1896. until false;
  1897. end;
  1898. procedure tscannerfile.addfile(hp:tinputfile);
  1899. begin
  1900. saveinputfile;
  1901. { add to list }
  1902. hp.next:=inputfile;
  1903. inputfile:=hp;
  1904. { load new inputfile }
  1905. restoreinputfile;
  1906. end;
  1907. procedure tscannerfile.reload;
  1908. begin
  1909. with inputfile do
  1910. begin
  1911. { when nothing more to read then leave immediatly, so we
  1912. don't change the current_filepos and leave it point to the last
  1913. char }
  1914. if (c=#26) and (not assigned(next)) then
  1915. exit;
  1916. repeat
  1917. { still more to read?, then change the #0 to a space so its seen
  1918. as a seperator, this can't be used for macro's which can change
  1919. the place of the #0 in the buffer with tempopen }
  1920. if (c=#0) and (bufsize>0) and
  1921. not(inputfile.is_macro) and
  1922. (inputpointer-inputbuffer<bufsize) then
  1923. begin
  1924. c:=' ';
  1925. inc(inputpointer);
  1926. exit;
  1927. end;
  1928. { can we read more from this file ? }
  1929. if (c<>#26) and (not endoffile) then
  1930. begin
  1931. readbuf;
  1932. inputpointer:=buf;
  1933. inputbuffer:=buf;
  1934. inputstart:=bufstart;
  1935. { first line? }
  1936. if line_no=0 then
  1937. begin
  1938. c:=inputpointer^;
  1939. { eat utf-8 signature? }
  1940. if (ord(inputpointer^)=$ef) and
  1941. (ord((inputpointer+1)^)=$bb) and
  1942. (ord((inputpointer+2)^)=$bf) then
  1943. begin
  1944. inc(inputpointer,3);
  1945. message(scan_c_switching_to_utf8);
  1946. current_settings.sourcecodepage:='utf8';
  1947. end;
  1948. line_no:=1;
  1949. if cs_asm_source in current_settings.globalswitches then
  1950. inputfile.setline(line_no,bufstart);
  1951. end;
  1952. end
  1953. else
  1954. begin
  1955. { load eof position in tokenpos/current_filepos }
  1956. gettokenpos;
  1957. { close file }
  1958. closeinputfile;
  1959. { no next module, than EOF }
  1960. if not assigned(inputfile.next) then
  1961. begin
  1962. c:=#26;
  1963. exit;
  1964. end;
  1965. { load next file and reopen it }
  1966. nextfile;
  1967. tempopeninputfile;
  1968. { status }
  1969. Message1(scan_t_back_in,inputfile.name^);
  1970. end;
  1971. { load next char }
  1972. c:=inputpointer^;
  1973. inc(inputpointer);
  1974. until c<>#0; { if also end, then reload again }
  1975. end;
  1976. end;
  1977. procedure tscannerfile.insertmacro(const macname:string;p:pchar;len,line,fileindex:longint);
  1978. var
  1979. hp : tinputfile;
  1980. begin
  1981. { save old postion }
  1982. dec(inputpointer);
  1983. tempcloseinputfile;
  1984. { create macro 'file' }
  1985. { use special name to dispose after !! }
  1986. hp:=do_openinputfile('_Macro_.'+macname);
  1987. addfile(hp);
  1988. with inputfile do
  1989. begin
  1990. setmacro(p,len);
  1991. { local buffer }
  1992. inputbuffer:=buf;
  1993. inputpointer:=buf;
  1994. inputstart:=bufstart;
  1995. ref_index:=fileindex;
  1996. end;
  1997. { reset line }
  1998. line_no:=line;
  1999. lastlinepos:=0;
  2000. lasttokenpos:=0;
  2001. { load new c }
  2002. c:=inputpointer^;
  2003. inc(inputpointer);
  2004. end;
  2005. procedure tscannerfile.gettokenpos;
  2006. { load the values of tokenpos and lasttokenpos }
  2007. begin
  2008. lasttokenpos:=inputstart+(inputpointer-inputbuffer);
  2009. current_tokenpos.line:=line_no;
  2010. current_tokenpos.column:=lasttokenpos-lastlinepos;
  2011. current_tokenpos.fileindex:=inputfile.ref_index;
  2012. current_tokenpos.moduleindex:=current_module.unit_index;
  2013. current_filepos:=current_tokenpos;
  2014. end;
  2015. procedure tscannerfile.inc_comment_level;
  2016. var
  2017. oldcurrent_filepos : tfileposinfo;
  2018. begin
  2019. if (m_nested_comment in current_settings.modeswitches) then
  2020. inc(comment_level)
  2021. else
  2022. comment_level:=1;
  2023. if (comment_level>1) then
  2024. begin
  2025. oldcurrent_filepos:=current_filepos;
  2026. gettokenpos; { update for warning }
  2027. Message1(scan_w_comment_level,tostr(comment_level));
  2028. current_filepos:=oldcurrent_filepos;
  2029. end;
  2030. end;
  2031. procedure tscannerfile.dec_comment_level;
  2032. begin
  2033. if (m_nested_comment in current_settings.modeswitches) then
  2034. dec(comment_level)
  2035. else
  2036. comment_level:=0;
  2037. end;
  2038. procedure tscannerfile.linebreak;
  2039. var
  2040. cur : char;
  2041. oldtokenpos,
  2042. oldcurrent_filepos : tfileposinfo;
  2043. begin
  2044. with inputfile do
  2045. begin
  2046. if (byte(inputpointer^)=0) and not(endoffile) then
  2047. begin
  2048. cur:=c;
  2049. reload;
  2050. if byte(cur)+byte(c)<>23 then
  2051. dec(inputpointer);
  2052. end
  2053. else
  2054. begin
  2055. { Support all combination of #10 and #13 as line break }
  2056. if (byte(inputpointer^)+byte(c)=23) then
  2057. inc(inputpointer);
  2058. end;
  2059. { Always return #10 as line break }
  2060. c:=#10;
  2061. { increase line counters }
  2062. lastlinepos:=bufstart+(inputpointer-inputbuffer);
  2063. inc(line_no);
  2064. { update linebuffer }
  2065. if cs_asm_source in current_settings.globalswitches then
  2066. inputfile.setline(line_no,lastlinepos);
  2067. { update for status and call the show status routine,
  2068. but don't touch current_filepos ! }
  2069. oldcurrent_filepos:=current_filepos;
  2070. oldtokenpos:=current_tokenpos;
  2071. gettokenpos; { update for v_status }
  2072. inc(status.compiledlines);
  2073. ShowStatus;
  2074. current_filepos:=oldcurrent_filepos;
  2075. current_tokenpos:=oldtokenpos;
  2076. end;
  2077. end;
  2078. procedure tscannerfile.illegal_char(c:char);
  2079. var
  2080. s : string;
  2081. begin
  2082. if c in [#32..#255] then
  2083. s:=''''+c+''''
  2084. else
  2085. s:='#'+tostr(ord(c));
  2086. Message2(scan_f_illegal_char,s,'$'+hexstr(ord(c),2));
  2087. end;
  2088. procedure tscannerfile.end_of_file;
  2089. begin
  2090. checkpreprocstack;
  2091. Message(scan_f_end_of_file);
  2092. end;
  2093. {-------------------------------------------
  2094. IF Conditional Handling
  2095. -------------------------------------------}
  2096. procedure tscannerfile.checkpreprocstack;
  2097. begin
  2098. { check for missing ifdefs }
  2099. while assigned(preprocstack) do
  2100. begin
  2101. Message4(scan_e_endif_expected,preprocstring[preprocstack.typ],preprocstack.name,
  2102. preprocstack.owner.inputfile.name^,tostr(preprocstack.line_nb));
  2103. poppreprocstack;
  2104. end;
  2105. end;
  2106. procedure tscannerfile.poppreprocstack;
  2107. var
  2108. hp : tpreprocstack;
  2109. begin
  2110. if assigned(preprocstack) then
  2111. begin
  2112. Message1(scan_c_endif_found,preprocstack.name);
  2113. hp:=preprocstack.next;
  2114. preprocstack.free;
  2115. preprocstack:=hp;
  2116. end
  2117. else
  2118. Message(scan_e_endif_without_if);
  2119. end;
  2120. procedure tscannerfile.ifpreprocstack(atyp : preproctyp;compile_time_predicate:tcompile_time_predicate;messid:longint);
  2121. var
  2122. condition: Boolean;
  2123. valuedescr: String;
  2124. begin
  2125. if (preprocstack=nil) or preprocstack.accept then
  2126. condition:= compile_time_predicate(valuedescr)
  2127. else
  2128. begin
  2129. condition:= false;
  2130. valuedescr:= '';
  2131. end;
  2132. preprocstack:=tpreprocstack.create(atyp, condition, preprocstack);
  2133. preprocstack.name:=valuedescr;
  2134. preprocstack.line_nb:=line_no;
  2135. preprocstack.owner:=self;
  2136. if preprocstack.accept then
  2137. Message2(messid,preprocstack.name,'accepted')
  2138. else
  2139. Message2(messid,preprocstack.name,'rejected');
  2140. end;
  2141. procedure tscannerfile.elsepreprocstack;
  2142. begin
  2143. if assigned(preprocstack) and
  2144. (preprocstack.typ<>pp_else) then
  2145. begin
  2146. if (preprocstack.typ=pp_elseif) then
  2147. preprocstack.accept:=false
  2148. else
  2149. if (not(assigned(preprocstack.next)) or (preprocstack.next.accept)) then
  2150. preprocstack.accept:=not preprocstack.accept;
  2151. preprocstack.typ:=pp_else;
  2152. preprocstack.line_nb:=line_no;
  2153. if preprocstack.accept then
  2154. Message2(scan_c_else_found,preprocstack.name,'accepted')
  2155. else
  2156. Message2(scan_c_else_found,preprocstack.name,'rejected');
  2157. end
  2158. else
  2159. Message(scan_e_endif_without_if);
  2160. end;
  2161. procedure tscannerfile.elseifpreprocstack(compile_time_predicate:tcompile_time_predicate);
  2162. var
  2163. valuedescr: String;
  2164. begin
  2165. if assigned(preprocstack) and
  2166. (preprocstack.typ in [pp_if,pp_elseif]) then
  2167. begin
  2168. { when the branch is accepted we use pp_elseif so we know that
  2169. all the next branches need to be rejected. when this branch is still
  2170. not accepted then leave it at pp_if }
  2171. if (preprocstack.typ=pp_elseif) then
  2172. preprocstack.accept:=false
  2173. else if (preprocstack.typ=pp_if) and preprocstack.accept then
  2174. begin
  2175. preprocstack.accept:=false;
  2176. preprocstack.typ:=pp_elseif;
  2177. end
  2178. else if (not(assigned(preprocstack.next)) or (preprocstack.next.accept))
  2179. and compile_time_predicate(valuedescr) then
  2180. begin
  2181. preprocstack.name:=valuedescr;
  2182. preprocstack.accept:=true;
  2183. preprocstack.typ:=pp_elseif;
  2184. end;
  2185. preprocstack.line_nb:=line_no;
  2186. if preprocstack.accept then
  2187. Message2(scan_c_else_found,preprocstack.name,'accepted')
  2188. else
  2189. Message2(scan_c_else_found,preprocstack.name,'rejected');
  2190. end
  2191. else
  2192. Message(scan_e_endif_without_if);
  2193. end;
  2194. procedure tscannerfile.handleconditional(p:tdirectiveitem);
  2195. var
  2196. oldcurrent_filepos : tfileposinfo;
  2197. begin
  2198. oldcurrent_filepos:=current_filepos;
  2199. repeat
  2200. current_scanner.gettokenpos;
  2201. p.proc();
  2202. { accept the text ? }
  2203. if (current_scanner.preprocstack=nil) or current_scanner.preprocstack.accept then
  2204. break
  2205. else
  2206. begin
  2207. current_scanner.gettokenpos;
  2208. Message(scan_c_skipping_until);
  2209. repeat
  2210. current_scanner.skipuntildirective;
  2211. if not (m_mac in current_settings.modeswitches) then
  2212. p:=tdirectiveitem(turbo_scannerdirectives.Find(current_scanner.readid))
  2213. else
  2214. p:=tdirectiveitem(mac_scannerdirectives.Find(current_scanner.readid));
  2215. until assigned(p) and (p.is_conditional);
  2216. current_scanner.gettokenpos;
  2217. Message1(scan_d_handling_switch,'$'+p.name);
  2218. end;
  2219. until false;
  2220. current_filepos:=oldcurrent_filepos;
  2221. end;
  2222. procedure tscannerfile.handledirectives;
  2223. var
  2224. t : tdirectiveitem;
  2225. hs : string;
  2226. begin
  2227. gettokenpos;
  2228. readchar; {Remove the $}
  2229. hs:=readid;
  2230. { handle empty directive }
  2231. if hs='' then
  2232. begin
  2233. Message1(scan_w_illegal_switch,'$');
  2234. exit;
  2235. end;
  2236. {$ifdef PREPROCWRITE}
  2237. if parapreprocess then
  2238. begin
  2239. t:=Get_Directive(hs);
  2240. if not(is_conditional(t) or (t=_DIR_DEFINE) or (t=_DIR_UNDEF)) then
  2241. begin
  2242. preprocfile^.AddSpace;
  2243. preprocfile^.Add('{$'+hs+current_scanner.readcomment+'}');
  2244. exit;
  2245. end;
  2246. end;
  2247. {$endif PREPROCWRITE}
  2248. { skip this directive? }
  2249. if (ignoredirectives.find(hs)<>nil) then
  2250. begin
  2251. if (comment_level>0) then
  2252. readcomment;
  2253. { we've read the whole comment }
  2254. aktcommentstyle:=comment_none;
  2255. exit;
  2256. end;
  2257. { Check for compiler switches }
  2258. while (length(hs)=1) and (c in ['-','+']) do
  2259. begin
  2260. HandleSwitch(hs[1],c);
  2261. current_scanner.readchar; {Remove + or -}
  2262. if c=',' then
  2263. begin
  2264. current_scanner.readchar; {Remove , }
  2265. { read next switch, support $v+,$+}
  2266. hs:=current_scanner.readid;
  2267. if (hs='') then
  2268. begin
  2269. if (c='$') and (m_fpc in current_settings.modeswitches) then
  2270. begin
  2271. current_scanner.readchar; { skip $ }
  2272. hs:=current_scanner.readid;
  2273. end;
  2274. if (hs='') then
  2275. Message1(scan_w_illegal_directive,'$'+c);
  2276. end
  2277. else
  2278. Message1(scan_d_handling_switch,'$'+hs);
  2279. end
  2280. else
  2281. hs:='';
  2282. end;
  2283. { directives may follow switches after a , }
  2284. if hs<>'' then
  2285. begin
  2286. if not (m_mac in current_settings.modeswitches) then
  2287. t:=tdirectiveitem(turbo_scannerdirectives.Find(hs))
  2288. else
  2289. t:=tdirectiveitem(mac_scannerdirectives.Find(hs));
  2290. if assigned(t) then
  2291. begin
  2292. if t.is_conditional then
  2293. handleconditional(t)
  2294. else
  2295. begin
  2296. Message1(scan_d_handling_switch,'$'+hs);
  2297. t.proc();
  2298. end;
  2299. end
  2300. else
  2301. begin
  2302. current_scanner.ignoredirectives.Add(hs,nil);
  2303. Message1(scan_w_illegal_directive,'$'+hs);
  2304. end;
  2305. { conditionals already read the comment }
  2306. if (current_scanner.comment_level>0) then
  2307. current_scanner.readcomment;
  2308. { we've read the whole comment }
  2309. aktcommentstyle:=comment_none;
  2310. end;
  2311. end;
  2312. procedure tscannerfile.readchar;
  2313. begin
  2314. c:=inputpointer^;
  2315. if c=#0 then
  2316. reload
  2317. else
  2318. inc(inputpointer);
  2319. end;
  2320. procedure tscannerfile.readstring;
  2321. var
  2322. i : longint;
  2323. err : boolean;
  2324. begin
  2325. err:=false;
  2326. i:=0;
  2327. repeat
  2328. case c of
  2329. '_',
  2330. '0'..'9',
  2331. 'A'..'Z' :
  2332. begin
  2333. if i<255 then
  2334. begin
  2335. inc(i);
  2336. orgpattern[i]:=c;
  2337. pattern[i]:=c;
  2338. end
  2339. else
  2340. begin
  2341. if not err then
  2342. begin
  2343. Message(scan_e_string_exceeds_255_chars);
  2344. err:=true;
  2345. end;
  2346. end;
  2347. c:=inputpointer^;
  2348. inc(inputpointer);
  2349. end;
  2350. 'a'..'z' :
  2351. begin
  2352. if i<255 then
  2353. begin
  2354. inc(i);
  2355. orgpattern[i]:=c;
  2356. pattern[i]:=chr(ord(c)-32)
  2357. end
  2358. else
  2359. begin
  2360. if not err then
  2361. begin
  2362. Message(scan_e_string_exceeds_255_chars);
  2363. err:=true;
  2364. end;
  2365. end;
  2366. c:=inputpointer^;
  2367. inc(inputpointer);
  2368. end;
  2369. #0 :
  2370. reload;
  2371. else
  2372. break;
  2373. end;
  2374. until false;
  2375. orgpattern[0]:=chr(i);
  2376. pattern[0]:=chr(i);
  2377. end;
  2378. procedure tscannerfile.readnumber;
  2379. var
  2380. base,
  2381. i : longint;
  2382. begin
  2383. case c of
  2384. '%' :
  2385. begin
  2386. readchar;
  2387. base:=2;
  2388. pattern[1]:='%';
  2389. i:=1;
  2390. end;
  2391. '&' :
  2392. begin
  2393. readchar;
  2394. base:=8;
  2395. pattern[1]:='&';
  2396. i:=1;
  2397. end;
  2398. '$' :
  2399. begin
  2400. readchar;
  2401. base:=16;
  2402. pattern[1]:='$';
  2403. i:=1;
  2404. end;
  2405. else
  2406. begin
  2407. base:=10;
  2408. i:=0;
  2409. end;
  2410. end;
  2411. while ((base>=10) and (c in ['0'..'9'])) or
  2412. ((base=16) and (c in ['A'..'F','a'..'f'])) or
  2413. ((base=8) and (c in ['0'..'7'])) or
  2414. ((base=2) and (c in ['0'..'1'])) do
  2415. begin
  2416. if i<255 then
  2417. begin
  2418. inc(i);
  2419. pattern[i]:=c;
  2420. end;
  2421. readchar;
  2422. end;
  2423. pattern[0]:=chr(i);
  2424. end;
  2425. function tscannerfile.readid:string;
  2426. begin
  2427. readstring;
  2428. readid:=pattern;
  2429. end;
  2430. function tscannerfile.readval:longint;
  2431. var
  2432. l : longint;
  2433. w : integer;
  2434. begin
  2435. readnumber;
  2436. val(pattern,l,w);
  2437. readval:=l;
  2438. end;
  2439. function tscannerfile.readval_asstring:string;
  2440. begin
  2441. readnumber;
  2442. readval_asstring:=pattern;
  2443. end;
  2444. function tscannerfile.readcomment:string;
  2445. var
  2446. i : longint;
  2447. begin
  2448. i:=0;
  2449. repeat
  2450. case c of
  2451. '{' :
  2452. begin
  2453. if aktcommentstyle=comment_tp then
  2454. inc_comment_level;
  2455. end;
  2456. '}' :
  2457. begin
  2458. if aktcommentstyle=comment_tp then
  2459. begin
  2460. readchar;
  2461. dec_comment_level;
  2462. if comment_level=0 then
  2463. break
  2464. else
  2465. continue;
  2466. end;
  2467. end;
  2468. '*' :
  2469. begin
  2470. if aktcommentstyle=comment_oldtp then
  2471. begin
  2472. readchar;
  2473. if c=')' then
  2474. begin
  2475. readchar;
  2476. dec_comment_level;
  2477. break;
  2478. end
  2479. else
  2480. { Add both characters !!}
  2481. if (i<255) then
  2482. begin
  2483. inc(i);
  2484. readcomment[i]:='*';
  2485. if (i<255) then
  2486. begin
  2487. inc(i);
  2488. readcomment[i]:=c;
  2489. end;
  2490. end;
  2491. end
  2492. else
  2493. { Not old TP comment, so add...}
  2494. begin
  2495. if (i<255) then
  2496. begin
  2497. inc(i);
  2498. readcomment[i]:='*';
  2499. end;
  2500. end;
  2501. end;
  2502. #10,#13 :
  2503. linebreak;
  2504. #26 :
  2505. end_of_file;
  2506. else
  2507. begin
  2508. if (i<255) then
  2509. begin
  2510. inc(i);
  2511. readcomment[i]:=c;
  2512. end;
  2513. end;
  2514. end;
  2515. readchar;
  2516. until false;
  2517. readcomment[0]:=chr(i);
  2518. end;
  2519. function tscannerfile.readquotedstring:string;
  2520. var
  2521. i : longint;
  2522. msgwritten : boolean;
  2523. begin
  2524. i:=0;
  2525. msgwritten:=false;
  2526. if (c='''') then
  2527. begin
  2528. repeat
  2529. readchar;
  2530. case c of
  2531. #26 :
  2532. end_of_file;
  2533. #10,#13 :
  2534. Message(scan_f_string_exceeds_line);
  2535. '''' :
  2536. begin
  2537. readchar;
  2538. if c<>'''' then
  2539. break;
  2540. end;
  2541. end;
  2542. if i<255 then
  2543. begin
  2544. inc(i);
  2545. result[i]:=c;
  2546. end
  2547. else
  2548. begin
  2549. if not msgwritten then
  2550. begin
  2551. Message(scan_e_string_exceeds_255_chars);
  2552. msgwritten:=true;
  2553. end;
  2554. end;
  2555. until false;
  2556. end;
  2557. result[0]:=chr(i);
  2558. end;
  2559. function tscannerfile.readstate:char;
  2560. var
  2561. state : char;
  2562. begin
  2563. state:=' ';
  2564. if c=' ' then
  2565. begin
  2566. current_scanner.skipspace;
  2567. current_scanner.readid;
  2568. if pattern='ON' then
  2569. state:='+'
  2570. else
  2571. if pattern='OFF' then
  2572. state:='-';
  2573. end
  2574. else
  2575. state:=c;
  2576. if not (state in ['+','-']) then
  2577. Message(scan_e_wrong_switch_toggle);
  2578. readstate:=state;
  2579. end;
  2580. function tscannerfile.readstatedefault:char;
  2581. var
  2582. state : char;
  2583. begin
  2584. state:=' ';
  2585. if c=' ' then
  2586. begin
  2587. current_scanner.skipspace;
  2588. current_scanner.readid;
  2589. if pattern='ON' then
  2590. state:='+'
  2591. else
  2592. if pattern='OFF' then
  2593. state:='-'
  2594. else
  2595. if pattern='DEFAULT' then
  2596. state:='*';
  2597. end
  2598. else
  2599. state:=c;
  2600. if not (state in ['+','-','*']) then
  2601. Message(scan_e_wrong_switch_toggle_default);
  2602. readstatedefault:=state;
  2603. end;
  2604. procedure tscannerfile.skipspace;
  2605. begin
  2606. repeat
  2607. case c of
  2608. #26 :
  2609. begin
  2610. reload;
  2611. if (c=#26) and not assigned(inputfile.next) then
  2612. break;
  2613. continue;
  2614. end;
  2615. #10,
  2616. #13 :
  2617. linebreak;
  2618. #9,#11,#12,' ' :
  2619. ;
  2620. else
  2621. break;
  2622. end;
  2623. readchar;
  2624. until false;
  2625. end;
  2626. procedure tscannerfile.skipuntildirective;
  2627. var
  2628. found : longint;
  2629. next_char_loaded : boolean;
  2630. begin
  2631. found:=0;
  2632. next_char_loaded:=false;
  2633. repeat
  2634. case c of
  2635. #10,
  2636. #13 :
  2637. linebreak;
  2638. #26 :
  2639. begin
  2640. reload;
  2641. if (c=#26) and not assigned(inputfile.next) then
  2642. end_of_file;
  2643. continue;
  2644. end;
  2645. '{' :
  2646. begin
  2647. if (aktcommentstyle in [comment_tp,comment_none]) then
  2648. begin
  2649. aktcommentstyle:=comment_tp;
  2650. if (comment_level=0) then
  2651. found:=1;
  2652. inc_comment_level;
  2653. end;
  2654. end;
  2655. '*' :
  2656. begin
  2657. if (aktcommentstyle=comment_oldtp) then
  2658. begin
  2659. readchar;
  2660. if c=')' then
  2661. begin
  2662. dec_comment_level;
  2663. found:=0;
  2664. aktcommentstyle:=comment_none;
  2665. end
  2666. else
  2667. next_char_loaded:=true;
  2668. end
  2669. else
  2670. found := 0;
  2671. end;
  2672. '}' :
  2673. begin
  2674. if (aktcommentstyle=comment_tp) then
  2675. begin
  2676. dec_comment_level;
  2677. if (comment_level=0) then
  2678. aktcommentstyle:=comment_none;
  2679. found:=0;
  2680. end;
  2681. end;
  2682. '$' :
  2683. begin
  2684. if found=1 then
  2685. found:=2;
  2686. end;
  2687. '''' :
  2688. if (aktcommentstyle=comment_none) then
  2689. begin
  2690. repeat
  2691. readchar;
  2692. case c of
  2693. #26 :
  2694. end_of_file;
  2695. #10,#13 :
  2696. break;
  2697. '''' :
  2698. begin
  2699. readchar;
  2700. if c<>'''' then
  2701. begin
  2702. next_char_loaded:=true;
  2703. break;
  2704. end;
  2705. end;
  2706. end;
  2707. until false;
  2708. end;
  2709. '(' :
  2710. begin
  2711. if (aktcommentstyle=comment_none) then
  2712. begin
  2713. readchar;
  2714. if c='*' then
  2715. begin
  2716. readchar;
  2717. if c='$' then
  2718. begin
  2719. found:=2;
  2720. inc_comment_level;
  2721. aktcommentstyle:=comment_oldtp;
  2722. end
  2723. else
  2724. begin
  2725. skipoldtpcomment;
  2726. next_char_loaded:=true;
  2727. end;
  2728. end
  2729. else
  2730. next_char_loaded:=true;
  2731. end
  2732. else
  2733. found:=0;
  2734. end;
  2735. '/' :
  2736. begin
  2737. if (aktcommentstyle=comment_none) then
  2738. begin
  2739. readchar;
  2740. if c='/' then
  2741. skipdelphicomment;
  2742. next_char_loaded:=true;
  2743. end
  2744. else
  2745. found:=0;
  2746. end;
  2747. else
  2748. found:=0;
  2749. end;
  2750. if next_char_loaded then
  2751. next_char_loaded:=false
  2752. else
  2753. readchar;
  2754. until (found=2);
  2755. end;
  2756. {****************************************************************************
  2757. Comment Handling
  2758. ****************************************************************************}
  2759. procedure tscannerfile.skipcomment;
  2760. begin
  2761. aktcommentstyle:=comment_tp;
  2762. readchar;
  2763. inc_comment_level;
  2764. { handle compiler switches }
  2765. if (c='$') then
  2766. handledirectives;
  2767. { handle_switches can dec comment_level, }
  2768. while (comment_level>0) do
  2769. begin
  2770. case c of
  2771. '{' :
  2772. inc_comment_level;
  2773. '}' :
  2774. dec_comment_level;
  2775. #10,#13 :
  2776. linebreak;
  2777. #26 :
  2778. begin
  2779. reload;
  2780. if (c=#26) and not assigned(inputfile.next) then
  2781. end_of_file;
  2782. continue;
  2783. end;
  2784. end;
  2785. readchar;
  2786. end;
  2787. aktcommentstyle:=comment_none;
  2788. end;
  2789. procedure tscannerfile.skipdelphicomment;
  2790. begin
  2791. aktcommentstyle:=comment_delphi;
  2792. inc_comment_level;
  2793. readchar;
  2794. { this is not supported }
  2795. if c='$' then
  2796. Message(scan_w_wrong_styled_switch);
  2797. { skip comment }
  2798. while not (c in [#10,#13,#26]) do
  2799. readchar;
  2800. dec_comment_level;
  2801. aktcommentstyle:=comment_none;
  2802. end;
  2803. procedure tscannerfile.skipoldtpcomment;
  2804. var
  2805. found : longint;
  2806. begin
  2807. aktcommentstyle:=comment_oldtp;
  2808. inc_comment_level;
  2809. { only load a char if last already processed,
  2810. was cause of bug1634 PM }
  2811. if c=#0 then
  2812. readchar;
  2813. { this is now supported }
  2814. if (c='$') then
  2815. handledirectives;
  2816. { skip comment }
  2817. while (comment_level>0) do
  2818. begin
  2819. found:=0;
  2820. repeat
  2821. case c of
  2822. #26 :
  2823. begin
  2824. reload;
  2825. if (c=#26) and not assigned(inputfile.next) then
  2826. end_of_file;
  2827. continue;
  2828. end;
  2829. #10,#13 :
  2830. linebreak;
  2831. '*' :
  2832. begin
  2833. if found=3 then
  2834. found:=4
  2835. else
  2836. found:=1;
  2837. end;
  2838. ')' :
  2839. begin
  2840. if found in [1,4] then
  2841. begin
  2842. dec_comment_level;
  2843. if comment_level=0 then
  2844. found:=2
  2845. else
  2846. found:=0;
  2847. end;
  2848. end;
  2849. '(' :
  2850. begin
  2851. if found=4 then
  2852. inc_comment_level;
  2853. found:=3;
  2854. end;
  2855. else
  2856. begin
  2857. if found=4 then
  2858. inc_comment_level;
  2859. found:=0;
  2860. end;
  2861. end;
  2862. readchar;
  2863. until (found=2);
  2864. end;
  2865. aktcommentstyle:=comment_none;
  2866. end;
  2867. {****************************************************************************
  2868. Token Scanner
  2869. ****************************************************************************}
  2870. procedure tscannerfile.readtoken(allowrecordtoken:boolean);
  2871. var
  2872. code : integer;
  2873. len,
  2874. low,high,mid : longint;
  2875. w : word;
  2876. m : longint;
  2877. mac : tmacro;
  2878. asciinr : string[6];
  2879. msgwritten,
  2880. iswidestring : boolean;
  2881. label
  2882. exit_label;
  2883. begin
  2884. if localswitcheschanged then
  2885. begin
  2886. current_settings.localswitches:=nextlocalswitches;
  2887. localswitcheschanged:=false;
  2888. end;
  2889. { record tokens? }
  2890. if allowrecordtoken and
  2891. assigned(recordtokenbuf) then
  2892. recordtoken;
  2893. { replay tokens? }
  2894. if assigned(replaytokenbuf) then
  2895. begin
  2896. replaytoken;
  2897. goto exit_label;
  2898. end;
  2899. { was there already a token read, then return that token }
  2900. if nexttoken<>NOTOKEN then
  2901. begin
  2902. token:=nexttoken;
  2903. nexttoken:=NOTOKEN;
  2904. goto exit_label;
  2905. end;
  2906. { Skip all spaces and comments }
  2907. repeat
  2908. case c of
  2909. '{' :
  2910. skipcomment;
  2911. #26 :
  2912. begin
  2913. reload;
  2914. if (c=#26) and not assigned(inputfile.next) then
  2915. break;
  2916. end;
  2917. ' ',#9..#13 :
  2918. begin
  2919. {$ifdef PREPROCWRITE}
  2920. if parapreprocess then
  2921. begin
  2922. if c=#10 then
  2923. preprocfile.eolfound:=true
  2924. else
  2925. preprocfile.spacefound:=true;
  2926. end;
  2927. {$endif PREPROCWRITE}
  2928. skipspace;
  2929. end
  2930. else
  2931. break;
  2932. end;
  2933. until false;
  2934. { Save current token position, for EOF its already loaded }
  2935. if c<>#26 then
  2936. gettokenpos;
  2937. { Check first for a identifier/keyword, this is 20+% faster (PFV) }
  2938. if c in ['A'..'Z','a'..'z','_'] then
  2939. begin
  2940. readstring;
  2941. token:=_ID;
  2942. idtoken:=_ID;
  2943. { keyword or any other known token,
  2944. pattern is always uppercased }
  2945. if (pattern[1]<>'_') and (length(pattern) in [tokenlenmin..tokenlenmax]) then
  2946. begin
  2947. low:=ord(tokenidx^[length(pattern),pattern[1]].first);
  2948. high:=ord(tokenidx^[length(pattern),pattern[1]].last);
  2949. while low<high do
  2950. begin
  2951. mid:=(high+low+1) shr 1;
  2952. if pattern<tokeninfo^[ttoken(mid)].str then
  2953. high:=mid-1
  2954. else
  2955. low:=mid;
  2956. end;
  2957. with tokeninfo^[ttoken(high)] do
  2958. if pattern=str then
  2959. begin
  2960. if keyword in current_settings.modeswitches then
  2961. if op=NOTOKEN then
  2962. token:=ttoken(high)
  2963. else
  2964. token:=op;
  2965. idtoken:=ttoken(high);
  2966. end;
  2967. end;
  2968. { Only process identifiers and not keywords }
  2969. if token=_ID then
  2970. begin
  2971. { this takes some time ... }
  2972. if (cs_support_macro in current_settings.moduleswitches) then
  2973. begin
  2974. mac:=tmacro(search_macro(pattern));
  2975. if assigned(mac) and (not mac.is_compiler_var) and (assigned(mac.buftext)) then
  2976. begin
  2977. if yylexcount<max_macro_nesting then
  2978. begin
  2979. mac.is_used:=true;
  2980. inc(yylexcount);
  2981. insertmacro(pattern,mac.buftext,mac.buflen,
  2982. mac.fileinfo.line,mac.fileinfo.fileindex);
  2983. { handle empty macros }
  2984. if c=#0 then
  2985. reload;
  2986. readtoken(false);
  2987. { that's all folks }
  2988. dec(yylexcount);
  2989. exit;
  2990. end
  2991. else
  2992. Message(scan_w_macro_too_deep);
  2993. end;
  2994. end;
  2995. end;
  2996. { return token }
  2997. goto exit_label;
  2998. end
  2999. else
  3000. begin
  3001. idtoken:=_NOID;
  3002. case c of
  3003. '$' :
  3004. begin
  3005. readnumber;
  3006. token:=_INTCONST;
  3007. goto exit_label;
  3008. end;
  3009. '%' :
  3010. begin
  3011. if not(m_fpc in current_settings.modeswitches) then
  3012. Illegal_Char(c)
  3013. else
  3014. begin
  3015. readnumber;
  3016. token:=_INTCONST;
  3017. goto exit_label;
  3018. end;
  3019. end;
  3020. '&' :
  3021. begin
  3022. if m_fpc in current_settings.modeswitches then
  3023. begin
  3024. readnumber;
  3025. token:=_INTCONST;
  3026. goto exit_label;
  3027. end
  3028. else if m_mac in current_settings.modeswitches then
  3029. begin
  3030. readchar;
  3031. token:=_AMPERSAND;
  3032. goto exit_label;
  3033. end
  3034. else
  3035. Illegal_Char(c);
  3036. end;
  3037. '0'..'9' :
  3038. begin
  3039. readnumber;
  3040. if (c in ['.','e','E']) then
  3041. begin
  3042. { first check for a . }
  3043. if c='.' then
  3044. begin
  3045. readchar;
  3046. { is it a .. from a range? }
  3047. case c of
  3048. '.' :
  3049. begin
  3050. readchar;
  3051. token:=_INTCONST;
  3052. nexttoken:=_POINTPOINT;
  3053. goto exit_label;
  3054. end;
  3055. ')' :
  3056. begin
  3057. readchar;
  3058. token:=_INTCONST;
  3059. nexttoken:=_RECKKLAMMER;
  3060. goto exit_label;
  3061. end;
  3062. end;
  3063. { insert the number after the . }
  3064. pattern:=pattern+'.';
  3065. while c in ['0'..'9'] do
  3066. begin
  3067. pattern:=pattern+c;
  3068. readchar;
  3069. end;
  3070. end;
  3071. { E can also follow after a point is scanned }
  3072. if c in ['e','E'] then
  3073. begin
  3074. pattern:=pattern+'E';
  3075. readchar;
  3076. if c in ['-','+'] then
  3077. begin
  3078. pattern:=pattern+c;
  3079. readchar;
  3080. end;
  3081. if not(c in ['0'..'9']) then
  3082. Illegal_Char(c);
  3083. while c in ['0'..'9'] do
  3084. begin
  3085. pattern:=pattern+c;
  3086. readchar;
  3087. end;
  3088. end;
  3089. token:=_REALNUMBER;
  3090. goto exit_label;
  3091. end;
  3092. token:=_INTCONST;
  3093. goto exit_label;
  3094. end;
  3095. ';' :
  3096. begin
  3097. readchar;
  3098. token:=_SEMICOLON;
  3099. goto exit_label;
  3100. end;
  3101. '[' :
  3102. begin
  3103. readchar;
  3104. token:=_LECKKLAMMER;
  3105. goto exit_label;
  3106. end;
  3107. ']' :
  3108. begin
  3109. readchar;
  3110. token:=_RECKKLAMMER;
  3111. goto exit_label;
  3112. end;
  3113. '(' :
  3114. begin
  3115. readchar;
  3116. case c of
  3117. '*' :
  3118. begin
  3119. c:=#0;{Signal skipoldtpcomment to reload a char }
  3120. skipoldtpcomment;
  3121. readtoken(false);
  3122. exit;
  3123. end;
  3124. '.' :
  3125. begin
  3126. readchar;
  3127. token:=_LECKKLAMMER;
  3128. goto exit_label;
  3129. end;
  3130. end;
  3131. token:=_LKLAMMER;
  3132. goto exit_label;
  3133. end;
  3134. ')' :
  3135. begin
  3136. readchar;
  3137. token:=_RKLAMMER;
  3138. goto exit_label;
  3139. end;
  3140. '+' :
  3141. begin
  3142. readchar;
  3143. if (c='=') and (cs_support_c_operators in current_settings.moduleswitches) then
  3144. begin
  3145. readchar;
  3146. token:=_PLUSASN;
  3147. goto exit_label;
  3148. end;
  3149. token:=_PLUS;
  3150. goto exit_label;
  3151. end;
  3152. '-' :
  3153. begin
  3154. readchar;
  3155. if (c='=') and (cs_support_c_operators in current_settings.moduleswitches) then
  3156. begin
  3157. readchar;
  3158. token:=_MINUSASN;
  3159. goto exit_label;
  3160. end;
  3161. token:=_MINUS;
  3162. goto exit_label;
  3163. end;
  3164. ':' :
  3165. begin
  3166. readchar;
  3167. if c='=' then
  3168. begin
  3169. readchar;
  3170. token:=_ASSIGNMENT;
  3171. goto exit_label;
  3172. end;
  3173. token:=_COLON;
  3174. goto exit_label;
  3175. end;
  3176. '*' :
  3177. begin
  3178. readchar;
  3179. if (c='=') and (cs_support_c_operators in current_settings.moduleswitches) then
  3180. begin
  3181. readchar;
  3182. token:=_STARASN;
  3183. end
  3184. else
  3185. if c='*' then
  3186. begin
  3187. readchar;
  3188. token:=_STARSTAR;
  3189. end
  3190. else
  3191. token:=_STAR;
  3192. goto exit_label;
  3193. end;
  3194. '/' :
  3195. begin
  3196. readchar;
  3197. case c of
  3198. '=' :
  3199. begin
  3200. if (cs_support_c_operators in current_settings.moduleswitches) then
  3201. begin
  3202. readchar;
  3203. token:=_SLASHASN;
  3204. goto exit_label;
  3205. end;
  3206. end;
  3207. '/' :
  3208. begin
  3209. skipdelphicomment;
  3210. readtoken(false);
  3211. exit;
  3212. end;
  3213. end;
  3214. token:=_SLASH;
  3215. goto exit_label;
  3216. end;
  3217. '|' :
  3218. if m_mac in current_settings.modeswitches then
  3219. begin
  3220. readchar;
  3221. token:=_PIPE;
  3222. goto exit_label;
  3223. end
  3224. else
  3225. Illegal_Char(c);
  3226. '=' :
  3227. begin
  3228. readchar;
  3229. token:=_EQUAL;
  3230. goto exit_label;
  3231. end;
  3232. '.' :
  3233. begin
  3234. readchar;
  3235. case c of
  3236. '.' :
  3237. begin
  3238. readchar;
  3239. case c of
  3240. '.' :
  3241. begin
  3242. readchar;
  3243. token:=_POINTPOINTPOINT;
  3244. goto exit_label;
  3245. end;
  3246. else
  3247. begin
  3248. token:=_POINTPOINT;
  3249. goto exit_label;
  3250. end;
  3251. end;
  3252. end;
  3253. ')' :
  3254. begin
  3255. readchar;
  3256. token:=_RECKKLAMMER;
  3257. goto exit_label;
  3258. end;
  3259. end;
  3260. token:=_POINT;
  3261. goto exit_label;
  3262. end;
  3263. '@' :
  3264. begin
  3265. readchar;
  3266. token:=_KLAMMERAFFE;
  3267. goto exit_label;
  3268. end;
  3269. ',' :
  3270. begin
  3271. readchar;
  3272. token:=_COMMA;
  3273. goto exit_label;
  3274. end;
  3275. '''','#','^' :
  3276. begin
  3277. len:=0;
  3278. msgwritten:=false;
  3279. pattern:='';
  3280. iswidestring:=false;
  3281. if c='^' then
  3282. begin
  3283. readchar;
  3284. c:=upcase(c);
  3285. if (block_type in [bt_type,bt_specialize]) or
  3286. (lasttoken=_ID) or (lasttoken=_NIL) or (lasttoken=_OPERATOR) or
  3287. (lasttoken=_RKLAMMER) or (lasttoken=_RECKKLAMMER) or (lasttoken=_CARET) then
  3288. begin
  3289. token:=_CARET;
  3290. goto exit_label;
  3291. end
  3292. else
  3293. begin
  3294. inc(len);
  3295. if c<#64 then
  3296. pattern[len]:=chr(ord(c)+64)
  3297. else
  3298. pattern[len]:=chr(ord(c)-64);
  3299. readchar;
  3300. end;
  3301. end;
  3302. repeat
  3303. case c of
  3304. '#' :
  3305. begin
  3306. readchar; { read # }
  3307. if c='$' then
  3308. begin
  3309. readchar; { read leading $ }
  3310. asciinr:='$';
  3311. while (upcase(c) in ['A'..'F','0'..'9']) and (length(asciinr)<6) do
  3312. begin
  3313. asciinr:=asciinr+c;
  3314. readchar;
  3315. end;
  3316. end
  3317. else
  3318. begin
  3319. asciinr:='';
  3320. while (c in ['0'..'9']) and (length(asciinr)<6) do
  3321. begin
  3322. asciinr:=asciinr+c;
  3323. readchar;
  3324. end;
  3325. end;
  3326. val(asciinr,m,code);
  3327. if (asciinr='') or (code<>0) then
  3328. Message(scan_e_illegal_char_const)
  3329. else if (m<0) or (m>255) or (length(asciinr)>3) then
  3330. begin
  3331. if (m>=0) and (m<=65535) then
  3332. begin
  3333. if not iswidestring then
  3334. begin
  3335. ascii2unicode(@pattern[1],len,patternw);
  3336. iswidestring:=true;
  3337. len:=0;
  3338. end;
  3339. concatwidestringchar(patternw,tcompilerwidechar(m));
  3340. end
  3341. else
  3342. Message(scan_e_illegal_char_const)
  3343. end
  3344. else if iswidestring then
  3345. concatwidestringchar(patternw,asciichar2unicode(char(m)))
  3346. else
  3347. begin
  3348. if len<255 then
  3349. begin
  3350. inc(len);
  3351. pattern[len]:=chr(m);
  3352. end
  3353. else
  3354. begin
  3355. if not msgwritten then
  3356. begin
  3357. Message(scan_e_string_exceeds_255_chars);
  3358. msgwritten:=true;
  3359. end;
  3360. end;
  3361. end;
  3362. end;
  3363. '''' :
  3364. begin
  3365. repeat
  3366. readchar;
  3367. case c of
  3368. #26 :
  3369. end_of_file;
  3370. #10,#13 :
  3371. Message(scan_f_string_exceeds_line);
  3372. '''' :
  3373. begin
  3374. readchar;
  3375. if c<>'''' then
  3376. break;
  3377. end;
  3378. end;
  3379. { interpret as utf-8 string? }
  3380. if (ord(c)>=$80) and (current_settings.sourcecodepage='utf8') then
  3381. begin
  3382. { convert existing string to an utf-8 string }
  3383. if not iswidestring then
  3384. begin
  3385. ascii2unicode(@pattern[1],len,patternw);
  3386. iswidestring:=true;
  3387. len:=0;
  3388. end;
  3389. { four or more chars aren't handled }
  3390. if (ord(c) and $f0)=$f0 then
  3391. message(scan_e_utf8_bigger_than_65535)
  3392. { three chars }
  3393. else if (ord(c) and $e0)=$e0 then
  3394. begin
  3395. w:=ord(c) and $f;
  3396. readchar;
  3397. if (ord(c) and $c0)<>$80 then
  3398. message(scan_e_utf8_malformed);
  3399. w:=(w shl 6) or (ord(c) and $3f);
  3400. readchar;
  3401. if (ord(c) and $c0)<>$80 then
  3402. message(scan_e_utf8_malformed);
  3403. w:=(w shl 6) or (ord(c) and $3f);
  3404. concatwidestringchar(patternw,w);
  3405. end
  3406. { two chars }
  3407. else if (ord(c) and $c0)<>0 then
  3408. begin
  3409. w:=ord(c) and $1f;
  3410. readchar;
  3411. if (ord(c) and $c0)<>$80 then
  3412. message(scan_e_utf8_malformed);
  3413. w:=(w shl 6) or (ord(c) and $3f);
  3414. concatwidestringchar(patternw,w);
  3415. end
  3416. { illegal }
  3417. else if (ord(c) and $80)<>0 then
  3418. message(scan_e_utf8_malformed)
  3419. else
  3420. concatwidestringchar(patternw,tcompilerwidechar(c))
  3421. end
  3422. else if iswidestring then
  3423. begin
  3424. if current_settings.sourcecodepage='utf8' then
  3425. concatwidestringchar(patternw,ord(c))
  3426. else
  3427. concatwidestringchar(patternw,asciichar2unicode(c))
  3428. end
  3429. else
  3430. begin
  3431. if len<255 then
  3432. begin
  3433. inc(len);
  3434. pattern[len]:=c;
  3435. end
  3436. else
  3437. begin
  3438. if not msgwritten then
  3439. begin
  3440. Message(scan_e_string_exceeds_255_chars);
  3441. msgwritten:=true;
  3442. end;
  3443. end;
  3444. end;
  3445. until false;
  3446. end;
  3447. '^' :
  3448. begin
  3449. readchar;
  3450. c:=upcase(c);
  3451. if c<#64 then
  3452. c:=chr(ord(c)+64)
  3453. else
  3454. c:=chr(ord(c)-64);
  3455. if iswidestring then
  3456. concatwidestringchar(patternw,asciichar2unicode(c))
  3457. else
  3458. begin
  3459. if len<255 then
  3460. begin
  3461. inc(len);
  3462. pattern[len]:=c;
  3463. end
  3464. else
  3465. begin
  3466. if not msgwritten then
  3467. begin
  3468. Message(scan_e_string_exceeds_255_chars);
  3469. msgwritten:=true;
  3470. end;
  3471. end;
  3472. end;
  3473. readchar;
  3474. end;
  3475. else
  3476. break;
  3477. end;
  3478. until false;
  3479. { strings with length 1 become const chars }
  3480. if iswidestring then
  3481. begin
  3482. if patternw^.len=1 then
  3483. token:=_CWCHAR
  3484. else
  3485. token:=_CWSTRING;
  3486. end
  3487. else
  3488. begin
  3489. pattern[0]:=chr(len);
  3490. if len=1 then
  3491. token:=_CCHAR
  3492. else
  3493. token:=_CSTRING;
  3494. end;
  3495. goto exit_label;
  3496. end;
  3497. '>' :
  3498. begin
  3499. readchar;
  3500. if (block_type in [bt_type,bt_specialize]) then
  3501. token:=_RSHARPBRACKET
  3502. else
  3503. begin
  3504. case c of
  3505. '=' :
  3506. begin
  3507. readchar;
  3508. token:=_GTE;
  3509. goto exit_label;
  3510. end;
  3511. '>' :
  3512. begin
  3513. readchar;
  3514. token:=_OP_SHR;
  3515. goto exit_label;
  3516. end;
  3517. '<' :
  3518. begin { >< is for a symetric diff for sets }
  3519. readchar;
  3520. token:=_SYMDIF;
  3521. goto exit_label;
  3522. end;
  3523. end;
  3524. token:=_GT;
  3525. end;
  3526. goto exit_label;
  3527. end;
  3528. '<' :
  3529. begin
  3530. readchar;
  3531. if (block_type in [bt_type,bt_specialize]) then
  3532. token:=_LSHARPBRACKET
  3533. else
  3534. begin
  3535. case c of
  3536. '>' :
  3537. begin
  3538. readchar;
  3539. token:=_UNEQUAL;
  3540. goto exit_label;
  3541. end;
  3542. '=' :
  3543. begin
  3544. readchar;
  3545. token:=_LTE;
  3546. goto exit_label;
  3547. end;
  3548. '<' :
  3549. begin
  3550. readchar;
  3551. token:=_OP_SHL;
  3552. goto exit_label;
  3553. end;
  3554. end;
  3555. token:=_LT;
  3556. end;
  3557. goto exit_label;
  3558. end;
  3559. #26 :
  3560. begin
  3561. token:=_EOF;
  3562. checkpreprocstack;
  3563. goto exit_label;
  3564. end;
  3565. else
  3566. Illegal_Char(c);
  3567. end;
  3568. end;
  3569. exit_label:
  3570. lasttoken:=token;
  3571. end;
  3572. function tscannerfile.readpreproc:ttoken;
  3573. begin
  3574. skipspace;
  3575. case c of
  3576. '_',
  3577. 'A'..'Z',
  3578. 'a'..'z' :
  3579. begin
  3580. current_scanner.preproc_pattern:=readid;
  3581. readpreproc:=_ID;
  3582. end;
  3583. '0'..'9' :
  3584. begin
  3585. current_scanner.preproc_pattern:=readval_asstring;
  3586. { realnumber? }
  3587. if c='.' then
  3588. begin
  3589. readchar;
  3590. while c in ['0'..'9'] do
  3591. begin
  3592. current_scanner.preproc_pattern:=current_scanner.preproc_pattern+c;
  3593. readchar;
  3594. end;
  3595. end;
  3596. readpreproc:=_ID;
  3597. end;
  3598. '$','%','&' :
  3599. begin
  3600. current_scanner.preproc_pattern:=readval_asstring;
  3601. readpreproc:=_ID;
  3602. end;
  3603. ',' :
  3604. begin
  3605. readchar;
  3606. readpreproc:=_COMMA;
  3607. end;
  3608. '}' :
  3609. begin
  3610. readpreproc:=_END;
  3611. end;
  3612. '(' :
  3613. begin
  3614. readchar;
  3615. readpreproc:=_LKLAMMER;
  3616. end;
  3617. ')' :
  3618. begin
  3619. readchar;
  3620. readpreproc:=_RKLAMMER;
  3621. end;
  3622. '[' :
  3623. begin
  3624. readchar;
  3625. readpreproc:=_LECKKLAMMER;
  3626. end;
  3627. ']' :
  3628. begin
  3629. readchar;
  3630. readpreproc:=_RECKKLAMMER;
  3631. end;
  3632. '+' :
  3633. begin
  3634. readchar;
  3635. readpreproc:=_PLUS;
  3636. end;
  3637. '-' :
  3638. begin
  3639. readchar;
  3640. readpreproc:=_MINUS;
  3641. end;
  3642. '*' :
  3643. begin
  3644. readchar;
  3645. readpreproc:=_STAR;
  3646. end;
  3647. '/' :
  3648. begin
  3649. readchar;
  3650. readpreproc:=_SLASH;
  3651. end;
  3652. '=' :
  3653. begin
  3654. readchar;
  3655. readpreproc:=_EQUAL;
  3656. end;
  3657. '>' :
  3658. begin
  3659. readchar;
  3660. if c='=' then
  3661. begin
  3662. readchar;
  3663. readpreproc:=_GTE;
  3664. end
  3665. else
  3666. readpreproc:=_GT;
  3667. end;
  3668. '<' :
  3669. begin
  3670. readchar;
  3671. case c of
  3672. '>' :
  3673. begin
  3674. readchar;
  3675. readpreproc:=_UNEQUAL;
  3676. end;
  3677. '=' :
  3678. begin
  3679. readchar;
  3680. readpreproc:=_LTE;
  3681. end;
  3682. else
  3683. readpreproc:=_LT;
  3684. end;
  3685. end;
  3686. #26 :
  3687. begin
  3688. readpreproc:=_EOF;
  3689. checkpreprocstack;
  3690. end;
  3691. else
  3692. Illegal_Char(c);
  3693. end;
  3694. end;
  3695. function tscannerfile.asmgetcharstart : char;
  3696. begin
  3697. { return first the character already
  3698. available in c }
  3699. lastasmgetchar:=c;
  3700. result:=asmgetchar;
  3701. end;
  3702. function tscannerfile.asmgetchar : char;
  3703. begin
  3704. if lastasmgetchar<>#0 then
  3705. begin
  3706. c:=lastasmgetchar;
  3707. lastasmgetchar:=#0;
  3708. end
  3709. else
  3710. readchar;
  3711. if in_asm_string then
  3712. begin
  3713. asmgetchar:=c;
  3714. exit;
  3715. end;
  3716. repeat
  3717. case c of
  3718. // the { ... } is used in ARM assembler to define register sets, so we can't used
  3719. // it as comment, either (* ... *), /* ... */ or // ... should be used instead.
  3720. // But compiler directives {$...} are allowed in ARM assembler.
  3721. '{' :
  3722. begin
  3723. {$ifdef arm}
  3724. readchar;
  3725. dec(inputpointer);
  3726. if c<>'$' then
  3727. begin
  3728. asmgetchar:='{';
  3729. exit;
  3730. end
  3731. else
  3732. {$endif arm}
  3733. skipcomment;
  3734. end;
  3735. #10,#13 :
  3736. begin
  3737. linebreak;
  3738. asmgetchar:=c;
  3739. exit;
  3740. end;
  3741. #26 :
  3742. begin
  3743. reload;
  3744. if (c=#26) and not assigned(inputfile.next) then
  3745. end_of_file;
  3746. continue;
  3747. end;
  3748. '/' :
  3749. begin
  3750. readchar;
  3751. if c='/' then
  3752. skipdelphicomment
  3753. else
  3754. begin
  3755. asmgetchar:='/';
  3756. lastasmgetchar:=c;
  3757. exit;
  3758. end;
  3759. end;
  3760. '(' :
  3761. begin
  3762. readchar;
  3763. if c='*' then
  3764. begin
  3765. c:=#0;{Signal skipoldtpcomment to reload a char }
  3766. skipoldtpcomment;
  3767. end
  3768. else
  3769. begin
  3770. asmgetchar:='(';
  3771. lastasmgetchar:=c;
  3772. exit;
  3773. end;
  3774. end;
  3775. else
  3776. begin
  3777. asmgetchar:=c;
  3778. exit;
  3779. end;
  3780. end;
  3781. until false;
  3782. end;
  3783. {*****************************************************************************
  3784. Helpers
  3785. *****************************************************************************}
  3786. procedure AddDirective(const s:string; dm: tdirectivemode; p:tdirectiveproc);
  3787. begin
  3788. if dm in [directive_all, directive_turbo] then
  3789. tdirectiveitem.create(turbo_scannerdirectives,s,p);
  3790. if dm in [directive_all, directive_mac] then
  3791. tdirectiveitem.create(mac_scannerdirectives,s,p);
  3792. end;
  3793. procedure AddConditional(const s:string; dm: tdirectivemode; p:tdirectiveproc);
  3794. begin
  3795. if dm in [directive_all, directive_turbo] then
  3796. tdirectiveitem.createcond(turbo_scannerdirectives,s,p);
  3797. if dm in [directive_all, directive_mac] then
  3798. tdirectiveitem.createcond(mac_scannerdirectives,s,p);
  3799. end;
  3800. {*****************************************************************************
  3801. Initialization
  3802. *****************************************************************************}
  3803. procedure InitScanner;
  3804. begin
  3805. InitWideString(patternw);
  3806. turbo_scannerdirectives:=TFPHashObjectList.Create;
  3807. mac_scannerdirectives:=TFPHashObjectList.Create;
  3808. { Common directives and conditionals }
  3809. AddDirective('I',directive_all, @dir_include);
  3810. AddDirective('DEFINE',directive_all, @dir_define);
  3811. AddDirective('UNDEF',directive_all, @dir_undef);
  3812. AddConditional('IF',directive_all, @dir_if);
  3813. AddConditional('IFDEF',directive_all, @dir_ifdef);
  3814. AddConditional('IFNDEF',directive_all, @dir_ifndef);
  3815. AddConditional('ELSE',directive_all, @dir_else);
  3816. AddConditional('ELSEIF',directive_all, @dir_elseif);
  3817. AddConditional('ENDIF',directive_all, @dir_endif);
  3818. { Directives and conditionals for all modes except mode macpas}
  3819. AddDirective('INCLUDE',directive_turbo, @dir_include);
  3820. AddDirective('LIBPREFIX',directive_turbo, @dir_libprefix);
  3821. AddDirective('LIBSUFFIX',directive_turbo, @dir_libsuffix);
  3822. AddDirective('EXTENSION',directive_turbo, @dir_extension);
  3823. AddConditional('IFEND',directive_turbo, @dir_endif);
  3824. AddConditional('IFOPT',directive_turbo, @dir_ifopt);
  3825. { Directives and conditionals for mode macpas: }
  3826. AddDirective('SETC',directive_mac, @dir_setc);
  3827. AddDirective('DEFINEC',directive_mac, @dir_definec);
  3828. AddDirective('UNDEFC',directive_mac, @dir_undef);
  3829. AddConditional('IFC',directive_mac, @dir_if);
  3830. AddConditional('ELSEC',directive_mac, @dir_else);
  3831. AddConditional('ELIFC',directive_mac, @dir_elseif);
  3832. AddConditional('ENDC',directive_mac, @dir_endif);
  3833. end;
  3834. procedure DoneScanner;
  3835. begin
  3836. turbo_scannerdirectives.Free;
  3837. mac_scannerdirectives.Free;
  3838. DoneWideString(patternw);
  3839. end;
  3840. end.