scanner.pas 197 KB

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