intrinsic.c 161 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156415741584159416041614162416341644165416641674168416941704171417241734174417541764177417841794180418141824183418441854186418741884189419041914192419341944195419641974198419942004201420242034204420542064207420842094210421142124213421442154216421742184219422042214222422342244225422642274228422942304231423242334234423542364237423842394240424142424243424442454246424742484249425042514252425342544255425642574258425942604261426242634264426542664267426842694270427142724273427442754276427742784279428042814282428342844285428642874288428942904291429242934294429542964297429842994300430143024303430443054306430743084309431043114312431343144315431643174318431943204321432243234324432543264327432843294330433143324333433443354336433743384339434043414342434343444345434643474348434943504351435243534354435543564357435843594360436143624363436443654366436743684369437043714372437343744375437643774378437943804381438243834384438543864387438843894390439143924393439443954396439743984399440044014402440344044405440644074408440944104411441244134414441544164417441844194420442144224423442444254426442744284429443044314432443344344435443644374438443944404441444244434444444544464447444844494450445144524453445444554456445744584459446044614462446344644465446644674468446944704471447244734474447544764477447844794480448144824483448444854486448744884489449044914492449344944495449644974498449945004501450245034504450545064507450845094510451145124513451445154516451745184519452045214522452345244525452645274528452945304531453245334534453545364537453845394540454145424543454445454546454745484549455045514552455345544555455645574558455945604561456245634564456545664567456845694570457145724573457445754576457745784579458045814582458345844585458645874588458945904591459245934594459545964597459845994600460146024603460446054606460746084609461046114612461346144615461646174618461946204621462246234624462546264627462846294630463146324633463446354636463746384639464046414642464346444645464646474648464946504651465246534654465546564657465846594660466146624663466446654666466746684669467046714672467346744675467646774678467946804681468246834684468546864687468846894690469146924693469446954696469746984699470047014702470347044705470647074708470947104711471247134714471547164717471847194720472147224723472447254726472747284729473047314732473347344735473647374738473947404741474247434744474547464747474847494750475147524753475447554756475747584759476047614762476347644765476647674768476947704771477247734774477547764777477847794780478147824783478447854786478747884789479047914792479347944795479647974798479948004801480248034804480548064807480848094810481148124813481448154816481748184819482048214822482348244825482648274828482948304831483248334834483548364837
  1. /* Build up a list of intrinsic subroutines and functions for the
  2. name-resolution stage.
  3. Copyright (C) 2000-2015 Free Software Foundation, Inc.
  4. Contributed by Andy Vaught & Katherine Holcomb
  5. This file is part of GCC.
  6. GCC is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU General Public License as published by the Free
  8. Software Foundation; either version 3, or (at your option) any later
  9. version.
  10. GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  11. WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
  13. for more details.
  14. You should have received a copy of the GNU General Public License
  15. along with GCC; see the file COPYING3. If not see
  16. <http://www.gnu.org/licenses/>. */
  17. #include "config.h"
  18. #include "system.h"
  19. #include "coretypes.h"
  20. #include "flags.h"
  21. #include "gfortran.h"
  22. #include "intrinsic.h"
  23. /* Namespace to hold the resolved symbols for intrinsic subroutines. */
  24. static gfc_namespace *gfc_intrinsic_namespace;
  25. bool gfc_init_expr_flag = false;
  26. /* Pointers to an intrinsic function and its argument names that are being
  27. checked. */
  28. const char *gfc_current_intrinsic;
  29. gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];
  30. locus *gfc_current_intrinsic_where;
  31. static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym;
  32. static gfc_intrinsic_sym *char_conversions;
  33. static gfc_intrinsic_arg *next_arg;
  34. static int nfunc, nsub, nargs, nconv, ncharconv;
  35. static enum
  36. { SZ_NOTHING = 0, SZ_SUBS, SZ_FUNCS, SZ_CONVS }
  37. sizing;
  38. enum klass
  39. { CLASS_IMPURE = 0, CLASS_PURE, CLASS_ELEMENTAL,
  40. CLASS_INQUIRY, CLASS_TRANSFORMATIONAL, CLASS_ATOMIC };
  41. #define ACTUAL_NO 0
  42. #define ACTUAL_YES 1
  43. #define REQUIRED 0
  44. #define OPTIONAL 1
  45. /* Return a letter based on the passed type. Used to construct the
  46. name of a type-dependent subroutine. */
  47. char
  48. gfc_type_letter (bt type)
  49. {
  50. char c;
  51. switch (type)
  52. {
  53. case BT_LOGICAL:
  54. c = 'l';
  55. break;
  56. case BT_CHARACTER:
  57. c = 's';
  58. break;
  59. case BT_INTEGER:
  60. c = 'i';
  61. break;
  62. case BT_REAL:
  63. c = 'r';
  64. break;
  65. case BT_COMPLEX:
  66. c = 'c';
  67. break;
  68. case BT_HOLLERITH:
  69. c = 'h';
  70. break;
  71. default:
  72. c = 'u';
  73. break;
  74. }
  75. return c;
  76. }
  77. /* Get a symbol for a resolved name. Note, if needed be, the elemental
  78. attribute has be added afterwards. */
  79. gfc_symbol *
  80. gfc_get_intrinsic_sub_symbol (const char *name)
  81. {
  82. gfc_symbol *sym;
  83. gfc_get_symbol (name, gfc_intrinsic_namespace, &sym);
  84. sym->attr.always_explicit = 1;
  85. sym->attr.subroutine = 1;
  86. sym->attr.flavor = FL_PROCEDURE;
  87. sym->attr.proc = PROC_INTRINSIC;
  88. gfc_commit_symbol (sym);
  89. return sym;
  90. }
  91. /* Return a pointer to the name of a conversion function given two
  92. typespecs. */
  93. static const char *
  94. conv_name (gfc_typespec *from, gfc_typespec *to)
  95. {
  96. return gfc_get_string ("__convert_%c%d_%c%d",
  97. gfc_type_letter (from->type), from->kind,
  98. gfc_type_letter (to->type), to->kind);
  99. }
  100. /* Given a pair of typespecs, find the gfc_intrinsic_sym node that
  101. corresponds to the conversion. Returns NULL if the conversion
  102. isn't found. */
  103. static gfc_intrinsic_sym *
  104. find_conv (gfc_typespec *from, gfc_typespec *to)
  105. {
  106. gfc_intrinsic_sym *sym;
  107. const char *target;
  108. int i;
  109. target = conv_name (from, to);
  110. sym = conversion;
  111. for (i = 0; i < nconv; i++, sym++)
  112. if (target == sym->name)
  113. return sym;
  114. return NULL;
  115. }
  116. /* Given a pair of CHARACTER typespecs, find the gfc_intrinsic_sym node
  117. that corresponds to the conversion. Returns NULL if the conversion
  118. isn't found. */
  119. static gfc_intrinsic_sym *
  120. find_char_conv (gfc_typespec *from, gfc_typespec *to)
  121. {
  122. gfc_intrinsic_sym *sym;
  123. const char *target;
  124. int i;
  125. target = conv_name (from, to);
  126. sym = char_conversions;
  127. for (i = 0; i < ncharconv; i++, sym++)
  128. if (target == sym->name)
  129. return sym;
  130. return NULL;
  131. }
  132. /* Check TS29113, C407b for assumed type and C535b for assumed-rank,
  133. and a likewise check for NO_ARG_CHECK. */
  134. static bool
  135. do_ts29113_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
  136. {
  137. gfc_actual_arglist *a;
  138. for (a = arg; a; a = a->next)
  139. {
  140. if (!a->expr)
  141. continue;
  142. if (a->expr->expr_type == EXPR_VARIABLE
  143. && (a->expr->symtree->n.sym->attr.ext_attr
  144. & (1 << EXT_ATTR_NO_ARG_CHECK))
  145. && specific->id != GFC_ISYM_C_LOC
  146. && specific->id != GFC_ISYM_PRESENT)
  147. {
  148. gfc_error ("Variable with NO_ARG_CHECK attribute at %L is only "
  149. "permitted as argument to the intrinsic functions "
  150. "C_LOC and PRESENT", &a->expr->where);
  151. return false;
  152. }
  153. else if (a->expr->ts.type == BT_ASSUMED
  154. && specific->id != GFC_ISYM_LBOUND
  155. && specific->id != GFC_ISYM_PRESENT
  156. && specific->id != GFC_ISYM_RANK
  157. && specific->id != GFC_ISYM_SHAPE
  158. && specific->id != GFC_ISYM_SIZE
  159. && specific->id != GFC_ISYM_SIZEOF
  160. && specific->id != GFC_ISYM_UBOUND
  161. && specific->id != GFC_ISYM_C_LOC)
  162. {
  163. gfc_error ("Assumed-type argument at %L is not permitted as actual"
  164. " argument to the intrinsic %s", &a->expr->where,
  165. gfc_current_intrinsic);
  166. return false;
  167. }
  168. else if (a->expr->ts.type == BT_ASSUMED && a != arg)
  169. {
  170. gfc_error ("Assumed-type argument at %L is only permitted as "
  171. "first actual argument to the intrinsic %s",
  172. &a->expr->where, gfc_current_intrinsic);
  173. return false;
  174. }
  175. if (a->expr->rank == -1 && !specific->inquiry)
  176. {
  177. gfc_error ("Assumed-rank argument at %L is only permitted as actual "
  178. "argument to intrinsic inquiry functions",
  179. &a->expr->where);
  180. return false;
  181. }
  182. if (a->expr->rank == -1 && arg != a)
  183. {
  184. gfc_error ("Assumed-rank argument at %L is only permitted as first "
  185. "actual argument to the intrinsic inquiry function %s",
  186. &a->expr->where, gfc_current_intrinsic);
  187. return false;
  188. }
  189. }
  190. return true;
  191. }
  192. /* Interface to the check functions. We break apart an argument list
  193. and call the proper check function rather than forcing each
  194. function to manipulate the argument list. */
  195. static bool
  196. do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
  197. {
  198. gfc_expr *a1, *a2, *a3, *a4, *a5;
  199. if (arg == NULL)
  200. return (*specific->check.f0) ();
  201. a1 = arg->expr;
  202. arg = arg->next;
  203. if (arg == NULL)
  204. return (*specific->check.f1) (a1);
  205. a2 = arg->expr;
  206. arg = arg->next;
  207. if (arg == NULL)
  208. return (*specific->check.f2) (a1, a2);
  209. a3 = arg->expr;
  210. arg = arg->next;
  211. if (arg == NULL)
  212. return (*specific->check.f3) (a1, a2, a3);
  213. a4 = arg->expr;
  214. arg = arg->next;
  215. if (arg == NULL)
  216. return (*specific->check.f4) (a1, a2, a3, a4);
  217. a5 = arg->expr;
  218. arg = arg->next;
  219. if (arg == NULL)
  220. return (*specific->check.f5) (a1, a2, a3, a4, a5);
  221. gfc_internal_error ("do_check(): too many args");
  222. }
  223. /*********** Subroutines to build the intrinsic list ****************/
  224. /* Add a single intrinsic symbol to the current list.
  225. Argument list:
  226. char * name of function
  227. int whether function is elemental
  228. int If the function can be used as an actual argument [1]
  229. bt return type of function
  230. int kind of return type of function
  231. int Fortran standard version
  232. check pointer to check function
  233. simplify pointer to simplification function
  234. resolve pointer to resolution function
  235. Optional arguments come in multiples of five:
  236. char * name of argument
  237. bt type of argument
  238. int kind of argument
  239. int arg optional flag (1=optional, 0=required)
  240. sym_intent intent of argument
  241. The sequence is terminated by a NULL name.
  242. [1] Whether a function can or cannot be used as an actual argument is
  243. determined by its presence on the 13.6 list in Fortran 2003. The
  244. following intrinsics, which are GNU extensions, are considered allowed
  245. as actual arguments: ACOSH ATANH DACOSH DASINH DATANH DCONJG DIMAG
  246. ZABS ZCOS ZEXP ZLOG ZSIN ZSQRT. */
  247. static void
  248. add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind,
  249. int standard, gfc_check_f check, gfc_simplify_f simplify,
  250. gfc_resolve_f resolve, ...)
  251. {
  252. char buf[GFC_MAX_SYMBOL_LEN + 11]; /* 10 for '_gfortran_', 1 for '\0' */
  253. int optional, first_flag;
  254. sym_intent intent;
  255. va_list argp;
  256. switch (sizing)
  257. {
  258. case SZ_SUBS:
  259. nsub++;
  260. break;
  261. case SZ_FUNCS:
  262. nfunc++;
  263. break;
  264. case SZ_NOTHING:
  265. next_sym->name = gfc_get_string (name);
  266. strcpy (buf, "_gfortran_");
  267. strcat (buf, name);
  268. next_sym->lib_name = gfc_get_string (buf);
  269. next_sym->pure = (cl != CLASS_IMPURE);
  270. next_sym->elemental = (cl == CLASS_ELEMENTAL);
  271. next_sym->inquiry = (cl == CLASS_INQUIRY);
  272. next_sym->transformational = (cl == CLASS_TRANSFORMATIONAL);
  273. next_sym->actual_ok = actual_ok;
  274. next_sym->ts.type = type;
  275. next_sym->ts.kind = kind;
  276. next_sym->standard = standard;
  277. next_sym->simplify = simplify;
  278. next_sym->check = check;
  279. next_sym->resolve = resolve;
  280. next_sym->specific = 0;
  281. next_sym->generic = 0;
  282. next_sym->conversion = 0;
  283. next_sym->id = id;
  284. break;
  285. default:
  286. gfc_internal_error ("add_sym(): Bad sizing mode");
  287. }
  288. va_start (argp, resolve);
  289. first_flag = 1;
  290. for (;;)
  291. {
  292. name = va_arg (argp, char *);
  293. if (name == NULL)
  294. break;
  295. type = (bt) va_arg (argp, int);
  296. kind = va_arg (argp, int);
  297. optional = va_arg (argp, int);
  298. intent = (sym_intent) va_arg (argp, int);
  299. if (sizing != SZ_NOTHING)
  300. nargs++;
  301. else
  302. {
  303. next_arg++;
  304. if (first_flag)
  305. next_sym->formal = next_arg;
  306. else
  307. (next_arg - 1)->next = next_arg;
  308. first_flag = 0;
  309. strcpy (next_arg->name, name);
  310. next_arg->ts.type = type;
  311. next_arg->ts.kind = kind;
  312. next_arg->optional = optional;
  313. next_arg->value = 0;
  314. next_arg->intent = intent;
  315. }
  316. }
  317. va_end (argp);
  318. next_sym++;
  319. }
  320. /* Add a symbol to the function list where the function takes
  321. 0 arguments. */
  322. static void
  323. add_sym_0 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
  324. int kind, int standard,
  325. bool (*check) (void),
  326. gfc_expr *(*simplify) (void),
  327. void (*resolve) (gfc_expr *))
  328. {
  329. gfc_simplify_f sf;
  330. gfc_check_f cf;
  331. gfc_resolve_f rf;
  332. cf.f0 = check;
  333. sf.f0 = simplify;
  334. rf.f0 = resolve;
  335. add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
  336. (void *) 0);
  337. }
  338. /* Add a symbol to the subroutine list where the subroutine takes
  339. 0 arguments. */
  340. static void
  341. add_sym_0s (const char *name, gfc_isym_id id, int standard,
  342. void (*resolve) (gfc_code *))
  343. {
  344. gfc_check_f cf;
  345. gfc_simplify_f sf;
  346. gfc_resolve_f rf;
  347. cf.f1 = NULL;
  348. sf.f1 = NULL;
  349. rf.s1 = resolve;
  350. add_sym (name, id, CLASS_IMPURE, ACTUAL_NO, BT_UNKNOWN, 0, standard, cf, sf,
  351. rf, (void *) 0);
  352. }
  353. /* Add a symbol to the function list where the function takes
  354. 1 arguments. */
  355. static void
  356. add_sym_1 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
  357. int kind, int standard,
  358. bool (*check) (gfc_expr *),
  359. gfc_expr *(*simplify) (gfc_expr *),
  360. void (*resolve) (gfc_expr *, gfc_expr *),
  361. const char *a1, bt type1, int kind1, int optional1)
  362. {
  363. gfc_check_f cf;
  364. gfc_simplify_f sf;
  365. gfc_resolve_f rf;
  366. cf.f1 = check;
  367. sf.f1 = simplify;
  368. rf.f1 = resolve;
  369. add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
  370. a1, type1, kind1, optional1, INTENT_IN,
  371. (void *) 0);
  372. }
  373. /* Add a symbol to the function list where the function takes
  374. 1 arguments, specifying the intent of the argument. */
  375. static void
  376. add_sym_1_intent (const char *name, gfc_isym_id id, enum klass cl,
  377. int actual_ok, bt type, int kind, int standard,
  378. bool (*check) (gfc_expr *),
  379. gfc_expr *(*simplify) (gfc_expr *),
  380. void (*resolve) (gfc_expr *, gfc_expr *),
  381. const char *a1, bt type1, int kind1, int optional1,
  382. sym_intent intent1)
  383. {
  384. gfc_check_f cf;
  385. gfc_simplify_f sf;
  386. gfc_resolve_f rf;
  387. cf.f1 = check;
  388. sf.f1 = simplify;
  389. rf.f1 = resolve;
  390. add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
  391. a1, type1, kind1, optional1, intent1,
  392. (void *) 0);
  393. }
  394. /* Add a symbol to the subroutine list where the subroutine takes
  395. 1 arguments, specifying the intent of the argument. */
  396. static void
  397. add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
  398. int standard, bool (*check) (gfc_expr *),
  399. gfc_expr *(*simplify) (gfc_expr *), void (*resolve) (gfc_code *),
  400. const char *a1, bt type1, int kind1, int optional1,
  401. sym_intent intent1)
  402. {
  403. gfc_check_f cf;
  404. gfc_simplify_f sf;
  405. gfc_resolve_f rf;
  406. cf.f1 = check;
  407. sf.f1 = simplify;
  408. rf.s1 = resolve;
  409. add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
  410. a1, type1, kind1, optional1, intent1,
  411. (void *) 0);
  412. }
  413. /* Add a symbol from the MAX/MIN family of intrinsic functions to the
  414. function. MAX et al take 2 or more arguments. */
  415. static void
  416. add_sym_1m (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
  417. int kind, int standard,
  418. bool (*check) (gfc_actual_arglist *),
  419. gfc_expr *(*simplify) (gfc_expr *),
  420. void (*resolve) (gfc_expr *, gfc_actual_arglist *),
  421. const char *a1, bt type1, int kind1, int optional1,
  422. const char *a2, bt type2, int kind2, int optional2)
  423. {
  424. gfc_check_f cf;
  425. gfc_simplify_f sf;
  426. gfc_resolve_f rf;
  427. cf.f1m = check;
  428. sf.f1 = simplify;
  429. rf.f1m = resolve;
  430. add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
  431. a1, type1, kind1, optional1, INTENT_IN,
  432. a2, type2, kind2, optional2, INTENT_IN,
  433. (void *) 0);
  434. }
  435. /* Add a symbol to the function list where the function takes
  436. 2 arguments. */
  437. static void
  438. add_sym_2 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
  439. int kind, int standard,
  440. bool (*check) (gfc_expr *, gfc_expr *),
  441. gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
  442. void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *),
  443. const char *a1, bt type1, int kind1, int optional1,
  444. const char *a2, bt type2, int kind2, int optional2)
  445. {
  446. gfc_check_f cf;
  447. gfc_simplify_f sf;
  448. gfc_resolve_f rf;
  449. cf.f2 = check;
  450. sf.f2 = simplify;
  451. rf.f2 = resolve;
  452. add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
  453. a1, type1, kind1, optional1, INTENT_IN,
  454. a2, type2, kind2, optional2, INTENT_IN,
  455. (void *) 0);
  456. }
  457. /* Add a symbol to the function list where the function takes
  458. 2 arguments; same as add_sym_2 - but allows to specify the intent. */
  459. static void
  460. add_sym_2_intent (const char *name, gfc_isym_id id, enum klass cl,
  461. int actual_ok, bt type, int kind, int standard,
  462. bool (*check) (gfc_expr *, gfc_expr *),
  463. gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
  464. void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *),
  465. const char *a1, bt type1, int kind1, int optional1,
  466. sym_intent intent1, const char *a2, bt type2, int kind2,
  467. int optional2, sym_intent intent2)
  468. {
  469. gfc_check_f cf;
  470. gfc_simplify_f sf;
  471. gfc_resolve_f rf;
  472. cf.f2 = check;
  473. sf.f2 = simplify;
  474. rf.f2 = resolve;
  475. add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
  476. a1, type1, kind1, optional1, intent1,
  477. a2, type2, kind2, optional2, intent2,
  478. (void *) 0);
  479. }
  480. /* Add a symbol to the subroutine list where the subroutine takes
  481. 2 arguments, specifying the intent of the arguments. */
  482. static void
  483. add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type,
  484. int kind, int standard,
  485. bool (*check) (gfc_expr *, gfc_expr *),
  486. gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
  487. void (*resolve) (gfc_code *),
  488. const char *a1, bt type1, int kind1, int optional1,
  489. sym_intent intent1, const char *a2, bt type2, int kind2,
  490. int optional2, sym_intent intent2)
  491. {
  492. gfc_check_f cf;
  493. gfc_simplify_f sf;
  494. gfc_resolve_f rf;
  495. cf.f2 = check;
  496. sf.f2 = simplify;
  497. rf.s1 = resolve;
  498. add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
  499. a1, type1, kind1, optional1, intent1,
  500. a2, type2, kind2, optional2, intent2,
  501. (void *) 0);
  502. }
  503. /* Add a symbol to the function list where the function takes
  504. 3 arguments. */
  505. static void
  506. add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
  507. int kind, int standard,
  508. bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
  509. gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
  510. void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
  511. const char *a1, bt type1, int kind1, int optional1,
  512. const char *a2, bt type2, int kind2, int optional2,
  513. const char *a3, bt type3, int kind3, int optional3)
  514. {
  515. gfc_check_f cf;
  516. gfc_simplify_f sf;
  517. gfc_resolve_f rf;
  518. cf.f3 = check;
  519. sf.f3 = simplify;
  520. rf.f3 = resolve;
  521. add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
  522. a1, type1, kind1, optional1, INTENT_IN,
  523. a2, type2, kind2, optional2, INTENT_IN,
  524. a3, type3, kind3, optional3, INTENT_IN,
  525. (void *) 0);
  526. }
  527. /* MINLOC and MAXLOC get special treatment because their argument
  528. might have to be reordered. */
  529. static void
  530. add_sym_3ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
  531. int kind, int standard,
  532. bool (*check) (gfc_actual_arglist *),
  533. gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
  534. void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
  535. const char *a1, bt type1, int kind1, int optional1,
  536. const char *a2, bt type2, int kind2, int optional2,
  537. const char *a3, bt type3, int kind3, int optional3)
  538. {
  539. gfc_check_f cf;
  540. gfc_simplify_f sf;
  541. gfc_resolve_f rf;
  542. cf.f3ml = check;
  543. sf.f3 = simplify;
  544. rf.f3 = resolve;
  545. add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
  546. a1, type1, kind1, optional1, INTENT_IN,
  547. a2, type2, kind2, optional2, INTENT_IN,
  548. a3, type3, kind3, optional3, INTENT_IN,
  549. (void *) 0);
  550. }
  551. /* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because
  552. their argument also might have to be reordered. */
  553. static void
  554. add_sym_3red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
  555. int kind, int standard,
  556. bool (*check) (gfc_actual_arglist *),
  557. gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
  558. void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
  559. const char *a1, bt type1, int kind1, int optional1,
  560. const char *a2, bt type2, int kind2, int optional2,
  561. const char *a3, bt type3, int kind3, int optional3)
  562. {
  563. gfc_check_f cf;
  564. gfc_simplify_f sf;
  565. gfc_resolve_f rf;
  566. cf.f3red = check;
  567. sf.f3 = simplify;
  568. rf.f3 = resolve;
  569. add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
  570. a1, type1, kind1, optional1, INTENT_IN,
  571. a2, type2, kind2, optional2, INTENT_IN,
  572. a3, type3, kind3, optional3, INTENT_IN,
  573. (void *) 0);
  574. }
  575. /* Add a symbol to the subroutine list where the subroutine takes
  576. 3 arguments, specifying the intent of the arguments. */
  577. static void
  578. add_sym_3s (const char *name, gfc_isym_id id, enum klass cl, bt type,
  579. int kind, int standard,
  580. bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
  581. gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
  582. void (*resolve) (gfc_code *),
  583. const char *a1, bt type1, int kind1, int optional1,
  584. sym_intent intent1, const char *a2, bt type2, int kind2,
  585. int optional2, sym_intent intent2, const char *a3, bt type3,
  586. int kind3, int optional3, sym_intent intent3)
  587. {
  588. gfc_check_f cf;
  589. gfc_simplify_f sf;
  590. gfc_resolve_f rf;
  591. cf.f3 = check;
  592. sf.f3 = simplify;
  593. rf.s1 = resolve;
  594. add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
  595. a1, type1, kind1, optional1, intent1,
  596. a2, type2, kind2, optional2, intent2,
  597. a3, type3, kind3, optional3, intent3,
  598. (void *) 0);
  599. }
  600. /* Add a symbol to the function list where the function takes
  601. 4 arguments. */
  602. static void
  603. add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
  604. int kind, int standard,
  605. bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
  606. gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
  607. gfc_expr *),
  608. void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
  609. gfc_expr *),
  610. const char *a1, bt type1, int kind1, int optional1,
  611. const char *a2, bt type2, int kind2, int optional2,
  612. const char *a3, bt type3, int kind3, int optional3,
  613. const char *a4, bt type4, int kind4, int optional4 )
  614. {
  615. gfc_check_f cf;
  616. gfc_simplify_f sf;
  617. gfc_resolve_f rf;
  618. cf.f4 = check;
  619. sf.f4 = simplify;
  620. rf.f4 = resolve;
  621. add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
  622. a1, type1, kind1, optional1, INTENT_IN,
  623. a2, type2, kind2, optional2, INTENT_IN,
  624. a3, type3, kind3, optional3, INTENT_IN,
  625. a4, type4, kind4, optional4, INTENT_IN,
  626. (void *) 0);
  627. }
  628. /* Add a symbol to the subroutine list where the subroutine takes
  629. 4 arguments. */
  630. static void
  631. add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
  632. int standard,
  633. bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
  634. gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
  635. gfc_expr *),
  636. void (*resolve) (gfc_code *),
  637. const char *a1, bt type1, int kind1, int optional1,
  638. sym_intent intent1, const char *a2, bt type2, int kind2,
  639. int optional2, sym_intent intent2, const char *a3, bt type3,
  640. int kind3, int optional3, sym_intent intent3, const char *a4,
  641. bt type4, int kind4, int optional4, sym_intent intent4)
  642. {
  643. gfc_check_f cf;
  644. gfc_simplify_f sf;
  645. gfc_resolve_f rf;
  646. cf.f4 = check;
  647. sf.f4 = simplify;
  648. rf.s1 = resolve;
  649. add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
  650. a1, type1, kind1, optional1, intent1,
  651. a2, type2, kind2, optional2, intent2,
  652. a3, type3, kind3, optional3, intent3,
  653. a4, type4, kind4, optional4, intent4,
  654. (void *) 0);
  655. }
  656. /* Add a symbol to the subroutine list where the subroutine takes
  657. 5 arguments. */
  658. static void
  659. add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
  660. int standard,
  661. bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
  662. gfc_expr *),
  663. gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
  664. gfc_expr *, gfc_expr *),
  665. void (*resolve) (gfc_code *),
  666. const char *a1, bt type1, int kind1, int optional1,
  667. sym_intent intent1, const char *a2, bt type2, int kind2,
  668. int optional2, sym_intent intent2, const char *a3, bt type3,
  669. int kind3, int optional3, sym_intent intent3, const char *a4,
  670. bt type4, int kind4, int optional4, sym_intent intent4,
  671. const char *a5, bt type5, int kind5, int optional5,
  672. sym_intent intent5)
  673. {
  674. gfc_check_f cf;
  675. gfc_simplify_f sf;
  676. gfc_resolve_f rf;
  677. cf.f5 = check;
  678. sf.f5 = simplify;
  679. rf.s1 = resolve;
  680. add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
  681. a1, type1, kind1, optional1, intent1,
  682. a2, type2, kind2, optional2, intent2,
  683. a3, type3, kind3, optional3, intent3,
  684. a4, type4, kind4, optional4, intent4,
  685. a5, type5, kind5, optional5, intent5,
  686. (void *) 0);
  687. }
  688. /* Locate an intrinsic symbol given a base pointer, number of elements
  689. in the table and a pointer to a name. Returns the NULL pointer if
  690. a name is not found. */
  691. static gfc_intrinsic_sym *
  692. find_sym (gfc_intrinsic_sym *start, int n, const char *name)
  693. {
  694. /* name may be a user-supplied string, so we must first make sure
  695. that we're comparing against a pointer into the global string
  696. table. */
  697. const char *p = gfc_get_string (name);
  698. while (n > 0)
  699. {
  700. if (p == start->name)
  701. return start;
  702. start++;
  703. n--;
  704. }
  705. return NULL;
  706. }
  707. gfc_isym_id
  708. gfc_isym_id_by_intmod (intmod_id from_intmod, int intmod_sym_id)
  709. {
  710. if (from_intmod == INTMOD_NONE)
  711. return (gfc_isym_id) intmod_sym_id;
  712. else if (from_intmod == INTMOD_ISO_C_BINDING)
  713. return (gfc_isym_id) c_interop_kinds_table[intmod_sym_id].value;
  714. else if (from_intmod == INTMOD_ISO_FORTRAN_ENV)
  715. switch (intmod_sym_id)
  716. {
  717. #define NAMED_SUBROUTINE(a,b,c,d) \
  718. case a: \
  719. return (gfc_isym_id) c;
  720. #define NAMED_FUNCTION(a,b,c,d) \
  721. case a: \
  722. return (gfc_isym_id) c;
  723. #include "iso-fortran-env.def"
  724. default:
  725. gcc_unreachable ();
  726. }
  727. else
  728. gcc_unreachable ();
  729. return (gfc_isym_id) 0;
  730. }
  731. gfc_isym_id
  732. gfc_isym_id_by_intmod_sym (gfc_symbol *sym)
  733. {
  734. return gfc_isym_id_by_intmod (sym->from_intmod, sym->intmod_sym_id);
  735. }
  736. gfc_intrinsic_sym *
  737. gfc_intrinsic_subroutine_by_id (gfc_isym_id id)
  738. {
  739. gfc_intrinsic_sym *start = subroutines;
  740. int n = nsub;
  741. while (true)
  742. {
  743. gcc_assert (n > 0);
  744. if (id == start->id)
  745. return start;
  746. start++;
  747. n--;
  748. }
  749. }
  750. gfc_intrinsic_sym *
  751. gfc_intrinsic_function_by_id (gfc_isym_id id)
  752. {
  753. gfc_intrinsic_sym *start = functions;
  754. int n = nfunc;
  755. while (true)
  756. {
  757. gcc_assert (n > 0);
  758. if (id == start->id)
  759. return start;
  760. start++;
  761. n--;
  762. }
  763. }
  764. /* Given a name, find a function in the intrinsic function table.
  765. Returns NULL if not found. */
  766. gfc_intrinsic_sym *
  767. gfc_find_function (const char *name)
  768. {
  769. gfc_intrinsic_sym *sym;
  770. sym = find_sym (functions, nfunc, name);
  771. if (!sym || sym->from_module)
  772. sym = find_sym (conversion, nconv, name);
  773. return (!sym || sym->from_module) ? NULL : sym;
  774. }
  775. /* Given a name, find a function in the intrinsic subroutine table.
  776. Returns NULL if not found. */
  777. gfc_intrinsic_sym *
  778. gfc_find_subroutine (const char *name)
  779. {
  780. gfc_intrinsic_sym *sym;
  781. sym = find_sym (subroutines, nsub, name);
  782. return (!sym || sym->from_module) ? NULL : sym;
  783. }
  784. /* Given a string, figure out if it is the name of a generic intrinsic
  785. function or not. */
  786. int
  787. gfc_generic_intrinsic (const char *name)
  788. {
  789. gfc_intrinsic_sym *sym;
  790. sym = gfc_find_function (name);
  791. return (!sym || sym->from_module) ? 0 : sym->generic;
  792. }
  793. /* Given a string, figure out if it is the name of a specific
  794. intrinsic function or not. */
  795. int
  796. gfc_specific_intrinsic (const char *name)
  797. {
  798. gfc_intrinsic_sym *sym;
  799. sym = gfc_find_function (name);
  800. return (!sym || sym->from_module) ? 0 : sym->specific;
  801. }
  802. /* Given a string, figure out if it is the name of an intrinsic function
  803. or subroutine allowed as an actual argument or not. */
  804. int
  805. gfc_intrinsic_actual_ok (const char *name, const bool subroutine_flag)
  806. {
  807. gfc_intrinsic_sym *sym;
  808. /* Intrinsic subroutines are not allowed as actual arguments. */
  809. if (subroutine_flag)
  810. return 0;
  811. else
  812. {
  813. sym = gfc_find_function (name);
  814. return (sym == NULL) ? 0 : sym->actual_ok;
  815. }
  816. }
  817. /* Given a symbol, find out if it is (and is to be treated as) an intrinsic.
  818. If its name refers to an intrinsic, but this intrinsic is not included in
  819. the selected standard, this returns FALSE and sets the symbol's external
  820. attribute. */
  821. bool
  822. gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc)
  823. {
  824. gfc_intrinsic_sym* isym;
  825. const char* symstd;
  826. /* If INTRINSIC attribute is already known, return. */
  827. if (sym->attr.intrinsic)
  828. return true;
  829. /* Check for attributes which prevent the symbol from being INTRINSIC. */
  830. if (sym->attr.external || sym->attr.contained
  831. || sym->attr.if_source == IFSRC_IFBODY)
  832. return false;
  833. if (subroutine_flag)
  834. isym = gfc_find_subroutine (sym->name);
  835. else
  836. isym = gfc_find_function (sym->name);
  837. /* No such intrinsic available at all? */
  838. if (!isym)
  839. return false;
  840. /* See if this intrinsic is allowed in the current standard. */
  841. if (!gfc_check_intrinsic_standard (isym, &symstd, false, loc)
  842. && !sym->attr.artificial)
  843. {
  844. if (sym->attr.proc == PROC_UNKNOWN && warn_intrinsics_std)
  845. gfc_warning_now (OPT_Wintrinsics_std, "The intrinsic %qs at %L is not "
  846. "included in the selected standard but %s and %qs will"
  847. " be treated as if declared EXTERNAL. Use an"
  848. " appropriate -std=* option or define"
  849. " -fall-intrinsics to allow this intrinsic.",
  850. sym->name, &loc, symstd, sym->name);
  851. return false;
  852. }
  853. return true;
  854. }
  855. /* Collect a set of intrinsic functions into a generic collection.
  856. The first argument is the name of the generic function, which is
  857. also the name of a specific function. The rest of the specifics
  858. currently in the table are placed into the list of specific
  859. functions associated with that generic.
  860. PR fortran/32778
  861. FIXME: Remove the argument STANDARD if no regressions are
  862. encountered. Change all callers (approx. 360).
  863. */
  864. static void
  865. make_generic (const char *name, gfc_isym_id id, int standard ATTRIBUTE_UNUSED)
  866. {
  867. gfc_intrinsic_sym *g;
  868. if (sizing != SZ_NOTHING)
  869. return;
  870. g = gfc_find_function (name);
  871. if (g == NULL)
  872. gfc_internal_error ("make_generic(): Can't find generic symbol %qs",
  873. name);
  874. gcc_assert (g->id == id);
  875. g->generic = 1;
  876. g->specific = 1;
  877. if ((g + 1)->name != NULL)
  878. g->specific_head = g + 1;
  879. g++;
  880. while (g->name != NULL)
  881. {
  882. g->next = g + 1;
  883. g->specific = 1;
  884. g++;
  885. }
  886. g--;
  887. g->next = NULL;
  888. }
  889. /* Create a duplicate intrinsic function entry for the current
  890. function, the only differences being the alternate name and
  891. a different standard if necessary. Note that we use argument
  892. lists more than once, but all argument lists are freed as a
  893. single block. */
  894. static void
  895. make_alias (const char *name, int standard)
  896. {
  897. switch (sizing)
  898. {
  899. case SZ_FUNCS:
  900. nfunc++;
  901. break;
  902. case SZ_SUBS:
  903. nsub++;
  904. break;
  905. case SZ_NOTHING:
  906. next_sym[0] = next_sym[-1];
  907. next_sym->name = gfc_get_string (name);
  908. next_sym->standard = standard;
  909. next_sym++;
  910. break;
  911. default:
  912. break;
  913. }
  914. }
  915. /* Make the current subroutine noreturn. */
  916. static void
  917. make_noreturn (void)
  918. {
  919. if (sizing == SZ_NOTHING)
  920. next_sym[-1].noreturn = 1;
  921. }
  922. /* Mark current intrinsic as module intrinsic. */
  923. static void
  924. make_from_module (void)
  925. {
  926. if (sizing == SZ_NOTHING)
  927. next_sym[-1].from_module = 1;
  928. }
  929. /* Set the attr.value of the current procedure. */
  930. static void
  931. set_attr_value (int n, ...)
  932. {
  933. gfc_intrinsic_arg *arg;
  934. va_list argp;
  935. int i;
  936. if (sizing != SZ_NOTHING)
  937. return;
  938. va_start (argp, n);
  939. arg = next_sym[-1].formal;
  940. for (i = 0; i < n; i++)
  941. {
  942. gcc_assert (arg != NULL);
  943. arg->value = va_arg (argp, int);
  944. arg = arg->next;
  945. }
  946. va_end (argp);
  947. }
  948. /* Add intrinsic functions. */
  949. static void
  950. add_functions (void)
  951. {
  952. /* Argument names as in the standard (to be used as argument keywords). */
  953. const char
  954. *a = "a", *f = "field", *pt = "pointer", *tg = "target",
  955. *b = "b", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b",
  956. *c = "c", *n = "n", *ncopies= "ncopies", *pos = "pos", *bck = "back",
  957. *i = "i", *v = "vector", *va = "vector_a", *vb = "vector_b",
  958. *j = "j", *a1 = "a1", *fs = "fsource", *ts = "tsource",
  959. *l = "l", *a2 = "a2", *mo = "mold", *ord = "order",
  960. *p = "p", *ar = "array", *shp = "shape", *src = "source",
  961. *r = "r", *bd = "boundary", *pad = "pad", *set = "set",
  962. *s = "s", *dm = "dim", *kind = "kind", *msk = "mask",
  963. *x = "x", *sh = "shift", *stg = "string", *ssg = "substring",
  964. *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b",
  965. *z = "z", *ln = "len", *ut = "unit", *han = "handler",
  966. *num = "number", *tm = "time", *nm = "name", *md = "mode",
  967. *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command",
  968. *ca = "coarray", *sub = "sub", *dist = "distance", *failed="failed";
  969. int di, dr, dd, dl, dc, dz, ii;
  970. di = gfc_default_integer_kind;
  971. dr = gfc_default_real_kind;
  972. dd = gfc_default_double_kind;
  973. dl = gfc_default_logical_kind;
  974. dc = gfc_default_character_kind;
  975. dz = gfc_default_complex_kind;
  976. ii = gfc_index_integer_kind;
  977. add_sym_1 ("abs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  978. gfc_check_abs, gfc_simplify_abs, gfc_resolve_abs,
  979. a, BT_REAL, dr, REQUIRED);
  980. add_sym_1 ("iabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
  981. NULL, gfc_simplify_abs, gfc_resolve_abs,
  982. a, BT_INTEGER, di, REQUIRED);
  983. add_sym_1 ("dabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  984. gfc_check_fn_d, gfc_simplify_abs, gfc_resolve_abs,
  985. a, BT_REAL, dd, REQUIRED);
  986. add_sym_1 ("cabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  987. NULL, gfc_simplify_abs, gfc_resolve_abs,
  988. a, BT_COMPLEX, dz, REQUIRED);
  989. add_sym_1 ("zabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
  990. NULL, gfc_simplify_abs, gfc_resolve_abs,
  991. a, BT_COMPLEX, dd, REQUIRED);
  992. make_alias ("cdabs", GFC_STD_GNU);
  993. make_generic ("abs", GFC_ISYM_ABS, GFC_STD_F77);
  994. /* The checking function for ACCESS is called gfc_check_access_func
  995. because the name gfc_check_access is already used in module.c. */
  996. add_sym_2 ("access", GFC_ISYM_ACCESS, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  997. di, GFC_STD_GNU, gfc_check_access_func, NULL, gfc_resolve_access,
  998. nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED);
  999. make_generic ("access", GFC_ISYM_ACCESS, GFC_STD_GNU);
  1000. add_sym_2 ("achar", GFC_ISYM_ACHAR, CLASS_ELEMENTAL, ACTUAL_NO,
  1001. BT_CHARACTER, dc, GFC_STD_F95,
  1002. gfc_check_achar, gfc_simplify_achar, gfc_resolve_achar,
  1003. i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
  1004. make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95);
  1005. add_sym_1 ("acos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  1006. gfc_check_fn_rc2008, gfc_simplify_acos, gfc_resolve_acos,
  1007. x, BT_REAL, dr, REQUIRED);
  1008. add_sym_1 ("dacos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  1009. gfc_check_fn_d, gfc_simplify_acos, gfc_resolve_acos,
  1010. x, BT_REAL, dd, REQUIRED);
  1011. make_generic ("acos", GFC_ISYM_ACOS, GFC_STD_F77);
  1012. add_sym_1 ("acosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,
  1013. GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_acosh,
  1014. gfc_resolve_acosh, x, BT_REAL, dr, REQUIRED);
  1015. add_sym_1 ("dacosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
  1016. gfc_check_fn_d, gfc_simplify_acosh, gfc_resolve_acosh,
  1017. x, BT_REAL, dd, REQUIRED);
  1018. make_generic ("acosh", GFC_ISYM_ACOSH, GFC_STD_F2008);
  1019. add_sym_1 ("adjustl", GFC_ISYM_ADJUSTL, CLASS_ELEMENTAL, ACTUAL_NO,
  1020. BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustl,
  1021. gfc_resolve_adjustl, stg, BT_CHARACTER, 0, REQUIRED);
  1022. make_generic ("adjustl", GFC_ISYM_ADJUSTL, GFC_STD_F95);
  1023. add_sym_1 ("adjustr", GFC_ISYM_ADJUSTR, CLASS_ELEMENTAL, ACTUAL_NO,
  1024. BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustr,
  1025. gfc_resolve_adjustr, stg, BT_CHARACTER, 0, REQUIRED);
  1026. make_generic ("adjustr", GFC_ISYM_ADJUSTR, GFC_STD_F95);
  1027. add_sym_1 ("aimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  1028. gfc_check_fn_c, gfc_simplify_aimag, gfc_resolve_aimag,
  1029. z, BT_COMPLEX, dz, REQUIRED);
  1030. make_alias ("imag", GFC_STD_GNU);
  1031. make_alias ("imagpart", GFC_STD_GNU);
  1032. add_sym_1 ("dimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
  1033. NULL, gfc_simplify_aimag, gfc_resolve_aimag,
  1034. z, BT_COMPLEX, dd, REQUIRED);
  1035. make_generic ("aimag", GFC_ISYM_AIMAG, GFC_STD_F77);
  1036. add_sym_2 ("aint", GFC_ISYM_AINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  1037. gfc_check_a_xkind, gfc_simplify_aint, gfc_resolve_aint,
  1038. a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
  1039. add_sym_1 ("dint", GFC_ISYM_AINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  1040. NULL, gfc_simplify_dint, gfc_resolve_dint,
  1041. a, BT_REAL, dd, REQUIRED);
  1042. make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77);
  1043. add_sym_2 ("all", GFC_ISYM_ALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
  1044. gfc_check_all_any, gfc_simplify_all, gfc_resolve_all,
  1045. msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
  1046. make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95);
  1047. add_sym_1 ("allocated", GFC_ISYM_ALLOCATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
  1048. gfc_check_allocated, NULL, NULL,
  1049. ar, BT_UNKNOWN, 0, REQUIRED);
  1050. make_generic ("allocated", GFC_ISYM_ALLOCATED, GFC_STD_F95);
  1051. add_sym_2 ("anint", GFC_ISYM_ANINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  1052. gfc_check_a_xkind, gfc_simplify_anint, gfc_resolve_anint,
  1053. a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
  1054. add_sym_1 ("dnint", GFC_ISYM_ANINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  1055. NULL, gfc_simplify_dnint, gfc_resolve_dnint,
  1056. a, BT_REAL, dd, REQUIRED);
  1057. make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77);
  1058. add_sym_2 ("any", GFC_ISYM_ANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
  1059. gfc_check_all_any, gfc_simplify_any, gfc_resolve_any,
  1060. msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
  1061. make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95);
  1062. add_sym_1 ("asin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  1063. gfc_check_fn_rc2008, gfc_simplify_asin, gfc_resolve_asin,
  1064. x, BT_REAL, dr, REQUIRED);
  1065. add_sym_1 ("dasin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  1066. gfc_check_fn_d, gfc_simplify_asin, gfc_resolve_asin,
  1067. x, BT_REAL, dd, REQUIRED);
  1068. make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77);
  1069. add_sym_1 ("asinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,
  1070. GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_asinh,
  1071. gfc_resolve_asinh, x, BT_REAL, dr, REQUIRED);
  1072. add_sym_1 ("dasinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
  1073. gfc_check_fn_d, gfc_simplify_asinh, gfc_resolve_asinh,
  1074. x, BT_REAL, dd, REQUIRED);
  1075. make_generic ("asinh", GFC_ISYM_ASINH, GFC_STD_F2008);
  1076. add_sym_2 ("associated", GFC_ISYM_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl,
  1077. GFC_STD_F95, gfc_check_associated, NULL, NULL,
  1078. pt, BT_UNKNOWN, 0, REQUIRED, tg, BT_UNKNOWN, 0, OPTIONAL);
  1079. make_generic ("associated", GFC_ISYM_ASSOCIATED, GFC_STD_F95);
  1080. add_sym_1 ("atan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  1081. gfc_check_fn_rc2008, gfc_simplify_atan, gfc_resolve_atan,
  1082. x, BT_REAL, dr, REQUIRED);
  1083. add_sym_1 ("datan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  1084. gfc_check_fn_d, gfc_simplify_atan, gfc_resolve_atan,
  1085. x, BT_REAL, dd, REQUIRED);
  1086. /* Two-argument version of atan, equivalent to atan2. */
  1087. add_sym_2 ("atan", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2008,
  1088. gfc_check_atan_2, gfc_simplify_atan2, gfc_resolve_atan2,
  1089. y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED);
  1090. make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77);
  1091. add_sym_1 ("atanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,
  1092. GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_atanh,
  1093. gfc_resolve_atanh, x, BT_REAL, dr, REQUIRED);
  1094. add_sym_1 ("datanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
  1095. gfc_check_fn_d, gfc_simplify_atanh, gfc_resolve_atanh,
  1096. x, BT_REAL, dd, REQUIRED);
  1097. make_generic ("atanh", GFC_ISYM_ATANH, GFC_STD_F2008);
  1098. add_sym_2 ("atan2", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  1099. gfc_check_atan2, gfc_simplify_atan2, gfc_resolve_atan2,
  1100. y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED);
  1101. add_sym_2 ("datan2", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  1102. gfc_check_datan2, gfc_simplify_atan2, gfc_resolve_atan2,
  1103. y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED);
  1104. make_generic ("atan2", GFC_ISYM_ATAN2, GFC_STD_F77);
  1105. /* Bessel and Neumann functions for G77 compatibility. */
  1106. add_sym_1 ("besj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
  1107. gfc_check_fn_r, gfc_simplify_bessel_j0, gfc_resolve_g77_math1,
  1108. x, BT_REAL, dr, REQUIRED);
  1109. make_alias ("bessel_j0", GFC_STD_F2008);
  1110. add_sym_1 ("dbesj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
  1111. gfc_check_fn_d, gfc_simplify_bessel_j0, gfc_resolve_g77_math1,
  1112. x, BT_REAL, dd, REQUIRED);
  1113. make_generic ("bessel_j0", GFC_ISYM_J0, GFC_STD_F2008);
  1114. add_sym_1 ("besj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
  1115. gfc_check_fn_r, gfc_simplify_bessel_j1, gfc_resolve_g77_math1,
  1116. x, BT_REAL, dr, REQUIRED);
  1117. make_alias ("bessel_j1", GFC_STD_F2008);
  1118. add_sym_1 ("dbesj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
  1119. gfc_check_fn_d, gfc_simplify_bessel_j1, gfc_resolve_g77_math1,
  1120. x, BT_REAL, dd, REQUIRED);
  1121. make_generic ("bessel_j1", GFC_ISYM_J1, GFC_STD_F2008);
  1122. add_sym_2 ("besjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
  1123. gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn,
  1124. n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
  1125. make_alias ("bessel_jn", GFC_STD_F2008);
  1126. add_sym_2 ("dbesjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
  1127. gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn,
  1128. n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
  1129. add_sym_3 ("bessel_jn", GFC_ISYM_JN2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
  1130. gfc_check_bessel_n2, gfc_simplify_bessel_jn2, gfc_resolve_bessel_n2,
  1131. "n1", BT_INTEGER, di, REQUIRED,"n2", BT_INTEGER, di, REQUIRED,
  1132. x, BT_REAL, dr, REQUIRED);
  1133. set_attr_value (3, true, true, true);
  1134. make_generic ("bessel_jn", GFC_ISYM_JN, GFC_STD_F2008);
  1135. add_sym_1 ("besy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
  1136. gfc_check_fn_r, gfc_simplify_bessel_y0, gfc_resolve_g77_math1,
  1137. x, BT_REAL, dr, REQUIRED);
  1138. make_alias ("bessel_y0", GFC_STD_F2008);
  1139. add_sym_1 ("dbesy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
  1140. gfc_check_fn_d, gfc_simplify_bessel_y0, gfc_resolve_g77_math1,
  1141. x, BT_REAL, dd, REQUIRED);
  1142. make_generic ("bessel_y0", GFC_ISYM_Y0, GFC_STD_F2008);
  1143. add_sym_1 ("besy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
  1144. gfc_check_fn_r, gfc_simplify_bessel_y1, gfc_resolve_g77_math1,
  1145. x, BT_REAL, dr, REQUIRED);
  1146. make_alias ("bessel_y1", GFC_STD_F2008);
  1147. add_sym_1 ("dbesy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
  1148. gfc_check_fn_d, gfc_simplify_bessel_y1, gfc_resolve_g77_math1,
  1149. x, BT_REAL, dd, REQUIRED);
  1150. make_generic ("bessel_y1", GFC_ISYM_Y1, GFC_STD_F2008);
  1151. add_sym_2 ("besyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
  1152. gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn,
  1153. n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
  1154. make_alias ("bessel_yn", GFC_STD_F2008);
  1155. add_sym_2 ("dbesyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
  1156. gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn,
  1157. n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
  1158. add_sym_3 ("bessel_yn", GFC_ISYM_YN2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
  1159. gfc_check_bessel_n2, gfc_simplify_bessel_yn2, gfc_resolve_bessel_n2,
  1160. "n1", BT_INTEGER, di, REQUIRED,"n2", BT_INTEGER, di, REQUIRED,
  1161. x, BT_REAL, dr, REQUIRED);
  1162. set_attr_value (3, true, true, true);
  1163. make_generic ("bessel_yn", GFC_ISYM_YN, GFC_STD_F2008);
  1164. add_sym_2 ("bge", GFC_ISYM_BGE, CLASS_ELEMENTAL, ACTUAL_NO,
  1165. BT_LOGICAL, dl, GFC_STD_F2008,
  1166. gfc_check_bge_bgt_ble_blt, gfc_simplify_bge, NULL,
  1167. i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
  1168. make_generic ("bge", GFC_ISYM_BGE, GFC_STD_F2008);
  1169. add_sym_2 ("bgt", GFC_ISYM_BGT, CLASS_ELEMENTAL, ACTUAL_NO,
  1170. BT_LOGICAL, dl, GFC_STD_F2008,
  1171. gfc_check_bge_bgt_ble_blt, gfc_simplify_bgt, NULL,
  1172. i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
  1173. make_generic ("bgt", GFC_ISYM_BGT, GFC_STD_F2008);
  1174. add_sym_1 ("bit_size", GFC_ISYM_BIT_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1175. gfc_check_i, gfc_simplify_bit_size, NULL,
  1176. i, BT_INTEGER, di, REQUIRED);
  1177. make_generic ("bit_size", GFC_ISYM_BIT_SIZE, GFC_STD_F95);
  1178. add_sym_2 ("ble", GFC_ISYM_BLE, CLASS_ELEMENTAL, ACTUAL_NO,
  1179. BT_LOGICAL, dl, GFC_STD_F2008,
  1180. gfc_check_bge_bgt_ble_blt, gfc_simplify_ble, NULL,
  1181. i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
  1182. make_generic ("ble", GFC_ISYM_BLE, GFC_STD_F2008);
  1183. add_sym_2 ("blt", GFC_ISYM_BLT, CLASS_ELEMENTAL, ACTUAL_NO,
  1184. BT_LOGICAL, dl, GFC_STD_F2008,
  1185. gfc_check_bge_bgt_ble_blt, gfc_simplify_blt, NULL,
  1186. i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
  1187. make_generic ("blt", GFC_ISYM_BLT, GFC_STD_F2008);
  1188. add_sym_2 ("btest", GFC_ISYM_BTEST, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
  1189. gfc_check_bitfcn, gfc_simplify_btest, gfc_resolve_btest,
  1190. i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
  1191. make_generic ("btest", GFC_ISYM_BTEST, GFC_STD_F95);
  1192. add_sym_2 ("ceiling", GFC_ISYM_CEILING, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1193. gfc_check_a_ikind, gfc_simplify_ceiling, gfc_resolve_ceiling,
  1194. a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
  1195. make_generic ("ceiling", GFC_ISYM_CEILING, GFC_STD_F95);
  1196. add_sym_2 ("char", GFC_ISYM_CHAR, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F77,
  1197. gfc_check_char, gfc_simplify_char, gfc_resolve_char,
  1198. i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
  1199. make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77);
  1200. add_sym_1 ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
  1201. GFC_STD_GNU, gfc_check_chdir, NULL, gfc_resolve_chdir,
  1202. nm, BT_CHARACTER, dc, REQUIRED);
  1203. make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU);
  1204. add_sym_2 ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1205. di, GFC_STD_GNU, gfc_check_chmod, NULL, gfc_resolve_chmod,
  1206. nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED);
  1207. make_generic ("chmod", GFC_ISYM_CHMOD, GFC_STD_GNU);
  1208. add_sym_3 ("cmplx", GFC_ISYM_CMPLX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_F77,
  1209. gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx,
  1210. x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, OPTIONAL,
  1211. kind, BT_INTEGER, di, OPTIONAL);
  1212. make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77);
  1213. add_sym_0 ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, CLASS_INQUIRY,
  1214. ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003, NULL, NULL, NULL);
  1215. make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT,
  1216. GFC_STD_F2003);
  1217. add_sym_2 ("complex", GFC_ISYM_COMPLEX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_GNU,
  1218. gfc_check_complex, gfc_simplify_complex, gfc_resolve_complex,
  1219. x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED);
  1220. make_generic ("complex", GFC_ISYM_COMPLEX, GFC_STD_GNU);
  1221. /* Making dcmplx a specific of cmplx causes cmplx to return a double
  1222. complex instead of the default complex. */
  1223. add_sym_2 ("dcmplx", GFC_ISYM_CMPLX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dd, GFC_STD_GNU,
  1224. gfc_check_dcmplx, gfc_simplify_dcmplx, gfc_resolve_dcmplx,
  1225. x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, OPTIONAL);
  1226. make_generic ("dcmplx", GFC_ISYM_CMPLX, GFC_STD_GNU);
  1227. add_sym_1 ("conjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
  1228. gfc_check_fn_c, gfc_simplify_conjg, gfc_resolve_conjg,
  1229. z, BT_COMPLEX, dz, REQUIRED);
  1230. add_sym_1 ("dconjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
  1231. NULL, gfc_simplify_conjg, gfc_resolve_conjg,
  1232. z, BT_COMPLEX, dd, REQUIRED);
  1233. make_generic ("conjg", GFC_ISYM_CONJG, GFC_STD_F77);
  1234. add_sym_1 ("cos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  1235. gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
  1236. x, BT_REAL, dr, REQUIRED);
  1237. add_sym_1 ("dcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  1238. gfc_check_fn_d, gfc_simplify_cos, gfc_resolve_cos,
  1239. x, BT_REAL, dd, REQUIRED);
  1240. add_sym_1 ("ccos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
  1241. NULL, gfc_simplify_cos, gfc_resolve_cos,
  1242. x, BT_COMPLEX, dz, REQUIRED);
  1243. add_sym_1 ("zcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
  1244. NULL, gfc_simplify_cos, gfc_resolve_cos,
  1245. x, BT_COMPLEX, dd, REQUIRED);
  1246. make_alias ("cdcos", GFC_STD_GNU);
  1247. make_generic ("cos", GFC_ISYM_COS, GFC_STD_F77);
  1248. add_sym_1 ("cosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  1249. gfc_check_fn_rc2008, gfc_simplify_cosh, gfc_resolve_cosh,
  1250. x, BT_REAL, dr, REQUIRED);
  1251. add_sym_1 ("dcosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  1252. gfc_check_fn_d, gfc_simplify_cosh, gfc_resolve_cosh,
  1253. x, BT_REAL, dd, REQUIRED);
  1254. make_generic ("cosh", GFC_ISYM_COSH, GFC_STD_F77);
  1255. add_sym_3 ("count", GFC_ISYM_COUNT, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
  1256. BT_INTEGER, di, GFC_STD_F95,
  1257. gfc_check_count, gfc_simplify_count, gfc_resolve_count,
  1258. msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
  1259. kind, BT_INTEGER, di, OPTIONAL);
  1260. make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95);
  1261. add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1262. gfc_check_cshift, NULL, gfc_resolve_cshift,
  1263. ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
  1264. dm, BT_INTEGER, ii, OPTIONAL);
  1265. make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95);
  1266. add_sym_1 ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
  1267. 0, GFC_STD_GNU, gfc_check_ctime, NULL, gfc_resolve_ctime,
  1268. tm, BT_INTEGER, di, REQUIRED);
  1269. make_generic ("ctime", GFC_ISYM_CTIME, GFC_STD_GNU);
  1270. add_sym_1 ("dble", GFC_ISYM_DBLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
  1271. gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble,
  1272. a, BT_REAL, dr, REQUIRED);
  1273. make_generic ("dble", GFC_ISYM_DBLE, GFC_STD_F77);
  1274. add_sym_1 ("digits", GFC_ISYM_DIGITS, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1275. gfc_check_digits, gfc_simplify_digits, NULL,
  1276. x, BT_UNKNOWN, dr, REQUIRED);
  1277. make_generic ("digits", GFC_ISYM_DIGITS, GFC_STD_F95);
  1278. add_sym_2 ("dim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  1279. gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim,
  1280. x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
  1281. add_sym_2 ("idim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
  1282. NULL, gfc_simplify_dim, gfc_resolve_dim,
  1283. x, BT_INTEGER, di, REQUIRED, y, BT_INTEGER, di, REQUIRED);
  1284. add_sym_2 ("ddim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  1285. gfc_check_x_yd, gfc_simplify_dim, gfc_resolve_dim,
  1286. x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, REQUIRED);
  1287. make_generic ("dim", GFC_ISYM_DIM, GFC_STD_F77);
  1288. add_sym_2 ("dot_product", GFC_ISYM_DOT_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr,
  1289. GFC_STD_F95, gfc_check_dot_product, gfc_simplify_dot_product, gfc_resolve_dot_product,
  1290. va, BT_REAL, dr, REQUIRED, vb, BT_REAL, dr, REQUIRED);
  1291. make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT, GFC_STD_F95);
  1292. add_sym_2 ("dprod", GFC_ISYM_DPROD,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  1293. gfc_check_dprod, gfc_simplify_dprod, gfc_resolve_dprod,
  1294. x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
  1295. make_generic ("dprod", GFC_ISYM_DPROD, GFC_STD_F77);
  1296. add_sym_1 ("dreal", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO,
  1297. BT_REAL, dd, GFC_STD_GNU, NULL, gfc_simplify_dreal, NULL,
  1298. a, BT_COMPLEX, dd, REQUIRED);
  1299. make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU);
  1300. add_sym_3 ("dshiftl", GFC_ISYM_DSHIFTL, CLASS_ELEMENTAL, ACTUAL_NO,
  1301. BT_INTEGER, di, GFC_STD_F2008,
  1302. gfc_check_dshift, gfc_simplify_dshiftl, gfc_resolve_dshift,
  1303. i, BT_INTEGER, di, REQUIRED,
  1304. j, BT_INTEGER, di, REQUIRED,
  1305. sh, BT_INTEGER, di, REQUIRED);
  1306. make_generic ("dshiftl", GFC_ISYM_DSHIFTL, GFC_STD_F2008);
  1307. add_sym_3 ("dshiftr", GFC_ISYM_DSHIFTR, CLASS_ELEMENTAL, ACTUAL_NO,
  1308. BT_INTEGER, di, GFC_STD_F2008,
  1309. gfc_check_dshift, gfc_simplify_dshiftr, gfc_resolve_dshift,
  1310. i, BT_INTEGER, di, REQUIRED,
  1311. j, BT_INTEGER, di, REQUIRED,
  1312. sh, BT_INTEGER, di, REQUIRED);
  1313. make_generic ("dshiftr", GFC_ISYM_DSHIFTR, GFC_STD_F2008);
  1314. add_sym_4 ("eoshift", GFC_ISYM_EOSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1315. gfc_check_eoshift, NULL, gfc_resolve_eoshift,
  1316. ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, ii, REQUIRED,
  1317. bd, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL);
  1318. make_generic ("eoshift", GFC_ISYM_EOSHIFT, GFC_STD_F95);
  1319. add_sym_1 ("epsilon", GFC_ISYM_EPSILON, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1320. gfc_check_x, gfc_simplify_epsilon, NULL,
  1321. x, BT_REAL, dr, REQUIRED);
  1322. make_generic ("epsilon", GFC_ISYM_EPSILON, GFC_STD_F95);
  1323. /* G77 compatibility for the ERF() and ERFC() functions. */
  1324. add_sym_1 ("erf", GFC_ISYM_ERF, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
  1325. GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_erf,
  1326. gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED);
  1327. add_sym_1 ("derf", GFC_ISYM_ERF, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd,
  1328. GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_erf,
  1329. gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED);
  1330. make_generic ("erf", GFC_ISYM_ERF, GFC_STD_F2008);
  1331. add_sym_1 ("erfc", GFC_ISYM_ERFC, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
  1332. GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_erfc,
  1333. gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED);
  1334. add_sym_1 ("derfc", GFC_ISYM_ERFC, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd,
  1335. GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_erfc,
  1336. gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED);
  1337. make_generic ("erfc", GFC_ISYM_ERFC, GFC_STD_F2008);
  1338. add_sym_1 ("erfc_scaled", GFC_ISYM_ERFC_SCALED, CLASS_ELEMENTAL, ACTUAL_NO,
  1339. BT_REAL, dr, GFC_STD_F2008, gfc_check_fn_r,
  1340. gfc_simplify_erfc_scaled, gfc_resolve_g77_math1, x, BT_REAL,
  1341. dr, REQUIRED);
  1342. make_generic ("erfc_scaled", GFC_ISYM_ERFC_SCALED, GFC_STD_F2008);
  1343. /* G77 compatibility */
  1344. add_sym_1 ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
  1345. 4, GFC_STD_GNU, gfc_check_dtime_etime, NULL, NULL,
  1346. x, BT_REAL, 4, REQUIRED);
  1347. make_generic ("dtime", GFC_ISYM_DTIME, GFC_STD_GNU);
  1348. add_sym_1 ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
  1349. 4, GFC_STD_GNU, gfc_check_dtime_etime, NULL, NULL,
  1350. x, BT_REAL, 4, REQUIRED);
  1351. make_generic ("etime", GFC_ISYM_ETIME, GFC_STD_GNU);
  1352. add_sym_1 ("exp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  1353. gfc_check_fn_rc, gfc_simplify_exp, gfc_resolve_exp,
  1354. x, BT_REAL, dr, REQUIRED);
  1355. add_sym_1 ("dexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  1356. gfc_check_fn_d, gfc_simplify_exp, gfc_resolve_exp,
  1357. x, BT_REAL, dd, REQUIRED);
  1358. add_sym_1 ("cexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
  1359. NULL, gfc_simplify_exp, gfc_resolve_exp,
  1360. x, BT_COMPLEX, dz, REQUIRED);
  1361. add_sym_1 ("zexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
  1362. NULL, gfc_simplify_exp, gfc_resolve_exp,
  1363. x, BT_COMPLEX, dd, REQUIRED);
  1364. make_alias ("cdexp", GFC_STD_GNU);
  1365. make_generic ("exp", GFC_ISYM_EXP, GFC_STD_F77);
  1366. add_sym_1 ("exponent", GFC_ISYM_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1367. gfc_check_x, gfc_simplify_exponent, gfc_resolve_exponent,
  1368. x, BT_REAL, dr, REQUIRED);
  1369. make_generic ("exponent", GFC_ISYM_EXPONENT, GFC_STD_F95);
  1370. add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY,
  1371. ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
  1372. gfc_check_same_type_as, gfc_simplify_extends_type_of,
  1373. gfc_resolve_extends_type_of,
  1374. a, BT_UNKNOWN, 0, REQUIRED,
  1375. mo, BT_UNKNOWN, 0, REQUIRED);
  1376. add_sym_0 ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
  1377. dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate);
  1378. make_generic ("fdate", GFC_ISYM_FDATE, GFC_STD_GNU);
  1379. add_sym_2 ("floor", GFC_ISYM_FLOOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1380. gfc_check_a_ikind, gfc_simplify_floor, gfc_resolve_floor,
  1381. a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
  1382. make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95);
  1383. /* G77 compatible fnum */
  1384. add_sym_1 ("fnum", GFC_ISYM_FNUM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1385. di, GFC_STD_GNU, gfc_check_fnum, NULL, gfc_resolve_fnum,
  1386. ut, BT_INTEGER, di, REQUIRED);
  1387. make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU);
  1388. add_sym_1 ("fraction", GFC_ISYM_FRACTION, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1389. gfc_check_x, gfc_simplify_fraction, gfc_resolve_fraction,
  1390. x, BT_REAL, dr, REQUIRED);
  1391. make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95);
  1392. add_sym_2_intent ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, ACTUAL_NO,
  1393. BT_INTEGER, di, GFC_STD_GNU,
  1394. gfc_check_fstat, NULL, gfc_resolve_fstat,
  1395. ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
  1396. vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
  1397. make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU);
  1398. add_sym_1 ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1399. ii, GFC_STD_GNU, gfc_check_ftell, NULL, gfc_resolve_ftell,
  1400. ut, BT_INTEGER, di, REQUIRED);
  1401. make_generic ("ftell", GFC_ISYM_FTELL, GFC_STD_GNU);
  1402. add_sym_2_intent ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, ACTUAL_NO,
  1403. BT_INTEGER, di, GFC_STD_GNU,
  1404. gfc_check_fgetputc, NULL, gfc_resolve_fgetc,
  1405. ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
  1406. c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
  1407. make_generic ("fgetc", GFC_ISYM_FGETC, GFC_STD_GNU);
  1408. add_sym_1_intent ("fget", GFC_ISYM_FGET, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1409. di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fget,
  1410. c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
  1411. make_generic ("fget", GFC_ISYM_FGET, GFC_STD_GNU);
  1412. add_sym_2 ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1413. di, GFC_STD_GNU, gfc_check_fgetputc, NULL, gfc_resolve_fputc,
  1414. ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
  1415. make_generic ("fputc", GFC_ISYM_FPUTC, GFC_STD_GNU);
  1416. add_sym_1 ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1417. di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fput,
  1418. c, BT_CHARACTER, dc, REQUIRED);
  1419. make_generic ("fput", GFC_ISYM_FPUT, GFC_STD_GNU);
  1420. add_sym_1 ("gamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
  1421. GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_gamma,
  1422. gfc_resolve_gamma, x, BT_REAL, dr, REQUIRED);
  1423. add_sym_1 ("dgamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
  1424. gfc_check_fn_d, gfc_simplify_gamma, gfc_resolve_gamma,
  1425. x, BT_REAL, dr, REQUIRED);
  1426. make_generic ("gamma", GFC_ISYM_TGAMMA, GFC_STD_F2008);
  1427. /* Unix IDs (g77 compatibility) */
  1428. add_sym_1 ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1429. di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getcwd,
  1430. c, BT_CHARACTER, dc, REQUIRED);
  1431. make_generic ("getcwd", GFC_ISYM_GETCWD, GFC_STD_GNU);
  1432. add_sym_0 ("getgid", GFC_ISYM_GETGID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1433. di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getgid);
  1434. make_generic ("getgid", GFC_ISYM_GETGID, GFC_STD_GNU);
  1435. add_sym_0 ("getpid", GFC_ISYM_GETPID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1436. di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getpid);
  1437. make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU);
  1438. add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1439. di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid);
  1440. make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU);
  1441. add_sym_1_intent ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, ACTUAL_NO,
  1442. BT_INTEGER, di, GFC_STD_GNU,
  1443. gfc_check_hostnm, NULL, gfc_resolve_hostnm,
  1444. c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
  1445. make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU);
  1446. add_sym_1 ("huge", GFC_ISYM_HUGE, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1447. gfc_check_huge, gfc_simplify_huge, NULL,
  1448. x, BT_UNKNOWN, dr, REQUIRED);
  1449. make_generic ("huge", GFC_ISYM_HUGE, GFC_STD_F95);
  1450. add_sym_2 ("hypot", GFC_ISYM_HYPOT, CLASS_ELEMENTAL, ACTUAL_NO,
  1451. BT_REAL, dr, GFC_STD_F2008,
  1452. gfc_check_hypot, gfc_simplify_hypot, gfc_resolve_hypot,
  1453. x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
  1454. make_generic ("hypot", GFC_ISYM_HYPOT, GFC_STD_F2008);
  1455. add_sym_2 ("iachar", GFC_ISYM_IACHAR, CLASS_ELEMENTAL, ACTUAL_NO,
  1456. BT_INTEGER, di, GFC_STD_F95,
  1457. gfc_check_ichar_iachar, gfc_simplify_iachar, gfc_resolve_iachar,
  1458. c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
  1459. make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95);
  1460. add_sym_2 ("iand", GFC_ISYM_IAND, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1461. gfc_check_iand, gfc_simplify_iand, gfc_resolve_iand,
  1462. i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
  1463. make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95);
  1464. add_sym_2 ("and", GFC_ISYM_AND, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
  1465. dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_and, gfc_resolve_and,
  1466. i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
  1467. make_generic ("and", GFC_ISYM_AND, GFC_STD_GNU);
  1468. add_sym_3red ("iall", GFC_ISYM_IALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
  1469. gfc_check_transf_bit_intrins, gfc_simplify_iall, gfc_resolve_iall,
  1470. ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
  1471. msk, BT_LOGICAL, dl, OPTIONAL);
  1472. make_generic ("iall", GFC_ISYM_IALL, GFC_STD_F2008);
  1473. add_sym_3red ("iany", GFC_ISYM_IANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
  1474. gfc_check_transf_bit_intrins, gfc_simplify_iany, gfc_resolve_iany,
  1475. ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
  1476. msk, BT_LOGICAL, dl, OPTIONAL);
  1477. make_generic ("iany", GFC_ISYM_IANY, GFC_STD_F2008);
  1478. add_sym_0 ("iargc", GFC_ISYM_IARGC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1479. di, GFC_STD_GNU, NULL, NULL, NULL);
  1480. make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU);
  1481. add_sym_2 ("ibclr", GFC_ISYM_IBCLR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1482. gfc_check_bitfcn, gfc_simplify_ibclr, gfc_resolve_ibclr,
  1483. i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
  1484. make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95);
  1485. add_sym_3 ("ibits", GFC_ISYM_IBITS, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1486. gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits,
  1487. i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED,
  1488. ln, BT_INTEGER, di, REQUIRED);
  1489. make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95);
  1490. add_sym_2 ("ibset", GFC_ISYM_IBSET, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1491. gfc_check_bitfcn, gfc_simplify_ibset, gfc_resolve_ibset,
  1492. i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
  1493. make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95);
  1494. add_sym_2 ("ichar", GFC_ISYM_ICHAR, CLASS_ELEMENTAL, ACTUAL_NO,
  1495. BT_INTEGER, di, GFC_STD_F77,
  1496. gfc_check_ichar_iachar, gfc_simplify_ichar, gfc_resolve_ichar,
  1497. c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
  1498. make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77);
  1499. add_sym_2 ("ieor", GFC_ISYM_IEOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1500. gfc_check_ieor, gfc_simplify_ieor, gfc_resolve_ieor,
  1501. i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
  1502. make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95);
  1503. add_sym_2 ("xor", GFC_ISYM_XOR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
  1504. dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_xor, gfc_resolve_xor,
  1505. i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
  1506. make_generic ("xor", GFC_ISYM_XOR, GFC_STD_GNU);
  1507. add_sym_0 ("ierrno", GFC_ISYM_IERRNO, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1508. di, GFC_STD_GNU, NULL, NULL, gfc_resolve_ierrno);
  1509. make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
  1510. add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
  1511. gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index,
  1512. ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED);
  1513. /* The resolution function for INDEX is called gfc_resolve_index_func
  1514. because the name gfc_resolve_index is already used in resolve.c. */
  1515. add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES,
  1516. BT_INTEGER, di, GFC_STD_F77,
  1517. gfc_check_index, gfc_simplify_index, gfc_resolve_index_func,
  1518. stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED,
  1519. bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
  1520. make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77);
  1521. add_sym_2 ("int", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
  1522. gfc_check_int, gfc_simplify_int, gfc_resolve_int,
  1523. a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
  1524. add_sym_1 ("ifix", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
  1525. NULL, gfc_simplify_ifix, NULL,
  1526. a, BT_REAL, dr, REQUIRED);
  1527. add_sym_1 ("idint", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
  1528. NULL, gfc_simplify_idint, NULL,
  1529. a, BT_REAL, dd, REQUIRED);
  1530. make_generic ("int", GFC_ISYM_INT, GFC_STD_F77);
  1531. add_sym_1 ("int2", GFC_ISYM_INT2, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
  1532. gfc_check_intconv, gfc_simplify_int2, gfc_resolve_int2,
  1533. a, BT_REAL, dr, REQUIRED);
  1534. make_alias ("short", GFC_STD_GNU);
  1535. make_generic ("int2", GFC_ISYM_INT2, GFC_STD_GNU);
  1536. add_sym_1 ("int8", GFC_ISYM_INT8, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
  1537. gfc_check_intconv, gfc_simplify_int8, gfc_resolve_int8,
  1538. a, BT_REAL, dr, REQUIRED);
  1539. make_generic ("int8", GFC_ISYM_INT8, GFC_STD_GNU);
  1540. add_sym_1 ("long", GFC_ISYM_LONG, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
  1541. gfc_check_intconv, gfc_simplify_long, gfc_resolve_long,
  1542. a, BT_REAL, dr, REQUIRED);
  1543. make_generic ("long", GFC_ISYM_LONG, GFC_STD_GNU);
  1544. add_sym_2 ("ior", GFC_ISYM_IOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1545. gfc_check_ior, gfc_simplify_ior, gfc_resolve_ior,
  1546. i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
  1547. make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95);
  1548. add_sym_2 ("or", GFC_ISYM_OR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
  1549. dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_or, gfc_resolve_or,
  1550. i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
  1551. make_generic ("or", GFC_ISYM_OR, GFC_STD_GNU);
  1552. add_sym_3red ("iparity", GFC_ISYM_IPARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
  1553. gfc_check_transf_bit_intrins, gfc_simplify_iparity, gfc_resolve_iparity,
  1554. ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
  1555. msk, BT_LOGICAL, dl, OPTIONAL);
  1556. make_generic ("iparity", GFC_ISYM_IPARITY, GFC_STD_F2008);
  1557. /* The following function is for G77 compatibility. */
  1558. add_sym_1 ("irand", GFC_ISYM_IRAND, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1559. 4, GFC_STD_GNU, gfc_check_irand, NULL, NULL,
  1560. i, BT_INTEGER, 4, OPTIONAL);
  1561. make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU);
  1562. add_sym_1 ("isatty", GFC_ISYM_ISATTY, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
  1563. dl, GFC_STD_GNU, gfc_check_isatty, NULL, gfc_resolve_isatty,
  1564. ut, BT_INTEGER, di, REQUIRED);
  1565. make_generic ("isatty", GFC_ISYM_ISATTY, GFC_STD_GNU);
  1566. add_sym_1 ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END,
  1567. CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
  1568. gfc_check_i, gfc_simplify_is_iostat_end, NULL,
  1569. i, BT_INTEGER, 0, REQUIRED);
  1570. make_generic ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END, GFC_STD_F2003);
  1571. add_sym_1 ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR,
  1572. CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
  1573. gfc_check_i, gfc_simplify_is_iostat_eor, NULL,
  1574. i, BT_INTEGER, 0, REQUIRED);
  1575. make_generic ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR, GFC_STD_F2003);
  1576. add_sym_1 ("isnan", GFC_ISYM_ISNAN, CLASS_ELEMENTAL, ACTUAL_NO,
  1577. BT_LOGICAL, dl, GFC_STD_GNU,
  1578. gfc_check_isnan, gfc_simplify_isnan, NULL,
  1579. x, BT_REAL, 0, REQUIRED);
  1580. make_generic ("isnan", GFC_ISYM_ISNAN, GFC_STD_GNU);
  1581. add_sym_2 ("rshift", GFC_ISYM_RSHIFT, CLASS_ELEMENTAL, ACTUAL_NO,
  1582. BT_INTEGER, di, GFC_STD_GNU,
  1583. gfc_check_ishft, gfc_simplify_rshift, gfc_resolve_rshift,
  1584. i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
  1585. make_generic ("rshift", GFC_ISYM_RSHIFT, GFC_STD_GNU);
  1586. add_sym_2 ("lshift", GFC_ISYM_LSHIFT, CLASS_ELEMENTAL, ACTUAL_NO,
  1587. BT_INTEGER, di, GFC_STD_GNU,
  1588. gfc_check_ishft, gfc_simplify_lshift, gfc_resolve_lshift,
  1589. i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
  1590. make_generic ("lshift", GFC_ISYM_LSHIFT, GFC_STD_GNU);
  1591. add_sym_2 ("ishft", GFC_ISYM_ISHFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1592. gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft,
  1593. i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
  1594. make_generic ("ishft", GFC_ISYM_ISHFT, GFC_STD_F95);
  1595. add_sym_3 ("ishftc", GFC_ISYM_ISHFTC, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1596. gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc,
  1597. i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
  1598. sz, BT_INTEGER, di, OPTIONAL);
  1599. make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95);
  1600. add_sym_2 ("kill", GFC_ISYM_KILL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1601. di, GFC_STD_GNU, gfc_check_kill, NULL, gfc_resolve_kill,
  1602. a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
  1603. make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU);
  1604. add_sym_1 ("kind", GFC_ISYM_KIND, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1605. gfc_check_kind, gfc_simplify_kind, NULL,
  1606. x, BT_REAL, dr, REQUIRED);
  1607. make_generic ("kind", GFC_ISYM_KIND, GFC_STD_F95);
  1608. add_sym_3 ("lbound", GFC_ISYM_LBOUND, CLASS_INQUIRY, ACTUAL_NO,
  1609. BT_INTEGER, di, GFC_STD_F95,
  1610. gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound,
  1611. ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, di, OPTIONAL,
  1612. kind, BT_INTEGER, di, OPTIONAL);
  1613. make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
  1614. add_sym_3 ("lcobound", GFC_ISYM_LCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
  1615. BT_INTEGER, di, GFC_STD_F2008,
  1616. gfc_check_lcobound, gfc_simplify_lcobound, gfc_resolve_lcobound,
  1617. ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
  1618. kind, BT_INTEGER, di, OPTIONAL);
  1619. make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F2008);
  1620. add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO,
  1621. BT_INTEGER, di, GFC_STD_F2008,
  1622. gfc_check_i, gfc_simplify_leadz, NULL,
  1623. i, BT_INTEGER, di, REQUIRED);
  1624. make_generic ("leadz", GFC_ISYM_LEADZ, GFC_STD_F2008);
  1625. add_sym_2 ("len", GFC_ISYM_LEN, CLASS_INQUIRY, ACTUAL_YES,
  1626. BT_INTEGER, di, GFC_STD_F77,
  1627. gfc_check_len_lentrim, gfc_simplify_len, gfc_resolve_len,
  1628. stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
  1629. make_generic ("len", GFC_ISYM_LEN, GFC_STD_F77);
  1630. add_sym_2 ("len_trim", GFC_ISYM_LEN_TRIM, CLASS_ELEMENTAL, ACTUAL_NO,
  1631. BT_INTEGER, di, GFC_STD_F95,
  1632. gfc_check_len_lentrim, gfc_simplify_len_trim, gfc_resolve_len_trim,
  1633. stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
  1634. make_alias ("lnblnk", GFC_STD_GNU);
  1635. make_generic ("len_trim", GFC_ISYM_LEN_TRIM, GFC_STD_F95);
  1636. add_sym_1 ("lgamma", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL,
  1637. dr, GFC_STD_GNU,
  1638. gfc_check_fn_r, gfc_simplify_lgamma, gfc_resolve_lgamma,
  1639. x, BT_REAL, dr, REQUIRED);
  1640. make_alias ("log_gamma", GFC_STD_F2008);
  1641. add_sym_1 ("algama", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
  1642. gfc_check_fn_r, gfc_simplify_lgamma, gfc_resolve_lgamma,
  1643. x, BT_REAL, dr, REQUIRED);
  1644. add_sym_1 ("dlgama", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
  1645. gfc_check_fn_d, gfc_simplify_lgamma, gfc_resolve_lgamma,
  1646. x, BT_REAL, dr, REQUIRED);
  1647. make_generic ("log_gamma", GFC_ISYM_LGAMMA, GFC_STD_F2008);
  1648. add_sym_2 ("lge", GFC_ISYM_LGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
  1649. GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lge, NULL,
  1650. sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
  1651. make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77);
  1652. add_sym_2 ("lgt", GFC_ISYM_LGT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
  1653. GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lgt, NULL,
  1654. sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
  1655. make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77);
  1656. add_sym_2 ("lle",GFC_ISYM_LLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
  1657. GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lle, NULL,
  1658. sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
  1659. make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77);
  1660. add_sym_2 ("llt", GFC_ISYM_LLT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
  1661. GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_llt, NULL,
  1662. sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
  1663. make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77);
  1664. add_sym_2 ("link", GFC_ISYM_LINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
  1665. GFC_STD_GNU, gfc_check_link, NULL, gfc_resolve_link,
  1666. p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
  1667. make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU);
  1668. add_sym_1 ("log", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
  1669. gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log,
  1670. x, BT_REAL, dr, REQUIRED);
  1671. add_sym_1 ("alog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  1672. NULL, gfc_simplify_log, gfc_resolve_log,
  1673. x, BT_REAL, dr, REQUIRED);
  1674. add_sym_1 ("dlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  1675. gfc_check_fn_d, gfc_simplify_log, gfc_resolve_log,
  1676. x, BT_REAL, dd, REQUIRED);
  1677. add_sym_1 ("clog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
  1678. NULL, gfc_simplify_log, gfc_resolve_log,
  1679. x, BT_COMPLEX, dz, REQUIRED);
  1680. add_sym_1 ("zlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
  1681. NULL, gfc_simplify_log, gfc_resolve_log,
  1682. x, BT_COMPLEX, dd, REQUIRED);
  1683. make_alias ("cdlog", GFC_STD_GNU);
  1684. make_generic ("log", GFC_ISYM_LOG, GFC_STD_F77);
  1685. add_sym_1 ("log10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
  1686. gfc_check_fn_r, gfc_simplify_log10, gfc_resolve_log10,
  1687. x, BT_REAL, dr, REQUIRED);
  1688. add_sym_1 ("alog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  1689. NULL, gfc_simplify_log10, gfc_resolve_log10,
  1690. x, BT_REAL, dr, REQUIRED);
  1691. add_sym_1 ("dlog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  1692. gfc_check_fn_d, gfc_simplify_log10, gfc_resolve_log10,
  1693. x, BT_REAL, dd, REQUIRED);
  1694. make_generic ("log10", GFC_ISYM_LOG10, GFC_STD_F77);
  1695. add_sym_2 ("logical", GFC_ISYM_LOGICAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
  1696. gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical,
  1697. l, BT_LOGICAL, dl, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
  1698. make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95);
  1699. add_sym_2_intent ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, ACTUAL_NO,
  1700. BT_INTEGER, di, GFC_STD_GNU,
  1701. gfc_check_stat, NULL, gfc_resolve_lstat,
  1702. nm, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  1703. vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
  1704. make_generic ("lstat", GFC_ISYM_LSTAT, GFC_STD_GNU);
  1705. add_sym_1 ("malloc", GFC_ISYM_MALLOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii,
  1706. GFC_STD_GNU, gfc_check_malloc, NULL, gfc_resolve_malloc,
  1707. sz, BT_INTEGER, di, REQUIRED);
  1708. make_generic ("malloc", GFC_ISYM_MALLOC, GFC_STD_GNU);
  1709. add_sym_2 ("maskl", GFC_ISYM_MASKL, CLASS_ELEMENTAL, ACTUAL_NO,
  1710. BT_INTEGER, di, GFC_STD_F2008,
  1711. gfc_check_mask, gfc_simplify_maskl, gfc_resolve_mask,
  1712. i, BT_INTEGER, di, REQUIRED,
  1713. kind, BT_INTEGER, di, OPTIONAL);
  1714. make_generic ("maskl", GFC_ISYM_MASKL, GFC_STD_F2008);
  1715. add_sym_2 ("maskr", GFC_ISYM_MASKR, CLASS_ELEMENTAL, ACTUAL_NO,
  1716. BT_INTEGER, di, GFC_STD_F2008,
  1717. gfc_check_mask, gfc_simplify_maskr, gfc_resolve_mask,
  1718. i, BT_INTEGER, di, REQUIRED,
  1719. kind, BT_INTEGER, di, OPTIONAL);
  1720. make_generic ("maskr", GFC_ISYM_MASKR, GFC_STD_F2008);
  1721. add_sym_2 ("matmul", GFC_ISYM_MATMUL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1722. gfc_check_matmul, gfc_simplify_matmul, gfc_resolve_matmul,
  1723. ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED);
  1724. make_generic ("matmul", GFC_ISYM_MATMUL, GFC_STD_F95);
  1725. /* Note: amax0 is equivalent to real(max), max1 is equivalent to
  1726. int(max). The max function must take at least two arguments. */
  1727. add_sym_1m ("max", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77,
  1728. gfc_check_min_max, gfc_simplify_max, gfc_resolve_max,
  1729. a1, BT_UNKNOWN, dr, REQUIRED, a2, BT_UNKNOWN, dr, REQUIRED);
  1730. add_sym_1m ("max0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
  1731. gfc_check_min_max_integer, gfc_simplify_max, NULL,
  1732. a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
  1733. add_sym_1m ("amax0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
  1734. gfc_check_min_max_integer, gfc_simplify_max, NULL,
  1735. a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
  1736. add_sym_1m ("amax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
  1737. gfc_check_min_max_real, gfc_simplify_max, NULL,
  1738. a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
  1739. add_sym_1m ("max1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
  1740. gfc_check_min_max_real, gfc_simplify_max, NULL,
  1741. a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
  1742. add_sym_1m ("dmax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
  1743. gfc_check_min_max_double, gfc_simplify_max, NULL,
  1744. a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
  1745. make_generic ("max", GFC_ISYM_MAX, GFC_STD_F77);
  1746. add_sym_1 ("maxexponent", GFC_ISYM_MAXEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
  1747. GFC_STD_F95, gfc_check_x, gfc_simplify_maxexponent, NULL,
  1748. x, BT_UNKNOWN, dr, REQUIRED);
  1749. make_generic ("maxexponent", GFC_ISYM_MAXEXPONENT, GFC_STD_F95);
  1750. add_sym_3ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1751. gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
  1752. ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
  1753. msk, BT_LOGICAL, dl, OPTIONAL);
  1754. make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
  1755. add_sym_3red ("maxval", GFC_ISYM_MAXVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1756. gfc_check_minval_maxval, gfc_simplify_maxval, gfc_resolve_maxval,
  1757. ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
  1758. msk, BT_LOGICAL, dl, OPTIONAL);
  1759. make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95);
  1760. add_sym_0 ("mclock", GFC_ISYM_MCLOCK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
  1761. GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock);
  1762. make_generic ("mclock", GFC_ISYM_MCLOCK, GFC_STD_GNU);
  1763. add_sym_0 ("mclock8", GFC_ISYM_MCLOCK8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  1764. di, GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock8);
  1765. make_generic ("mclock8", GFC_ISYM_MCLOCK8, GFC_STD_GNU);
  1766. add_sym_3 ("merge", GFC_ISYM_MERGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1767. gfc_check_merge, gfc_simplify_merge, gfc_resolve_merge,
  1768. ts, BT_REAL, dr, REQUIRED, fs, BT_REAL, dr, REQUIRED,
  1769. msk, BT_LOGICAL, dl, REQUIRED);
  1770. make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95);
  1771. add_sym_3 ("merge_bits", GFC_ISYM_MERGE_BITS, CLASS_ELEMENTAL, ACTUAL_NO,
  1772. BT_INTEGER, di, GFC_STD_F2008,
  1773. gfc_check_merge_bits, gfc_simplify_merge_bits,
  1774. gfc_resolve_merge_bits,
  1775. i, BT_INTEGER, di, REQUIRED,
  1776. j, BT_INTEGER, di, REQUIRED,
  1777. msk, BT_INTEGER, di, REQUIRED);
  1778. make_generic ("merge_bits", GFC_ISYM_MERGE_BITS, GFC_STD_F2008);
  1779. /* Note: amin0 is equivalent to real(min), min1 is equivalent to
  1780. int(min). */
  1781. add_sym_1m ("min", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77,
  1782. gfc_check_min_max, gfc_simplify_min, gfc_resolve_min,
  1783. a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
  1784. add_sym_1m ("min0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
  1785. gfc_check_min_max_integer, gfc_simplify_min, NULL,
  1786. a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
  1787. add_sym_1m ("amin0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
  1788. gfc_check_min_max_integer, gfc_simplify_min, NULL,
  1789. a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
  1790. add_sym_1m ("amin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
  1791. gfc_check_min_max_real, gfc_simplify_min, NULL,
  1792. a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
  1793. add_sym_1m ("min1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
  1794. gfc_check_min_max_real, gfc_simplify_min, NULL,
  1795. a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
  1796. add_sym_1m ("dmin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
  1797. gfc_check_min_max_double, gfc_simplify_min, NULL,
  1798. a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
  1799. make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77);
  1800. add_sym_1 ("minexponent", GFC_ISYM_MINEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
  1801. GFC_STD_F95, gfc_check_x, gfc_simplify_minexponent, NULL,
  1802. x, BT_UNKNOWN, dr, REQUIRED);
  1803. make_generic ("minexponent", GFC_ISYM_MINEXPONENT, GFC_STD_F95);
  1804. add_sym_3ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1805. gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
  1806. ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
  1807. msk, BT_LOGICAL, dl, OPTIONAL);
  1808. make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
  1809. add_sym_3red ("minval", GFC_ISYM_MINVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1810. gfc_check_minval_maxval, gfc_simplify_minval, gfc_resolve_minval,
  1811. ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
  1812. msk, BT_LOGICAL, dl, OPTIONAL);
  1813. make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95);
  1814. add_sym_2 ("mod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
  1815. gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod,
  1816. a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED);
  1817. add_sym_2 ("amod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  1818. NULL, gfc_simplify_mod, gfc_resolve_mod,
  1819. a, BT_REAL, dr, REQUIRED, p, BT_REAL, dr, REQUIRED);
  1820. add_sym_2 ("dmod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  1821. gfc_check_x_yd, gfc_simplify_mod, gfc_resolve_mod,
  1822. a, BT_REAL, dd, REQUIRED, p, BT_REAL, dd, REQUIRED);
  1823. make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77);
  1824. add_sym_2 ("modulo", GFC_ISYM_MODULO, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, di, GFC_STD_F95,
  1825. gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo,
  1826. a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED);
  1827. make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95);
  1828. add_sym_2 ("nearest", GFC_ISYM_NEAREST, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1829. gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest,
  1830. x, BT_REAL, dr, REQUIRED, s, BT_REAL, dr, REQUIRED);
  1831. make_generic ("nearest", GFC_ISYM_NEAREST, GFC_STD_F95);
  1832. add_sym_1 ("new_line", GFC_ISYM_NEW_LINE, CLASS_INQUIRY, ACTUAL_NO, BT_CHARACTER, dc,
  1833. GFC_STD_F2003, gfc_check_new_line, gfc_simplify_new_line, NULL,
  1834. a, BT_CHARACTER, dc, REQUIRED);
  1835. make_generic ("new_line", GFC_ISYM_NEW_LINE, GFC_STD_F2003);
  1836. add_sym_2 ("nint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
  1837. gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
  1838. a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
  1839. add_sym_1 ("idnint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
  1840. gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint,
  1841. a, BT_REAL, dd, REQUIRED);
  1842. make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77);
  1843. add_sym_1 ("not", GFC_ISYM_NOT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1844. gfc_check_i, gfc_simplify_not, gfc_resolve_not,
  1845. i, BT_INTEGER, di, REQUIRED);
  1846. make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95);
  1847. add_sym_2 ("norm2", GFC_ISYM_NORM2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr,
  1848. GFC_STD_F2008, gfc_check_norm2, gfc_simplify_norm2, gfc_resolve_norm2,
  1849. x, BT_REAL, dr, REQUIRED,
  1850. dm, BT_INTEGER, ii, OPTIONAL);
  1851. make_generic ("norm2", GFC_ISYM_NORM2, GFC_STD_F2008);
  1852. add_sym_1 ("null", GFC_ISYM_NULL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1853. gfc_check_null, gfc_simplify_null, NULL,
  1854. mo, BT_INTEGER, di, OPTIONAL);
  1855. make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95);
  1856. add_sym_2 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_INQUIRY, ACTUAL_NO,
  1857. BT_INTEGER, di, GFC_STD_F2008,
  1858. gfc_check_num_images, gfc_simplify_num_images, NULL,
  1859. dist, BT_INTEGER, di, OPTIONAL,
  1860. failed, BT_LOGICAL, dl, OPTIONAL);
  1861. add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1862. gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack,
  1863. ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
  1864. v, BT_REAL, dr, OPTIONAL);
  1865. make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95);
  1866. add_sym_2 ("parity", GFC_ISYM_PARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl,
  1867. GFC_STD_F2008, gfc_check_parity, gfc_simplify_parity, gfc_resolve_parity,
  1868. msk, BT_LOGICAL, dl, REQUIRED,
  1869. dm, BT_INTEGER, ii, OPTIONAL);
  1870. make_generic ("parity", GFC_ISYM_PARITY, GFC_STD_F2008);
  1871. add_sym_1 ("popcnt", GFC_ISYM_POPCNT, CLASS_ELEMENTAL, ACTUAL_NO,
  1872. BT_INTEGER, di, GFC_STD_F2008,
  1873. gfc_check_i, gfc_simplify_popcnt, NULL,
  1874. i, BT_INTEGER, di, REQUIRED);
  1875. make_generic ("popcnt", GFC_ISYM_POPCNT, GFC_STD_F2008);
  1876. add_sym_1 ("poppar", GFC_ISYM_POPPAR, CLASS_ELEMENTAL, ACTUAL_NO,
  1877. BT_INTEGER, di, GFC_STD_F2008,
  1878. gfc_check_i, gfc_simplify_poppar, NULL,
  1879. i, BT_INTEGER, di, REQUIRED);
  1880. make_generic ("poppar", GFC_ISYM_POPPAR, GFC_STD_F2008);
  1881. add_sym_1 ("precision", GFC_ISYM_PRECISION, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1882. gfc_check_precision, gfc_simplify_precision, NULL,
  1883. x, BT_UNKNOWN, 0, REQUIRED);
  1884. make_generic ("precision", GFC_ISYM_PRECISION, GFC_STD_F95);
  1885. add_sym_1_intent ("present", GFC_ISYM_PRESENT, CLASS_INQUIRY, ACTUAL_NO,
  1886. BT_LOGICAL, dl, GFC_STD_F95, gfc_check_present, NULL, NULL,
  1887. a, BT_REAL, dr, REQUIRED, INTENT_UNKNOWN);
  1888. make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
  1889. add_sym_3red ("product", GFC_ISYM_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1890. gfc_check_product_sum, gfc_simplify_product, gfc_resolve_product,
  1891. ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
  1892. msk, BT_LOGICAL, dl, OPTIONAL);
  1893. make_generic ("product", GFC_ISYM_PRODUCT, GFC_STD_F95);
  1894. add_sym_1 ("radix", GFC_ISYM_RADIX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1895. gfc_check_radix, gfc_simplify_radix, NULL,
  1896. x, BT_UNKNOWN, 0, REQUIRED);
  1897. make_generic ("radix", GFC_ISYM_RADIX, GFC_STD_F95);
  1898. /* The following function is for G77 compatibility. */
  1899. add_sym_1 ("rand", GFC_ISYM_RAND, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
  1900. 4, GFC_STD_GNU, gfc_check_rand, NULL, NULL,
  1901. i, BT_INTEGER, 4, OPTIONAL);
  1902. /* Compatibility with HP FORTRAN 77/iX Reference. Note, rand() and ran()
  1903. use slightly different shoddy multiplicative congruential PRNG. */
  1904. make_alias ("ran", GFC_STD_GNU);
  1905. make_generic ("rand", GFC_ISYM_RAND, GFC_STD_GNU);
  1906. add_sym_1 ("range", GFC_ISYM_RANGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1907. gfc_check_range, gfc_simplify_range, NULL,
  1908. x, BT_REAL, dr, REQUIRED);
  1909. make_generic ("range", GFC_ISYM_RANGE, GFC_STD_F95);
  1910. add_sym_1 ("rank", GFC_ISYM_RANK, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
  1911. GFC_STD_F2008_TS, gfc_check_rank, gfc_simplify_rank, gfc_resolve_rank,
  1912. a, BT_REAL, dr, REQUIRED);
  1913. make_generic ("rank", GFC_ISYM_RANK, GFC_STD_F2008_TS);
  1914. add_sym_2 ("real", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
  1915. gfc_check_real, gfc_simplify_real, gfc_resolve_real,
  1916. a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
  1917. /* This provides compatibility with g77. */
  1918. add_sym_1 ("realpart", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
  1919. gfc_check_fn_c, gfc_simplify_realpart, gfc_resolve_realpart,
  1920. a, BT_UNKNOWN, dr, REQUIRED);
  1921. add_sym_1 ("float", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
  1922. gfc_check_float, gfc_simplify_float, NULL,
  1923. a, BT_INTEGER, di, REQUIRED);
  1924. add_sym_1 ("dfloat", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
  1925. gfc_check_float, gfc_simplify_dble, gfc_resolve_dble,
  1926. a, BT_REAL, dr, REQUIRED);
  1927. add_sym_1 ("sngl", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
  1928. gfc_check_sngl, gfc_simplify_sngl, NULL,
  1929. a, BT_REAL, dd, REQUIRED);
  1930. make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77);
  1931. add_sym_2 ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
  1932. GFC_STD_GNU, gfc_check_rename, NULL, gfc_resolve_rename,
  1933. p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
  1934. make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU);
  1935. add_sym_2 ("repeat", GFC_ISYM_REPEAT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
  1936. gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
  1937. stg, BT_CHARACTER, dc, REQUIRED, ncopies, BT_INTEGER, di, REQUIRED);
  1938. make_generic ("repeat", GFC_ISYM_REPEAT, GFC_STD_F95);
  1939. add_sym_4 ("reshape", GFC_ISYM_RESHAPE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1940. gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape,
  1941. src, BT_REAL, dr, REQUIRED, shp, BT_INTEGER, ii, REQUIRED,
  1942. pad, BT_REAL, dr, OPTIONAL, ord, BT_INTEGER, ii, OPTIONAL);
  1943. make_generic ("reshape", GFC_ISYM_RESHAPE, GFC_STD_F95);
  1944. add_sym_1 ("rrspacing", GFC_ISYM_RRSPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1945. gfc_check_x, gfc_simplify_rrspacing, gfc_resolve_rrspacing,
  1946. x, BT_REAL, dr, REQUIRED);
  1947. make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95);
  1948. add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO,
  1949. BT_LOGICAL, dl, GFC_STD_F2003,
  1950. gfc_check_same_type_as, gfc_simplify_same_type_as, NULL,
  1951. a, BT_UNKNOWN, 0, REQUIRED,
  1952. b, BT_UNKNOWN, 0, REQUIRED);
  1953. add_sym_2 ("scale", GFC_ISYM_SCALE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1954. gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale,
  1955. x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
  1956. make_generic ("scale", GFC_ISYM_SCALE, GFC_STD_F95);
  1957. add_sym_4 ("scan", GFC_ISYM_SCAN, CLASS_ELEMENTAL, ACTUAL_NO,
  1958. BT_INTEGER, di, GFC_STD_F95,
  1959. gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan,
  1960. stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
  1961. bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
  1962. make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95);
  1963. /* Added for G77 compatibility garbage. */
  1964. add_sym_0 ("second", GFC_ISYM_SECOND, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
  1965. 4, GFC_STD_GNU, NULL, NULL, NULL);
  1966. make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU);
  1967. /* Added for G77 compatibility. */
  1968. add_sym_1 ("secnds", GFC_ISYM_SECNDS, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
  1969. dr, GFC_STD_GNU, gfc_check_secnds, NULL, gfc_resolve_secnds,
  1970. x, BT_REAL, dr, REQUIRED);
  1971. make_generic ("secnds", GFC_ISYM_SECNDS, GFC_STD_GNU);
  1972. add_sym_1 ("selected_char_kind", GFC_ISYM_SC_KIND, CLASS_TRANSFORMATIONAL,
  1973. ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003,
  1974. gfc_check_selected_char_kind, gfc_simplify_selected_char_kind,
  1975. NULL, nm, BT_CHARACTER, dc, REQUIRED);
  1976. make_generic ("selected_char_kind", GFC_ISYM_SC_KIND, GFC_STD_F2003);
  1977. add_sym_1 ("selected_int_kind", GFC_ISYM_SI_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
  1978. GFC_STD_F95, gfc_check_selected_int_kind,
  1979. gfc_simplify_selected_int_kind, NULL, r, BT_INTEGER, di, REQUIRED);
  1980. make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95);
  1981. add_sym_3 ("selected_real_kind", GFC_ISYM_SR_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
  1982. GFC_STD_F95, gfc_check_selected_real_kind,
  1983. gfc_simplify_selected_real_kind, NULL,
  1984. p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL,
  1985. "radix", BT_INTEGER, di, OPTIONAL);
  1986. make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95);
  1987. add_sym_2 ("set_exponent", GFC_ISYM_SET_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  1988. gfc_check_set_exponent, gfc_simplify_set_exponent,
  1989. gfc_resolve_set_exponent,
  1990. x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
  1991. make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95);
  1992. add_sym_2 ("shape", GFC_ISYM_SHAPE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
  1993. gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape,
  1994. src, BT_REAL, dr, REQUIRED,
  1995. kind, BT_INTEGER, di, OPTIONAL);
  1996. make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95);
  1997. add_sym_2 ("shifta", GFC_ISYM_SHIFTA, CLASS_ELEMENTAL, ACTUAL_NO,
  1998. BT_INTEGER, di, GFC_STD_F2008,
  1999. gfc_check_shift, gfc_simplify_shifta, gfc_resolve_shift,
  2000. i, BT_INTEGER, di, REQUIRED,
  2001. sh, BT_INTEGER, di, REQUIRED);
  2002. make_generic ("shifta", GFC_ISYM_SHIFTA, GFC_STD_F2008);
  2003. add_sym_2 ("shiftl", GFC_ISYM_SHIFTL, CLASS_ELEMENTAL, ACTUAL_NO,
  2004. BT_INTEGER, di, GFC_STD_F2008,
  2005. gfc_check_shift, gfc_simplify_shiftl, gfc_resolve_shift,
  2006. i, BT_INTEGER, di, REQUIRED,
  2007. sh, BT_INTEGER, di, REQUIRED);
  2008. make_generic ("shiftl", GFC_ISYM_SHIFTL, GFC_STD_F2008);
  2009. add_sym_2 ("shiftr", GFC_ISYM_SHIFTR, CLASS_ELEMENTAL, ACTUAL_NO,
  2010. BT_INTEGER, di, GFC_STD_F2008,
  2011. gfc_check_shift, gfc_simplify_shiftr, gfc_resolve_shift,
  2012. i, BT_INTEGER, di, REQUIRED,
  2013. sh, BT_INTEGER, di, REQUIRED);
  2014. make_generic ("shiftr", GFC_ISYM_SHIFTR, GFC_STD_F2008);
  2015. add_sym_2 ("sign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  2016. gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign,
  2017. a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED);
  2018. add_sym_2 ("isign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
  2019. NULL, gfc_simplify_sign, gfc_resolve_sign,
  2020. a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
  2021. add_sym_2 ("dsign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  2022. gfc_check_x_yd, gfc_simplify_sign, gfc_resolve_sign,
  2023. a, BT_REAL, dd, REQUIRED, b, BT_REAL, dd, REQUIRED);
  2024. make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77);
  2025. add_sym_2 ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  2026. di, GFC_STD_GNU, gfc_check_signal, NULL, gfc_resolve_signal,
  2027. num, BT_INTEGER, di, REQUIRED, han, BT_VOID, 0, REQUIRED);
  2028. make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU);
  2029. add_sym_1 ("sin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  2030. gfc_check_fn_rc, gfc_simplify_sin, gfc_resolve_sin,
  2031. x, BT_REAL, dr, REQUIRED);
  2032. add_sym_1 ("dsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  2033. gfc_check_fn_d, gfc_simplify_sin, gfc_resolve_sin,
  2034. x, BT_REAL, dd, REQUIRED);
  2035. add_sym_1 ("csin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
  2036. NULL, gfc_simplify_sin, gfc_resolve_sin,
  2037. x, BT_COMPLEX, dz, REQUIRED);
  2038. add_sym_1 ("zsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
  2039. NULL, gfc_simplify_sin, gfc_resolve_sin,
  2040. x, BT_COMPLEX, dd, REQUIRED);
  2041. make_alias ("cdsin", GFC_STD_GNU);
  2042. make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77);
  2043. add_sym_1 ("sinh", GFC_ISYM_SINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  2044. gfc_check_fn_rc2008, gfc_simplify_sinh, gfc_resolve_sinh,
  2045. x, BT_REAL, dr, REQUIRED);
  2046. add_sym_1 ("dsinh", GFC_ISYM_SINH,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  2047. gfc_check_fn_d, gfc_simplify_sinh, gfc_resolve_sinh,
  2048. x, BT_REAL, dd, REQUIRED);
  2049. make_generic ("sinh", GFC_ISYM_SINH, GFC_STD_F77);
  2050. add_sym_3 ("size", GFC_ISYM_SIZE, CLASS_INQUIRY, ACTUAL_NO,
  2051. BT_INTEGER, di, GFC_STD_F95,
  2052. gfc_check_size, gfc_simplify_size, gfc_resolve_size,
  2053. ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
  2054. kind, BT_INTEGER, di, OPTIONAL);
  2055. make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
  2056. /* Obtain the stride for a given dimensions; to be used only internally.
  2057. "make_from_module" makes it inaccessible for external users. */
  2058. add_sym_2 (GFC_PREFIX ("stride"), GFC_ISYM_STRIDE, CLASS_INQUIRY, ACTUAL_NO,
  2059. BT_INTEGER, gfc_index_integer_kind, GFC_STD_GNU,
  2060. NULL, NULL, gfc_resolve_stride,
  2061. ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
  2062. make_from_module();
  2063. add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
  2064. BT_INTEGER, ii, GFC_STD_GNU,
  2065. gfc_check_sizeof, gfc_simplify_sizeof, NULL,
  2066. x, BT_UNKNOWN, 0, REQUIRED);
  2067. make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
  2068. /* The following functions are part of ISO_C_BINDING. */
  2069. add_sym_2 ("c_associated", GFC_ISYM_C_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO,
  2070. BT_LOGICAL, dl, GFC_STD_F2003, gfc_check_c_associated, NULL, NULL,
  2071. "C_PTR_1", BT_VOID, 0, REQUIRED,
  2072. "C_PTR_2", BT_VOID, 0, OPTIONAL);
  2073. make_from_module();
  2074. add_sym_1 ("c_loc", GFC_ISYM_C_LOC, CLASS_INQUIRY, ACTUAL_NO,
  2075. BT_VOID, 0, GFC_STD_F2003,
  2076. gfc_check_c_loc, NULL, gfc_resolve_c_loc,
  2077. x, BT_UNKNOWN, 0, REQUIRED);
  2078. make_from_module();
  2079. add_sym_1 ("c_funloc", GFC_ISYM_C_FUNLOC, CLASS_INQUIRY, ACTUAL_NO,
  2080. BT_VOID, 0, GFC_STD_F2003,
  2081. gfc_check_c_funloc, NULL, gfc_resolve_c_funloc,
  2082. x, BT_UNKNOWN, 0, REQUIRED);
  2083. make_from_module();
  2084. add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
  2085. BT_INTEGER, gfc_index_integer_kind, GFC_STD_F2008,
  2086. gfc_check_c_sizeof, gfc_simplify_sizeof, NULL,
  2087. x, BT_UNKNOWN, 0, REQUIRED);
  2088. make_from_module();
  2089. /* COMPILER_OPTIONS and COMPILER_VERSION are part of ISO_FORTRAN_ENV. */
  2090. add_sym_0 ("compiler_options", GFC_ISYM_COMPILER_OPTIONS, CLASS_INQUIRY,
  2091. ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008,
  2092. NULL, gfc_simplify_compiler_options, NULL);
  2093. make_from_module();
  2094. add_sym_0 ("compiler_version", GFC_ISYM_COMPILER_VERSION, CLASS_INQUIRY,
  2095. ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008,
  2096. NULL, gfc_simplify_compiler_version, NULL);
  2097. make_from_module();
  2098. add_sym_1 ("spacing", GFC_ISYM_SPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  2099. gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
  2100. x, BT_REAL, dr, REQUIRED);
  2101. make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95);
  2102. add_sym_3 ("spread", GFC_ISYM_SPREAD, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  2103. gfc_check_spread, gfc_simplify_spread, gfc_resolve_spread,
  2104. src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED,
  2105. ncopies, BT_INTEGER, di, REQUIRED);
  2106. make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95);
  2107. add_sym_1 ("sqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  2108. gfc_check_fn_rc, gfc_simplify_sqrt, gfc_resolve_sqrt,
  2109. x, BT_REAL, dr, REQUIRED);
  2110. add_sym_1 ("dsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  2111. gfc_check_fn_d, gfc_simplify_sqrt, gfc_resolve_sqrt,
  2112. x, BT_REAL, dd, REQUIRED);
  2113. add_sym_1 ("csqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
  2114. NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
  2115. x, BT_COMPLEX, dz, REQUIRED);
  2116. add_sym_1 ("zsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
  2117. NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
  2118. x, BT_COMPLEX, dd, REQUIRED);
  2119. make_alias ("cdsqrt", GFC_STD_GNU);
  2120. make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77);
  2121. add_sym_2_intent ("stat", GFC_ISYM_STAT, CLASS_IMPURE, ACTUAL_NO,
  2122. BT_INTEGER, di, GFC_STD_GNU,
  2123. gfc_check_stat, NULL, gfc_resolve_stat,
  2124. nm, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2125. vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
  2126. make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
  2127. add_sym_2 ("storage_size", GFC_ISYM_STORAGE_SIZE, CLASS_INQUIRY, ACTUAL_NO,
  2128. BT_INTEGER, di, GFC_STD_F2008,
  2129. gfc_check_storage_size, gfc_simplify_storage_size,
  2130. gfc_resolve_storage_size,
  2131. a, BT_UNKNOWN, 0, REQUIRED,
  2132. kind, BT_INTEGER, di, OPTIONAL);
  2133. add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  2134. gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum,
  2135. ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
  2136. msk, BT_LOGICAL, dl, OPTIONAL);
  2137. make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95);
  2138. add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
  2139. GFC_STD_GNU, gfc_check_symlnk, NULL, gfc_resolve_symlnk,
  2140. p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
  2141. make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU);
  2142. add_sym_1 ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
  2143. GFC_STD_GNU, NULL, NULL, NULL,
  2144. com, BT_CHARACTER, dc, REQUIRED);
  2145. make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU);
  2146. add_sym_1 ("tan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  2147. gfc_check_fn_rc2008, gfc_simplify_tan, gfc_resolve_tan,
  2148. x, BT_REAL, dr, REQUIRED);
  2149. add_sym_1 ("dtan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  2150. gfc_check_fn_d, gfc_simplify_tan, gfc_resolve_tan,
  2151. x, BT_REAL, dd, REQUIRED);
  2152. make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77);
  2153. add_sym_1 ("tanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
  2154. gfc_check_fn_rc2008, gfc_simplify_tanh, gfc_resolve_tanh,
  2155. x, BT_REAL, dr, REQUIRED);
  2156. add_sym_1 ("dtanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
  2157. gfc_check_fn_d, gfc_simplify_tanh, gfc_resolve_tanh,
  2158. x, BT_REAL, dd, REQUIRED);
  2159. make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
  2160. add_sym_3 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
  2161. gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image,
  2162. ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL,
  2163. dist, BT_INTEGER, di, OPTIONAL);
  2164. add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  2165. di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time);
  2166. make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU);
  2167. add_sym_0 ("time8", GFC_ISYM_TIME8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  2168. di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time8);
  2169. make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU);
  2170. add_sym_1 ("tiny", GFC_ISYM_TINY, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  2171. gfc_check_x, gfc_simplify_tiny, NULL,
  2172. x, BT_REAL, dr, REQUIRED);
  2173. make_generic ("tiny", GFC_ISYM_TINY, GFC_STD_F95);
  2174. add_sym_1 ("trailz", GFC_ISYM_TRAILZ, CLASS_ELEMENTAL, ACTUAL_NO,
  2175. BT_INTEGER, di, GFC_STD_F2008,
  2176. gfc_check_i, gfc_simplify_trailz, NULL,
  2177. i, BT_INTEGER, di, REQUIRED);
  2178. make_generic ("trailz", GFC_ISYM_TRAILZ, GFC_STD_F2008);
  2179. add_sym_3 ("transfer", GFC_ISYM_TRANSFER, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  2180. gfc_check_transfer, gfc_simplify_transfer, gfc_resolve_transfer,
  2181. src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED,
  2182. sz, BT_INTEGER, di, OPTIONAL);
  2183. make_generic ("transfer", GFC_ISYM_TRANSFER, GFC_STD_F95);
  2184. add_sym_1 ("transpose", GFC_ISYM_TRANSPOSE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  2185. gfc_check_transpose, gfc_simplify_transpose, gfc_resolve_transpose,
  2186. m, BT_REAL, dr, REQUIRED);
  2187. make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95);
  2188. add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
  2189. gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
  2190. stg, BT_CHARACTER, dc, REQUIRED);
  2191. make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
  2192. add_sym_1 ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
  2193. 0, GFC_STD_GNU, gfc_check_ttynam, NULL, gfc_resolve_ttynam,
  2194. ut, BT_INTEGER, di, REQUIRED);
  2195. make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU);
  2196. add_sym_3 ("ubound", GFC_ISYM_UBOUND, CLASS_INQUIRY, ACTUAL_NO,
  2197. BT_INTEGER, di, GFC_STD_F95,
  2198. gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
  2199. ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
  2200. kind, BT_INTEGER, di, OPTIONAL);
  2201. make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
  2202. add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
  2203. BT_INTEGER, di, GFC_STD_F2008,
  2204. gfc_check_ucobound, gfc_simplify_ucobound, gfc_resolve_ucobound,
  2205. ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
  2206. kind, BT_INTEGER, di, OPTIONAL);
  2207. make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F2008);
  2208. /* g77 compatibility for UMASK. */
  2209. add_sym_1 ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
  2210. GFC_STD_GNU, gfc_check_umask, NULL, gfc_resolve_umask,
  2211. msk, BT_INTEGER, di, REQUIRED);
  2212. make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU);
  2213. /* g77 compatibility for UNLINK. */
  2214. add_sym_1 ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
  2215. di, GFC_STD_GNU, gfc_check_unlink, NULL, gfc_resolve_unlink,
  2216. "path", BT_CHARACTER, dc, REQUIRED);
  2217. make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
  2218. add_sym_3 ("unpack", GFC_ISYM_UNPACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
  2219. gfc_check_unpack, gfc_simplify_unpack, gfc_resolve_unpack,
  2220. v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
  2221. f, BT_REAL, dr, REQUIRED);
  2222. make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95);
  2223. add_sym_4 ("verify", GFC_ISYM_VERIFY, CLASS_ELEMENTAL, ACTUAL_NO,
  2224. BT_INTEGER, di, GFC_STD_F95,
  2225. gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify,
  2226. stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
  2227. bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
  2228. make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
  2229. add_sym_1 ("loc", GFC_ISYM_LOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii,
  2230. GFC_STD_GNU, gfc_check_loc, NULL, gfc_resolve_loc,
  2231. x, BT_UNKNOWN, 0, REQUIRED);
  2232. make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
  2233. /* The following function is internally used for coarray libray functions.
  2234. "make_from_module" makes it inaccessible for external users. */
  2235. add_sym_1 (GFC_PREFIX ("caf_get"), GFC_ISYM_CAF_GET, CLASS_IMPURE, ACTUAL_NO,
  2236. BT_REAL, dr, GFC_STD_GNU, NULL, NULL, NULL,
  2237. x, BT_REAL, dr, REQUIRED);
  2238. make_from_module();
  2239. }
  2240. /* Add intrinsic subroutines. */
  2241. static void
  2242. add_subroutines (void)
  2243. {
  2244. /* Argument names as in the standard (to be used as argument keywords). */
  2245. const char
  2246. *a = "a", *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
  2247. *c = "count", *tm = "time", *tp = "topos", *gt = "get",
  2248. *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
  2249. *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
  2250. *com = "command", *length = "length", *st = "status",
  2251. *val = "value", *num = "number", *name = "name",
  2252. *trim_name = "trim_name", *ut = "unit", *han = "handler",
  2253. *sec = "seconds", *res = "result", *of = "offset", *md = "mode",
  2254. *whence = "whence", *pos = "pos", *ptr = "ptr", *p1 = "path1",
  2255. *p2 = "path2", *msk = "mask", *old = "old", *result_image = "result_image",
  2256. *stat = "stat", *errmsg = "errmsg";
  2257. int di, dr, dc, dl, ii;
  2258. di = gfc_default_integer_kind;
  2259. dr = gfc_default_real_kind;
  2260. dc = gfc_default_character_kind;
  2261. dl = gfc_default_logical_kind;
  2262. ii = gfc_index_integer_kind;
  2263. add_sym_0s ("abort", GFC_ISYM_ABORT, GFC_STD_GNU, NULL);
  2264. make_noreturn();
  2265. add_sym_3s ("atomic_define", GFC_ISYM_ATOMIC_DEF, CLASS_ATOMIC,
  2266. BT_UNKNOWN, 0, GFC_STD_F2008,
  2267. gfc_check_atomic_def, NULL, gfc_resolve_atomic_def,
  2268. "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2269. "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
  2270. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2271. add_sym_3s ("atomic_ref", GFC_ISYM_ATOMIC_REF, CLASS_ATOMIC,
  2272. BT_UNKNOWN, 0, GFC_STD_F2008,
  2273. gfc_check_atomic_ref, NULL, gfc_resolve_atomic_ref,
  2274. "value", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2275. "atom", BT_INTEGER, di, REQUIRED, INTENT_IN,
  2276. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2277. add_sym_5s ("atomic_cas", GFC_ISYM_ATOMIC_CAS, CLASS_ATOMIC,
  2278. BT_UNKNOWN, 0, GFC_STD_F2008_TS,
  2279. gfc_check_atomic_cas, NULL, NULL,
  2280. "atom", BT_INTEGER, di, REQUIRED, INTENT_INOUT,
  2281. "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2282. "compare", BT_INTEGER, di, REQUIRED, INTENT_IN,
  2283. "new", BT_INTEGER, di, REQUIRED, INTENT_IN,
  2284. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2285. add_sym_3s ("atomic_add", GFC_ISYM_ATOMIC_ADD, CLASS_ATOMIC,
  2286. BT_UNKNOWN, 0, GFC_STD_F2008_TS,
  2287. gfc_check_atomic_op, NULL, NULL,
  2288. "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2289. "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
  2290. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2291. add_sym_3s ("atomic_and", GFC_ISYM_ATOMIC_AND, CLASS_ATOMIC,
  2292. BT_UNKNOWN, 0, GFC_STD_F2008_TS,
  2293. gfc_check_atomic_op, NULL, NULL,
  2294. "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2295. "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
  2296. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2297. add_sym_3s ("atomic_or", GFC_ISYM_ATOMIC_OR, CLASS_ATOMIC,
  2298. BT_UNKNOWN, 0, GFC_STD_F2008_TS,
  2299. gfc_check_atomic_op, NULL, NULL,
  2300. "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2301. "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
  2302. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2303. add_sym_3s ("atomic_xor", GFC_ISYM_ATOMIC_XOR, CLASS_ATOMIC,
  2304. BT_UNKNOWN, 0, GFC_STD_F2008_TS,
  2305. gfc_check_atomic_op, NULL, NULL,
  2306. "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2307. "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
  2308. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2309. add_sym_4s ("atomic_fetch_add", GFC_ISYM_ATOMIC_FETCH_ADD, CLASS_ATOMIC,
  2310. BT_UNKNOWN, 0, GFC_STD_F2008_TS,
  2311. gfc_check_atomic_fetch_op, NULL, NULL,
  2312. "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2313. "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
  2314. "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2315. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2316. add_sym_4s ("atomic_fetch_and", GFC_ISYM_ATOMIC_FETCH_AND, CLASS_ATOMIC,
  2317. BT_UNKNOWN, 0, GFC_STD_F2008_TS,
  2318. gfc_check_atomic_fetch_op, NULL, NULL,
  2319. "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2320. "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
  2321. "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2322. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2323. add_sym_4s ("atomic_fetch_or", GFC_ISYM_ATOMIC_FETCH_OR, CLASS_ATOMIC,
  2324. BT_UNKNOWN, 0, GFC_STD_F2008_TS,
  2325. gfc_check_atomic_fetch_op, NULL, NULL,
  2326. "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2327. "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
  2328. "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2329. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2330. add_sym_4s ("atomic_fetch_xor", GFC_ISYM_ATOMIC_FETCH_XOR, CLASS_ATOMIC,
  2331. BT_UNKNOWN, 0, GFC_STD_F2008_TS,
  2332. gfc_check_atomic_fetch_op, NULL, NULL,
  2333. "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2334. "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
  2335. "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2336. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2337. add_sym_0s ("backtrace", GFC_ISYM_BACKTRACE, GFC_STD_GNU, NULL);
  2338. add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, CLASS_IMPURE, BT_UNKNOWN, 0,
  2339. GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
  2340. tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
  2341. /* More G77 compatibility garbage. */
  2342. add_sym_2s ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2343. gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
  2344. tm, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2345. res, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
  2346. add_sym_1s ("idate", GFC_ISYM_IDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2347. gfc_check_itime_idate, NULL, gfc_resolve_idate,
  2348. vl, BT_INTEGER, 4, REQUIRED, INTENT_OUT);
  2349. add_sym_1s ("itime", GFC_ISYM_ITIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2350. gfc_check_itime_idate, NULL, gfc_resolve_itime,
  2351. vl, BT_INTEGER, 4, REQUIRED, INTENT_OUT);
  2352. add_sym_2s ("ltime", GFC_ISYM_LTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2353. gfc_check_ltime_gmtime, NULL, gfc_resolve_ltime,
  2354. tm, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2355. vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
  2356. add_sym_2s ("gmtime", GFC_ISYM_GMTIME, CLASS_IMPURE, BT_UNKNOWN, 0,
  2357. GFC_STD_GNU, gfc_check_ltime_gmtime, NULL, gfc_resolve_gmtime,
  2358. tm, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2359. vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
  2360. add_sym_1s ("second", GFC_ISYM_SECOND, CLASS_IMPURE, BT_UNKNOWN, 0,
  2361. GFC_STD_GNU, gfc_check_second_sub, NULL, gfc_resolve_second_sub,
  2362. tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
  2363. add_sym_2s ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2364. gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
  2365. name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2366. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2367. add_sym_3s ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2368. gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub,
  2369. name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2370. md, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2371. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2372. add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, CLASS_IMPURE, BT_UNKNOWN,
  2373. 0, GFC_STD_F95, gfc_check_date_and_time, NULL, NULL,
  2374. dt, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
  2375. tm, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
  2376. zn, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
  2377. vl, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2378. /* More G77 compatibility garbage. */
  2379. add_sym_2s ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2380. gfc_check_dtime_etime_sub, NULL, gfc_resolve_etime_sub,
  2381. vl, BT_REAL, 4, REQUIRED, INTENT_OUT,
  2382. tm, BT_REAL, 4, REQUIRED, INTENT_OUT);
  2383. add_sym_2s ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2384. gfc_check_dtime_etime_sub, NULL, gfc_resolve_dtime_sub,
  2385. vl, BT_REAL, 4, REQUIRED, INTENT_OUT,
  2386. tm, BT_REAL, 4, REQUIRED, INTENT_OUT);
  2387. add_sym_5s ("execute_command_line", GFC_ISYM_EXECUTE_COMMAND_LINE,
  2388. CLASS_IMPURE , BT_UNKNOWN, 0, GFC_STD_F2008,
  2389. NULL, NULL, gfc_resolve_execute_command_line,
  2390. "command", BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2391. "wait", BT_LOGICAL, dl, OPTIONAL, INTENT_IN,
  2392. "exitstat", BT_INTEGER, di, OPTIONAL, INTENT_INOUT,
  2393. "cmdstat", BT_INTEGER, di, OPTIONAL, INTENT_OUT,
  2394. "cmdmsg", BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT);
  2395. add_sym_1s ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2396. gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub,
  2397. dt, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
  2398. add_sym_1s ("gerror", GFC_ISYM_GERROR, CLASS_IMPURE, BT_UNKNOWN,
  2399. 0, GFC_STD_GNU, gfc_check_gerror, NULL, gfc_resolve_gerror,
  2400. res, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
  2401. add_sym_2s ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, BT_UNKNOWN, 0,
  2402. GFC_STD_GNU, gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
  2403. c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
  2404. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2405. add_sym_2s ("getenv", GFC_ISYM_GETENV, CLASS_IMPURE, BT_UNKNOWN,
  2406. 0, GFC_STD_GNU, NULL, NULL, NULL,
  2407. name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2408. val, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
  2409. add_sym_2s ("getarg", GFC_ISYM_GETARG, CLASS_IMPURE, BT_UNKNOWN,
  2410. 0, GFC_STD_GNU, gfc_check_getarg, NULL, gfc_resolve_getarg,
  2411. pos, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2412. val, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
  2413. add_sym_1s ("getlog", GFC_ISYM_GETLOG, CLASS_IMPURE, BT_UNKNOWN,
  2414. 0, GFC_STD_GNU, gfc_check_getlog, NULL, gfc_resolve_getlog,
  2415. c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
  2416. /* F2003 commandline routines. */
  2417. add_sym_3s ("get_command", GFC_ISYM_GET_COMMAND, CLASS_IMPURE,
  2418. BT_UNKNOWN, 0, GFC_STD_F2003,
  2419. NULL, NULL, gfc_resolve_get_command,
  2420. com, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
  2421. length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
  2422. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2423. add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT,
  2424. CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003, NULL, NULL,
  2425. gfc_resolve_get_command_argument,
  2426. num, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2427. val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
  2428. length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
  2429. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2430. /* F2003 subroutine to get environment variables. */
  2431. add_sym_5s ("get_environment_variable", GFC_ISYM_GET_ENVIRONMENT_VARIABLE,
  2432. CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003,
  2433. NULL, NULL, gfc_resolve_get_environment_variable,
  2434. name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2435. val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
  2436. length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
  2437. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
  2438. trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN);
  2439. add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0,
  2440. GFC_STD_F2003,
  2441. gfc_check_move_alloc, NULL, NULL,
  2442. f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT,
  2443. t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
  2444. add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0,
  2445. GFC_STD_F95, gfc_check_mvbits, gfc_simplify_mvbits,
  2446. gfc_resolve_mvbits,
  2447. f, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2448. fp, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2449. ln, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2450. t, BT_INTEGER, di, REQUIRED, INTENT_INOUT,
  2451. tp, BT_INTEGER, di, REQUIRED, INTENT_IN);
  2452. add_sym_1s ("random_number", GFC_ISYM_RANDOM_NUMBER, CLASS_IMPURE,
  2453. BT_UNKNOWN, 0, GFC_STD_F95,
  2454. gfc_check_random_number, NULL, gfc_resolve_random_number,
  2455. h, BT_REAL, dr, REQUIRED, INTENT_OUT);
  2456. add_sym_3s ("random_seed", GFC_ISYM_RANDOM_SEED, CLASS_IMPURE,
  2457. BT_UNKNOWN, 0, GFC_STD_F95,
  2458. gfc_check_random_seed, NULL, gfc_resolve_random_seed,
  2459. sz, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
  2460. pt, BT_INTEGER, di, OPTIONAL, INTENT_IN,
  2461. gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2462. /* The following subroutines are part of ISO_C_BINDING. */
  2463. add_sym_3s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0,
  2464. GFC_STD_F2003, gfc_check_c_f_pointer, NULL, NULL,
  2465. "cptr", BT_VOID, 0, REQUIRED, INTENT_IN,
  2466. "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT,
  2467. "shape", BT_INTEGER, di, OPTIONAL, INTENT_IN);
  2468. make_from_module();
  2469. add_sym_2s ("c_f_procpointer", GFC_ISYM_C_F_PROCPOINTER, CLASS_IMPURE,
  2470. BT_UNKNOWN, 0, GFC_STD_F2003, gfc_check_c_f_procpointer,
  2471. NULL, NULL,
  2472. "cptr", BT_VOID, 0, REQUIRED, INTENT_IN,
  2473. "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
  2474. make_from_module();
  2475. /* Coarray collectives. */
  2476. add_sym_4s ("co_broadcast", GFC_ISYM_CO_BROADCAST, CLASS_IMPURE,
  2477. BT_UNKNOWN, 0, GFC_STD_F2008_TS,
  2478. gfc_check_co_broadcast, NULL, NULL,
  2479. a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
  2480. "source_image", BT_INTEGER, di, REQUIRED, INTENT_IN,
  2481. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
  2482. errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
  2483. add_sym_4s ("co_max", GFC_ISYM_CO_MAX, CLASS_IMPURE,
  2484. BT_UNKNOWN, 0, GFC_STD_F2008_TS,
  2485. gfc_check_co_minmax, NULL, NULL,
  2486. a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
  2487. result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
  2488. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
  2489. errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
  2490. add_sym_4s ("co_min", GFC_ISYM_CO_MIN, CLASS_IMPURE,
  2491. BT_UNKNOWN, 0, GFC_STD_F2008_TS,
  2492. gfc_check_co_minmax, NULL, NULL,
  2493. a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
  2494. result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
  2495. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
  2496. errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
  2497. add_sym_4s ("co_sum", GFC_ISYM_CO_SUM, CLASS_IMPURE,
  2498. BT_UNKNOWN, 0, GFC_STD_F2008_TS,
  2499. gfc_check_co_sum, NULL, NULL,
  2500. a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
  2501. result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
  2502. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
  2503. errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
  2504. add_sym_5s ("co_reduce", GFC_ISYM_CO_REDUCE, CLASS_IMPURE,
  2505. BT_UNKNOWN, 0, GFC_STD_F2008_TS,
  2506. gfc_check_co_reduce, NULL, NULL,
  2507. a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
  2508. "operator", BT_INTEGER, di, REQUIRED, INTENT_IN,
  2509. result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
  2510. stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
  2511. errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
  2512. /* The following subroutine is internally used for coarray libray functions.
  2513. "make_from_module" makes it inaccessible for external users. */
  2514. add_sym_2s (GFC_PREFIX ("caf_send"), GFC_ISYM_CAF_SEND, CLASS_IMPURE,
  2515. BT_UNKNOWN, 0, GFC_STD_GNU, NULL, NULL, NULL,
  2516. "x", BT_REAL, dr, REQUIRED, INTENT_OUT,
  2517. "y", BT_REAL, dr, REQUIRED, INTENT_IN);
  2518. make_from_module();
  2519. /* More G77 compatibility garbage. */
  2520. add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2521. gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
  2522. sec, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2523. han, BT_UNKNOWN, 0, REQUIRED, INTENT_IN,
  2524. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2525. add_sym_1s ("srand", GFC_ISYM_SRAND, CLASS_IMPURE, BT_UNKNOWN,
  2526. di, GFC_STD_GNU, gfc_check_srand, NULL, gfc_resolve_srand,
  2527. "seed", BT_INTEGER, 4, REQUIRED, INTENT_IN);
  2528. add_sym_1s ("exit", GFC_ISYM_EXIT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2529. gfc_check_exit, NULL, gfc_resolve_exit,
  2530. st, BT_INTEGER, di, OPTIONAL, INTENT_IN);
  2531. make_noreturn();
  2532. add_sym_3s ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2533. gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub,
  2534. ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2535. c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
  2536. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2537. add_sym_2s ("fget", GFC_ISYM_FGET, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2538. gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub,
  2539. c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
  2540. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2541. add_sym_1s ("flush", GFC_ISYM_FLUSH, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2542. gfc_check_flush, NULL, gfc_resolve_flush,
  2543. ut, BT_INTEGER, di, OPTIONAL, INTENT_IN);
  2544. add_sym_3s ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2545. gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub,
  2546. ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2547. c, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2548. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2549. add_sym_2s ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2550. gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub,
  2551. c, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2552. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2553. add_sym_1s ("free", GFC_ISYM_FREE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2554. gfc_check_free, NULL, gfc_resolve_free,
  2555. ptr, BT_INTEGER, ii, REQUIRED, INTENT_INOUT);
  2556. add_sym_4s ("fseek", GFC_ISYM_FSEEK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2557. gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub,
  2558. ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2559. of, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2560. whence, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2561. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2562. add_sym_2s ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2563. gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub,
  2564. ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2565. of, BT_INTEGER, ii, REQUIRED, INTENT_OUT);
  2566. add_sym_2s ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, BT_UNKNOWN, 0,
  2567. GFC_STD_GNU, gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
  2568. c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
  2569. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2570. add_sym_3s ("kill", GFC_ISYM_KILL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2571. gfc_check_kill_sub, NULL, gfc_resolve_kill_sub,
  2572. c, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2573. val, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2574. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2575. add_sym_3s ("link", GFC_ISYM_LINK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2576. gfc_check_link_sub, NULL, gfc_resolve_link_sub,
  2577. p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2578. p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2579. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2580. add_sym_1s ("perror", GFC_ISYM_PERROR, CLASS_IMPURE, BT_UNKNOWN,
  2581. 0, GFC_STD_GNU, gfc_check_perror, NULL, gfc_resolve_perror,
  2582. "string", BT_CHARACTER, dc, REQUIRED, INTENT_IN);
  2583. add_sym_3s ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, BT_UNKNOWN, 0,
  2584. GFC_STD_GNU, gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
  2585. p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2586. p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2587. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2588. add_sym_1s ("sleep", GFC_ISYM_SLEEP, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2589. gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
  2590. sec, BT_INTEGER, di, REQUIRED, INTENT_IN);
  2591. add_sym_3s ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2592. gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
  2593. ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2594. vl, BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2595. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2596. add_sym_3s ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2597. gfc_check_stat_sub, NULL, gfc_resolve_lstat_sub,
  2598. name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2599. vl, BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2600. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2601. add_sym_3s ("stat", GFC_ISYM_STAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2602. gfc_check_stat_sub, NULL, gfc_resolve_stat_sub,
  2603. name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2604. vl, BT_INTEGER, di, REQUIRED, INTENT_OUT,
  2605. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2606. add_sym_3s ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, BT_UNKNOWN, 0,
  2607. GFC_STD_GNU, gfc_check_signal_sub, NULL, gfc_resolve_signal_sub,
  2608. num, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2609. han, BT_UNKNOWN, 0, REQUIRED, INTENT_IN,
  2610. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2611. add_sym_3s ("symlnk", GFC_ISYM_SYMLINK, CLASS_IMPURE, BT_UNKNOWN, 0,
  2612. GFC_STD_GNU, gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
  2613. p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2614. p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2615. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2616. add_sym_2s ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, BT_UNKNOWN,
  2617. 0, GFC_STD_GNU, NULL, NULL, gfc_resolve_system_sub,
  2618. com, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2619. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2620. add_sym_3s ("system_clock", GFC_ISYM_SYSTEM_CLOCK, CLASS_IMPURE,
  2621. BT_UNKNOWN, 0, GFC_STD_F95,
  2622. gfc_check_system_clock, NULL, gfc_resolve_system_clock,
  2623. c, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
  2624. cr, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
  2625. cm, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2626. add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, BT_UNKNOWN, 0,
  2627. GFC_STD_GNU, gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
  2628. ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2629. name, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
  2630. add_sym_2s ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
  2631. gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
  2632. msk, BT_INTEGER, di, REQUIRED, INTENT_IN,
  2633. old, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2634. add_sym_2s ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, BT_UNKNOWN, 0,
  2635. GFC_STD_GNU, gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
  2636. "path", BT_CHARACTER, dc, REQUIRED, INTENT_IN,
  2637. st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
  2638. }
  2639. /* Add a function to the list of conversion symbols. */
  2640. static void
  2641. add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard)
  2642. {
  2643. gfc_typespec from, to;
  2644. gfc_intrinsic_sym *sym;
  2645. if (sizing == SZ_CONVS)
  2646. {
  2647. nconv++;
  2648. return;
  2649. }
  2650. gfc_clear_ts (&from);
  2651. from.type = from_type;
  2652. from.kind = from_kind;
  2653. gfc_clear_ts (&to);
  2654. to.type = to_type;
  2655. to.kind = to_kind;
  2656. sym = conversion + nconv;
  2657. sym->name = conv_name (&from, &to);
  2658. sym->lib_name = sym->name;
  2659. sym->simplify.cc = gfc_convert_constant;
  2660. sym->standard = standard;
  2661. sym->elemental = 1;
  2662. sym->pure = 1;
  2663. sym->conversion = 1;
  2664. sym->ts = to;
  2665. sym->id = GFC_ISYM_CONVERSION;
  2666. nconv++;
  2667. }
  2668. /* Create gfc_intrinsic_sym nodes for all intrinsic conversion
  2669. functions by looping over the kind tables. */
  2670. static void
  2671. add_conversions (void)
  2672. {
  2673. int i, j;
  2674. /* Integer-Integer conversions. */
  2675. for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
  2676. for (j = 0; gfc_integer_kinds[j].kind != 0; j++)
  2677. {
  2678. if (i == j)
  2679. continue;
  2680. add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
  2681. BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77);
  2682. }
  2683. /* Integer-Real/Complex conversions. */
  2684. for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
  2685. for (j = 0; gfc_real_kinds[j].kind != 0; j++)
  2686. {
  2687. add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
  2688. BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
  2689. add_conv (BT_REAL, gfc_real_kinds[j].kind,
  2690. BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
  2691. add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
  2692. BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
  2693. add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
  2694. BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
  2695. }
  2696. if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
  2697. {
  2698. /* Hollerith-Integer conversions. */
  2699. for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
  2700. add_conv (BT_HOLLERITH, gfc_default_character_kind,
  2701. BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
  2702. /* Hollerith-Real conversions. */
  2703. for (i = 0; gfc_real_kinds[i].kind != 0; i++)
  2704. add_conv (BT_HOLLERITH, gfc_default_character_kind,
  2705. BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
  2706. /* Hollerith-Complex conversions. */
  2707. for (i = 0; gfc_real_kinds[i].kind != 0; i++)
  2708. add_conv (BT_HOLLERITH, gfc_default_character_kind,
  2709. BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
  2710. /* Hollerith-Character conversions. */
  2711. add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER,
  2712. gfc_default_character_kind, GFC_STD_LEGACY);
  2713. /* Hollerith-Logical conversions. */
  2714. for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
  2715. add_conv (BT_HOLLERITH, gfc_default_character_kind,
  2716. BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY);
  2717. }
  2718. /* Real/Complex - Real/Complex conversions. */
  2719. for (i = 0; gfc_real_kinds[i].kind != 0; i++)
  2720. for (j = 0; gfc_real_kinds[j].kind != 0; j++)
  2721. {
  2722. if (i != j)
  2723. {
  2724. add_conv (BT_REAL, gfc_real_kinds[i].kind,
  2725. BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
  2726. add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
  2727. BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
  2728. }
  2729. add_conv (BT_REAL, gfc_real_kinds[i].kind,
  2730. BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
  2731. add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
  2732. BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
  2733. }
  2734. /* Logical/Logical kind conversion. */
  2735. for (i = 0; gfc_logical_kinds[i].kind; i++)
  2736. for (j = 0; gfc_logical_kinds[j].kind; j++)
  2737. {
  2738. if (i == j)
  2739. continue;
  2740. add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind,
  2741. BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77);
  2742. }
  2743. /* Integer-Logical and Logical-Integer conversions. */
  2744. if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
  2745. for (i=0; gfc_integer_kinds[i].kind; i++)
  2746. for (j=0; gfc_logical_kinds[j].kind; j++)
  2747. {
  2748. add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
  2749. BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY);
  2750. add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind,
  2751. BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
  2752. }
  2753. }
  2754. static void
  2755. add_char_conversions (void)
  2756. {
  2757. int n, i, j;
  2758. /* Count possible conversions. */
  2759. for (i = 0; gfc_character_kinds[i].kind != 0; i++)
  2760. for (j = 0; gfc_character_kinds[j].kind != 0; j++)
  2761. if (i != j)
  2762. ncharconv++;
  2763. /* Allocate memory. */
  2764. char_conversions = XCNEWVEC (gfc_intrinsic_sym, ncharconv);
  2765. /* Add the conversions themselves. */
  2766. n = 0;
  2767. for (i = 0; gfc_character_kinds[i].kind != 0; i++)
  2768. for (j = 0; gfc_character_kinds[j].kind != 0; j++)
  2769. {
  2770. gfc_typespec from, to;
  2771. if (i == j)
  2772. continue;
  2773. gfc_clear_ts (&from);
  2774. from.type = BT_CHARACTER;
  2775. from.kind = gfc_character_kinds[i].kind;
  2776. gfc_clear_ts (&to);
  2777. to.type = BT_CHARACTER;
  2778. to.kind = gfc_character_kinds[j].kind;
  2779. char_conversions[n].name = conv_name (&from, &to);
  2780. char_conversions[n].lib_name = char_conversions[n].name;
  2781. char_conversions[n].simplify.cc = gfc_convert_char_constant;
  2782. char_conversions[n].standard = GFC_STD_F2003;
  2783. char_conversions[n].elemental = 1;
  2784. char_conversions[n].pure = 1;
  2785. char_conversions[n].conversion = 0;
  2786. char_conversions[n].ts = to;
  2787. char_conversions[n].id = GFC_ISYM_CONVERSION;
  2788. n++;
  2789. }
  2790. }
  2791. /* Initialize the table of intrinsics. */
  2792. void
  2793. gfc_intrinsic_init_1 (void)
  2794. {
  2795. nargs = nfunc = nsub = nconv = 0;
  2796. /* Create a namespace to hold the resolved intrinsic symbols. */
  2797. gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0);
  2798. sizing = SZ_FUNCS;
  2799. add_functions ();
  2800. sizing = SZ_SUBS;
  2801. add_subroutines ();
  2802. sizing = SZ_CONVS;
  2803. add_conversions ();
  2804. functions = XCNEWVAR (struct gfc_intrinsic_sym,
  2805. sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
  2806. + sizeof (gfc_intrinsic_arg) * nargs);
  2807. next_sym = functions;
  2808. subroutines = functions + nfunc;
  2809. conversion = XCNEWVEC (gfc_intrinsic_sym, nconv);
  2810. next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
  2811. sizing = SZ_NOTHING;
  2812. nconv = 0;
  2813. add_functions ();
  2814. add_subroutines ();
  2815. add_conversions ();
  2816. /* Character conversion intrinsics need to be treated separately. */
  2817. add_char_conversions ();
  2818. }
  2819. void
  2820. gfc_intrinsic_done_1 (void)
  2821. {
  2822. free (functions);
  2823. free (conversion);
  2824. free (char_conversions);
  2825. gfc_free_namespace (gfc_intrinsic_namespace);
  2826. }
  2827. /******** Subroutines to check intrinsic interfaces ***********/
  2828. /* Given a formal argument list, remove any NULL arguments that may
  2829. have been left behind by a sort against some formal argument list. */
  2830. static void
  2831. remove_nullargs (gfc_actual_arglist **ap)
  2832. {
  2833. gfc_actual_arglist *head, *tail, *next;
  2834. tail = NULL;
  2835. for (head = *ap; head; head = next)
  2836. {
  2837. next = head->next;
  2838. if (head->expr == NULL && !head->label)
  2839. {
  2840. head->next = NULL;
  2841. gfc_free_actual_arglist (head);
  2842. }
  2843. else
  2844. {
  2845. if (tail == NULL)
  2846. *ap = head;
  2847. else
  2848. tail->next = head;
  2849. tail = head;
  2850. tail->next = NULL;
  2851. }
  2852. }
  2853. if (tail == NULL)
  2854. *ap = NULL;
  2855. }
  2856. /* Given an actual arglist and a formal arglist, sort the actual
  2857. arglist so that its arguments are in a one-to-one correspondence
  2858. with the format arglist. Arguments that are not present are given
  2859. a blank gfc_actual_arglist structure. If something is obviously
  2860. wrong (say, a missing required argument) we abort sorting and
  2861. return false. */
  2862. static bool
  2863. sort_actual (const char *name, gfc_actual_arglist **ap,
  2864. gfc_intrinsic_arg *formal, locus *where)
  2865. {
  2866. gfc_actual_arglist *actual, *a;
  2867. gfc_intrinsic_arg *f;
  2868. remove_nullargs (ap);
  2869. actual = *ap;
  2870. for (f = formal; f; f = f->next)
  2871. f->actual = NULL;
  2872. f = formal;
  2873. a = actual;
  2874. if (f == NULL && a == NULL) /* No arguments */
  2875. return true;
  2876. for (;;)
  2877. { /* Put the nonkeyword arguments in a 1:1 correspondence */
  2878. if (f == NULL)
  2879. break;
  2880. if (a == NULL)
  2881. goto optional;
  2882. if (a->name != NULL)
  2883. goto keywords;
  2884. f->actual = a;
  2885. f = f->next;
  2886. a = a->next;
  2887. }
  2888. if (a == NULL)
  2889. goto do_sort;
  2890. gfc_error ("Too many arguments in call to %qs at %L", name, where);
  2891. return false;
  2892. keywords:
  2893. /* Associate the remaining actual arguments, all of which have
  2894. to be keyword arguments. */
  2895. for (; a; a = a->next)
  2896. {
  2897. for (f = formal; f; f = f->next)
  2898. if (strcmp (a->name, f->name) == 0)
  2899. break;
  2900. if (f == NULL)
  2901. {
  2902. if (a->name[0] == '%')
  2903. gfc_error ("The argument list functions %%VAL, %%LOC or %%REF "
  2904. "are not allowed in this context at %L", where);
  2905. else
  2906. gfc_error ("Can't find keyword named %qs in call to %qs at %L",
  2907. a->name, name, where);
  2908. return false;
  2909. }
  2910. if (f->actual != NULL)
  2911. {
  2912. gfc_error ("Argument %qs appears twice in call to %qs at %L",
  2913. f->name, name, where);
  2914. return false;
  2915. }
  2916. f->actual = a;
  2917. }
  2918. optional:
  2919. /* At this point, all unmatched formal args must be optional. */
  2920. for (f = formal; f; f = f->next)
  2921. {
  2922. if (f->actual == NULL && f->optional == 0)
  2923. {
  2924. gfc_error ("Missing actual argument %qs in call to %qs at %L",
  2925. f->name, name, where);
  2926. return false;
  2927. }
  2928. }
  2929. do_sort:
  2930. /* Using the formal argument list, string the actual argument list
  2931. together in a way that corresponds with the formal list. */
  2932. actual = NULL;
  2933. for (f = formal; f; f = f->next)
  2934. {
  2935. if (f->actual && f->actual->label != NULL && f->ts.type)
  2936. {
  2937. gfc_error ("ALTERNATE RETURN not permitted at %L", where);
  2938. return false;
  2939. }
  2940. if (f->actual == NULL)
  2941. {
  2942. a = gfc_get_actual_arglist ();
  2943. a->missing_arg_type = f->ts.type;
  2944. }
  2945. else
  2946. a = f->actual;
  2947. if (actual == NULL)
  2948. *ap = a;
  2949. else
  2950. actual->next = a;
  2951. actual = a;
  2952. }
  2953. actual->next = NULL; /* End the sorted argument list. */
  2954. return true;
  2955. }
  2956. /* Compare an actual argument list with an intrinsic's formal argument
  2957. list. The lists are checked for agreement of type. We don't check
  2958. for arrayness here. */
  2959. static bool
  2960. check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
  2961. int error_flag)
  2962. {
  2963. gfc_actual_arglist *actual;
  2964. gfc_intrinsic_arg *formal;
  2965. int i;
  2966. formal = sym->formal;
  2967. actual = *ap;
  2968. i = 0;
  2969. for (; formal; formal = formal->next, actual = actual->next, i++)
  2970. {
  2971. gfc_typespec ts;
  2972. if (actual->expr == NULL)
  2973. continue;
  2974. ts = formal->ts;
  2975. /* A kind of 0 means we don't check for kind. */
  2976. if (ts.kind == 0)
  2977. ts.kind = actual->expr->ts.kind;
  2978. if (!gfc_compare_types (&ts, &actual->expr->ts))
  2979. {
  2980. if (error_flag)
  2981. gfc_error ("Type of argument %qs in call to %qs at %L should "
  2982. "be %s, not %s", gfc_current_intrinsic_arg[i]->name,
  2983. gfc_current_intrinsic, &actual->expr->where,
  2984. gfc_typename (&formal->ts),
  2985. gfc_typename (&actual->expr->ts));
  2986. return false;
  2987. }
  2988. /* If the formal argument is INTENT([IN]OUT), check for definability. */
  2989. if (formal->intent == INTENT_INOUT || formal->intent == INTENT_OUT)
  2990. {
  2991. const char* context = (error_flag
  2992. ? _("actual argument to INTENT = OUT/INOUT")
  2993. : NULL);
  2994. /* No pointer arguments for intrinsics. */
  2995. if (!gfc_check_vardef_context (actual->expr, false, false, false, context))
  2996. return false;
  2997. }
  2998. }
  2999. return true;
  3000. }
  3001. /* Given a pointer to an intrinsic symbol and an expression node that
  3002. represent the function call to that subroutine, figure out the type
  3003. of the result. This may involve calling a resolution subroutine. */
  3004. static void
  3005. resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e)
  3006. {
  3007. gfc_expr *a1, *a2, *a3, *a4, *a5;
  3008. gfc_actual_arglist *arg;
  3009. if (specific->resolve.f1 == NULL)
  3010. {
  3011. if (e->value.function.name == NULL)
  3012. e->value.function.name = specific->lib_name;
  3013. if (e->ts.type == BT_UNKNOWN)
  3014. e->ts = specific->ts;
  3015. return;
  3016. }
  3017. arg = e->value.function.actual;
  3018. /* Special case hacks for MIN and MAX. */
  3019. if (specific->resolve.f1m == gfc_resolve_max
  3020. || specific->resolve.f1m == gfc_resolve_min)
  3021. {
  3022. (*specific->resolve.f1m) (e, arg);
  3023. return;
  3024. }
  3025. if (arg == NULL)
  3026. {
  3027. (*specific->resolve.f0) (e);
  3028. return;
  3029. }
  3030. a1 = arg->expr;
  3031. arg = arg->next;
  3032. if (arg == NULL)
  3033. {
  3034. (*specific->resolve.f1) (e, a1);
  3035. return;
  3036. }
  3037. a2 = arg->expr;
  3038. arg = arg->next;
  3039. if (arg == NULL)
  3040. {
  3041. (*specific->resolve.f2) (e, a1, a2);
  3042. return;
  3043. }
  3044. a3 = arg->expr;
  3045. arg = arg->next;
  3046. if (arg == NULL)
  3047. {
  3048. (*specific->resolve.f3) (e, a1, a2, a3);
  3049. return;
  3050. }
  3051. a4 = arg->expr;
  3052. arg = arg->next;
  3053. if (arg == NULL)
  3054. {
  3055. (*specific->resolve.f4) (e, a1, a2, a3, a4);
  3056. return;
  3057. }
  3058. a5 = arg->expr;
  3059. arg = arg->next;
  3060. if (arg == NULL)
  3061. {
  3062. (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
  3063. return;
  3064. }
  3065. gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
  3066. }
  3067. /* Given an intrinsic symbol node and an expression node, call the
  3068. simplification function (if there is one), perhaps replacing the
  3069. expression with something simpler. We return false on an error
  3070. of the simplification, true if the simplification worked, even
  3071. if nothing has changed in the expression itself. */
  3072. static bool
  3073. do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
  3074. {
  3075. gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
  3076. gfc_actual_arglist *arg;
  3077. /* Max and min require special handling due to the variable number
  3078. of args. */
  3079. if (specific->simplify.f1 == gfc_simplify_min)
  3080. {
  3081. result = gfc_simplify_min (e);
  3082. goto finish;
  3083. }
  3084. if (specific->simplify.f1 == gfc_simplify_max)
  3085. {
  3086. result = gfc_simplify_max (e);
  3087. goto finish;
  3088. }
  3089. if (specific->simplify.f1 == NULL)
  3090. {
  3091. result = NULL;
  3092. goto finish;
  3093. }
  3094. arg = e->value.function.actual;
  3095. if (arg == NULL)
  3096. {
  3097. result = (*specific->simplify.f0) ();
  3098. goto finish;
  3099. }
  3100. a1 = arg->expr;
  3101. arg = arg->next;
  3102. if (specific->simplify.cc == gfc_convert_constant
  3103. || specific->simplify.cc == gfc_convert_char_constant)
  3104. {
  3105. result = specific->simplify.cc (a1, specific->ts.type, specific->ts.kind);
  3106. goto finish;
  3107. }
  3108. if (arg == NULL)
  3109. result = (*specific->simplify.f1) (a1);
  3110. else
  3111. {
  3112. a2 = arg->expr;
  3113. arg = arg->next;
  3114. if (arg == NULL)
  3115. result = (*specific->simplify.f2) (a1, a2);
  3116. else
  3117. {
  3118. a3 = arg->expr;
  3119. arg = arg->next;
  3120. if (arg == NULL)
  3121. result = (*specific->simplify.f3) (a1, a2, a3);
  3122. else
  3123. {
  3124. a4 = arg->expr;
  3125. arg = arg->next;
  3126. if (arg == NULL)
  3127. result = (*specific->simplify.f4) (a1, a2, a3, a4);
  3128. else
  3129. {
  3130. a5 = arg->expr;
  3131. arg = arg->next;
  3132. if (arg == NULL)
  3133. result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
  3134. else
  3135. gfc_internal_error
  3136. ("do_simplify(): Too many args for intrinsic");
  3137. }
  3138. }
  3139. }
  3140. }
  3141. finish:
  3142. if (result == &gfc_bad_expr)
  3143. return false;
  3144. if (result == NULL)
  3145. resolve_intrinsic (specific, e); /* Must call at run-time */
  3146. else
  3147. {
  3148. result->where = e->where;
  3149. gfc_replace_expr (e, result);
  3150. }
  3151. return true;
  3152. }
  3153. /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
  3154. error messages. This subroutine returns false if a subroutine
  3155. has more than MAX_INTRINSIC_ARGS, in which case the actual argument
  3156. list cannot match any intrinsic. */
  3157. static void
  3158. init_arglist (gfc_intrinsic_sym *isym)
  3159. {
  3160. gfc_intrinsic_arg *formal;
  3161. int i;
  3162. gfc_current_intrinsic = isym->name;
  3163. i = 0;
  3164. for (formal = isym->formal; formal; formal = formal->next)
  3165. {
  3166. if (i >= MAX_INTRINSIC_ARGS)
  3167. gfc_internal_error ("init_arglist(): too many arguments");
  3168. gfc_current_intrinsic_arg[i++] = formal;
  3169. }
  3170. }
  3171. /* Given a pointer to an intrinsic symbol and an expression consisting
  3172. of a function call, see if the function call is consistent with the
  3173. intrinsic's formal argument list. Return true if the expression
  3174. and intrinsic match, false otherwise. */
  3175. static bool
  3176. check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
  3177. {
  3178. gfc_actual_arglist *arg, **ap;
  3179. bool t;
  3180. ap = &expr->value.function.actual;
  3181. init_arglist (specific);
  3182. /* Don't attempt to sort the argument list for min or max. */
  3183. if (specific->check.f1m == gfc_check_min_max
  3184. || specific->check.f1m == gfc_check_min_max_integer
  3185. || specific->check.f1m == gfc_check_min_max_real
  3186. || specific->check.f1m == gfc_check_min_max_double)
  3187. {
  3188. if (!do_ts29113_check (specific, *ap))
  3189. return false;
  3190. return (*specific->check.f1m) (*ap);
  3191. }
  3192. if (!sort_actual (specific->name, ap, specific->formal, &expr->where))
  3193. return false;
  3194. if (!do_ts29113_check (specific, *ap))
  3195. return false;
  3196. if (specific->check.f3ml == gfc_check_minloc_maxloc)
  3197. /* This is special because we might have to reorder the argument list. */
  3198. t = gfc_check_minloc_maxloc (*ap);
  3199. else if (specific->check.f3red == gfc_check_minval_maxval)
  3200. /* This is also special because we also might have to reorder the
  3201. argument list. */
  3202. t = gfc_check_minval_maxval (*ap);
  3203. else if (specific->check.f3red == gfc_check_product_sum)
  3204. /* Same here. The difference to the previous case is that we allow a
  3205. general numeric type. */
  3206. t = gfc_check_product_sum (*ap);
  3207. else if (specific->check.f3red == gfc_check_transf_bit_intrins)
  3208. /* Same as for PRODUCT and SUM, but different checks. */
  3209. t = gfc_check_transf_bit_intrins (*ap);
  3210. else
  3211. {
  3212. if (specific->check.f1 == NULL)
  3213. {
  3214. t = check_arglist (ap, specific, error_flag);
  3215. if (t)
  3216. expr->ts = specific->ts;
  3217. }
  3218. else
  3219. t = do_check (specific, *ap);
  3220. }
  3221. /* Check conformance of elemental intrinsics. */
  3222. if (t && specific->elemental)
  3223. {
  3224. int n = 0;
  3225. gfc_expr *first_expr;
  3226. arg = expr->value.function.actual;
  3227. /* There is no elemental intrinsic without arguments. */
  3228. gcc_assert(arg != NULL);
  3229. first_expr = arg->expr;
  3230. for ( ; arg && arg->expr; arg = arg->next, n++)
  3231. if (!gfc_check_conformance (first_expr, arg->expr,
  3232. "arguments '%s' and '%s' for "
  3233. "intrinsic '%s'",
  3234. gfc_current_intrinsic_arg[0]->name,
  3235. gfc_current_intrinsic_arg[n]->name,
  3236. gfc_current_intrinsic))
  3237. return false;
  3238. }
  3239. if (!t)
  3240. remove_nullargs (ap);
  3241. return t;
  3242. }
  3243. /* Check whether an intrinsic belongs to whatever standard the user
  3244. has chosen, taking also into account -fall-intrinsics. Here, no
  3245. warning/error is emitted; but if symstd is not NULL, it is pointed to a
  3246. textual representation of the symbols standard status (like
  3247. "new in Fortran 2008", "a GNU extension" or "obsolescent in Fortran 95") that
  3248. can be used to construct a detailed warning/error message in case of
  3249. a false. */
  3250. bool
  3251. gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym,
  3252. const char** symstd, bool silent, locus where)
  3253. {
  3254. const char* symstd_msg;
  3255. /* For -fall-intrinsics, just succeed. */
  3256. if (flag_all_intrinsics)
  3257. return true;
  3258. /* Find the symbol's standard message for later usage. */
  3259. switch (isym->standard)
  3260. {
  3261. case GFC_STD_F77:
  3262. symstd_msg = "available since Fortran 77";
  3263. break;
  3264. case GFC_STD_F95_OBS:
  3265. symstd_msg = "obsolescent in Fortran 95";
  3266. break;
  3267. case GFC_STD_F95_DEL:
  3268. symstd_msg = "deleted in Fortran 95";
  3269. break;
  3270. case GFC_STD_F95:
  3271. symstd_msg = "new in Fortran 95";
  3272. break;
  3273. case GFC_STD_F2003:
  3274. symstd_msg = "new in Fortran 2003";
  3275. break;
  3276. case GFC_STD_F2008:
  3277. symstd_msg = "new in Fortran 2008";
  3278. break;
  3279. case GFC_STD_F2008_TS:
  3280. symstd_msg = "new in TS 29113/TS 18508";
  3281. break;
  3282. case GFC_STD_GNU:
  3283. symstd_msg = "a GNU Fortran extension";
  3284. break;
  3285. case GFC_STD_LEGACY:
  3286. symstd_msg = "for backward compatibility";
  3287. break;
  3288. default:
  3289. gfc_internal_error ("Invalid standard code on intrinsic %qs (%d)",
  3290. isym->name, isym->standard);
  3291. }
  3292. /* If warning about the standard, warn and succeed. */
  3293. if (gfc_option.warn_std & isym->standard)
  3294. {
  3295. /* Do only print a warning if not a GNU extension. */
  3296. if (!silent && isym->standard != GFC_STD_GNU)
  3297. gfc_warning (0, "Intrinsic %qs (is %s) is used at %L",
  3298. isym->name, _(symstd_msg), &where);
  3299. return true;
  3300. }
  3301. /* If allowing the symbol's standard, succeed, too. */
  3302. if (gfc_option.allow_std & isym->standard)
  3303. return true;
  3304. /* Otherwise, fail. */
  3305. if (symstd)
  3306. *symstd = _(symstd_msg);
  3307. return false;
  3308. }
  3309. /* See if a function call corresponds to an intrinsic function call.
  3310. We return:
  3311. MATCH_YES if the call corresponds to an intrinsic, simplification
  3312. is done if possible.
  3313. MATCH_NO if the call does not correspond to an intrinsic
  3314. MATCH_ERROR if the call corresponds to an intrinsic but there was an
  3315. error during the simplification process.
  3316. The error_flag parameter enables an error reporting. */
  3317. match
  3318. gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
  3319. {
  3320. gfc_intrinsic_sym *isym, *specific;
  3321. gfc_actual_arglist *actual;
  3322. const char *name;
  3323. int flag;
  3324. if (expr->value.function.isym != NULL)
  3325. return (!do_simplify(expr->value.function.isym, expr))
  3326. ? MATCH_ERROR : MATCH_YES;
  3327. if (!error_flag)
  3328. gfc_push_suppress_errors ();
  3329. flag = 0;
  3330. for (actual = expr->value.function.actual; actual; actual = actual->next)
  3331. if (actual->expr != NULL)
  3332. flag |= (actual->expr->ts.type != BT_INTEGER
  3333. && actual->expr->ts.type != BT_CHARACTER);
  3334. name = expr->symtree->n.sym->name;
  3335. if (expr->symtree->n.sym->intmod_sym_id)
  3336. {
  3337. gfc_isym_id id = gfc_isym_id_by_intmod_sym (expr->symtree->n.sym);
  3338. isym = specific = gfc_intrinsic_function_by_id (id);
  3339. }
  3340. else
  3341. isym = specific = gfc_find_function (name);
  3342. if (isym == NULL)
  3343. {
  3344. if (!error_flag)
  3345. gfc_pop_suppress_errors ();
  3346. return MATCH_NO;
  3347. }
  3348. if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE
  3349. || isym->id == GFC_ISYM_CMPLX)
  3350. && gfc_init_expr_flag
  3351. && !gfc_notify_std (GFC_STD_F2003, "Function %qs as initialization "
  3352. "expression at %L", name, &expr->where))
  3353. {
  3354. if (!error_flag)
  3355. gfc_pop_suppress_errors ();
  3356. return MATCH_ERROR;
  3357. }
  3358. gfc_current_intrinsic_where = &expr->where;
  3359. /* Bypass the generic list for min, max and ISO_C_Binding's c_loc. */
  3360. if (isym->check.f1m == gfc_check_min_max)
  3361. {
  3362. init_arglist (isym);
  3363. if (isym->check.f1m(expr->value.function.actual))
  3364. goto got_specific;
  3365. if (!error_flag)
  3366. gfc_pop_suppress_errors ();
  3367. return MATCH_NO;
  3368. }
  3369. /* If the function is generic, check all of its specific
  3370. incarnations. If the generic name is also a specific, we check
  3371. that name last, so that any error message will correspond to the
  3372. specific. */
  3373. gfc_push_suppress_errors ();
  3374. if (isym->generic)
  3375. {
  3376. for (specific = isym->specific_head; specific;
  3377. specific = specific->next)
  3378. {
  3379. if (specific == isym)
  3380. continue;
  3381. if (check_specific (specific, expr, 0))
  3382. {
  3383. gfc_pop_suppress_errors ();
  3384. goto got_specific;
  3385. }
  3386. }
  3387. }
  3388. gfc_pop_suppress_errors ();
  3389. if (!check_specific (isym, expr, error_flag))
  3390. {
  3391. if (!error_flag)
  3392. gfc_pop_suppress_errors ();
  3393. return MATCH_NO;
  3394. }
  3395. specific = isym;
  3396. got_specific:
  3397. expr->value.function.isym = specific;
  3398. if (!expr->symtree->n.sym->module)
  3399. gfc_intrinsic_symbol (expr->symtree->n.sym);
  3400. if (!error_flag)
  3401. gfc_pop_suppress_errors ();
  3402. if (!do_simplify (specific, expr))
  3403. return MATCH_ERROR;
  3404. /* F95, 7.1.6.1, Initialization expressions
  3405. (4) An elemental intrinsic function reference of type integer or
  3406. character where each argument is an initialization expression
  3407. of type integer or character
  3408. F2003, 7.1.7 Initialization expression
  3409. (4) A reference to an elemental standard intrinsic function,
  3410. where each argument is an initialization expression */
  3411. if (gfc_init_expr_flag && isym->elemental && flag
  3412. && !gfc_notify_std (GFC_STD_F2003, "Elemental function as "
  3413. "initialization expression with non-integer/non-"
  3414. "character arguments at %L", &expr->where))
  3415. return MATCH_ERROR;
  3416. return MATCH_YES;
  3417. }
  3418. /* See if a CALL statement corresponds to an intrinsic subroutine.
  3419. Returns MATCH_YES if the subroutine corresponds to an intrinsic,
  3420. MATCH_NO if not, and MATCH_ERROR if there was an error (but did
  3421. correspond). */
  3422. match
  3423. gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
  3424. {
  3425. gfc_intrinsic_sym *isym;
  3426. const char *name;
  3427. name = c->symtree->n.sym->name;
  3428. if (c->symtree->n.sym->intmod_sym_id)
  3429. {
  3430. gfc_isym_id id;
  3431. id = gfc_isym_id_by_intmod_sym (c->symtree->n.sym);
  3432. isym = gfc_intrinsic_subroutine_by_id (id);
  3433. }
  3434. else
  3435. isym = gfc_find_subroutine (name);
  3436. if (isym == NULL)
  3437. return MATCH_NO;
  3438. if (!error_flag)
  3439. gfc_push_suppress_errors ();
  3440. init_arglist (isym);
  3441. if (!sort_actual (name, &c->ext.actual, isym->formal, &c->loc))
  3442. goto fail;
  3443. if (!do_ts29113_check (isym, c->ext.actual))
  3444. goto fail;
  3445. if (isym->check.f1 != NULL)
  3446. {
  3447. if (!do_check (isym, c->ext.actual))
  3448. goto fail;
  3449. }
  3450. else
  3451. {
  3452. if (!check_arglist (&c->ext.actual, isym, 1))
  3453. goto fail;
  3454. }
  3455. /* The subroutine corresponds to an intrinsic. Allow errors to be
  3456. seen at this point. */
  3457. if (!error_flag)
  3458. gfc_pop_suppress_errors ();
  3459. c->resolved_isym = isym;
  3460. if (isym->resolve.s1 != NULL)
  3461. isym->resolve.s1 (c);
  3462. else
  3463. {
  3464. c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
  3465. c->resolved_sym->attr.elemental = isym->elemental;
  3466. }
  3467. if (gfc_do_concurrent_flag && !isym->pure)
  3468. {
  3469. gfc_error ("Subroutine call to intrinsic %qs in DO CONCURRENT "
  3470. "block at %L is not PURE", name, &c->loc);
  3471. return MATCH_ERROR;
  3472. }
  3473. if (!isym->pure && gfc_pure (NULL))
  3474. {
  3475. gfc_error ("Subroutine call to intrinsic %qs at %L is not PURE", name,
  3476. &c->loc);
  3477. return MATCH_ERROR;
  3478. }
  3479. if (!isym->pure)
  3480. gfc_unset_implicit_pure (NULL);
  3481. c->resolved_sym->attr.noreturn = isym->noreturn;
  3482. return MATCH_YES;
  3483. fail:
  3484. if (!error_flag)
  3485. gfc_pop_suppress_errors ();
  3486. return MATCH_NO;
  3487. }
  3488. /* Call gfc_convert_type() with warning enabled. */
  3489. bool
  3490. gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag)
  3491. {
  3492. return gfc_convert_type_warn (expr, ts, eflag, 1);
  3493. }
  3494. /* Try to convert an expression (in place) from one type to another.
  3495. 'eflag' controls the behavior on error.
  3496. The possible values are:
  3497. 1 Generate a gfc_error()
  3498. 2 Generate a gfc_internal_error().
  3499. 'wflag' controls the warning related to conversion. */
  3500. bool
  3501. gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
  3502. {
  3503. gfc_intrinsic_sym *sym;
  3504. gfc_typespec from_ts;
  3505. locus old_where;
  3506. gfc_expr *new_expr;
  3507. int rank;
  3508. mpz_t *shape;
  3509. from_ts = expr->ts; /* expr->ts gets clobbered */
  3510. if (ts->type == BT_UNKNOWN)
  3511. goto bad;
  3512. /* NULL and zero size arrays get their type here. */
  3513. if (expr->expr_type == EXPR_NULL
  3514. || (expr->expr_type == EXPR_ARRAY && expr->value.constructor == NULL))
  3515. {
  3516. /* Sometimes the RHS acquire the type. */
  3517. expr->ts = *ts;
  3518. return true;
  3519. }
  3520. if (expr->ts.type == BT_UNKNOWN)
  3521. goto bad;
  3522. if (expr->ts.type == BT_DERIVED && ts->type == BT_DERIVED
  3523. && gfc_compare_types (&expr->ts, ts))
  3524. return true;
  3525. sym = find_conv (&expr->ts, ts);
  3526. if (sym == NULL)
  3527. goto bad;
  3528. /* At this point, a conversion is necessary. A warning may be needed. */
  3529. if ((gfc_option.warn_std & sym->standard) != 0)
  3530. {
  3531. gfc_warning_now (0, "Extension: Conversion from %s to %s at %L",
  3532. gfc_typename (&from_ts), gfc_typename (ts),
  3533. &expr->where);
  3534. }
  3535. else if (wflag)
  3536. {
  3537. if (flag_range_check && expr->expr_type == EXPR_CONSTANT
  3538. && from_ts.type == ts->type)
  3539. {
  3540. /* Do nothing. Constants of the same type are range-checked
  3541. elsewhere. If a value too large for the target type is
  3542. assigned, an error is generated. Not checking here avoids
  3543. duplications of warnings/errors.
  3544. If range checking was disabled, but -Wconversion enabled,
  3545. a non range checked warning is generated below. */
  3546. }
  3547. else if (from_ts.type == BT_LOGICAL || ts->type == BT_LOGICAL)
  3548. {
  3549. /* Do nothing. This block exists only to simplify the other
  3550. else-if expressions.
  3551. LOGICAL <> LOGICAL no warning, independent of kind values
  3552. LOGICAL <> INTEGER extension, warned elsewhere
  3553. LOGICAL <> REAL invalid, error generated elsewhere
  3554. LOGICAL <> COMPLEX invalid, error generated elsewhere */
  3555. }
  3556. else if (from_ts.type == ts->type
  3557. || (from_ts.type == BT_INTEGER && ts->type == BT_REAL)
  3558. || (from_ts.type == BT_INTEGER && ts->type == BT_COMPLEX)
  3559. || (from_ts.type == BT_REAL && ts->type == BT_COMPLEX))
  3560. {
  3561. /* Larger kinds can hold values of smaller kinds without problems.
  3562. Hence, only warn if target kind is smaller than the source
  3563. kind - or if -Wconversion-extra is specified. */
  3564. if (warn_conversion && from_ts.kind > ts->kind)
  3565. gfc_warning_now (OPT_Wconversion, "Possible change of value in "
  3566. "conversion from %s to %s at %L",
  3567. gfc_typename (&from_ts), gfc_typename (ts),
  3568. &expr->where);
  3569. else if (warn_conversion_extra)
  3570. gfc_warning_now (OPT_Wconversion_extra, "Conversion from %s to %s "
  3571. "at %L", gfc_typename (&from_ts),
  3572. gfc_typename (ts), &expr->where);
  3573. }
  3574. else if ((from_ts.type == BT_REAL && ts->type == BT_INTEGER)
  3575. || (from_ts.type == BT_COMPLEX && ts->type == BT_INTEGER)
  3576. || (from_ts.type == BT_COMPLEX && ts->type == BT_REAL))
  3577. {
  3578. /* Conversion from REAL/COMPLEX to INTEGER or COMPLEX to REAL
  3579. usually comes with a loss of information, regardless of kinds. */
  3580. if (warn_conversion)
  3581. gfc_warning_now (OPT_Wconversion, "Possible change of value in "
  3582. "conversion from %s to %s at %L",
  3583. gfc_typename (&from_ts), gfc_typename (ts),
  3584. &expr->where);
  3585. }
  3586. else if (from_ts.type == BT_HOLLERITH || ts->type == BT_HOLLERITH)
  3587. {
  3588. /* If HOLLERITH is involved, all bets are off. */
  3589. if (warn_conversion)
  3590. gfc_warning_now (OPT_Wconversion, "Conversion from %s to %s at %L",
  3591. gfc_typename (&from_ts), gfc_typename (ts),
  3592. &expr->where);
  3593. }
  3594. else
  3595. gcc_unreachable ();
  3596. }
  3597. /* Insert a pre-resolved function call to the right function. */
  3598. old_where = expr->where;
  3599. rank = expr->rank;
  3600. shape = expr->shape;
  3601. new_expr = gfc_get_expr ();
  3602. *new_expr = *expr;
  3603. new_expr = gfc_build_conversion (new_expr);
  3604. new_expr->value.function.name = sym->lib_name;
  3605. new_expr->value.function.isym = sym;
  3606. new_expr->where = old_where;
  3607. new_expr->rank = rank;
  3608. new_expr->shape = gfc_copy_shape (shape, rank);
  3609. gfc_get_ha_sym_tree (sym->name, &new_expr->symtree);
  3610. new_expr->symtree->n.sym->result = new_expr->symtree->n.sym;
  3611. new_expr->symtree->n.sym->ts = *ts;
  3612. new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
  3613. new_expr->symtree->n.sym->attr.function = 1;
  3614. new_expr->symtree->n.sym->attr.elemental = 1;
  3615. new_expr->symtree->n.sym->attr.pure = 1;
  3616. new_expr->symtree->n.sym->attr.referenced = 1;
  3617. gfc_intrinsic_symbol(new_expr->symtree->n.sym);
  3618. gfc_commit_symbol (new_expr->symtree->n.sym);
  3619. *expr = *new_expr;
  3620. free (new_expr);
  3621. expr->ts = *ts;
  3622. if (gfc_is_constant_expr (expr->value.function.actual->expr)
  3623. && !do_simplify (sym, expr))
  3624. {
  3625. if (eflag == 2)
  3626. goto bad;
  3627. return false; /* Error already generated in do_simplify() */
  3628. }
  3629. return true;
  3630. bad:
  3631. if (eflag == 1)
  3632. {
  3633. gfc_error ("Can't convert %s to %s at %L",
  3634. gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
  3635. return false;
  3636. }
  3637. gfc_internal_error ("Can't convert %qs to %qs at %L",
  3638. gfc_typename (&from_ts), gfc_typename (ts),
  3639. &expr->where);
  3640. /* Not reached */
  3641. }
  3642. bool
  3643. gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts)
  3644. {
  3645. gfc_intrinsic_sym *sym;
  3646. locus old_where;
  3647. gfc_expr *new_expr;
  3648. int rank;
  3649. mpz_t *shape;
  3650. gcc_assert (expr->ts.type == BT_CHARACTER && ts->type == BT_CHARACTER);
  3651. sym = find_char_conv (&expr->ts, ts);
  3652. gcc_assert (sym);
  3653. /* Insert a pre-resolved function call to the right function. */
  3654. old_where = expr->where;
  3655. rank = expr->rank;
  3656. shape = expr->shape;
  3657. new_expr = gfc_get_expr ();
  3658. *new_expr = *expr;
  3659. new_expr = gfc_build_conversion (new_expr);
  3660. new_expr->value.function.name = sym->lib_name;
  3661. new_expr->value.function.isym = sym;
  3662. new_expr->where = old_where;
  3663. new_expr->rank = rank;
  3664. new_expr->shape = gfc_copy_shape (shape, rank);
  3665. gfc_get_ha_sym_tree (sym->name, &new_expr->symtree);
  3666. new_expr->symtree->n.sym->ts = *ts;
  3667. new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
  3668. new_expr->symtree->n.sym->attr.function = 1;
  3669. new_expr->symtree->n.sym->attr.elemental = 1;
  3670. new_expr->symtree->n.sym->attr.referenced = 1;
  3671. gfc_intrinsic_symbol(new_expr->symtree->n.sym);
  3672. gfc_commit_symbol (new_expr->symtree->n.sym);
  3673. *expr = *new_expr;
  3674. free (new_expr);
  3675. expr->ts = *ts;
  3676. if (gfc_is_constant_expr (expr->value.function.actual->expr)
  3677. && !do_simplify (sym, expr))
  3678. {
  3679. /* Error already generated in do_simplify() */
  3680. return false;
  3681. }
  3682. return true;
  3683. }
  3684. /* Check if the passed name is name of an intrinsic (taking into account the
  3685. current -std=* and -fall-intrinsic settings). If it is, see if we should
  3686. warn about this as a user-procedure having the same name as an intrinsic
  3687. (-Wintrinsic-shadow enabled) and do so if we should. */
  3688. void
  3689. gfc_warn_intrinsic_shadow (const gfc_symbol* sym, bool in_module, bool func)
  3690. {
  3691. gfc_intrinsic_sym* isym;
  3692. /* If the warning is disabled, do nothing at all. */
  3693. if (!warn_intrinsic_shadow)
  3694. return;
  3695. /* Try to find an intrinsic of the same name. */
  3696. if (func)
  3697. isym = gfc_find_function (sym->name);
  3698. else
  3699. isym = gfc_find_subroutine (sym->name);
  3700. /* If no intrinsic was found with this name or it's not included in the
  3701. selected standard, everything's fine. */
  3702. if (!isym || !gfc_check_intrinsic_standard (isym, NULL, true,
  3703. sym->declared_at))
  3704. return;
  3705. /* Emit the warning. */
  3706. if (in_module || sym->ns->proc_name)
  3707. gfc_warning (OPT_Wintrinsic_shadow,
  3708. "%qs declared at %L may shadow the intrinsic of the same"
  3709. " name. In order to call the intrinsic, explicit INTRINSIC"
  3710. " declarations may be required.",
  3711. sym->name, &sym->declared_at);
  3712. else
  3713. gfc_warning (OPT_Wintrinsic_shadow,
  3714. "%qs declared at %L is also the name of an intrinsic. It can"
  3715. " only be called via an explicit interface or if declared"
  3716. " EXTERNAL.", sym->name, &sym->declared_at);
  3717. }