1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096 |
- {
- Copyright (c) 2000-2002 by Florian Klaempfl
- Type checking and register allocation for type converting nodes
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- ****************************************************************************
- }
- unit ncnv;
- {$i fpcdefs.inc}
- interface
- uses
- node,
- symtype,
- defutil,defcmp,
- nld
- ;
- type
- ttypeconvnode = class(tunarynode)
- totypedef : tdef;
- totypedefderef : tderef;
- convtype : tconverttype;
- warn_pointer_to_signed,
- assignment_side: boolean;
- constructor create(node : tnode;def:tdef);virtual;
- constructor create_explicit(node : tnode;def:tdef);
- constructor create_internal(node : tnode;def:tdef);
- constructor create_proc_to_procvar(node : tnode);
- constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
- procedure ppuwrite(ppufile:tcompilerppufile);override;
- procedure buildderefimpl;override;
- procedure derefimpl;override;
- function dogetcopy : tnode;override;
- procedure printnodeinfo(var t : text);override;
- function pass_1 : tnode;override;
- function pass_typecheck:tnode;override;
- function simplify(forinline : boolean):tnode; override;
- procedure mark_write;override;
- function docompare(p: tnode) : boolean; override;
- function retains_value_location:boolean;
- function assign_allowed:boolean;
- procedure second_call_helper(c : tconverttype);
- { always called before any other type conversion checks. If it
- returns true, the type conversion is ok and no further checks/
- handling are required. }
- function target_specific_general_typeconv: boolean;virtual;
- { called in case of a valid explicit type conversion. Can be used to
- replace this explicit type conversion with a different node, or to
- reject it after all }
- function target_specific_explicit_typeconv: boolean;virtual;
- { called when inserttypeconv is used to convert to a def that is equal
- according to compare_defs() }
- class function target_specific_need_equal_typeconv(fromdef, todef: tdef): boolean; virtual;
- protected
- function typecheck_int_to_int : tnode; virtual;
- function typecheck_cord_to_pointer : tnode; virtual;
- function typecheck_chararray_to_string : tnode; virtual;
- function typecheck_string_to_chararray : tnode; virtual;
- function typecheck_string_to_string : tnode; virtual;
- function typecheck_char_to_string : tnode; virtual;
- function typecheck_char_to_chararray : tnode; virtual;
- function typecheck_int_to_real : tnode; virtual;
- function typecheck_real_to_real : tnode; virtual;
- function typecheck_real_to_currency : tnode; virtual;
- function typecheck_cchar_to_pchar : tnode; virtual;
- function typecheck_cstring_to_pchar : tnode; virtual;
- function typecheck_cstring_to_int : tnode; virtual;
- function typecheck_char_to_char : tnode; virtual;
- function typecheck_arrayconstructor_to_set : tnode; virtual;
- function typecheck_set_to_set : tnode; virtual;
- function typecheck_pchar_to_string : tnode; virtual;
- function typecheck_interface_to_string : tnode; virtual;
- function typecheck_interface_to_guid : tnode; virtual;
- function typecheck_dynarray_to_openarray : tnode; virtual;
- function typecheck_pwchar_to_string : tnode; virtual;
- function typecheck_variant_to_dynarray : tnode; virtual;
- function typecheck_dynarray_to_variant : tnode; virtual;
- function typecheck_variant_to_enum : tnode; virtual;
- function typecheck_enum_to_variant : tnode; virtual;
- function typecheck_proc_to_procvar : tnode; virtual;
- function typecheck_variant_to_interface : tnode; virtual;
- function typecheck_interface_to_variant : tnode; virtual;
- function typecheck_array_2_dynarray : tnode; virtual;
- function typecheck_elem_2_openarray : tnode; virtual;
- private
- function _typecheck_int_to_int : tnode;
- function _typecheck_cord_to_pointer : tnode;
- function _typecheck_chararray_to_string : tnode;
- function _typecheck_string_to_chararray : tnode;
- function _typecheck_string_to_string : tnode;
- function _typecheck_char_to_string : tnode;
- function _typecheck_char_to_chararray : tnode;
- function _typecheck_int_to_real : tnode;
- function _typecheck_real_to_real : tnode;
- function _typecheck_real_to_currency : tnode;
- function _typecheck_cchar_to_pchar : tnode;
- function _typecheck_cstring_to_pchar : tnode;
- function _typecheck_cstring_to_int : tnode;
- function _typecheck_char_to_char : tnode;
- function _typecheck_arrayconstructor_to_set : tnode;
- function _typecheck_set_to_set : tnode;
- function _typecheck_pchar_to_string : tnode;
- function _typecheck_interface_to_string : tnode;
- function _typecheck_interface_to_guid : tnode;
- function _typecheck_dynarray_to_openarray : tnode;
- function _typecheck_pwchar_to_string : tnode;
- function _typecheck_variant_to_dynarray : tnode;
- function _typecheck_dynarray_to_variant : tnode;
- function _typecheck_variant_to_enum : tnode;
- function _typecheck_enum_to_variant : tnode;
- function _typecheck_proc_to_procvar : tnode;
- function _typecheck_variant_to_interface : tnode;
- function _typecheck_interface_to_variant : tnode;
- function _typecheck_array_2_dynarray : tnode;
- function _typecheck_elem_2_openarray : tnode;
- protected
- function first_int_to_int : tnode;virtual;
- function first_cstring_to_pchar : tnode;virtual;
- function first_cstring_to_int : tnode;virtual;
- function first_string_to_chararray : tnode;virtual;
- function first_char_to_string : tnode;virtual;
- function first_char_to_chararray : tnode; virtual;
- function first_nothing : tnode;virtual;
- function first_array_to_pointer : tnode;virtual;
- function first_int_to_real : tnode;virtual;
- function first_real_to_real : tnode;virtual;
- function first_pointer_to_array : tnode;virtual;
- function first_cchar_to_pchar : tnode;virtual;
- function first_bool_to_int : tnode;virtual;
- function first_int_to_bool : tnode;virtual;
- function first_bool_to_bool : tnode;virtual;
- function first_proc_to_procvar : tnode;virtual;
- function first_nil_to_methodprocvar : tnode;virtual;
- function first_set_to_set : tnode;virtual;
- function first_cord_to_pointer : tnode;virtual;
- function first_ansistring_to_pchar : tnode;virtual;
- function first_arrayconstructor_to_set : tnode;virtual;
- function first_class_to_intf : tnode;virtual;
- function first_char_to_char : tnode;virtual;
- function first_string_to_string : tnode;virtual;
- function first_call_helper(c : tconverttype) : tnode;
- function typecheck_call_helper(c : tconverttype) : tnode;
- private
- { these wrapper are necessary, because the first_* stuff is called }
- { through a table. Without the wrappers override wouldn't have }
- { any effect }
- function _first_int_to_int : tnode;
- function _first_cstring_to_pchar : tnode;
- function _first_cstring_to_int : tnode;
- function _first_string_to_chararray : tnode;
- function _first_char_to_string : tnode;
- function _first_char_to_chararray : tnode;
- function _first_nothing : tnode;
- function _first_array_to_pointer : tnode;
- function _first_int_to_real : tnode;
- function _first_real_to_real: tnode;
- function _first_pointer_to_array : tnode;
- function _first_cchar_to_pchar : tnode;
- function _first_bool_to_int : tnode;
- function _first_int_to_bool : tnode;
- function _first_bool_to_bool : tnode;
- function _first_proc_to_procvar : tnode;
- function _first_nil_to_methodprocvar : tnode;
- function _first_cord_to_pointer : tnode;
- function _first_ansistring_to_pchar : tnode;
- function _first_arrayconstructor_to_set : tnode;
- function _first_class_to_intf : tnode;
- function _first_char_to_char : tnode;
- function _first_set_to_set : tnode;
- function _first_string_to_string : tnode;
- procedure _second_int_to_int;virtual;
- procedure _second_string_to_string;virtual;
- procedure _second_cstring_to_pchar;virtual;
- procedure _second_cstring_to_int;virtual;
- procedure _second_string_to_chararray;virtual;
- procedure _second_array_to_pointer;virtual;
- procedure _second_pointer_to_array;virtual;
- procedure _second_chararray_to_string;virtual;
- procedure _second_char_to_string;virtual;
- procedure _second_int_to_real;virtual;
- procedure _second_real_to_real;virtual;
- procedure _second_cord_to_pointer;virtual;
- procedure _second_proc_to_procvar;virtual;
- procedure _second_nil_to_methodprocvar;virtual;
- procedure _second_bool_to_int;virtual;
- procedure _second_int_to_bool;virtual;
- procedure _second_bool_to_bool;virtual;
- procedure _second_set_to_set;virtual;
- procedure _second_ansistring_to_pchar;virtual;
- procedure _second_class_to_intf;virtual;
- procedure _second_char_to_char;virtual;
- procedure _second_elem_to_openarray;virtual;
- procedure _second_nothing; virtual;
- protected
- procedure second_int_to_int;virtual;abstract;
- procedure second_string_to_string;virtual;abstract;
- procedure second_cstring_to_pchar;virtual;abstract;
- procedure second_cstring_to_int;virtual;abstract;
- procedure second_string_to_chararray;virtual;abstract;
- procedure second_array_to_pointer;virtual;abstract;
- procedure second_pointer_to_array;virtual;abstract;
- procedure second_chararray_to_string;virtual;abstract;
- procedure second_char_to_string;virtual;abstract;
- procedure second_int_to_real;virtual;abstract;
- procedure second_real_to_real;virtual;abstract;
- procedure second_cord_to_pointer;virtual;abstract;
- procedure second_proc_to_procvar;virtual;abstract;
- procedure second_nil_to_methodprocvar;virtual;abstract;
- procedure second_bool_to_int;virtual;abstract;
- procedure second_int_to_bool;virtual;abstract;
- procedure second_bool_to_bool;virtual;abstract;
- procedure second_set_to_set;virtual;abstract;
- procedure second_ansistring_to_pchar;virtual;abstract;
- procedure second_class_to_intf;virtual;abstract;
- procedure second_char_to_char;virtual;abstract;
- procedure second_elem_to_openarray;virtual;abstract;
- procedure second_nothing; virtual;abstract;
- end;
- ttypeconvnodeclass = class of ttypeconvnode;
- { common functionality of as-nodes and is-nodes }
- tasisnode = class(tbinarynode)
- protected
- { if non-standard usage of as-nodes is possible, targets can override
- this method and return true in case the conditions are fulfilled }
- function target_specific_typecheck: boolean;virtual;
- public
- function pass_typecheck:tnode;override;
- end;
- tasnode = class(tasisnode)
- { as nodes cannot be translated directly into call nodes bcause:
- When using -CR, explicit class typecasts are replaced with as-nodes to perform
- class type checking. The problem is that if a typecasted class instance is
- passed as a var-parameter, then you cannot replace it with a function call. So the as-node
- a) call the as helper to perform the type checking
- b) still pass the original instance as parameter to var-parameters
- (and in general: to return it as the result of the as-node)
- so the call field is required
- }
- call: tnode;
- constructor create(l,r : tnode);virtual;
- constructor create_internal(l,r : tnode);virtual;
- function pass_1 : tnode;override;
- function dogetcopy: tnode;override;
- function docompare(p: tnode): boolean; override;
- destructor destroy; override;
- end;
- tasnodeclass = class of tasnode;
- tisnode = class(tasisnode)
- constructor create(l,r : tnode);virtual;
- constructor create_internal(l,r : tnode);virtual;
- function pass_1 : tnode;override;
- procedure pass_generate_code;override;
- end;
- tisnodeclass = class of tisnode;
- var
- ctypeconvnode : ttypeconvnodeclass = ttypeconvnode;
- casnode : tasnodeclass = tasnode;
- cisnode : tisnodeclass=tisnode;
- procedure inserttypeconv(var p:tnode;def:tdef);
- procedure inserttypeconv_explicit(var p:tnode;def:tdef);
- procedure inserttypeconv_internal(var p:tnode;def:tdef);
- procedure arrayconstructor_to_set(var p : tnode);
- procedure insert_varargstypeconv(var p : tnode; iscvarargs: boolean);
- function maybe_global_proc_to_nested(var fromnode: tnode; todef: tdef): boolean;
- implementation
- uses
- globtype,systems,constexp,
- cutils,verbose,globals,widestr,
- symconst,symdef,symsym,symcpu,symtable,
- ncon,ncal,nset,nadd,nmem,nmat,nbas,nutils,ninl,
- cgbase,procinfo,
- htypechk,pass_1,cpuinfo;
- {*****************************************************************************
- Helpers
- *****************************************************************************}
- type
- ttypeconvnodetype = (tct_implicit,tct_explicit,tct_internal);
- procedure do_inserttypeconv(var p: tnode;def: tdef; convtype: ttypeconvnodetype);
- begin
- if not assigned(p.resultdef) then
- begin
- typecheckpass(p);
- if codegenerror then
- exit;
- end;
- { don't insert superfluous type conversions, but
- in case of bitpacked accesses, the original type must
- remain too so that not too many/few bits are laoded.
- Also, in case the deftyp changes, don't ignore because lots of code
- expects that if the resultdef is set to e.g. stringdef, it remains
- that way (e.g., in case of Java where java_jlstring equals
- unicodestring according to equal_defs, but an add node for strings
- still expects the resultdef of the node to be a stringdef) }
- if equal_defs(p.resultdef,def) and
- (p.resultdef.typ=def.typ) and
- not is_bitpacked_access(p) and
- not ctypeconvnode.target_specific_need_equal_typeconv(p.resultdef,def) then
- begin
- { don't replace encoded string constants to rawbytestring encoding.
- preserve the codepage }
- if not (is_rawbytestring(def) and (p.nodetype=stringconstn)) then
- p.resultdef:=def
- end
- else
- begin
- case convtype of
- tct_implicit:
- p:=ctypeconvnode.create(p,def);
- tct_explicit:
- p:=ctypeconvnode.create_explicit(p,def);
- tct_internal:
- p:=ctypeconvnode.create_internal(p,def);
- end;
- p.fileinfo:=ttypeconvnode(p).left.fileinfo;
- typecheckpass(p);
- end;
- end;
- procedure inserttypeconv(var p:tnode;def:tdef);
- begin
- do_inserttypeconv(p,def,tct_implicit);
- end;
- procedure inserttypeconv_explicit(var p: tnode; def: tdef);
- begin
- do_inserttypeconv(p,def,tct_explicit);
- end;
- procedure inserttypeconv_internal(var p:tnode;def:tdef);
- begin
- do_inserttypeconv(p,def,tct_internal);
- end;
- {*****************************************************************************
- Array constructor to Set Conversion
- *****************************************************************************}
- procedure arrayconstructor_to_set(var p : tnode);
- var
- constp : tsetconstnode;
- buildp,
- p2,p3,p4 : tnode;
- hdef : tdef;
- constset : Pconstset;
- constsetlo,
- constsethi : TConstExprInt;
- procedure update_constsethi(def:tdef; maybetruncenumrange: boolean);
- begin
- if (def.typ=orddef) and
- ((torddef(def).high>=constsethi) or
- (torddef(def).low <=constsetlo)) then
- begin
- if torddef(def).ordtype=uwidechar then
- begin
- constsethi:=255;
- constsetlo:=0;
- if hdef=nil then
- hdef:=def;
- end
- else
- begin
- if (torddef(def).high>=constsethi) then
- constsethi:=torddef(def).high;
- if (torddef(def).low<=constsetlo) then
- constsetlo:=torddef(def).low;
- if hdef=nil then
- begin
- if (constsethi>255) or
- (torddef(def).low<0) then
- hdef:=u8inttype
- else
- hdef:=def;
- end;
- if constsethi>255 then
- constsethi:=255;
- if constsetlo<0 then
- constsetlo:=0;
- end;
- end
- else if (def.typ=enumdef) and
- ((tenumdef(def).max>=constsethi) or
- (tenumdef(def).min<=constsetlo)) then
- begin
- if hdef=nil then
- hdef:=def;
- if (tenumdef(def).max>=constsethi) then
- constsethi:=tenumdef(def).max;
- if (tenumdef(def).min<=constsetlo) then
- constsetlo:=tenumdef(def).min;
- { for constant set elements, delphi allows the usage of elements of enumerations which
- have value>255 if there is no element with a value > 255 used }
- if (maybetruncenumrange) then
- begin
- if constsethi>255 then
- constsethi:=255;
- if constsetlo<0 then
- constsetlo:=0;
- end;
- end;
- end;
- procedure do_set(pos : longint);
- begin
- if (pos and not $ff)<>0 then
- Message(parser_e_illegal_set_expr);
- if pos>constsethi then
- constsethi:=pos;
- if pos<constsetlo then
- constsetlo:=pos;
- if pos in constset^ then
- Message(parser_e_illegal_set_expr);
- include(constset^,pos);
- end;
- var
- l : Longint;
- lr,hr : TConstExprInt;
- hp : tarrayconstructornode;
- oldfilepos: tfileposinfo;
- begin
- if p.nodetype<>arrayconstructorn then
- internalerror(200205105);
- new(constset);
- constset^:=[];
- hdef:=nil;
- { make sure to set constsetlo correctly for empty sets }
- if assigned(tarrayconstructornode(p).left) then
- constsetlo:=high(aint)
- else
- constsetlo:=0;
- constsethi:=0;
- constp:=csetconstnode.create(nil,hdef);
- constp.value_set:=constset;
- buildp:=constp;
- hp:=tarrayconstructornode(p);
- if assigned(hp.left) then
- begin
- while assigned(hp) do
- begin
- p4:=nil; { will contain the tree to create the set }
- {split a range into p2 and p3 }
- if hp.left.nodetype=arrayconstructorrangen then
- begin
- p2:=tarrayconstructorrangenode(hp.left).left;
- p3:=tarrayconstructorrangenode(hp.left).right;
- tarrayconstructorrangenode(hp.left).left:=nil;
- tarrayconstructorrangenode(hp.left).right:=nil;
- end
- else
- begin
- p2:=hp.left;
- hp.left:=nil;
- p3:=nil;
- end;
- typecheckpass(p2);
- set_varstate(p2,vs_read,[vsf_must_be_valid]);
- if assigned(p3) then
- begin
- typecheckpass(p3);
- set_varstate(p3,vs_read,[vsf_must_be_valid]);
- end;
- if codegenerror then
- break;
- oldfilepos:=current_filepos;
- current_filepos:=p2.fileinfo;
- case p2.resultdef.typ of
- enumdef,
- orddef:
- begin
- { widechars are not yet supported }
- if is_widechar(p2.resultdef) then
- begin
- inserttypeconv(p2,cansichartype);
- if (p2.nodetype<>ordconstn) then
- incompatibletypes(cwidechartype,cansichartype);
- end;
- getrange(p2.resultdef,lr,hr);
- if assigned(p3) then
- begin
- if is_widechar(p3.resultdef) then
- begin
- inserttypeconv(p3,cansichartype);
- if (p3.nodetype<>ordconstn) then
- begin
- current_filepos:=p3.fileinfo;
- incompatibletypes(cwidechartype,cansichartype);
- end;
- end;
- { this isn't good, you'll get problems with
- type t010 = 0..10;
- ts = set of t010;
- var s : ts;b : t010
- begin s:=[1,2,b]; end.
- if is_integer(p3^.resultdef) then
- begin
- inserttypeconv(p3,u8bitdef);
- end;
- }
- if assigned(hdef) and not(equal_defs(hdef,p3.resultdef)) then
- begin
- CGMessagePos(p3.fileinfo,type_e_typeconflict_in_set);
- end
- else
- begin
- if (p2.nodetype=ordconstn) and (p3.nodetype=ordconstn) then
- begin
- if not(is_integer(p3.resultdef)) then
- hdef:=p3.resultdef
- else
- begin
- inserttypeconv(p3,u8inttype);
- inserttypeconv(p2,u8inttype);
- end;
- for l:=tordconstnode(p2).value.svalue to tordconstnode(p3).value.svalue do
- do_set(l);
- p2.free;
- p3.free;
- end
- else
- begin
- update_constsethi(p2.resultdef,false);
- inserttypeconv(p2,hdef);
- update_constsethi(p3.resultdef,false);
- inserttypeconv(p3,hdef);
- if assigned(hdef) then
- inserttypeconv(p3,hdef)
- else
- inserttypeconv(p3,u8inttype);
- p4:=csetelementnode.create(p2,p3);
- end;
- end;
- end
- else
- begin
- { Single value }
- if p2.nodetype=ordconstn then
- begin
- if not(is_integer(p2.resultdef)) then
- update_constsethi(p2.resultdef,true);
- if assigned(hdef) then
- inserttypeconv(p2,hdef)
- else
- inserttypeconv(p2,u8inttype);
- do_set(tordconstnode(p2).value.svalue);
- p2.free;
- end
- else
- begin
- update_constsethi(p2.resultdef,false);
- if assigned(hdef) then
- inserttypeconv(p2,hdef)
- else
- inserttypeconv(p2,u8inttype);
- p4:=csetelementnode.create(p2,nil);
- end;
- end;
- end;
- stringdef :
- begin
- if (p2.nodetype<>stringconstn) then
- Message(parser_e_illegal_expression)
- { if we've already set elements which are constants }
- { throw an error }
- else if ((hdef=nil) and assigned(buildp)) or
- not(is_char(hdef)) then
- CGMessage(type_e_typeconflict_in_set)
- else
- for l:=1 to length(pshortstring(tstringconstnode(p2).value_str)^) do
- do_set(ord(pshortstring(tstringconstnode(p2).value_str)^[l]));
- if hdef=nil then
- hdef:=cansichartype;
- p2.free;
- end;
- else
- CGMessage(type_e_ordinal_expr_expected);
- end;
- { insert the set creation tree }
- if assigned(p4) then
- buildp:=caddnode.create(addn,buildp,p4);
- { load next and dispose current node }
- p2:=hp;
- hp:=tarrayconstructornode(tarrayconstructornode(p2).right);
- tarrayconstructornode(p2).right:=nil;
- p2.free;
- current_filepos:=oldfilepos;
- end;
- if (hdef=nil) then
- hdef:=u8inttype;
- end
- else
- begin
- { empty set [], only remove node }
- p.free;
- end;
- { set the initial set type }
- constp.resultdef:=csetdef.create(hdef,constsetlo.svalue,constsethi.svalue);
- { determine the resultdef for the tree }
- typecheckpass(buildp);
- { set the new tree }
- p:=buildp;
- end;
- procedure insert_varargstypeconv(var p : tnode; iscvarargs: boolean);
- begin
- { procvars without arguments in variant arrays are always called by
- Delphi }
- if not(iscvarargs) then
- maybe_call_procvar(p,true);
- if not(iscvarargs) and
- (p.nodetype=stringconstn) and
- { don't cast to AnsiString if already casted to Wide/UnicodeString, issue #18266 }
- (tstringconstnode(p).cst_type in [cst_conststring,cst_shortstring,cst_longstring]) then
- p:=ctypeconvnode.create_internal(p,getansistringdef)
- else
- case p.resultdef.typ of
- enumdef :
- p:=ctypeconvnode.create_internal(p,s32inttype);
- arraydef :
- begin
- if is_chararray(p.resultdef) then
- p:=ctypeconvnode.create_internal(p,charpointertype)
- else
- if is_widechararray(p.resultdef) then
- p:=ctypeconvnode.create_internal(p,widecharpointertype)
- else
- CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resultdef.typename);
- end;
- orddef :
- begin
- if is_integer(p.resultdef) and
- not(is_64bitint(p.resultdef)) then
- if not(m_delphi in current_settings.modeswitches) then
- p:=ctypeconvnode.create(p,s32inttype)
- else
- { delphi doesn't generate a range error when passing a
- cardinal >= $80000000, but since these are seen as
- longint on the callee side, this causes data loss;
- as a result, we require an explicit longint()
- typecast in FPC mode on the caller side if range
- checking should be disabled, but not in Delphi mode }
- p:=ctypeconvnode.create_internal(p,s32inttype)
- else if is_void(p.resultdef) then
- CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resultdef.typename)
- else if iscvarargs and is_currency(p.resultdef)
- and (current_settings.fputype<>fpu_none) then
- p:=ctypeconvnode.create(p,s64floattype);
- end;
- floatdef :
- if not(iscvarargs) then
- begin
- if not(is_currency(p.resultdef)) then
- p:=ctypeconvnode.create(p,pbestrealtype^);
- end
- else
- begin
- if is_constrealnode(p) and
- not(nf_explicit in p.flags) then
- MessagePos(p.fileinfo,type_w_double_c_varargs);
- if (tfloatdef(p.resultdef).floattype in [s32real,s64currency]) or
- (is_constrealnode(p) and
- not(nf_explicit in p.flags)) then
- p:=ctypeconvnode.create(p,s64floattype);
- end;
- procvardef :
- p:=ctypeconvnode.create(p,voidpointertype);
- stringdef:
- if iscvarargs then
- p:=ctypeconvnode.create(p,charpointertype);
- variantdef:
- if iscvarargs then
- CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resultdef.typename);
- { maybe warn in case it's not using "packrecords c"? }
- recorddef:
- if not iscvarargs then
- CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resultdef.typename);
- pointerdef:
- ;
- classrefdef:
- if iscvarargs then
- p:=ctypeconvnode.create(p,voidpointertype);
- objectdef :
- if (iscvarargs and
- not is_objc_class_or_protocol(p.resultdef)) or
- is_object(p.resultdef) then
- CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resultdef.typename);
- else
- CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resultdef.typename);
- end;
- typecheckpass(p);
- end;
- { in FPC mode, @procname immediately has to be evaluated as a
- procvar. If procname is global, then this will be a global
- procvar. Since converting global procvars to local procvars is
- not allowed (see point d in defcmp.proc_to_procvar_equal()),
- this results in errors when passing global procedures to local
- procvar parameters or assigning them to nested procvars. The
- solution is to remove the (wrong) conversion to a global procvar,
- and instead insert a conversion to the local procvar type. }
- function maybe_global_proc_to_nested(var fromnode: tnode; todef: tdef): boolean;
- var
- hp: tnode;
- begin
- result:=false;
- if (m_nested_procvars in current_settings.modeswitches) and
- not(m_tp_procvar in current_settings.modeswitches) and
- (todef.typ=procvardef) and
- is_nested_pd(tprocvardef(todef)) and
- (fromnode.nodetype=typeconvn) and
- (ttypeconvnode(fromnode).convtype=tc_proc_2_procvar) and
- not is_nested_pd(tprocvardef(fromnode.resultdef)) and
- (proc_to_procvar_equal(tprocdef(ttypeconvnode(fromnode).left.resultdef),tprocvardef(todef),false)>=te_convert_l1) then
- begin
- hp:=fromnode;
- fromnode:=ctypeconvnode.create_proc_to_procvar(ttypeconvnode(fromnode).left);
- ttypeconvnode(fromnode).totypedef:=todef;
- typecheckpass(fromnode);
- ttypeconvnode(hp).left:=nil;
- hp.free;
- result:=true;
- end;
- end;
- {*****************************************************************************
- TTYPECONVNODE
- *****************************************************************************}
- constructor ttypeconvnode.create(node : tnode;def:tdef);
- begin
- inherited create(typeconvn,node);
- convtype:=tc_none;
- totypedef:=def;
- if def=nil then
- internalerror(200103281);
- fileinfo:=node.fileinfo;
- {An attempt to convert the result of a floating point division
- (with the / operator) to an integer type will fail. Give a hint
- to use the div operator.}
- if (node.nodetype=slashn) and (def.typ=orddef) then
- cgmessage(type_h_use_div_for_int);
- {In expressions like int64:=longint+longint, an integer overflow could be avoided
- by simply converting the operands to int64 first. Give a hint to do this.}
- if (node.nodetype in [addn,subn,muln]) and
- (def.typ=orddef) and (node.resultdef<>nil) and (node.resultdef.typ=orddef) and
- ((Torddef(node.resultdef).low>=Torddef(def).low) and (Torddef(node.resultdef).high<=Torddef(def).high)) and
- ((Torddef(node.resultdef).low>Torddef(def).low) or (Torddef(node.resultdef).high<Torddef(def).high)) then
- case node.nodetype of
- addn:
- cgmessage1(type_h_convert_add_operands_to_prevent_overflow,def.typename);
- subn:
- cgmessage1(type_h_convert_sub_operands_to_prevent_overflow,def.typename);
- muln:
- cgmessage1(type_h_convert_mul_operands_to_prevent_overflow,def.typename);
- end;
- end;
- constructor ttypeconvnode.create_explicit(node : tnode;def:tdef);
- begin
- self.create(node,def);
- include(flags,nf_explicit);
- end;
- constructor ttypeconvnode.create_internal(node : tnode;def:tdef);
- begin
- self.create(node,def);
- { handle like explicit conversions }
- include(flags,nf_explicit);
- include(flags,nf_internal);
- end;
- constructor ttypeconvnode.create_proc_to_procvar(node : tnode);
- begin
- self.create(node,voidtype);
- convtype:=tc_proc_2_procvar;
- end;
- constructor ttypeconvnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
- begin
- inherited ppuload(t,ppufile);
- ppufile.getderef(totypedefderef);
- convtype:=tconverttype(ppufile.getbyte);
- end;
- procedure ttypeconvnode.ppuwrite(ppufile:tcompilerppufile);
- begin
- inherited ppuwrite(ppufile);
- ppufile.putderef(totypedefderef);
- ppufile.putbyte(byte(convtype));
- end;
- procedure ttypeconvnode.buildderefimpl;
- begin
- inherited buildderefimpl;
- totypedefderef.build(totypedef);
- end;
- procedure ttypeconvnode.derefimpl;
- begin
- inherited derefimpl;
- totypedef:=tdef(totypedefderef.resolve);
- end;
- function ttypeconvnode.dogetcopy : tnode;
- var
- n : ttypeconvnode;
- begin
- n:=ttypeconvnode(inherited dogetcopy);
- n.convtype:=convtype;
- n.totypedef:=totypedef;
- n.assignment_side:=assignment_side;
- dogetcopy:=n;
- end;
- procedure ttypeconvnode.printnodeinfo(var t : text);
- const
- convtyp2str : array[tconverttype] of pchar = (
- 'tc_none',
- 'tc_equal',
- 'tc_not_possible',
- 'tc_string_2_string',
- 'tc_char_2_string',
- 'tc_char_2_chararray',
- 'tc_pchar_2_string',
- 'tc_cchar_2_pchar',
- 'tc_cstring_2_pchar',
- 'tc_cstring_2_int',
- 'tc_ansistring_2_pchar',
- 'tc_string_2_chararray',
- 'tc_chararray_2_string',
- 'tc_array_2_pointer',
- 'tc_pointer_2_array',
- 'tc_int_2_int',
- 'tc_int_2_bool',
- 'tc_bool_2_bool',
- 'tc_bool_2_int',
- 'tc_real_2_real',
- 'tc_int_2_real',
- 'tc_real_2_currency',
- 'tc_proc_2_procvar',
- 'tc_nil_2_methodprocvar',
- 'tc_arrayconstructor_2_set',
- 'tc_set_2_set',
- 'tc_cord_2_pointer',
- 'tc_intf_2_string',
- 'tc_intf_2_guid',
- 'tc_class_2_intf',
- 'tc_char_2_char',
- 'tc_dynarray_2_openarray',
- 'tc_pwchar_2_string',
- 'tc_variant_2_dynarray',
- 'tc_dynarray_2_variant',
- 'tc_variant_2_enum',
- 'tc_enum_2_variant',
- 'tc_interface_2_variant',
- 'tc_variant_2_interface',
- 'tc_array_2_dynarray',
- 'tc_elem_2_openarray'
- );
- begin
- inherited printnodeinfo(t);
- write(t,', convtype = ',strpas(convtyp2str[convtype]));
- end;
- function ttypeconvnode.typecheck_cord_to_pointer : tnode;
- begin
- result:=nil;
- if left.nodetype=ordconstn then
- begin
- { check if we have a valid pointer constant (JM) }
- {$if sizeof(pointer) > sizeof(TConstPtrUInt)}
- {$if sizeof(TConstPtrUInt) = 4}
- if (tordconstnode(left).value < int64(low(longint))) or
- (tordconstnode(left).value > int64(high(cardinal))) then
- CGMessage(parser_e_range_check_error);
- {$else} {$if sizeof(TConstPtrUInt) = 8}
- if (tordconstnode(left).value < int64(low(int64))) or
- (tordconstnode(left).value > int64(high(qword))) then
- CGMessage(parser_e_range_check_error);
- {$else}
- internalerror(2001020801);
- {$endif} {$endif}
- {$endif}
- if not(nf_explicit in flags) then
- if (tordconstnode(left).value.svalue=0) then
- CGMessage(type_w_zero_to_nil)
- else
- { in Delphi mode, these aren't caught in compare_defs_ext }
- IncompatibleTypes(left.resultdef,resultdef);
- result:=cpointerconstnode.create(TConstPtrUInt(tordconstnode(left).value.uvalue),resultdef);
- end
- else
- internalerror(200104023);
- end;
- function ttypeconvnode.typecheck_chararray_to_string : tnode;
- var
- chartype : string[8];
- newblock : tblocknode;
- newstat : tstatementnode;
- restemp : ttempcreatenode;
- begin
- if is_widechar(tarraydef(left.resultdef).elementdef) then
- chartype:='widechar'
- else
- chartype:='char';
- if tstringdef(resultdef).stringtype=st_shortstring then
- begin
- newblock:=internalstatements(newstat);
- restemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,false);
- addstatement(newstat,restemp);
- addstatement(newstat,ccallnode.createintern('fpc_'+chartype+'array_to_shortstr',
- ccallparanode.create(cordconstnode.create(
- ord(tarraydef(left.resultdef).lowrange=0),pasbool8type,false),
- ccallparanode.create(left,ccallparanode.create(
- ctemprefnode.create(restemp),nil)))));
- addstatement(newstat,ctempdeletenode.create_normal_temp(restemp));
- addstatement(newstat,ctemprefnode.create(restemp));
- result:=newblock;
- end
- else if (tstringdef(resultdef).stringtype=st_ansistring) then
- begin
- result:=ccallnode.createinternres(
- 'fpc_'+chartype+'array_to_'+tstringdef(resultdef).stringtypname,
- ccallparanode.create(
- cordconstnode.create(
- ord(tarraydef(left.resultdef).lowrange=0),
- pasbool8type,
- false
- ),
- ccallparanode.create(
- cordconstnode.create(
- getparaencoding(resultdef),
- u16inttype,
- true
- ),
- ccallparanode.create(left,nil)
- )
- ),
- resultdef
- );
- end
- else
- result:=ccallnode.createinternres(
- 'fpc_'+chartype+'array_to_'+tstringdef(resultdef).stringtypname,
- ccallparanode.create(cordconstnode.create(
- ord(tarraydef(left.resultdef).lowrange=0),pasbool8type,false),
- ccallparanode.create(left,nil)),resultdef);
- left:=nil;
- end;
- function ttypeconvnode.typecheck_string_to_chararray : tnode;
- var
- newblock : tblocknode;
- newstat : tstatementnode;
- restemp : ttempcreatenode;
- pchtemp : pchar;
- arrsize : aint;
- chartype : string[8];
- begin
- result := nil;
- with tarraydef(resultdef) do
- begin
- if highrange<lowrange then
- internalerror(200501051);
- arrsize := highrange-lowrange+1;
- end;
- if (left.nodetype = stringconstn) and
- (tstringconstnode(left).cst_type=cst_conststring) then
- begin
- { if the array of char is large enough we can use the string
- constant directly. This is handled in ncgcnv }
- if (arrsize>=tstringconstnode(left).len) and
- is_char(tarraydef(resultdef).elementdef) then
- begin
- { pad the constant string with #0 to the array len }
- { (2.0.x compatible) }
- if (arrsize>tstringconstnode(left).len) then
- begin
- pchtemp:=concatansistrings(tstringconstnode(left).value_str,pchar(StringOfChar(#0,arrsize-tstringconstnode(left).len)),tstringconstnode(left).len,arrsize-tstringconstnode(left).len);
- left.free;
- left:=cstringconstnode.createpchar(pchtemp,arrsize,nil);
- typecheckpass(left);
- end;
- exit;
- end;
- { Convert to wide/short/ansistring and call default helper }
- if is_widechar(tarraydef(resultdef).elementdef) then
- inserttypeconv(left,cunicodestringtype)
- else
- begin
- if tstringconstnode(left).len>255 then
- inserttypeconv(left,getansistringdef)
- else
- inserttypeconv(left,cshortstringtype);
- end;
- end;
- if is_widechar(tarraydef(resultdef).elementdef) then
- chartype:='widechar'
- else
- chartype:='char';
- newblock:=internalstatements(newstat);
- restemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,false);
- addstatement(newstat,restemp);
- addstatement(newstat,ccallnode.createintern('fpc_'+tstringdef(left.resultdef).stringtypname+
- '_to_'+chartype+'array',ccallparanode.create(left,ccallparanode.create(
- ctemprefnode.create(restemp),nil))));
- addstatement(newstat,ctempdeletenode.create_normal_temp(restemp));
- addstatement(newstat,ctemprefnode.create(restemp));
- result:=newblock;
- left:=nil;
- end;
- function ttypeconvnode.typecheck_char_to_string : tnode;
- var
- procname: string[31];
- para : tcallparanode;
- hp : tstringconstnode;
- ws : pcompilerwidestring;
- newblock : tblocknode;
- newstat : tstatementnode;
- restemp : ttempcreatenode;
- sa : ansistring;
- cw : tcompilerwidechar;
- l : SizeUInt;
- begin
- result:=nil;
- if (left.nodetype=ordconstn) and
- ((tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring,st_ansistring]) or
- (torddef(left.resultdef).ordtype in [uchar,uwidechar])) then
- begin
- if (tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring]) then
- begin
- initwidestring(ws);
- if torddef(left.resultdef).ordtype=uwidechar then
- concatwidestringchar(ws,tcompilerwidechar(tordconstnode(left).value.uvalue))
- else
- concatwidestringchar(ws,asciichar2unicode(chr(tordconstnode(left).value.uvalue)));
- hp:=cstringconstnode.createunistr(ws);
- hp.changestringtype(resultdef);
- donewidestring(ws);
- end
- else
- begin
- if (torddef(left.resultdef).ordtype=uwidechar) then
- begin
- if (current_settings.sourcecodepage<>CP_UTF8) then
- begin
- if tordconstnode(left).value.uvalue>127 then
- begin
- Message(type_w_unicode_data_loss);
- // compiler has different codepage than a system running an application
- // to prevent wrong codepage and data loss we are converting unicode char
- // using a helper routine. This is not delphi compatible behavior.
- // Delphi converts UniocodeChar to ansistring at the compile time
- // old behavior:
- // hp:=cstringconstnode.createstr(unicode2asciichar(tcompilerwidechar(tordconstnode(left).value.uvalue)));
- para:=ccallparanode.create(left,nil);
- if tstringdef(resultdef).stringtype=st_ansistring then
- para:=ccallparanode.create(cordconstnode.create(getparaencoding(resultdef),u16inttype,true),para);
- result:=ccallnode.createinternres('fpc_uchar_to_'+tstringdef(resultdef).stringtypname,
- para,resultdef);
- left:=nil;
- exit;
- end
- else
- hp:=cstringconstnode.createstr(unicode2asciichar(tcompilerwidechar(tordconstnode(left).value.uvalue)));
- end
- else
- begin
- cw:=tcompilerwidechar(tordconstnode(left).value.uvalue);
- SetLength(sa,5);
- l:=UnicodeToUtf8(@(sa[1]),Length(sa),@cw,1);
- SetLength(sa,l-1);
- hp:=cstringconstnode.createstr(sa);
- end
- end
- else
- hp:=cstringconstnode.createstr(chr(tordconstnode(left).value.uvalue));
- { output string consts in local ansistring encoding }
- if is_ansistring(resultdef) and ((tstringdef(resultdef).encoding=0) or (tstringdef(resultdef).encoding=globals.CP_NONE)) then
- tstringconstnode(hp).changestringtype(getansistringdef)
- else
- tstringconstnode(hp).changestringtype(resultdef);
- end;
- result:=hp;
- end
- else
- { shortstrings are handled 'inline' (except for widechars) }
- if (tstringdef(resultdef).stringtype<>st_shortstring) or
- (torddef(left.resultdef).ordtype=uwidechar) or
- (target_info.system in systems_managed_vm) then
- begin
- { parameter }
- para:=ccallparanode.create(left,nil);
- { encoding required? }
- if tstringdef(resultdef).stringtype=st_ansistring then
- para:=ccallparanode.create(cordconstnode.create(getparaencoding(resultdef),u16inttype,true),para);
- { create the procname }
- if torddef(left.resultdef).ordtype<>uwidechar then
- begin
- procname:='fpc_char_to_';
- if tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring] then
- if nf_explicit in flags then
- Message2(type_w_explicit_string_cast,left.resultdef.typename,resultdef.typename)
- else
- Message2(type_w_implicit_string_cast,left.resultdef.typename,resultdef.typename);
- end
- else
- begin
- procname:='fpc_uchar_to_';
- if not (tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring]) then
- if nf_explicit in flags then
- Message2(type_w_explicit_string_cast_loss,left.resultdef.typename,resultdef.typename)
- else
- Message2(type_w_implicit_string_cast_loss,left.resultdef.typename,resultdef.typename);
- end;
- procname:=procname+tstringdef(resultdef).stringtypname;
- { and finally the call }
- result:=ccallnode.createinternres(procname,para,resultdef);
- left := nil;
- end
- else
- begin
- { create word(byte(char) shl 8 or 1) for litte endian machines }
- { and word(byte(char) or 256) for big endian machines }
- left := ctypeconvnode.create_internal(left,u8inttype);
- if (target_info.endian = endian_little) then
- left := caddnode.create(orn,
- cshlshrnode.create(shln,left,cordconstnode.create(8,s32inttype,false)),
- cordconstnode.create(1,s32inttype,false))
- else
- left := caddnode.create(orn,left,
- cordconstnode.create(1 shl 8,s32inttype,false));
- left := ctypeconvnode.create_internal(left,u16inttype);
- typecheckpass(left);
- end;
- end;
- function ttypeconvnode.typecheck_string_to_string : tnode;
- begin
- result:=nil;
- if (left.nodetype=stringconstn) and
- (((tstringdef(resultdef).stringtype=st_ansistring) and
- (tstringdef(resultdef).encoding<>CP_NONE)
- )
- ) and
- (tstringdef(left.resultdef).stringtype in [st_unicodestring,st_widestring]) then
- begin
- tstringconstnode(left).changestringtype(resultdef);
- Result:=left;
- left:=nil;
- end
- else if (tstringdef(resultdef).stringtype=st_ansistring) and
- (tstringdef(left.resultdef).stringtype=st_ansistring) and
- (tstringdef(resultdef).encoding<>tstringdef(left.resultdef).encoding) then
- begin
- result:=ccallnode.createinternres(
- 'fpc_ansistr_to_ansistr',
- ccallparanode.create(
- cordconstnode.create(
- tstringdef(resultdef).encoding,
- u16inttype,
- true
- ),
- ccallparanode.create(left,nil)
- ),
- resultdef
- );
- left:=nil;
- end
- else if (left.nodetype=stringconstn) and
- (tstringdef(left.resultdef).stringtype in [st_unicodestring,st_widestring]) and
- (tstringdef(resultdef).stringtype=st_shortstring) then
- begin
- if not hasnonasciichars(pcompilerwidestring(tstringconstnode(left).value_str)) then
- begin
- tstringconstnode(left).changestringtype(resultdef);
- Result:=left;
- left:=nil;
- end;
- end
- else if (tstringdef(left.resultdef).stringtype in [st_unicodestring,st_widestring]) and
- not (tstringdef(resultdef).stringtype in [st_unicodestring,st_widestring]) then
- begin
- if nf_explicit in flags then
- Message2(type_w_explicit_string_cast_loss,left.resultdef.typename,resultdef.typename)
- else
- Message2(type_w_implicit_string_cast_loss,left.resultdef.typename,resultdef.typename);
- end
- else if not (tstringdef(left.resultdef).stringtype in [st_unicodestring,st_widestring]) and
- (tstringdef(resultdef).stringtype in [st_unicodestring,st_widestring]) then
- begin
- if nf_explicit in flags then
- Message2(type_w_explicit_string_cast,left.resultdef.typename,resultdef.typename)
- else
- Message2(type_w_implicit_string_cast,left.resultdef.typename,resultdef.typename);
- end
- end;
- function ttypeconvnode.typecheck_char_to_chararray : tnode;
- begin
- result:=nil;
- end;
- function ttypeconvnode.typecheck_char_to_char : tnode;
- var
- hp : tordconstnode;
- begin
- result:=nil;
- if (left.nodetype=ordconstn) and
- ((torddef(resultdef).ordtype<>uchar) or
- (torddef(left.resultdef).ordtype<>uwidechar) or
- (current_settings.sourcecodepage<>CP_UTF8))
- then
- begin
- if (torddef(resultdef).ordtype=uchar) and
- (torddef(left.resultdef).ordtype=uwidechar) and
- (current_settings.sourcecodepage<>CP_UTF8) then
- begin
- if tordconstnode(left).value.uvalue>127 then
- Message(type_w_unicode_data_loss);
- hp:=cordconstnode.create(
- ord(unicode2asciichar(tcompilerwidechar(tordconstnode(left).value.uvalue))),
- cansichartype,true);
- result:=hp;
- end
- else if (torddef(resultdef).ordtype=uwidechar) and
- (torddef(left.resultdef).ordtype=uchar) then
- begin
- hp:=cordconstnode.create(
- asciichar2unicode(chr(tordconstnode(left).value.uvalue)),
- cwidechartype,true);
- result:=hp;
- end
- else
- internalerror(200105131);
- exit;
- end;
- end;
- function ttypeconvnode.typecheck_int_to_int : tnode;
- var
- v : TConstExprInt;
- begin
- result:=nil;
- if left.nodetype=ordconstn then
- begin
- v:=tordconstnode(left).value;
- if is_currency(resultdef) and
- not(nf_internal in flags) then
- v:=v*10000;
- if (resultdef.typ=pointerdef) then
- result:=cpointerconstnode.create(TConstPtrUInt(v.uvalue),resultdef)
- else
- begin
- if is_currency(left.resultdef) and
- not(nf_internal in flags) then
- v:=v div 10000;
- result:=cordconstnode.create(v,resultdef,false);
- end;
- end
- else if left.nodetype=pointerconstn then
- begin
- v:=tpointerconstnode(left).value;
- if (resultdef.typ=pointerdef) then
- result:=cpointerconstnode.create(v.uvalue,resultdef)
- else
- begin
- if is_currency(resultdef) and
- not(nf_internal in flags) then
- v:=v*10000;
- result:=cordconstnode.create(v,resultdef,false);
- end;
- end
- else
- begin
- if (is_currency(resultdef) or
- is_currency(left.resultdef)) and
- (nf_internal in flags) then
- begin
- include(flags,nf_is_currency)
- end
- { multiply by 10000 for currency. We need to use getcopy to pass
- the argument because the current node is always disposed. Only
- inserting the multiply in the left node is not possible because
- it'll get in an infinite loop to convert int->currency }
- else if is_currency(resultdef) then
- begin
- result:=caddnode.create(muln,getcopy,cordconstnode.create(10000,resultdef,false));
- include(result.flags,nf_is_currency);
- end
- else if is_currency(left.resultdef) then
- begin
- result:=cmoddivnode.create(divn,getcopy,cordconstnode.create(10000,resultdef,false));
- include(result.flags,nf_is_currency);
- end;
- end;
- end;
- function ttypeconvnode.typecheck_int_to_real : tnode;
- var
- rv : bestreal;
- begin
- result:=nil;
- if left.nodetype=ordconstn then
- begin
- rv:=tordconstnode(left).value;
- if is_currency(resultdef) and
- not(nf_internal in flags) then
- rv:=rv*10000.0
- else if is_currency(left.resultdef) and
- not(nf_internal in flags) then
- rv:=rv/10000.0;
- result:=crealconstnode.create(rv,resultdef);
- end
- else
- begin
- if (is_currency(resultdef) or
- is_currency(left.resultdef)) and
- (nf_internal in flags) then
- begin
- include(flags,nf_is_currency)
- end
- { multiply by 10000 for currency. We need to use getcopy to pass
- the argument because the current node is always disposed. Only
- inserting the multiply in the left node is not possible because
- it'll get in an infinite loop to convert int->currency }
- else if is_currency(resultdef) then
- begin
- result:=caddnode.create(muln,getcopy,crealconstnode.create(10000.0,resultdef));
- include(result.flags,nf_is_currency);
- end
- else if is_currency(left.resultdef) then
- begin
- result:=caddnode.create(slashn,getcopy,crealconstnode.create(10000.0,resultdef));
- include(result.flags,nf_is_currency);
- end;
- end;
- end;
- function ttypeconvnode.typecheck_real_to_currency : tnode;
- begin
- if not is_currency(resultdef) then
- internalerror(200304221);
- result:=nil;
- left:=caddnode.create(muln,left,crealconstnode.create(10000.0,left.resultdef));
- include(left.flags,nf_is_currency);
- typecheckpass(left);
- { Convert constants directly, else call Round() }
- if left.nodetype=realconstn then
- result:=cordconstnode.create(round(trealconstnode(left).value_real),resultdef,false)
- else
- begin
- result:=cinlinenode.create(in_round_real,false,left);
- { Internal type cast to currency }
- result:=ctypeconvnode.create_internal(result,s64currencytype);
- left:=nil;
- end;
- end;
- function ttypeconvnode.typecheck_real_to_real : tnode;
- begin
- result:=nil;
- if is_currency(left.resultdef) and not(is_currency(resultdef)) then
- begin
- left:=caddnode.create(slashn,left,crealconstnode.create(10000.0,left.resultdef));
- include(left.flags,nf_is_currency);
- typecheckpass(left);
- end
- else
- if is_currency(resultdef) and not(is_currency(left.resultdef)) then
- begin
- left:=caddnode.create(muln,left,crealconstnode.create(10000.0,left.resultdef));
- include(left.flags,nf_is_currency);
- typecheckpass(left);
- end;
- end;
- function ttypeconvnode.typecheck_cchar_to_pchar : tnode;
- begin
- result:=nil;
- { handle any constants via cunicodestringtype because the compiler
- cannot convert arbitrary unicodechar constants at compile time to
- a shortstring (since it doesn't know the code page to use) }
- inserttypeconv(left,cunicodestringtype);
- { evaluate again, reset resultdef so the convert_typ
- will be calculated again and cstring_to_pchar will
- be used for futher conversion }
- convtype:=tc_none;
- result:=pass_typecheck;
- end;
- function ttypeconvnode.typecheck_cstring_to_pchar : tnode;
- begin
- result:=nil;
- if is_pwidechar(resultdef) then
- inserttypeconv(left,cunicodestringtype)
- else
- if is_pchar(resultdef) and
- (is_widestring(left.resultdef) or
- is_unicodestring(left.resultdef)) then
- begin
- inserttypeconv(left,getansistringdef);
- { the second pass of second_cstring_to_pchar expects a }
- { strinconstn, but this may become a call to the }
- { widestring manager in case left contains "high ascii" }
- if (left.nodetype<>stringconstn) then
- begin
- result:=left;
- left:=nil;
- end;
- end;
- end;
- function ttypeconvnode.typecheck_cstring_to_int : tnode;
- var
- fcc : cardinal;
- pb : pbyte;
- begin
- result:=nil;
- if left.nodetype<>stringconstn then
- internalerror(200510012);
- if tstringconstnode(left).len=4 then
- begin
- pb:=pbyte(tstringconstnode(left).value_str);
- fcc:=(pb[0] shl 24) or (pb[1] shl 16) or (pb[2] shl 8) or pb[3];
- result:=cordconstnode.create(fcc,u32inttype,false);
- end
- else
- CGMessage2(type_e_illegal_type_conversion,left.resultdef.typename,resultdef.typename);
- end;
- function ttypeconvnode.typecheck_arrayconstructor_to_set : tnode;
- var
- hp : tnode;
- begin
- result:=nil;
- if left.nodetype<>arrayconstructorn then
- internalerror(5546);
- { remove typeconv node }
- hp:=left;
- left:=nil;
- { create a set constructor tree }
- arrayconstructor_to_set(hp);
- result:=hp;
- end;
- function ttypeconvnode.typecheck_set_to_set : tnode;
- begin
- result:=nil;
- { constant sets can be converted by changing the type only }
- if (left.nodetype=setconstn) then
- begin
- left.resultdef:=resultdef;
- result:=left;
- left:=nil;
- exit;
- end;
- end;
- function ttypeconvnode.typecheck_pchar_to_string : tnode;
- var
- newblock : tblocknode;
- newstat : tstatementnode;
- restemp : ttempcreatenode;
- begin
- if tstringdef(resultdef).stringtype=st_shortstring then
- begin
- newblock:=internalstatements(newstat);
- restemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,false);
- addstatement(newstat,restemp);
- addstatement(newstat,ccallnode.createintern('fpc_pchar_to_shortstr',ccallparanode.create(left,ccallparanode.create(
- ctemprefnode.create(restemp),nil))));
- addstatement(newstat,ctempdeletenode.create_normal_temp(restemp));
- addstatement(newstat,ctemprefnode.create(restemp));
- result:=newblock;
- end
- else if tstringdef(resultdef).stringtype=st_ansistring then
- result := ccallnode.createinternres(
- 'fpc_pchar_to_'+tstringdef(resultdef).stringtypname,
- ccallparanode.create(
- cordconstnode.create(getparaencoding(resultdef),u16inttype,true),
- ccallparanode.create(left,nil)
- ),
- resultdef
- )
- else
- result := ccallnode.createinternres(
- 'fpc_pchar_to_'+tstringdef(resultdef).stringtypname,
- ccallparanode.create(left,nil),resultdef);
- left:=nil;
- end;
- function ttypeconvnode.typecheck_interface_to_string : tnode;
- begin
- if assigned(tobjectdef(left.resultdef).iidstr) then
- begin
- if not(oo_has_valid_guid in tobjectdef(left.resultdef).objectoptions) then
- CGMessage1(type_e_interface_has_no_guid,tobjectdef(left.resultdef).typename);
- result:=cstringconstnode.createstr(tobjectdef(left.resultdef).iidstr^);
- tstringconstnode(result).changestringtype(cshortstringtype);
- end
- else
- internalerror(2013112913);
- end;
- function ttypeconvnode.typecheck_interface_to_guid : tnode;
- begin
- if assigned(tobjectdef(left.resultdef).iidguid) then
- begin
- if not(oo_has_valid_guid in tobjectdef(left.resultdef).objectoptions) then
- CGMessage1(type_e_interface_has_no_guid,tobjectdef(left.resultdef).typename);
- result:=cguidconstnode.create(tobjectdef(left.resultdef).iidguid^);
- end
- else
- internalerror(2013112914);
- end;
- function ttypeconvnode.typecheck_dynarray_to_openarray : tnode;
- begin
- { a dynamic array is a pointer to an array, so to convert it to }
- { an open array, we have to dereference it (JM) }
- result := ctypeconvnode.create_internal(left,voidpointertype);
- typecheckpass(result);
- { left is reused }
- left := nil;
- result := cderefnode.create(result);
- include(result.flags,nf_no_checkpointer);
- result.resultdef := resultdef;
- end;
- function ttypeconvnode.typecheck_pwchar_to_string : tnode;
- var
- newblock : tblocknode;
- newstat : tstatementnode;
- restemp : ttempcreatenode;
- begin
- if tstringdef(resultdef).stringtype=st_shortstring then
- begin
- newblock:=internalstatements(newstat);
- restemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,false);
- addstatement(newstat,restemp);
- addstatement(newstat,ccallnode.createintern('fpc_pwidechar_to_shortstr',ccallparanode.create(left,ccallparanode.create(
- ctemprefnode.create(restemp),nil))));
- addstatement(newstat,ctempdeletenode.create_normal_temp(restemp));
- addstatement(newstat,ctemprefnode.create(restemp));
- result:=newblock;
- end
- else if tstringdef(resultdef).stringtype=st_ansistring then
- begin
- result:=ccallnode.createinternres(
- 'fpc_pwidechar_to_'+tstringdef(resultdef).stringtypname,
- ccallparanode.create(
- cordconstnode.create(
- getparaencoding(resultdef),
- u16inttype,
- true
- ),
- ccallparanode.create(left,nil)
- ),
- resultdef
- );
- end
- else
- result := ccallnode.createinternres(
- 'fpc_pwidechar_to_'+tstringdef(resultdef).stringtypname,
- ccallparanode.create(left,nil),resultdef);
- left:=nil;
- end;
- function ttypeconvnode.typecheck_variant_to_dynarray : tnode;
- begin
- result := ccallnode.createinternres(
- 'fpc_variant_to_dynarray',
- ccallparanode.create(caddrnode.create_internal(crttinode.create(tstoreddef(resultdef),initrtti,rdt_normal)),
- ccallparanode.create(left,nil)
- ),resultdef);
- typecheckpass(result);
- left:=nil;
- end;
- function ttypeconvnode.typecheck_dynarray_to_variant : tnode;
- begin
- result := ccallnode.createinternres(
- 'fpc_dynarray_to_variant',
- ccallparanode.create(caddrnode.create_internal(crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
- ccallparanode.create(ctypeconvnode.create_explicit(left,voidpointertype),nil)
- ),resultdef);
- typecheckpass(result);
- left:=nil;
- end;
- function ttypeconvnode.typecheck_variant_to_interface : tnode;
- begin
- if def_is_related(tobjectdef(resultdef),tobjectdef(search_system_type('IDISPATCH').typedef)) then
- result := ccallnode.createinternres(
- 'fpc_variant_to_idispatch',
- ccallparanode.create(left,nil)
- ,resultdef)
- else
- result := ccallnode.createinternres(
- 'fpc_variant_to_interface',
- ccallparanode.create(left,nil)
- ,resultdef);
- typecheckpass(result);
- left:=nil;
- end;
- function ttypeconvnode.typecheck_interface_to_variant : tnode;
- begin
- if def_is_related(tobjectdef(left.resultdef),tobjectdef(search_system_type('IDISPATCH').typedef)) then
- result := ccallnode.createinternres(
- 'fpc_idispatch_to_variant',
- ccallparanode.create(left,nil)
- ,resultdef)
- else
- result := ccallnode.createinternres(
- 'fpc_interface_to_variant',
- ccallparanode.create(left,nil)
- ,resultdef);
- typecheckpass(result);
- left:=nil;
- end;
- function ttypeconvnode.typecheck_variant_to_enum : tnode;
- begin
- result := ctypeconvnode.create_internal(left,sinttype);
- result := ctypeconvnode.create_internal(result,resultdef);
- typecheckpass(result);
- { left is reused }
- left := nil;
- end;
- function ttypeconvnode.typecheck_enum_to_variant : tnode;
- begin
- result := ctypeconvnode.create_internal(left,sinttype);
- result := ctypeconvnode.create_internal(result,cvarianttype);
- typecheckpass(result);
- { left is reused }
- left := nil;
- end;
- function ttypeconvnode.typecheck_array_2_dynarray : tnode;
- var
- newstatement : tstatementnode;
- temp : ttempcreatenode;
- temp2 : ttempcreatenode;
- begin
- { create statements with call to getmem+initialize }
- result:=internalstatements(newstatement);
- { create temp for result }
- temp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true);
- addstatement(newstatement,temp);
- { get temp for array of lengths }
- temp2:=ctempcreatenode.create(sinttype,sinttype.size,tt_persistent,false);
- addstatement(newstatement,temp2);
- { one dimensional }
- addstatement(newstatement,cassignmentnode.create(
- ctemprefnode.create_offset(temp2,0),
- cordconstnode.create
- (tarraydef(left.resultdef).highrange+1,s32inttype,true)));
- { create call to fpc_dynarr_setlength }
- addstatement(newstatement,ccallnode.createintern('fpc_dynarray_setlength',
- ccallparanode.create(caddrnode.create_internal
- (ctemprefnode.create(temp2)),
- ccallparanode.create(cordconstnode.create
- (1,s32inttype,true),
- ccallparanode.create(caddrnode.create_internal
- (crttinode.create(tstoreddef(resultdef),initrtti,rdt_normal)),
- ccallparanode.create(
- ctypeconvnode.create_internal(
- ctemprefnode.create(temp),voidpointertype),
- nil))))
- ));
- addstatement(newstatement,ctempdeletenode.create(temp2));
- { copy ... }
- addstatement(newstatement,cassignmentnode.create(
- ctypeconvnode.create_internal(cderefnode.create(ctypeconvnode.create_internal(ctemprefnode.create(temp),voidpointertype)),left.resultdef),
- left
- ));
- { left is reused }
- left:=nil;
- { the last statement should return the value as
- location and type, this is done be referencing the
- temp and converting it first from a persistent temp to
- normal temp }
- addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
- addstatement(newstatement,ctemprefnode.create(temp));
- end;
- function ttypeconvnode.typecheck_elem_2_openarray : tnode;
- begin
- result:=nil;
- end;
- function ttypeconvnode._typecheck_int_to_int : tnode;
- begin
- result := typecheck_int_to_int;
- end;
- function ttypeconvnode._typecheck_cord_to_pointer : tnode;
- begin
- result := typecheck_cord_to_pointer;
- end;
- function ttypeconvnode._typecheck_chararray_to_string : tnode;
- begin
- result := typecheck_chararray_to_string;
- end;
- function ttypeconvnode._typecheck_string_to_chararray : tnode;
- begin
- result := typecheck_string_to_chararray;
- end;
- function ttypeconvnode._typecheck_string_to_string: tnode;
- begin
- result := typecheck_string_to_string;
- end;
- function ttypeconvnode._typecheck_char_to_string : tnode;
- begin
- result := typecheck_char_to_string;
- end;
- function ttypeconvnode._typecheck_char_to_chararray : tnode;
- begin
- result := typecheck_char_to_chararray;
- end;
- function ttypeconvnode._typecheck_int_to_real : tnode;
- begin
- result := typecheck_int_to_real;
- end;
- function ttypeconvnode._typecheck_real_to_real : tnode;
- begin
- result := typecheck_real_to_real;
- end;
- function ttypeconvnode._typecheck_real_to_currency : tnode;
- begin
- result := typecheck_real_to_currency;
- end;
- function ttypeconvnode._typecheck_cchar_to_pchar : tnode;
- begin
- result := typecheck_cchar_to_pchar;
- end;
- function ttypeconvnode._typecheck_cstring_to_pchar : tnode;
- begin
- result := typecheck_cstring_to_pchar;
- end;
- function ttypeconvnode._typecheck_cstring_to_int : tnode;
- begin
- result := typecheck_cstring_to_int;
- end;
- function ttypeconvnode._typecheck_char_to_char : tnode;
- begin
- result := typecheck_char_to_char;
- end;
- function ttypeconvnode._typecheck_arrayconstructor_to_set : tnode;
- begin
- result := typecheck_arrayconstructor_to_set;
- end;
- function ttypeconvnode._typecheck_set_to_set : tnode;
- begin
- result := typecheck_set_to_set;
- end;
- function ttypeconvnode._typecheck_pchar_to_string : tnode;
- begin
- result := typecheck_pchar_to_string;
- end;
- function ttypeconvnode._typecheck_interface_to_string : tnode;
- begin
- result := typecheck_interface_to_string;
- end;
- function ttypeconvnode._typecheck_interface_to_guid : tnode;
- begin
- result := typecheck_interface_to_guid;
- end;
- function ttypeconvnode._typecheck_dynarray_to_openarray : tnode;
- begin
- result := typecheck_dynarray_to_openarray;
- end;
- function ttypeconvnode._typecheck_pwchar_to_string : tnode;
- begin
- result := typecheck_pwchar_to_string;
- end;
- function ttypeconvnode._typecheck_variant_to_dynarray : tnode;
- begin
- result := typecheck_variant_to_dynarray;
- end;
- function ttypeconvnode._typecheck_dynarray_to_variant : tnode;
- begin
- result := typecheck_dynarray_to_variant;
- end;
- function ttypeconvnode._typecheck_variant_to_enum : tnode;
- begin
- result := typecheck_variant_to_enum;
- end;
- function ttypeconvnode._typecheck_enum_to_variant : tnode;
- begin
- result := typecheck_enum_to_variant;
- end;
- function ttypeconvnode._typecheck_proc_to_procvar : tnode;
- begin
- result := typecheck_proc_to_procvar;
- end;
- function ttypeconvnode._typecheck_variant_to_interface : tnode;
- begin
- result := typecheck_variant_to_interface;
- end;
- function ttypeconvnode._typecheck_interface_to_variant : tnode;
- begin
- result := typecheck_interface_to_variant;
- end;
- function ttypeconvnode._typecheck_array_2_dynarray : tnode;
- begin
- result := typecheck_array_2_dynarray;
- end;
- function ttypeconvnode._typecheck_elem_2_openarray : tnode;
- begin
- result := typecheck_elem_2_openarray;
- end;
- function ttypeconvnode.target_specific_general_typeconv: boolean;
- begin
- result:=false;
- end;
- function ttypeconvnode.target_specific_explicit_typeconv: boolean;
- begin
- result:=false;
- end;
- class function ttypeconvnode.target_specific_need_equal_typeconv(fromdef, todef: tdef): boolean;
- begin
- result:=false;
- end;
- function ttypeconvnode.typecheck_proc_to_procvar : tnode;
- var
- pd : tabstractprocdef;
- begin
- result:=nil;
- pd:=tabstractprocdef(left.resultdef);
- { create procvardef (default for create_proc_to_procvar is voiddef,
- but if later a regular inserttypeconvnode() is used to insert a type
- conversion to the actual procvardef, totypedef will be set to the
- real procvartype that we are converting to) }
- if assigned(totypedef) and
- (totypedef.typ=procvardef) then
- resultdef:=totypedef
- else
- begin
- resultdef:=pd.getcopyas(procvardef,pc_normal);
- { only need the address of the method? this is needed
- for @tobject.create. In this case there will be a loadn without
- a methodpointer. }
- if (left.nodetype=loadn) and
- not assigned(tloadnode(left).left) and
- (not(m_nested_procvars in current_settings.modeswitches) or
- not is_nested_pd(tprocvardef(resultdef))) then
- include(tprocvardef(resultdef).procoptions,po_addressonly);
- { calculate parameter list & order }
- tprocvardef(resultdef).calcparas;
- end;
- end;
- function ttypeconvnode.typecheck_call_helper(c : tconverttype) : tnode;
- const
- resultdefconvert : array[tconverttype] of pointer = (
- {none} nil,
- {equal} nil,
- {not_possible} nil,
- { string_2_string } @ttypeconvnode._typecheck_string_to_string,
- { char_2_string } @ttypeconvnode._typecheck_char_to_string,
- { char_2_chararray } @ttypeconvnode._typecheck_char_to_chararray,
- { pchar_2_string } @ttypeconvnode._typecheck_pchar_to_string,
- { cchar_2_pchar } @ttypeconvnode._typecheck_cchar_to_pchar,
- { cstring_2_pchar } @ttypeconvnode._typecheck_cstring_to_pchar,
- { cstring_2_int } @ttypeconvnode._typecheck_cstring_to_int,
- { ansistring_2_pchar } nil,
- { string_2_chararray } @ttypeconvnode._typecheck_string_to_chararray,
- { chararray_2_string } @ttypeconvnode._typecheck_chararray_to_string,
- { array_2_pointer } nil,
- { pointer_2_array } nil,
- { int_2_int } @ttypeconvnode._typecheck_int_to_int,
- { int_2_bool } nil,
- { bool_2_bool } nil,
- { bool_2_int } nil,
- { real_2_real } @ttypeconvnode._typecheck_real_to_real,
- { int_2_real } @ttypeconvnode._typecheck_int_to_real,
- { real_2_currency } @ttypeconvnode._typecheck_real_to_currency,
- { proc_2_procvar } @ttypeconvnode._typecheck_proc_to_procvar,
- { nil_2_methodprocvar } nil,
- { arrayconstructor_2_set } @ttypeconvnode._typecheck_arrayconstructor_to_set,
- { set_to_set } @ttypeconvnode._typecheck_set_to_set,
- { cord_2_pointer } @ttypeconvnode._typecheck_cord_to_pointer,
- { intf_2_string } @ttypeconvnode._typecheck_interface_to_string,
- { intf_2_guid } @ttypeconvnode._typecheck_interface_to_guid,
- { class_2_intf } nil,
- { char_2_char } @ttypeconvnode._typecheck_char_to_char,
- { dynarray_2_openarray} @ttypeconvnode._typecheck_dynarray_to_openarray,
- { pwchar_2_string} @ttypeconvnode._typecheck_pwchar_to_string,
- { variant_2_dynarray} @ttypeconvnode._typecheck_variant_to_dynarray,
- { dynarray_2_variant} @ttypeconvnode._typecheck_dynarray_to_variant,
- { variant_2_enum} @ttypeconvnode._typecheck_variant_to_enum,
- { enum_2_variant} @ttypeconvnode._typecheck_enum_to_variant,
- { variant_2_interface} @ttypeconvnode._typecheck_interface_to_variant,
- { interface_2_variant} @ttypeconvnode._typecheck_variant_to_interface,
- { array_2_dynarray} @ttypeconvnode._typecheck_array_2_dynarray,
- { elem_2_openarray } @ttypeconvnode._typecheck_elem_2_openarray
- );
- type
- tprocedureofobject = function : tnode of object;
- var
- r : packed record
- proc : pointer;
- obj : pointer;
- end;
- begin
- result:=nil;
- { this is a little bit dirty but it works }
- { and should be quite portable too }
- r.proc:=resultdefconvert[c];
- r.obj:=self;
- if assigned(r.proc) then
- result:=tprocedureofobject(r)();
- end;
- function ttypeconvnode.pass_typecheck:tnode;
- var
- hdef : tdef;
- hp : tnode;
- currprocdef : tabstractprocdef;
- aprocdef : tprocdef;
- eq : tequaltype;
- cdoptions : tcompare_defs_options;
- newblock: tblocknode;
- newstatement: tstatementnode;
- tempnode: ttempcreatenode;
- begin
- result:=nil;
- resultdef:=totypedef;
- typecheckpass(left);
- if codegenerror then
- exit;
- { When absolute force tc_equal }
- if (nf_absolute in flags) then
- begin
- convtype:=tc_equal;
- if (tstoreddef(resultdef).is_intregable<>tstoreddef(left.resultdef).is_intregable) or
- (tstoreddef(resultdef).is_fpuregable<>tstoreddef(left.resultdef).is_fpuregable) then
- make_not_regable(left,[ra_addr_regable]);
- exit;
- end;
- { tp procvar support. Skip typecasts to procvar, record or set. Those
- convert on the procvar value. This is used to access the
- fields of a methodpointer }
- if not(nf_load_procvar in flags) and
- not(resultdef.typ in [procvardef,recorddef,setdef]) then
- maybe_call_procvar(left,true);
- { convert array constructors to sets, because there is no conversion
- possible for array constructors }
- if (resultdef.typ<>arraydef) and
- is_array_constructor(left.resultdef) then
- begin
- arrayconstructor_to_set(left);
- typecheckpass(left);
- end;
- if target_specific_general_typeconv then
- exit;
- if convtype=tc_none then
- begin
- cdoptions:=[cdo_allow_variant,cdo_warn_incompatible_univ];
- { overloaded operators require calls, which is not possible inside
- a constant declaration }
- if (block_type<>bt_const) and
- not(nf_internal in flags) then
- include(cdoptions,cdo_check_operator);
- if nf_explicit in flags then
- include(cdoptions,cdo_explicit);
- if nf_internal in flags then
- include(cdoptions,cdo_internal);
- eq:=compare_defs_ext(left.resultdef,resultdef,left.nodetype,convtype,aprocdef,cdoptions);
- case eq of
- te_exact,
- te_equal :
- begin
- result := simplify(false);
- if assigned(result) then
- exit;
- { in case of bitpacked accesses, the original type must
- remain so that not too many/few bits are laoded }
- if is_bitpacked_access(left) then
- convtype:=tc_int_2_int;
- { Only leave when there is no conversion to do.
- We can still need to call a conversion routine,
- like the routine to convert a stringconstnode }
- if (convtype in [tc_equal,tc_not_possible]) and
- { some conversions, like dynarray to pointer in Delphi
- mode, must not be removed, because then we get memory
- leaks due to missing temp finalization }
- (not is_managed_type(left.resultdef) or
- { different kinds of refcounted types may need calls
- to different kinds of refcounting helpers }
- (resultdef=left.resultdef)) then
- begin
- left.resultdef:=resultdef;
- if (nf_explicit in flags) and (left.nodetype = addrn) then
- include(left.flags, nf_typedaddr);
- result:=left;
- left:=nil;
- exit;
- end;
- end;
- te_convert_l1,
- te_convert_l2,
- te_convert_l3,
- te_convert_l4,
- te_convert_l5,
- te_convert_l6:
- { nothing to do }
- ;
- te_convert_operator :
- begin
- include(current_procinfo.flags,pi_do_call);
- addsymref(aprocdef.procsym);
- hp:=ccallnode.create(ccallparanode.create(left,nil),Tprocsym(aprocdef.procsym),nil,nil,[]);
- { tell explicitly which def we must use !! (PM) }
- tcallnode(hp).procdefinition:=aprocdef;
- left:=nil;
- result:=hp;
- exit;
- end;
- te_incompatible :
- begin
- { Procedures have a resultdef of voiddef and functions of their
- own resultdef. They will therefore always be incompatible with
- a procvar. Because isconvertable cannot check for procedures we
- use an extra check for them.}
- if (left.nodetype=calln) and
- (tcallnode(left).required_para_count=0) and
- (resultdef.typ=procvardef) and
- (
- (m_tp_procvar in current_settings.modeswitches) or
- (m_mac_procvar in current_settings.modeswitches)
- ) then
- begin
- if assigned(tcallnode(left).right) then
- begin
- { this is already a procvar, if it is really equal
- is checked below }
- convtype:=tc_equal;
- hp:=tcallnode(left).right.getcopy;
- currprocdef:=tabstractprocdef(hp.resultdef);
- end
- else
- begin
- convtype:=tc_proc_2_procvar;
- currprocdef:=Tprocsym(Tcallnode(left).symtableprocentry).Find_procdef_byprocvardef(Tprocvardef(resultdef));
- hp:=cloadnode.create_procvar(tprocsym(tcallnode(left).symtableprocentry),
- tprocdef(currprocdef),tcallnode(left).symtableproc);
- if (tcallnode(left).symtableprocentry.owner.symtabletype=ObjectSymtable) then
- begin
- if assigned(tcallnode(left).methodpointer) then
- tloadnode(hp).set_mp(tcallnode(left).methodpointer.getcopy)
- else
- tloadnode(hp).set_mp(load_self_node);
- end;
- typecheckpass(hp);
- end;
- left.free;
- left:=hp;
- { Now check if the procedure we are going to assign to
- the procvar, is compatible with the procvar's type }
- if not(nf_explicit in flags) and
- (proc_to_procvar_equal(currprocdef,tprocvardef(resultdef),false)=te_incompatible) then
- IncompatibleTypes(left.resultdef,resultdef);
- exit;
- end
- else if maybe_global_proc_to_nested(left,resultdef) then
- begin
- result:=left;
- left:=nil;
- exit;
- end;
- { Handle explicit type conversions }
- if nf_explicit in flags then
- begin
- { do common tc_equal cast, except when dealing with proc -> procvar
- (may have to get rid of method pointer) }
- if (left.resultdef.typ<>procdef) or
- (resultdef.typ<>procvardef) then
- convtype:=tc_equal
- else
- convtype:=tc_proc_2_procvar;
- { ordinal constants can be resized to 1,2,4,8 bytes }
- if (left.nodetype=ordconstn) then
- begin
- { Insert typeconv for ordinal to the correct size first on left, after
- that the other conversion can be done }
- hdef:=nil;
- case longint(resultdef.size) of
- 1 :
- hdef:=s8inttype;
- 2 :
- hdef:=s16inttype;
- 4 :
- hdef:=s32inttype;
- 8 :
- hdef:=s64inttype;
- end;
- { we need explicit, because it can also be an enum }
- if assigned(hdef) then
- inserttypeconv_internal(left,hdef)
- else
- CGMessage2(type_e_illegal_type_conversion,left.resultdef.typename,resultdef.typename);
- end;
- { class/interface to class/interface, with checkobject support }
- if is_class_or_interface_or_objc(resultdef) and
- is_class_or_interface_or_objc(left.resultdef) then
- begin
- { check if the types are related }
- if not(nf_internal in flags) and
- (not(def_is_related(tobjectdef(left.resultdef),tobjectdef(resultdef)))) and
- (not(def_is_related(tobjectdef(resultdef),tobjectdef(left.resultdef)))) then
- begin
- { Give an error when typecasting class to interface, this is compatible
- with delphi }
- if is_interface(resultdef) and
- not is_interface(left.resultdef) then
- CGMessage2(type_e_classes_not_related,
- FullTypeName(left.resultdef,resultdef),
- FullTypeName(resultdef,left.resultdef))
- else
- CGMessage2(type_w_classes_not_related,
- FullTypeName(left.resultdef,resultdef),
- FullTypeName(resultdef,left.resultdef))
- end;
- { Add runtime check? }
- if not is_objc_class_or_protocol(resultdef) and
- not is_objc_class_or_protocol(left.resultdef) and
- (cs_check_object in current_settings.localswitches) and
- not(nf_internal in flags) then
- begin
- { we can translate the typeconvnode to 'as' when
- typecasting to a class or interface }
- { we need to make sure the result can still be
- passed as a var parameter }
- newblock:=internalstatements(newstatement);
- if (valid_for_var(left,false)) then
- begin
- tempnode:=ctempcreatenode.create(voidpointertype,voidpointertype.size,tt_persistent,true);
- addstatement(newstatement,tempnode);
- addstatement(newstatement,cassignmentnode.create(
- ctemprefnode.create(tempnode),
- caddrnode.create_internal(left)));
- left:=ctypeconvnode.create_internal(cderefnode.create(ctemprefnode.create(tempnode)),left.resultdef);
- end
- else
- begin
- tempnode:=ctempcreatenode.create(left.resultdef,left.resultdef.size,tt_persistent,true);
- addstatement(newstatement,tempnode);
- addstatement(newstatement,cassignmentnode.create(
- ctemprefnode.create(tempnode),
- left));
- left:=ctemprefnode.create(tempnode);
- end;
- addstatement(newstatement,casnode.create(left.getcopy,cloadvmtaddrnode.create(ctypenode.create(resultdef))));
- addstatement(newstatement,ctempdeletenode.create_normal_temp(tempnode));
- addstatement(newstatement,ctypeconvnode.create_internal(left,resultdef));
- left:=nil;
- result:=newblock;
- exit;
- end;
- end
- else
- begin
- { only if the same size or formal def, and }
- { don't allow type casting of constants to }
- { structured types }
- if not(
- (left.resultdef.typ=formaldef) or
- {$ifdef jvm}
- { enums /are/ class instances on the JVM
- platform }
- (((left.resultdef.typ=enumdef) and
- (resultdef.typ=objectdef)) or
- ((resultdef.typ=enumdef) and
- (left.resultdef.typ=objectdef))) or
- {$endif}
- (
- not(is_open_array(left.resultdef)) and
- not(is_array_constructor(left.resultdef)) and
- not(is_array_of_const(left.resultdef)) and
- (left.resultdef.size=resultdef.size) and
- { disallow casts of const nodes }
- (not is_constnode(left) or
- { however, there are some exceptions }
- (not(resultdef.typ in [arraydef,recorddef,setdef,stringdef,
- filedef,variantdef,objectdef]) or
- is_class_or_interface_or_objc(resultdef) or
- { the softfloat code generates casts <const. float> to record }
- (nf_internal in flags)
- ))
- ) or
- (
- is_void(left.resultdef) and
- (left.nodetype=derefn)
- )
- ) then
- CGMessage2(type_e_illegal_type_conversion,left.resultdef.typename,resultdef.typename)
- else
- begin
- { perform target-specific explicit typecast
- checks }
- if target_specific_explicit_typeconv then
- begin
- result:=simplify(false);
- exit;
- end;
- end;
- end;
- end
- else
- IncompatibleTypes(left.resultdef,resultdef);
- end;
- else
- internalerror(200211231);
- end;
- end;
- { Give hint or warning for unportable code, exceptions are
- - typecasts from constants
- - void }
- if not(nf_internal in flags) and
- (left.nodetype<>ordconstn) and
- not(is_void(left.resultdef)) and
- (((left.resultdef.typ=orddef) and
- (resultdef.typ in [pointerdef,procvardef,classrefdef])) or
- ((resultdef.typ=orddef) and
- (left.resultdef.typ in [pointerdef,procvardef,classrefdef]))) then
- begin
- {Converting pointers to signed integers is a bad idea. Warn.}
- warn_pointer_to_signed:=(resultdef.typ=orddef) and (Torddef(resultdef).ordtype in [s8bit,s16bit,s32bit,s64bit]);
- { Give a warning when sizes don't match, because then info will be lost }
- if left.resultdef.size=resultdef.size then
- CGMessage(type_h_pointer_to_longint_conv_not_portable)
- else
- CGMessage(type_w_pointer_to_longint_conv_not_portable);
- end;
- { tc_cord_2_pointer still requires a type check, which
- simplify does not do }
- if (convtype<>tc_cord_2_pointer) then
- begin
- result := simplify(false);
- if assigned(result) then
- exit;
- end;
- { now call the resultdef helper to do constant folding }
- result:=typecheck_call_helper(convtype);
- end;
- { some code generators for 64 bit CPUs might not support 32 bit operations, so we can
- disable the following optimization in fpcdefs.inc. Currently the only CPU for which
- this applies is powerpc64
- }
- {$ifndef CPUNO32BITOPS}
- { checks whether we can safely remove 64 bit typeconversions
- in case range and overflow checking are off, and in case
- the result of this node tree is downcasted again to a
- 8/16/32 bit value afterwards
- We do this on 64 bit CPUs as well, they benefit from it as well }
- function checkremove64bittypeconvs(n: tnode; out gotsint: boolean): boolean;
- var
- gotdivmod: boolean;
- { checks whether a node is either an u32bit, or originally }
- { was one but was implicitly converted to s64bit }
- function wasoriginallyint32(n: tnode): boolean;
- begin
- if (n.resultdef.typ<>orddef) then
- exit(false);
- if (torddef(n.resultdef).ordtype in [s8bit,u8bit,s16bit,u16bit,s32bit,u32bit]) then
- begin
- if (torddef(n.resultdef).ordtype in [s8bit,s16bit,s32bit]) then
- gotsint:=true;
- exit(true);
- end;
- if (torddef(n.resultdef).ordtype in [u64bit,s64bit]) and
- { nf_explicit is also set for explicitly typecasted }
- { ordconstn's }
- ([nf_internal,nf_explicit]*n.flags=[]) and
- { either a typeconversion node coming from u32bit }
- (((n.nodetype=typeconvn) and
- (ttypeconvnode(n).left.resultdef.typ=orddef) and
- (torddef(ttypeconvnode(n).left.resultdef).ordtype in [s8bit,u8bit,s16bit,u16bit,s32bit,u32bit])) or
- { or an ordconstnode which was/is a valid cardinal }
- ((n.nodetype=ordconstn) and
- (tordconstnode(n).value>=int64(low(longint))) and
- (tordconstnode(n).value<=high(cardinal)))) then
- begin
- if ((n.nodetype=typeconvn) and
- (torddef(ttypeconvnode(n).left.resultdef).ordtype in [s8bit,s16bit,s32bit])) or
- ((n.nodetype=ordconstn) and
- (tordconstnode(n).value<0)) then
- gotsint:=true;
- exit(true);
- end;
- result:=false;
- end;
- function docheckremove64bittypeconvs(n: tnode): boolean;
- begin
- result:=false;
- if wasoriginallyint32(n) then
- exit(true);
- case n.nodetype of
- subn,orn,xorn:
- begin
- { the result could become negative in this case }
- if n.nodetype=subn then
- gotsint:=true;
- result:=
- docheckremove64bittypeconvs(tbinarynode(n).left) and
- docheckremove64bittypeconvs(tbinarynode(n).right);
- end;
- addn,muln,divn,modn,andn:
- begin
- if n.nodetype in [divn,modn] then
- gotdivmod:=true;
- result:=
- (docheckremove64bittypeconvs(tbinarynode(n).left) and
- docheckremove64bittypeconvs(tbinarynode(n).right)) or
- { in case of div/mod, the result of that division/modulo can
- usually be different in 32 and 64 bit }
- (not gotdivmod and
- (((n.nodetype=andn) and wasoriginallyint32(tbinarynode(n).left)) or
- ((n.nodetype=andn) and wasoriginallyint32(tbinarynode(n).right))));
- end;
- end;
- end;
- begin { checkremove64bittypeconvs }
- gotdivmod:=false;
- gotsint:=false;
- result:=
- docheckremove64bittypeconvs(n) and
- not(gotdivmod and gotsint);
- end;
- procedure doremove64bittypeconvs(var n: tnode; todef: tdef; forceunsigned: boolean);
- begin
- case n.nodetype of
- subn,addn,muln,divn,modn,xorn,andn,orn:
- begin
- exclude(n.flags,nf_internal);
- if not forceunsigned and
- is_signed(n.resultdef) then
- begin
- doremove64bittypeconvs(tbinarynode(n).left,s32inttype,false);
- doremove64bittypeconvs(tbinarynode(n).right,s32inttype,false);
- n.resultdef:=s32inttype
- end
- else
- begin
- doremove64bittypeconvs(tbinarynode(n).left,u32inttype,forceunsigned);
- doremove64bittypeconvs(tbinarynode(n).right,u32inttype,forceunsigned);
- n.resultdef:=u32inttype
- end;
- //if ((n.nodetype=andn) and (tbinarynode(n).left.nodetype=ordconstn) and
- // ((tordconstnode(tbinarynode(n).left).value and $7fffffff)=tordconstnode(tbinarynode(n).left).value)
- // ) then
- // inserttypeconv_internal(tbinarynode(n).right,n.resultdef)
- //else if (n.nodetype=andn) and (tbinarynode(n).right.nodetype=ordconstn) and
- // ((tordconstnode(tbinarynode(n).right).value and $7fffffff)=tordconstnode(tbinarynode(n).right).value) then
- // inserttypeconv_internal(tbinarynode(n).left,n.resultdef);
- end;
- typeconvn:
- begin
- ttypeconvnode(n).totypedef:=todef;
- { may change the type conversion, e.g. if the old conversion was
- from 64 bit to a 64 bit, and now becomes 64 bit to 32 bit }
- n.resultdef:=nil;
- ttypeconvnode(n).convtype:=tc_none;
- typecheckpass(n);
- end;
- else
- inserttypeconv_internal(n,todef);
- end;
- end;
- {$endif not CPUNO32BITOPS}
- procedure swap_const_value (var val : TConstExprInt; size : longint);
- begin
- case size of
- 1 : {do nothing };
- 2 : if val.signed then
- val.svalue:=swapendian(smallint(val.svalue))
- else
- val.uvalue:=swapendian(word(val.uvalue));
- 4 : if val.signed then
- val.svalue:=swapendian(longint(val.svalue))
- else
- val.uvalue:=swapendian(qword(val.uvalue));
- 8 : if val.signed then
- val.svalue:=swapendian(int64(val.svalue))
- else
- val.uvalue:=swapendian(qword(val.uvalue));
- else
- internalerror(2014111201);
- end;
- end;
- function ttypeconvnode.simplify(forinline : boolean): tnode;
- var
- hp: tnode;
- {$ifndef CPUNO32BITOPS}
- foundsint: boolean;
- {$endif not CPUNO32BITOPS}
- begin
- result := nil;
- { Constant folding and other node transitions to
- remove the typeconv node }
- case left.nodetype of
- stringconstn :
- if (convtype=tc_string_2_string) and
- (resultdef.typ=stringdef) and
- (
- ((not is_widechararray(left.resultdef) and
- not is_wide_or_unicode_string(left.resultdef)) or
- (tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring,st_ansistring])
- )
- ) then
- begin
- { output string consts in local ansistring encoding }
- if is_ansistring(resultdef) and ((tstringdef(resultdef).encoding=0)or(tstringdef(resultdef).encoding=globals.CP_NONE)) then
- tstringconstnode(left).changestringtype(getansistringdef)
- else
- tstringconstnode(left).changestringtype(resultdef);
- result:=left;
- resultdef:=left.resultdef;
- left:=nil;
- exit;
- end;
- realconstn :
- begin
- if (convtype = tc_real_2_currency) then
- result := typecheck_real_to_currency
- else if (convtype = tc_real_2_real) then
- result := typecheck_real_to_real
- else
- exit;
- if not(assigned(result)) then
- begin
- result := left;
- left := nil;
- end;
- if (result.nodetype = realconstn) then
- begin
- hp:=result;
- result:=crealconstnode.create(trealconstnode(hp).value_real,resultdef);
- if ([nf_explicit,nf_internal] * flags <> []) then
- include(result.flags, nf_explicit);
- hp.free;
- end;
- end;
- niln :
- begin
- { nil to ordinal node }
- if (resultdef.typ=orddef) then
- begin
- hp:=cordconstnode.create(0,resultdef,true);
- if ([nf_explicit,nf_internal] * flags <> []) then
- include(hp.flags, nf_explicit);
- result:=hp;
- exit;
- end
- else
- { fold nil to any pointer type }
- if (resultdef.typ=pointerdef) then
- begin
- hp:=cnilnode.create;
- hp.resultdef:=resultdef;
- if ([nf_explicit,nf_internal] * flags <> []) then
- include(hp.flags, nf_explicit);
- result:=hp;
- exit;
- end
- else
- { remove typeconv after niln, but not when the result is a
- methodpointer. The typeconv of the methodpointer will then
- take care of updateing size of niln to OS_64 }
- if not((resultdef.typ=procvardef) and
- not(tprocvardef(resultdef).is_addressonly)) then
- begin
- left.resultdef:=resultdef;
- if ([nf_explicit,nf_internal] * flags <> []) then
- include(left.flags, nf_explicit);
- result:=left;
- left:=nil;
- exit;
- end;
- end;
- ordconstn :
- begin
- { ordinal contants can be directly converted }
- { but not char to char because it is a widechar to char or via versa }
- { which needs extra code to do the code page transistion }
- { constant ordinal to pointer }
- if (resultdef.typ=pointerdef) and
- (convtype<>tc_cchar_2_pchar) then
- begin
- if (target_info.system in systems_managed_vm) and
- (tordconstnode(left).value<>0) then
- message(parser_e_feature_unsupported_for_vm);
- hp:=cpointerconstnode.create(TConstPtrUInt(tordconstnode(left).value.uvalue),resultdef);
- if ([nf_explicit,nf_internal] * flags <> []) then
- include(hp.flags, nf_explicit);
- result:=hp;
- exit;
- end
- else if is_ordinal(resultdef) and
- not(convtype=tc_char_2_char) then
- begin
- { replace the resultdef and recheck the range }
- if ([nf_explicit,nf_absolute, nf_internal] * flags <> []) then
- include(left.flags, nf_explicit)
- else
- { no longer an ordconst with an explicit typecast }
- exclude(left.flags, nf_explicit);
- { when converting from one boolean type to another, force }
- { booleans to 0/1, and byte/word/long/qwordbool to 0/-1 }
- { (Delphi-compatibile) }
- if is_boolean(left.resultdef) and
- is_boolean(resultdef) and
- (is_cbool(left.resultdef) or
- is_cbool(resultdef)) then
- begin
- if is_pasbool(resultdef) then
- tordconstnode(left).value:=ord(tordconstnode(left).value<>0)
- else
- tordconstnode(left).value:=-ord(tordconstnode(left).value<>0);
- end
- else
- begin
- { for constant values on absolute variables, swaping is required }
- if (target_info.endian = endian_big) and (nf_absolute in flags) then
- swap_const_value(tordconstnode(left).value,tordconstnode(left).resultdef.size);
- testrange(resultdef,tordconstnode(left).value,(nf_explicit in flags)
- or (nf_absolute in flags),false);
- { swap value back, but according to new type }
- if (target_info.endian = endian_big) and (nf_absolute in flags) then
- swap_const_value(tordconstnode(left).value,resultdef.size);
- end;
- left.resultdef:=resultdef;
- tordconstnode(left).typedef:=resultdef;
- if is_signed(resultdef) then
- tordconstnode(left).value.signed:=true
- else
- tordconstnode(left).value.signed:=false;
- result:=left;
- left:=nil;
- exit;
- end;
- end;
- pointerconstn :
- begin
- { pointerconstn to any pointer is folded too }
- if (resultdef.typ=pointerdef) then
- begin
- left.resultdef:=resultdef;
- if ([nf_explicit,nf_internal] * flags <> []) then
- include(left.flags, nf_explicit)
- else
- { no longer an ordconst with an explicit typecast }
- exclude(left.flags, nf_explicit);
- result:=left;
- left:=nil;
- exit;
- end
- { constant pointer to ordinal }
- else if is_ordinal(resultdef) then
- begin
- hp:=cordconstnode.create(TConstExprInt(tpointerconstnode(left).value),
- resultdef,not(nf_explicit in flags));
- if ([nf_explicit,nf_internal] * flags <> []) then
- include(hp.flags, nf_explicit);
- result:=hp;
- exit;
- end;
- end;
- end;
- {$ifndef CPUNO32BITOPS}
- { must be done before code below, because we need the
- typeconversions for ordconstn's as well }
- case convtype of
- tc_int_2_int:
- begin
- if (localswitches * [cs_check_range,cs_check_overflow] = []) and
- (resultdef.typ in [pointerdef,orddef,enumdef]) and
- (resultdef.size <= 4) and
- is_64bitint(left.resultdef) and
- (left.nodetype in [subn,addn,muln,divn,modn,xorn,andn,orn]) and
- checkremove64bittypeconvs(left,foundsint) then
- begin
- { avoid unnecessary widening of intermediary calculations }
- { to 64 bit }
- doremove64bittypeconvs(left,generrordef,not foundsint);
- end;
- end;
- end;
- {$endif not CPUNO32BITOPS}
- end;
- procedure Ttypeconvnode.mark_write;
- begin
- left.mark_write;
- end;
- function ttypeconvnode.first_cord_to_pointer : tnode;
- begin
- result:=nil;
- internalerror(200104043);
- end;
- function ttypeconvnode.first_int_to_int : tnode;
- begin
- first_int_to_int:=nil;
- expectloc:=left.expectloc;
- if not is_void(left.resultdef) then
- begin
- if (left.expectloc<>LOC_REGISTER) and
- ((resultdef.size>left.resultdef.size) or
- (left.expectloc in [LOC_SUBSETREF,LOC_CSUBSETREF,LOC_SUBSETREG,LOC_CSUBSETREG])) then
- expectloc:=LOC_REGISTER
- else
- if (left.expectloc=LOC_CREGISTER) and
- (resultdef.size<left.resultdef.size) then
- expectloc:=LOC_REGISTER;
- end;
- end;
- function ttypeconvnode.first_cstring_to_pchar : tnode;
- begin
- result:=nil;
- expectloc:=LOC_REGISTER;
- { Use of FPC_EMPTYCHAR label requires setting pi_needs_got flag }
- if (cs_create_pic in current_settings.moduleswitches) then
- include(current_procinfo.flags,pi_needs_got);
- end;
- function ttypeconvnode.first_cstring_to_int : tnode;
- begin
- result:=nil;
- internalerror(200510014);
- end;
- function ttypeconvnode.first_string_to_chararray : tnode;
- begin
- first_string_to_chararray:=nil;
- expectloc:=left.expectloc;
- end;
- function ttypeconvnode.first_char_to_string : tnode;
- begin
- first_char_to_string:=nil;
- if tstringdef(resultdef).stringtype=st_shortstring then
- inc(current_procinfo.estimatedtempsize,256);
- expectloc:=LOC_REFERENCE;
- end;
- function ttypeconvnode.first_char_to_chararray : tnode;
- begin
- if resultdef.size <> 1 then
- begin
- { convert first to string, then to chararray }
- inserttypeconv(left,cshortstringtype);
- inserttypeconv(left,resultdef);
- result:=left;
- left := nil;
- exit;
- end;
- result := nil;
- end;
- function ttypeconvnode.first_nothing : tnode;
- begin
- first_nothing:=nil;
- end;
- function ttypeconvnode.first_array_to_pointer : tnode;
- begin
- first_array_to_pointer:=nil;
- expectloc:=LOC_REGISTER;
- end;
- function ttypeconvnode.first_int_to_real: tnode;
- var
- fname: string[32];
- begin
- if target_info.system in systems_wince then
- begin
- { converting a 64bit integer to a float requires a helper }
- if is_64bitint(left.resultdef) or
- is_currency(left.resultdef) then
- begin
- { hack to avoid double division by 10000, as it's
- already done by typecheckpass.resultdef_int_to_real }
- if is_currency(left.resultdef) then
- left.resultdef := s64inttype;
- if is_signed(left.resultdef) then
- fname:='I64TO'
- else
- fname:='UI64TO';
- end
- else
- { other integers are supposed to be 32 bit }
- begin
- if is_signed(left.resultdef) then
- fname:='ITO'
- else
- fname:='UTO';
- firstpass(left);
- end;
- if tfloatdef(resultdef).floattype=s64real then
- fname:=fname+'D'
- else
- fname:=fname+'S';
- result:=ccallnode.createintern(fname,ccallparanode.create(
- left,nil));
- left:=nil;
- firstpass(result);
- exit;
- end
- else
- begin
- { converting a 64bit integer to a float requires a helper }
- if is_64bitint(left.resultdef) or
- is_currency(left.resultdef) then
- begin
- { hack to avoid double division by 10000, as it's
- already done by typecheckpass.resultdef_int_to_real }
- if is_currency(left.resultdef) then
- left.resultdef := s64inttype;
- if is_signed(left.resultdef) then
- fname:='int64_to_'
- else
- { we can't do better currently }
- fname:='qword_to_';
- end
- else
- { other integers are supposed to be 32 bit }
- begin
- if is_signed(left.resultdef) then
- fname:='int32_to_'
- else
- fname:='int64_to_';
- firstpass(left);
- end;
- if tfloatdef(resultdef).floattype=s64real then
- fname:=fname+'float64'
- else
- fname:=fname+'float32';
- result:=ctypeconvnode.create_internal(ccallnode.createintern(fname,ccallparanode.create(
- left,nil)),resultdef);
- left:=nil;
- firstpass(result);
- exit;
- end;
- end;
- function ttypeconvnode.first_real_to_real : tnode;
- begin
- {$ifdef cpufpemu}
- if cs_fp_emulation in current_settings.moduleswitches then
- begin
- if target_info.system in systems_wince then
- begin
- case tfloatdef(left.resultdef).floattype of
- s32real:
- case tfloatdef(resultdef).floattype of
- s64real:
- result:=ccallnode.createintern('STOD',ccallparanode.create(left,nil));
- s32real:
- begin
- result:=left;
- left:=nil;
- end;
- else
- internalerror(2005082704);
- end;
- s64real:
- case tfloatdef(resultdef).floattype of
- s32real:
- result:=ccallnode.createintern('DTOS',ccallparanode.create(left,nil));
- s64real:
- begin
- result:=left;
- left:=nil;
- end;
- else
- internalerror(2005082703);
- end;
- else
- internalerror(2005082702);
- end;
- left:=nil;
- firstpass(result);
- exit;
- end
- else
- begin
- case tfloatdef(left.resultdef).floattype of
- s32real:
- case tfloatdef(resultdef).floattype of
- s64real:
- result:=ctypeconvnode.create_explicit(ccallnode.createintern('float32_to_float64',ccallparanode.create(
- ctypeconvnode.create_internal(left,search_system_type('FLOAT32REC').typedef),nil)),resultdef);
- s32real:
- begin
- result:=left;
- left:=nil;
- end;
- else
- internalerror(200610151);
- end;
- s64real:
- case tfloatdef(resultdef).floattype of
- s32real:
- result:=ctypeconvnode.create_explicit(ccallnode.createintern('float64_to_float32',ccallparanode.create(
- ctypeconvnode.create_internal(left,search_system_type('FLOAT64').typedef),nil)),resultdef);
- s64real:
- begin
- result:=left;
- left:=nil;
- end;
- else
- internalerror(200610152);
- end;
- else
- internalerror(200610153);
- end;
- left:=nil;
- firstpass(result);
- exit;
- end;
- end
- else
- {$endif cpufpemu}
- begin
- first_real_to_real:=nil;
- if not use_vectorfpu(resultdef) then
- expectloc:=LOC_FPUREGISTER
- else
- expectloc:=LOC_MMREGISTER;
- end;
- end;
- function ttypeconvnode.first_pointer_to_array : tnode;
- begin
- first_pointer_to_array:=nil;
- expectloc:=LOC_REFERENCE;
- end;
- function ttypeconvnode.first_cchar_to_pchar : tnode;
- begin
- first_cchar_to_pchar:=nil;
- internalerror(200104021);
- end;
- function ttypeconvnode.first_bool_to_int : tnode;
- begin
- first_bool_to_int:=nil;
- { byte(boolean) or word(wordbool) or longint(longbool) must
- be accepted for var parameters }
- if (nf_explicit in flags) and
- (left.resultdef.size=resultdef.size) and
- (left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then
- exit;
- expectloc:=LOC_REGISTER;
- end;
- function ttypeconvnode.first_int_to_bool : tnode;
- begin
- first_int_to_bool:=nil;
- { byte(boolean) or word(wordbool) or longint(longbool) must
- be accepted for var parameters }
- if (nf_explicit in flags) and
- (left.resultdef.size=resultdef.size) and
- (left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then
- exit;
- { when converting 64bit int to C-ctyle boolean, first convert to an int32 and then }
- { convert to a boolean (only necessary for 32bit processors) }
- if (left.resultdef.size > sizeof(aint)) and (left.resultdef.size<>resultdef.size)
- and is_cbool(resultdef) then
- begin
- left:=ctypeconvnode.create_internal(left,s32inttype);
- firstpass(left);
- exit;
- end;
- expectloc:=LOC_REGISTER;
- end;
- function ttypeconvnode.first_bool_to_bool : tnode;
- begin
- first_bool_to_bool:=nil;
- if (left.expectloc in [LOC_FLAGS,LOC_JUMP]) and
- not is_cbool(resultdef) then
- expectloc := left.expectloc
- else
- expectloc:=LOC_REGISTER;
- end;
- function ttypeconvnode.first_char_to_char : tnode;
- var
- fname: string[18];
- begin
- if (torddef(resultdef).ordtype=uchar) and
- (torddef(left.resultdef).ordtype=uwidechar) then
- fname := 'fpc_uchar_to_char'
- else if (torddef(resultdef).ordtype=uwidechar) and
- (torddef(left.resultdef).ordtype=uchar) then
- fname := 'fpc_char_to_uchar'
- else
- internalerror(2007081201);
- result := ccallnode.createintern(fname,ccallparanode.create(left,nil));
- left:=nil;
- firstpass(result);
- end;
- function ttypeconvnode.first_proc_to_procvar : tnode;
- begin
- first_proc_to_procvar:=nil;
- { if we take the address of a nested function, the current function/
- procedure needs a stack frame since it's required to construct
- the nested procvar }
- if is_nested_pd(tprocvardef(resultdef)) then
- include(current_procinfo.flags,pi_needs_stackframe);
- if tabstractprocdef(resultdef).is_addressonly then
- expectloc:=LOC_REGISTER
- else
- expectloc:=left.expectloc;
- end;
- function ttypeconvnode.first_nil_to_methodprocvar : tnode;
- begin
- first_nil_to_methodprocvar:=nil;
- expectloc:=LOC_REGISTER;
- end;
- function ttypeconvnode.first_set_to_set : tnode;
- var
- newstatement : tstatementnode;
- temp : ttempcreatenode;
- begin
- { in theory, we should do range checking here,
- but Delphi doesn't do it either (FK) }
- if left.nodetype=setconstn then
- begin
- left.resultdef:=resultdef;
- result:=left;
- left:=nil;
- end
- { equal sets for the code generator? }
- else if (left.resultdef.size=resultdef.size) and
- (tsetdef(left.resultdef).setbase=tsetdef(resultdef).setbase) then
- { TODO: This causes wrong (but Delphi-compatible) results for disjoint subsets}
- { e.g., this prints true because of this:
- var
- sa: set of 1..2;
- sb: set of 5..6;
- b: byte;
- begin
- b:=1;
- sa:=[1..2];
- sb:=sa;
- writeln(b in sb);
- end.
- }
- begin
- result:=left;
- left:=nil;
- end
- else
- begin
- result:=internalstatements(newstatement);
- { in case left is a smallset expression, it can be an addn or so. }
- { fpc_varset_load expects a formal const parameter, which doesn't }
- { accept set addn's -> assign to a temp first and pass the temp }
- if not(left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE]) then
- begin
- temp:=ctempcreatenode.create(left.resultdef,left.resultdef.size,tt_persistent,false);
- addstatement(newstatement,temp);
- { temp := left }
- addstatement(newstatement,cassignmentnode.create(
- ctemprefnode.create(temp),left));
- addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
- addstatement(newstatement,ctemprefnode.create(temp));
- left:=result;
- firstpass(left);
- { recreate the result's internalstatements list }
- result:=internalstatements(newstatement);
- end;
- { create temp for result }
- temp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true);
- addstatement(newstatement,temp);
- addstatement(newstatement,ccallnode.createintern('fpc_varset_load',
- ccallparanode.create(cordconstnode.create(tsetdef(left.resultdef).setbase div 8 - tsetdef(resultdef).setbase div 8,sinttype,false),
- ccallparanode.create(cordconstnode.create(resultdef.size,sinttype,false),
- ccallparanode.create(ctemprefnode.create(temp),
- ccallparanode.create(cordconstnode.create(left.resultdef.size,sinttype,false),
- ccallparanode.create(left,nil))))))
- );
- addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
- addstatement(newstatement,ctemprefnode.create(temp));
- left:=nil;
- end;
- end;
- function ttypeconvnode.first_ansistring_to_pchar : tnode;
- begin
- first_ansistring_to_pchar:=nil;
- expectloc:=LOC_REGISTER;
- { Use of FPC_EMPTYCHAR label requires setting pi_needs_got flag }
- if (cs_create_pic in current_settings.moduleswitches) then
- include(current_procinfo.flags,pi_needs_got);
- end;
- function ttypeconvnode.first_arrayconstructor_to_set : tnode;
- begin
- first_arrayconstructor_to_set:=nil;
- internalerror(200104022);
- end;
- function ttypeconvnode.first_class_to_intf : tnode;
- var
- hd : tobjectdef;
- ImplIntf : TImplementedInterface;
- begin
- result:=nil;
- expectloc:=LOC_REGISTER;
- hd:=tobjectdef(left.resultdef);
- while assigned(hd) do
- begin
- ImplIntf:=find_implemented_interface(hd,tobjectdef(resultdef));
- if assigned(ImplIntf) then
- begin
- case ImplIntf.IType of
- etStandard:
- { handle in pass 2 }
- ;
- etFieldValue, etFieldValueClass:
- if is_interface(tobjectdef(resultdef)) then
- begin
- result:=left;
- propaccesslist_to_node(result,tpropertysym(implintf.implementsgetter).owner,tpropertysym(implintf.implementsgetter).propaccesslist[palt_read]);
- { this ensures proper refcounting when field is of class type }
- if not is_interface(result.resultdef) then
- inserttypeconv(result, resultdef);
- left:=nil;
- end
- else
- begin
- internalerror(200802213);
- end;
- etStaticMethodResult, etStaticMethodClass,
- etVirtualMethodResult, etVirtualMethodClass:
- if is_interface(tobjectdef(resultdef)) then
- begin
- { TODO: generating a call to TObject.GetInterface instead could yield
- smaller code size. OTOH, refcounting gotchas are possible that way. }
- { constructor create(l:tnode; v : tprocsym;st : TSymtable; mp: tnode; callflags:tcallnodeflags); }
- result:=ccallnode.create(nil,tprocsym(tpropertysym(implintf.implementsgetter).propaccesslist[palt_read].firstsym^.sym),
- tprocsym(tpropertysym(implintf.implementsgetter).propaccesslist[palt_read].firstsym^.sym).owner,
- left,[]);
- addsymref(tpropertysym(implintf.implementsgetter).propaccesslist[palt_read].firstsym^.sym);
- { if it is a class, process it further in a similar way }
- if not is_interface(result.resultdef) then
- inserttypeconv(result, resultdef);
- left:=nil;
- end
- else if is_class(tobjectdef(resultdef)) then
- begin
- internalerror(200802211);
- end
- else
- internalerror(200802231);
- else
- internalerror(200802165);
- end;
- break;
- end;
- hd:=hd.childof;
- end;
- if hd=nil then
- internalerror(200802164);
- end;
- function ttypeconvnode.first_string_to_string : tnode;
- var
- procname: string[31];
- newblock : tblocknode;
- newstat : tstatementnode;
- restemp : ttempcreatenode;
- begin
- { get the correct procedure name }
- procname := 'fpc_'+tstringdef(left.resultdef).stringtypname+
- '_to_'+tstringdef(resultdef).stringtypname;
- if tstringdef(resultdef).stringtype=st_shortstring then
- begin
- newblock:=internalstatements(newstat);
- restemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,false);
- addstatement(newstat,restemp);
- addstatement(newstat,ccallnode.createintern(procname,ccallparanode.create(left,ccallparanode.create(
- ctemprefnode.create(restemp),nil))));
- addstatement(newstat,ctempdeletenode.create_normal_temp(restemp));
- addstatement(newstat,ctemprefnode.create(restemp));
- result:=newblock;
- end
- { encoding parameter required? }
- else if (tstringdef(resultdef).stringtype=st_ansistring) and
- (tstringdef(left.resultdef).stringtype in [st_widestring,st_unicodestring,st_shortstring,st_ansistring]) then
- result:=ccallnode.createinternres(procname,
- ccallparanode.create(cordconstnode.create(getparaencoding(resultdef),u16inttype,true),
- ccallparanode.create(left,nil)),resultdef)
- else
- result:=ccallnode.createinternres(procname,ccallparanode.create(left,nil),resultdef);
- left:=nil;
- end;
- function ttypeconvnode._first_int_to_int : tnode;
- begin
- result:=first_int_to_int;
- end;
- function ttypeconvnode._first_cstring_to_pchar : tnode;
- begin
- result:=first_cstring_to_pchar;
- end;
- function ttypeconvnode._first_cstring_to_int : tnode;
- begin
- result:=first_cstring_to_int;
- end;
- function ttypeconvnode._first_string_to_chararray : tnode;
- begin
- result:=first_string_to_chararray;
- end;
- function ttypeconvnode._first_char_to_string : tnode;
- begin
- result:=first_char_to_string;
- end;
- function ttypeconvnode._first_char_to_chararray: tnode;
- begin
- result:=first_char_to_chararray;
- end;
- function ttypeconvnode._first_nothing : tnode;
- begin
- result:=first_nothing;
- end;
- function ttypeconvnode._first_array_to_pointer : tnode;
- begin
- result:=first_array_to_pointer;
- end;
- function ttypeconvnode._first_int_to_real : tnode;
- begin
- result:=first_int_to_real;
- end;
- function ttypeconvnode._first_real_to_real : tnode;
- begin
- result:=first_real_to_real;
- end;
- function ttypeconvnode._first_pointer_to_array : tnode;
- begin
- result:=first_pointer_to_array;
- end;
- function ttypeconvnode._first_cchar_to_pchar : tnode;
- begin
- result:=first_cchar_to_pchar;
- end;
- function ttypeconvnode._first_bool_to_int : tnode;
- begin
- result:=first_bool_to_int;
- end;
- function ttypeconvnode._first_int_to_bool : tnode;
- begin
- result:=first_int_to_bool;
- end;
- function ttypeconvnode._first_bool_to_bool : tnode;
- begin
- result:=first_bool_to_bool;
- end;
- function ttypeconvnode._first_proc_to_procvar : tnode;
- begin
- result:=first_proc_to_procvar;
- end;
- function ttypeconvnode._first_nil_to_methodprocvar : tnode;
- begin
- result:=first_nil_to_methodprocvar;
- end;
- function ttypeconvnode._first_set_to_set : tnode;
- begin
- result:=first_set_to_set;
- end;
- function ttypeconvnode._first_cord_to_pointer : tnode;
- begin
- result:=first_cord_to_pointer;
- end;
- function ttypeconvnode._first_ansistring_to_pchar : tnode;
- begin
- result:=first_ansistring_to_pchar;
- end;
- function ttypeconvnode._first_arrayconstructor_to_set : tnode;
- begin
- result:=first_arrayconstructor_to_set;
- end;
- function ttypeconvnode._first_class_to_intf : tnode;
- begin
- result:=first_class_to_intf;
- end;
- function ttypeconvnode._first_char_to_char : tnode;
- begin
- result:=first_char_to_char;
- end;
- function ttypeconvnode._first_string_to_string : tnode;
- begin
- result:=first_string_to_string;
- end;
- function ttypeconvnode.first_call_helper(c : tconverttype) : tnode;
- const
- firstconvert : array[tconverttype] of pointer = (
- nil, { none }
- @ttypeconvnode._first_nothing, {equal}
- @ttypeconvnode._first_nothing, {not_possible}
- @ttypeconvnode._first_string_to_string,
- @ttypeconvnode._first_char_to_string,
- @ttypeconvnode._first_char_to_chararray,
- nil, { removed in typecheck_chararray_to_string }
- @ttypeconvnode._first_cchar_to_pchar,
- @ttypeconvnode._first_cstring_to_pchar,
- @ttypeconvnode._first_cstring_to_int,
- @ttypeconvnode._first_ansistring_to_pchar,
- @ttypeconvnode._first_string_to_chararray,
- nil, { removed in typecheck_chararray_to_string }
- @ttypeconvnode._first_array_to_pointer,
- @ttypeconvnode._first_pointer_to_array,
- @ttypeconvnode._first_int_to_int,
- @ttypeconvnode._first_int_to_bool,
- @ttypeconvnode._first_bool_to_bool,
- @ttypeconvnode._first_bool_to_int,
- @ttypeconvnode._first_real_to_real,
- @ttypeconvnode._first_int_to_real,
- nil, { removed in typecheck_real_to_currency }
- @ttypeconvnode._first_proc_to_procvar,
- @ttypeconvnode._first_nil_to_methodprocvar,
- @ttypeconvnode._first_arrayconstructor_to_set,
- @ttypeconvnode._first_set_to_set,
- @ttypeconvnode._first_cord_to_pointer,
- @ttypeconvnode._first_nothing,
- @ttypeconvnode._first_nothing,
- @ttypeconvnode._first_class_to_intf,
- @ttypeconvnode._first_char_to_char,
- @ttypeconvnode._first_nothing,
- @ttypeconvnode._first_nothing,
- nil,
- nil,
- nil,
- nil,
- nil,
- nil,
- nil,
- @ttypeconvnode._first_nothing
- );
- type
- tprocedureofobject = function : tnode of object;
- var
- r : packed record
- proc : pointer;
- obj : pointer;
- end;
- begin
- { this is a little bit dirty but it works }
- { and should be quite portable too }
- r.proc:=firstconvert[c];
- r.obj:=self;
- if not assigned(r.proc) then
- internalerror(200312081);
- first_call_helper:=tprocedureofobject(r)()
- end;
- function ttypeconvnode.pass_1 : tnode;
- begin
- if warn_pointer_to_signed then
- cgmessage(type_w_pointer_to_signed);
- result:=nil;
- firstpass(left);
- if codegenerror then
- exit;
- expectloc:=left.expectloc;
- if nf_explicit in flags then
- { check if the result could be in a register }
- if (not(tstoreddef(resultdef).is_intregable) and
- not(tstoreddef(resultdef).is_fpuregable)) or
- ((left.resultdef.typ = floatdef) and
- (resultdef.typ <> floatdef)) then
- make_not_regable(left,[ra_addr_regable]);
- result:=first_call_helper(convtype);
- end;
- function ttypeconvnode.retains_value_location:boolean;
- begin
- result:=(convtype=tc_equal) or
- { typecasting from void is always allowed }
- is_void(left.resultdef) or
- (left.resultdef.typ=formaldef) or
- { int 2 int with same size reuses same location, or for
- tp7 mode also allow size < orignal size }
- (
- (convtype=tc_int_2_int) and
- (
- not is_bitpacked_access(left) and
- (resultdef.size=left.resultdef.size) or
- ((m_tp7 in current_settings.modeswitches) and
- (resultdef.size<left.resultdef.size))
- )
- ) or
- { int 2 bool/bool 2 int, explicit typecast, see also nx86cnv }
- ((convtype in [tc_int_2_bool,tc_bool_2_int,tc_bool_2_bool]) and
- (nf_explicit in flags) and
- (resultdef.size=left.resultdef.size)) or
- { on managed platforms, converting an element to an open array
- involves creating an actual array -> value location changes }
- ((convtype=tc_elem_2_openarray) and
- not(target_info.system in systems_managed_vm));
- end;
- function ttypeconvnode.assign_allowed:boolean;
- begin
- result:=retains_value_location;
- { When using only a part of the value it can't be in a register since
- that will load the value in a new register first }
- { the same goes for changing the sign of equal-sized values which
- are smaller than an entire register }
- if result and
- { don't try to check the size of an open array }
- (is_open_array(resultdef) or
- (resultdef.size<left.resultdef.size) or
- ((resultdef.size=left.resultdef.size) and
- (left.resultdef.size<sizeof(aint)) and
- (is_signed(resultdef) xor is_signed(left.resultdef)))) then
- make_not_regable(left,[ra_addr_regable]);
- end;
- function ttypeconvnode.docompare(p: tnode) : boolean;
- begin
- docompare :=
- inherited docompare(p) and
- (convtype = ttypeconvnode(p).convtype) and
- equal_defs(totypedef,ttypeconvnode(p).totypedef);
- end;
- procedure ttypeconvnode._second_int_to_int;
- begin
- second_int_to_int;
- end;
- procedure ttypeconvnode._second_string_to_string;
- begin
- second_string_to_string;
- end;
- procedure ttypeconvnode._second_cstring_to_pchar;
- begin
- second_cstring_to_pchar;
- end;
- procedure ttypeconvnode._second_cstring_to_int;
- begin
- second_cstring_to_int;
- end;
- procedure ttypeconvnode._second_string_to_chararray;
- begin
- second_string_to_chararray;
- end;
- procedure ttypeconvnode._second_array_to_pointer;
- begin
- second_array_to_pointer;
- end;
- procedure ttypeconvnode._second_pointer_to_array;
- begin
- second_pointer_to_array;
- end;
- procedure ttypeconvnode._second_chararray_to_string;
- begin
- second_chararray_to_string;
- end;
- procedure ttypeconvnode._second_char_to_string;
- begin
- second_char_to_string;
- end;
- procedure ttypeconvnode._second_int_to_real;
- begin
- second_int_to_real;
- end;
- procedure ttypeconvnode._second_real_to_real;
- begin
- second_real_to_real;
- end;
- procedure ttypeconvnode._second_cord_to_pointer;
- begin
- second_cord_to_pointer;
- end;
- procedure ttypeconvnode._second_proc_to_procvar;
- begin
- second_proc_to_procvar;
- end;
- procedure ttypeconvnode._second_nil_to_methodprocvar;
- begin
- second_nil_to_methodprocvar;
- end;
- procedure ttypeconvnode._second_bool_to_int;
- begin
- second_bool_to_int;
- end;
- procedure ttypeconvnode._second_int_to_bool;
- begin
- second_int_to_bool;
- end;
- procedure ttypeconvnode._second_bool_to_bool;
- begin
- second_bool_to_bool;
- end;
- procedure ttypeconvnode._second_set_to_set;
- begin
- second_set_to_set;
- end;
- procedure ttypeconvnode._second_ansistring_to_pchar;
- begin
- second_ansistring_to_pchar;
- end;
- procedure ttypeconvnode._second_class_to_intf;
- begin
- second_class_to_intf;
- end;
- procedure ttypeconvnode._second_char_to_char;
- begin
- second_char_to_char;
- end;
- procedure ttypeconvnode._second_elem_to_openarray;
- begin
- second_elem_to_openarray;
- end;
- procedure ttypeconvnode._second_nothing;
- begin
- second_nothing;
- end;
- procedure ttypeconvnode.second_call_helper(c : tconverttype);
- const
- secondconvert : array[tconverttype] of pointer = (
- @ttypeconvnode._second_nothing, {none}
- @ttypeconvnode._second_nothing, {equal}
- @ttypeconvnode._second_nothing, {not_possible}
- @ttypeconvnode._second_nothing, {second_string_to_string, handled in resultdef pass }
- @ttypeconvnode._second_char_to_string,
- @ttypeconvnode._second_nothing, {char_to_charray}
- @ttypeconvnode._second_nothing, { pchar_to_string, handled in resultdef pass }
- @ttypeconvnode._second_nothing, {cchar_to_pchar}
- @ttypeconvnode._second_cstring_to_pchar,
- @ttypeconvnode._second_cstring_to_int,
- @ttypeconvnode._second_ansistring_to_pchar,
- @ttypeconvnode._second_string_to_chararray,
- @ttypeconvnode._second_nothing, { chararray_to_string, handled in resultdef pass }
- @ttypeconvnode._second_array_to_pointer,
- @ttypeconvnode._second_pointer_to_array,
- @ttypeconvnode._second_int_to_int,
- @ttypeconvnode._second_int_to_bool,
- @ttypeconvnode._second_bool_to_bool,
- @ttypeconvnode._second_bool_to_int,
- @ttypeconvnode._second_real_to_real,
- @ttypeconvnode._second_int_to_real,
- @ttypeconvnode._second_nothing, { real_to_currency, handled in resultdef pass }
- @ttypeconvnode._second_proc_to_procvar,
- @ttypeconvnode._second_nil_to_methodprocvar,
- @ttypeconvnode._second_nothing, { arrayconstructor_to_set }
- @ttypeconvnode._second_nothing, { second_set_to_set, handled in first pass }
- @ttypeconvnode._second_cord_to_pointer,
- @ttypeconvnode._second_nothing, { interface 2 string }
- @ttypeconvnode._second_nothing, { interface 2 guid }
- @ttypeconvnode._second_class_to_intf,
- @ttypeconvnode._second_char_to_char,
- @ttypeconvnode._second_nothing, { dynarray_2_openarray }
- @ttypeconvnode._second_nothing, { pwchar_2_string }
- @ttypeconvnode._second_nothing, { variant_2_dynarray }
- @ttypeconvnode._second_nothing, { dynarray_2_variant}
- @ttypeconvnode._second_nothing, { variant_2_enum }
- @ttypeconvnode._second_nothing, { enum_2_variant }
- @ttypeconvnode._second_nothing, { variant_2_interface }
- @ttypeconvnode._second_nothing, { interface_2_variant }
- @ttypeconvnode._second_nothing, { array_2_dynarray }
- @ttypeconvnode._second_elem_to_openarray { elem_2_openarray }
- );
- type
- tprocedureofobject = procedure of object;
- var
- r : packed record
- proc : pointer;
- obj : pointer;
- end;
- begin
- { this is a little bit dirty but it works }
- { and should be quite portable too }
- r.proc:=secondconvert[c];
- r.obj:=self;
- tprocedureofobject(r)();
- end;
- {*****************************************************************************
- TASNODE
- *****************************************************************************}
- function tasisnode.target_specific_typecheck: boolean;
- begin
- result:=false;
- end;
- function tasisnode.pass_typecheck: tnode;
- var
- hp : tnode;
- begin
- result:=nil;
- typecheckpass(right);
- typecheckpass(left);
- set_varstate(right,vs_read,[vsf_must_be_valid]);
- set_varstate(left,vs_read,[vsf_must_be_valid]);
- if codegenerror then
- exit;
- if target_specific_typecheck then
- begin
- // ok
- end
- else if (right.resultdef.typ=classrefdef) then
- begin
- { left maybe an interface reference }
- if is_interfacecom(left.resultdef) or
- is_javainterface(left.resultdef) then
- begin
- { relation checks are not possible }
- end
- { or left must be a class }
- else if is_class(left.resultdef) or
- is_javaclass(left.resultdef) then
- begin
- { the operands must be related }
- if (not(def_is_related(tobjectdef(left.resultdef),
- tobjectdef(tclassrefdef(right.resultdef).pointeddef)))) and
- (not(def_is_related(tobjectdef(tclassrefdef(right.resultdef).pointeddef),
- tobjectdef(left.resultdef)))) then
- CGMessage2(type_e_classes_not_related,
- FullTypeName(left.resultdef,tclassrefdef(right.resultdef).pointeddef),
- FullTypeName(tclassrefdef(right.resultdef).pointeddef,left.resultdef));
- end
- else
- CGMessage1(type_e_class_or_cominterface_type_expected,left.resultdef.typename);
- case nodetype of
- isn:
- resultdef:=pasbool8type;
- asn:
- resultdef:=tclassrefdef(right.resultdef).pointeddef;
- end;
- end
- else if is_interface(right.resultdef) or
- is_dispinterface(right.resultdef) or
- is_javainterface(right.resultdef) then
- begin
- case nodetype of
- isn:
- resultdef:=pasbool8type;
- asn:
- resultdef:=right.resultdef;
- end;
- { left is a class or interface }
- if is_javainterface(right.resultdef) then
- begin
- if not is_java_class_or_interface(left.resultdef) then
- CGMessage1(type_e_class_or_cominterface_type_expected,left.resultdef.typename);
- end
- else if not(is_class(left.resultdef) or
- is_interfacecom(left.resultdef)) then
- CGMessage1(type_e_class_or_cominterface_type_expected,left.resultdef.typename)
- else
- begin
- { load the GUID of the interface }
- if (right.nodetype=typen) then
- begin
- if tobjectdef(right.resultdef).objecttype=odt_interfacecorba then
- begin
- if assigned(tobjectdef(right.resultdef).iidstr) then
- begin
- hp:=cstringconstnode.createstr(tobjectdef(right.resultdef).iidstr^);
- tstringconstnode(hp).changestringtype(cshortstringtype);
- right.free;
- right:=hp;
- end
- else
- internalerror(201006131);
- end
- else
- begin
- if assigned(tobjectdef(right.resultdef).iidguid) then
- begin
- if not(oo_has_valid_guid in tobjectdef(right.resultdef).objectoptions) then
- CGMessage1(type_e_interface_has_no_guid,tobjectdef(right.resultdef).typename);
- hp:=cguidconstnode.create(tobjectdef(right.resultdef).iidguid^);
- right.free;
- right:=hp;
- end
- else
- internalerror(201006132);
- end;
- typecheckpass(right);
- end;
- end;
- end
- else
- CGMessage1(type_e_class_or_interface_type_expected,right.resultdef.typename);
- end;
- {*****************************************************************************
- TISNODE
- *****************************************************************************}
- constructor tisnode.create(l,r : tnode);
- begin
- inherited create(isn,l,r);
- end;
- constructor tisnode.create_internal(l, r: tnode);
- begin
- create(l,r);
- include(flags,nf_internal);
- end;
- function tisnode.pass_1 : tnode;
- var
- procname: string;
- begin
- result:=nil;
- { Passing a class type to an "is" expression cannot result in a class
- of that type to be constructed.
- }
- include(right.flags,nf_ignore_for_wpo);
- if is_class(left.resultdef) and
- (right.resultdef.typ=classrefdef) then
- result := ccallnode.createinternres('fpc_do_is',
- ccallparanode.create(left,ccallparanode.create(right,nil)),
- resultdef)
- else
- begin
- if is_class(left.resultdef) then
- if is_shortstring(right.resultdef) then
- procname := 'fpc_class_is_corbaintf'
- else
- procname := 'fpc_class_is_intf'
- else
- if right.resultdef.typ=classrefdef then
- procname := 'fpc_intf_is_class'
- else
- procname := 'fpc_intf_is';
- result := ctypeconvnode.create_internal(ccallnode.createintern(procname,
- ccallparanode.create(right,ccallparanode.create(left,nil))),resultdef);
- end;
- left := nil;
- right := nil;
- //firstpass(call);
- if codegenerror then
- exit;
- end;
- { dummy pass_2, it will never be called, but we need one since }
- { you can't instantiate an abstract class }
- procedure tisnode.pass_generate_code;
- begin
- end;
- {*****************************************************************************
- TASNODE
- *****************************************************************************}
- constructor tasnode.create(l,r : tnode);
- begin
- inherited create(asn,l,r);
- call := nil;
- end;
- constructor tasnode.create_internal(l,r : tnode);
- begin
- create(l,r);
- include(flags,nf_internal);
- end;
- destructor tasnode.destroy;
- begin
- call.free;
- inherited destroy;
- end;
- function tasnode.dogetcopy: tnode;
- begin
- result := inherited dogetcopy;
- if assigned(call) then
- tasnode(result).call := call.getcopy
- else
- tasnode(result).call := nil;
- end;
- function tasnode.docompare(p: tnode): boolean;
- begin
- result:=
- inherited docompare(p) and
- tasnode(p).call.isequal(call);
- end;
- function tasnode.pass_1 : tnode;
- var
- procname: string;
- begin
- result:=nil;
- { Passing a class type to an "as" expression cannot result in a class
- of that type to be constructed.
- }
- include(right.flags,nf_ignore_for_wpo);
- if not assigned(call) then
- begin
- if is_class(left.resultdef) and
- (right.resultdef.typ=classrefdef) then
- call := ccallnode.createinternres('fpc_do_as',
- ccallparanode.create(left,ccallparanode.create(right,nil)),
- resultdef)
- else
- begin
- if is_class(left.resultdef) then
- if is_shortstring(right.resultdef) then
- procname := 'fpc_class_as_corbaintf'
- else
- procname := 'fpc_class_as_intf'
- else
- if right.resultdef.typ=classrefdef then
- procname := 'fpc_intf_as_class'
- else
- procname := 'fpc_intf_as';
- call := ctypeconvnode.create_internal(ccallnode.createintern(procname,
- ccallparanode.create(right,ccallparanode.create(left,nil))),resultdef);
- end;
- left := nil;
- right := nil;
- firstpass(call);
- if codegenerror then
- exit;
- expectloc:=call.expectloc;
- end;
- end;
- end.
|