cg68k.pas 233 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156415741584159416041614162416341644165416641674168416941704171417241734174417541764177417841794180418141824183418441854186418741884189419041914192419341944195419641974198419942004201420242034204420542064207420842094210421142124213421442154216421742184219422042214222422342244225422642274228422942304231423242334234423542364237423842394240424142424243424442454246424742484249425042514252425342544255425642574258425942604261426242634264426542664267426842694270427142724273427442754276427742784279428042814282428342844285428642874288428942904291429242934294429542964297429842994300430143024303430443054306430743084309431043114312431343144315431643174318431943204321432243234324432543264327432843294330433143324333433443354336433743384339434043414342434343444345434643474348434943504351435243534354435543564357435843594360436143624363436443654366436743684369437043714372437343744375437643774378437943804381438243834384438543864387438843894390439143924393439443954396439743984399440044014402440344044405440644074408440944104411441244134414441544164417441844194420442144224423442444254426442744284429443044314432443344344435443644374438443944404441444244434444444544464447444844494450445144524453445444554456445744584459446044614462446344644465446644674468446944704471447244734474447544764477447844794480448144824483448444854486448744884489449044914492449344944495449644974498449945004501450245034504450545064507450845094510451145124513451445154516451745184519452045214522452345244525452645274528452945304531453245334534453545364537453845394540454145424543454445454546454745484549455045514552455345544555455645574558455945604561456245634564456545664567456845694570457145724573457445754576457745784579458045814582458345844585458645874588458945904591459245934594459545964597459845994600460146024603460446054606460746084609461046114612461346144615461646174618461946204621462246234624462546264627462846294630463146324633463446354636463746384639464046414642464346444645464646474648464946504651465246534654465546564657465846594660466146624663466446654666466746684669467046714672467346744675467646774678467946804681468246834684468546864687468846894690469146924693469446954696469746984699470047014702470347044705470647074708470947104711471247134714471547164717471847194720472147224723472447254726472747284729473047314732473347344735473647374738473947404741474247434744474547464747474847494750475147524753475447554756475747584759476047614762476347644765476647674768476947704771477247734774477547764777477847794780478147824783478447854786478747884789479047914792479347944795479647974798479948004801480248034804480548064807480848094810481148124813481448154816481748184819482048214822482348244825482648274828482948304831483248334834483548364837483848394840484148424843484448454846484748484849485048514852485348544855485648574858485948604861486248634864486548664867486848694870487148724873487448754876487748784879488048814882488348844885488648874888488948904891489248934894489548964897489848994900490149024903490449054906490749084909491049114912491349144915491649174918491949204921492249234924492549264927492849294930493149324933493449354936493749384939494049414942494349444945494649474948494949504951495249534954495549564957495849594960496149624963496449654966496749684969497049714972497349744975497649774978497949804981498249834984498549864987498849894990499149924993499449954996499749984999500050015002500350045005500650075008500950105011501250135014501550165017501850195020502150225023502450255026502750285029503050315032503350345035503650375038503950405041504250435044504550465047504850495050505150525053505450555056505750585059506050615062506350645065506650675068506950705071507250735074507550765077507850795080508150825083508450855086508750885089509050915092509350945095509650975098509951005101510251035104510551065107510851095110511151125113511451155116511751185119512051215122512351245125512651275128512951305131513251335134513551365137513851395140514151425143514451455146514751485149515051515152515351545155515651575158515951605161516251635164516551665167516851695170517151725173517451755176517751785179518051815182518351845185518651875188518951905191519251935194519551965197519851995200520152025203520452055206520752085209521052115212521352145215521652175218521952205221522252235224522552265227522852295230523152325233523452355236523752385239524052415242524352445245524652475248524952505251525252535254525552565257525852595260526152625263526452655266526752685269527052715272527352745275527652775278527952805281528252835284528552865287528852895290529152925293529452955296529752985299530053015302530353045305530653075308530953105311531253135314531553165317531853195320532153225323532453255326532753285329533053315332533353345335533653375338533953405341534253435344534553465347534853495350535153525353535453555356535753585359536053615362536353645365536653675368536953705371537253735374537553765377537853795380538153825383538453855386538753885389539053915392539353945395539653975398539954005401540254035404540554065407540854095410541154125413541454155416541754185419542054215422542354245425542654275428542954305431543254335434543554365437543854395440544154425443544454455446544754485449545054515452545354545455545654575458545954605461546254635464
  1. {
  2. $Id$
  3. Copyright (c) 1993,98 by Florian Klaempfl, Carl Eric Codere
  4. This unit generates 68000 (or better) assembler from the parse tree
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************}
  17. {$ifdef tp}
  18. {$E+,F+,N+,D+,L+,Y+}
  19. {$endif}
  20. {---------------------------------------------------------------------------}
  21. { LEFT TO DO IN CG68k AND CG68k2 }
  22. {---------------------------------------------------------------------------}
  23. { o Test and correct problems with extended support. }
  24. { o Optimize secondmoddiv when doing a constant modulo. }
  25. { o Add emulation support for Cardinal under MC68000. }
  26. {---------------------------------------------------------------------------}
  27. unit cg68k;
  28. {***************************************************************************}
  29. interface
  30. {***************************************************************************}
  31. uses objects,verbose,cobjects,systems,globals,tree,
  32. symtable,types,strings,pass_1,hcodegen,temp_gen,
  33. aasm,m68k,tgen68k,files,cga68k,cg68k2,link
  34. {$ifdef GDB}
  35. ,gdb
  36. {$endif}
  37. ;
  38. { produces assembler for the expression in variable p }
  39. { and produces an assembler node at the end }
  40. procedure generatecode(var p : ptree);
  41. { produces the actual code }
  42. function do_secondpass(var p : ptree) : boolean;
  43. procedure secondpass(var p : ptree);
  44. {$ifdef test_dest_loc}
  45. const { used to avoid temporary assignments }
  46. dest_loc_known : boolean = false;
  47. in_dest_loc : boolean = false;
  48. dest_loc_tree : ptree = nil;
  49. var dest_loc : tlocation;
  50. procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
  51. {$endif test_dest_loc}
  52. {***************************************************************************}
  53. implementation
  54. {***************************************************************************}
  55. uses
  56. scanner;
  57. const
  58. never_copy_const_param : boolean = false;
  59. bytes2Sxx:array[1..4] of Topsize=(S_B,S_W,S_NO,S_L);
  60. { used to avoid temporary assignments }
  61. dest_loc_known : boolean = false;
  62. in_dest_loc : boolean = false;
  63. dest_loc_tree : ptree = nil;
  64. var
  65. { this is for open arrays and strings }
  66. { but be careful, this data is in the }
  67. { generated code destroyed quick, and also }
  68. { the next call of secondload destroys this }
  69. { data }
  70. { So be careful using the informations }
  71. { provided by this variables }
  72. highframepointer : tregister;
  73. highoffset : longint;
  74. dest_loc : tlocation;
  75. procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
  76. begin
  77. if (dest_loc.loc=LOC_CREGISTER) or (dest_loc.loc=LOC_REGISTER) then
  78. begin
  79. emit_reg_reg(A_MOVE,s,reg,dest_loc.register);
  80. p^.location:=dest_loc;
  81. in_dest_loc:=true;
  82. end
  83. else
  84. if (dest_loc.loc=LOC_REFERENCE) or (dest_loc.loc=LOC_MEM) then
  85. begin
  86. exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,s,reg,newreference(dest_loc.reference))));
  87. p^.location:=dest_loc;
  88. in_dest_loc:=true;
  89. end
  90. else
  91. internalerror(20080);
  92. end;
  93. procedure error(const t : tmsgconst);
  94. begin
  95. if not(codegenerror) then
  96. verbose.Message(t);
  97. codegenerror:=true;
  98. end;
  99. type
  100. secondpassproc = procedure(var p : ptree);
  101. procedure seconderror(var p : ptree);
  102. begin
  103. p^.error:=true;
  104. codegenerror:=true;
  105. end;
  106. procedure secondstatement(var p : ptree);
  107. var
  108. hp : ptree;
  109. begin
  110. hp:=p;
  111. while assigned(hp) do
  112. begin
  113. { assignments could be distance optimized }
  114. if assigned(hp^.right) then
  115. begin
  116. cleartempgen;
  117. secondpass(hp^.right);
  118. end;
  119. hp:=hp^.left;
  120. end;
  121. end;
  122. procedure secondload(var p : ptree);
  123. var
  124. hregister : tregister;
  125. i : longint;
  126. symtabletype: tsymtabletype;
  127. hp : preference;
  128. begin
  129. simple_loadn:=true;
  130. reset_reference(p^.location.reference);
  131. case p^.symtableentry^.typ of
  132. { this is only for toasm and toaddr }
  133. absolutesym :
  134. begin
  135. stringdispose(p^.location.reference.symbol);
  136. p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
  137. if p^.symtableentry^.owner^.symtabletype=unitsymtable then
  138. concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
  139. end;
  140. varsym :
  141. begin
  142. hregister:=R_NO;
  143. symtabletype:=p^.symtable^.symtabletype;
  144. { in case it is a register variable: }
  145. { we simply set the location to the }
  146. { correct register. }
  147. if pvarsym(p^.symtableentry)^.reg<>R_NO then
  148. begin
  149. p^.location.loc:=LOC_CREGISTER;
  150. p^.location.register:=pvarsym(p^.symtableentry)^.reg;
  151. unused:=unused-[pvarsym(p^.symtableentry)^.reg];
  152. end
  153. else
  154. begin
  155. { --------------------- LOCAL AND TEMP VARIABLES ------------- }
  156. if (symtabletype=parasymtable) or (symtabletype=localsymtable) then
  157. begin
  158. p^.location.reference.base:=procinfo.framepointer;
  159. p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
  160. if (symtabletype=localsymtable) then
  161. p^.location.reference.offset:=-p^.location.reference.offset;
  162. if (symtabletype=parasymtable) then
  163. inc(p^.location.reference.offset,p^.symtable^.call_offset);
  164. if (lexlevel>(p^.symtable^.symtablelevel)) then
  165. begin
  166. hregister:=getaddressreg;
  167. { make a reference }
  168. new(hp);
  169. reset_reference(hp^);
  170. hp^.offset:=procinfo.framepointer_offset;
  171. hp^.base:=procinfo.framepointer;
  172. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,hregister)));
  173. simple_loadn:=false;
  174. i:=lexlevel-1;
  175. while i>(p^.symtable^.symtablelevel) do
  176. begin
  177. { make a reference }
  178. new(hp);
  179. reset_reference(hp^);
  180. hp^.offset:=8;
  181. hp^.base:=hregister;
  182. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,hregister)));
  183. dec(i);
  184. end;
  185. p^.location.reference.base:=hregister;
  186. end;
  187. end
  188. { --------------------- END OF LOCAL AND TEMP VARS ---------------- }
  189. else
  190. case symtabletype of
  191. unitsymtable,globalsymtable,
  192. staticsymtable : begin
  193. stringdispose(p^.location.reference.symbol);
  194. p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
  195. if symtabletype=unitsymtable then
  196. concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
  197. end;
  198. objectsymtable : begin
  199. if (pvarsym(p^.symtableentry)^.properties and sp_static)<>0 then
  200. begin
  201. stringdispose(p^.location.reference.symbol);
  202. p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
  203. if p^.symtable^.defowner^.owner^.symtabletype=unitsymtable then
  204. concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
  205. end
  206. else
  207. begin
  208. p^.location.reference.base:=R_A5;
  209. p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
  210. end;
  211. end;
  212. withsymtable : begin
  213. hregister:=getaddressreg;
  214. p^.location.reference.base:=hregister;
  215. { make a reference }
  216. new(hp);
  217. reset_reference(hp^);
  218. hp^.offset:=p^.symtable^.datasize;
  219. hp^.base:=procinfo.framepointer;
  220. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,hregister)));
  221. p^.location.reference.offset:=
  222. pvarsym(p^.symtableentry)^.address;
  223. end;
  224. end;
  225. { in case call by reference, then calculate: }
  226. if (pvarsym(p^.symtableentry)^.varspez=vs_var) or
  227. ((pvarsym(p^.symtableentry)^.varspez=vs_const) and
  228. dont_copy_const_param(pvarsym(p^.symtableentry)^.definition)) then
  229. begin
  230. simple_loadn:=false;
  231. if hregister=R_NO then
  232. hregister:=getaddressreg;
  233. { ADDED FOR OPEN ARRAY SUPPORT. }
  234. if (p^.location.reference.base=procinfo.framepointer) then
  235. begin
  236. highframepointer:=p^.location.reference.base;
  237. highoffset:=p^.location.reference.offset;
  238. end
  239. else
  240. begin
  241. highframepointer:=R_A1;
  242. highoffset:=p^.location.reference.offset;
  243. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
  244. p^.location.reference.base,R_A1)));
  245. end;
  246. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),
  247. hregister)));
  248. { END ADDITION }
  249. clear_reference(p^.location.reference);
  250. p^.location.reference.base:=hregister;
  251. end;
  252. { should be dereferenced later (FK)
  253. if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and
  254. ((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oois_class)<>0) then
  255. begin
  256. simple_loadn:=false;
  257. if hregister=R_NO then
  258. hregister:=getaddressreg;
  259. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),
  260. hregister)));
  261. clear_reference(p^.location.reference);
  262. p^.location.reference.base:=hregister;
  263. end;
  264. }
  265. end;
  266. end;
  267. procsym:
  268. begin
  269. {!!!!! Be aware, work on virtual methods too }
  270. stringdispose(p^.location.reference.symbol);
  271. p^.location.reference.symbol:=
  272. stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname);
  273. if p^.symtable^.symtabletype=unitsymtable then
  274. concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
  275. end;
  276. typedconstsym :
  277. begin
  278. stringdispose(p^.location.reference.symbol);
  279. p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
  280. if p^.symtable^.symtabletype=unitsymtable then
  281. concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
  282. end;
  283. else internalerror(4);
  284. end;
  285. end;
  286. { D0 and D1 used as temp (ok) }
  287. procedure secondmoddiv(var p : ptree);
  288. var
  289. hreg1 : tregister;
  290. power : longint;
  291. hl : plabel;
  292. reg: tregister;
  293. pushed: boolean;
  294. begin
  295. secondpass(p^.left);
  296. set_location(p^.location,p^.left^.location);
  297. pushed:=maybe_push(p^.right^.registers32,p);
  298. secondpass(p^.right);
  299. if pushed then restore(p);
  300. { put numerator in register }
  301. if p^.left^.location.loc<>LOC_REGISTER then
  302. begin
  303. if p^.left^.location.loc=LOC_CREGISTER then
  304. begin
  305. hreg1:=getregister32;
  306. emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hreg1);
  307. end
  308. else
  309. begin
  310. del_reference(p^.left^.location.reference);
  311. hreg1:=getregister32;
  312. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
  313. hreg1)));
  314. end;
  315. p^.left^.location.loc:=LOC_REGISTER;
  316. p^.left^.location.register:=hreg1;
  317. end
  318. else hreg1:=p^.left^.location.register;
  319. if (p^.treetype=divn) and (p^.right^.treetype=ordconstn) and
  320. ispowerof2(p^.right^.value,power) then
  321. begin
  322. exprasmlist^.concat(new(pai68k, op_reg(A_TST, S_L, hreg1)));
  323. getlabel(hl);
  324. emitl(A_BPL,hl);
  325. if (power = 1) then
  326. exprasmlist^.concat(new(pai68k, op_const_reg(A_ADDQ, S_L,1, hreg1)));
  327. if (p^.right^.value-1) < 9 then
  328. exprasmlist^.concat(new(pai68k, op_const_reg(A_ADDQ, S_L,p^.right^.value-1, hreg1)))
  329. else
  330. exprasmlist^.concat(new(pai68k, op_const_reg(A_ADD, S_L,p^.right^.value-1, hreg1)));
  331. emitl(A_LABEL, hl);
  332. if (power > 0) and (power < 9) then
  333. exprasmlist^.concat(new(pai68k, op_const_reg(A_ASR, S_L,power, hreg1)))
  334. else
  335. begin
  336. exprasmlist^.concat(new(pai68k, op_const_reg(A_MOVE,S_L,power, R_D0)));
  337. exprasmlist^.concat(new(pai68k, op_reg_reg(A_ASR,S_L,R_D0, hreg1)));
  338. end;
  339. end
  340. else
  341. begin
  342. { bring denominator to D1 }
  343. { D1 is always free, it's }
  344. { only used for temporary }
  345. { purposes }
  346. if (p^.right^.location.loc<>LOC_REGISTER) and
  347. (p^.right^.location.loc<>LOC_CREGISTER) then
  348. begin
  349. del_reference(p^.right^.location.reference);
  350. p^.left^.location.loc:=LOC_REGISTER;
  351. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference),R_D1)));
  352. end
  353. else
  354. begin
  355. ungetregister32(p^.right^.location.register);
  356. emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,R_D1);
  357. end;
  358. { on entering this section D1 should contain the divisor }
  359. if (aktoptprocessor
  360. = MC68020) then
  361. begin
  362. if (p^.treetype = modn) then
  363. Begin
  364. reg := getregister32;
  365. exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,reg)));
  366. getlabel(hl);
  367. { here what we do is prepare the high register with the }
  368. { correct sign. i.e we clear it, check if the low dword reg }
  369. { which will participate in the division is signed, if so we}
  370. { we extend the sign to the high doword register by inverting }
  371. { all the bits. }
  372. exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,hreg1)));
  373. emitl(A_BPL,hl);
  374. exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,reg)));
  375. emitl(A_LABEL,hl);
  376. { reg:hreg1 / d1 }
  377. exprasmlist^.concat(new(pai68k,op_reg_reg_reg(A_DIVSL,S_L,R_D1,reg,hreg1)));
  378. { hreg1 already contains quotient }
  379. { looking for remainder }
  380. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,reg,hreg1)));
  381. ungetregister32(reg);
  382. end
  383. else
  384. { simple division... }
  385. Begin
  386. { reg:hreg1 / d1 }
  387. exprasmlist^.concat(new(pai68k,op_reg_reg(A_DIVS,S_L,R_D1,hreg1)));
  388. end;
  389. end
  390. else { MC68000 operations }
  391. begin
  392. { put numerator in d0 }
  393. emit_reg_reg(A_MOVE,S_L,hreg1,R_D0);
  394. { operation to perform on entry to both }
  395. { routines... d0/d1 }
  396. { return result in d0 }
  397. if p^.treetype = divn then
  398. emitcall('LONGDIV',true)
  399. else
  400. emitcall('LONGMOD',true);
  401. emit_reg_reg(A_MOVE,S_L,R_D0,hreg1);
  402. end; { endif }
  403. end;
  404. { this registers are always used when div/mod are present }
  405. usedinproc:=usedinproc or ($800 shr word(R_D1));
  406. usedinproc:=usedinproc or ($800 shr word(R_D0));
  407. p^.location.loc:=LOC_REGISTER;
  408. p^.location.register:=hreg1;
  409. end;
  410. { D6 used as scratch (ok) }
  411. procedure secondshlshr(var p : ptree);
  412. var
  413. hregister1,hregister2,hregister3 : tregister;
  414. op : tasmop;
  415. pushed : boolean;
  416. begin
  417. secondpass(p^.left);
  418. pushed:=maybe_push(p^.right^.registers32,p);
  419. secondpass(p^.right);
  420. if pushed then restore(p);
  421. { load left operators in a register }
  422. if p^.left^.location.loc<>LOC_REGISTER then
  423. begin
  424. if p^.left^.location.loc=LOC_CREGISTER then
  425. begin
  426. hregister1:=getregister32;
  427. emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
  428. hregister1);
  429. end
  430. else
  431. begin
  432. del_reference(p^.left^.location.reference);
  433. hregister1:=getregister32;
  434. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
  435. hregister1)));
  436. end;
  437. end
  438. else hregister1:=p^.left^.location.register;
  439. { determine operator }
  440. if p^.treetype=shln then
  441. op:=A_LSL
  442. else
  443. op:=A_LSR;
  444. { shifting by a constant directly decode: }
  445. if (p^.right^.treetype=ordconstn) then
  446. begin
  447. if (p^.right^.location.reference.offset and 31 > 0) and (p^.right^.location.reference.offset and 31 < 9) then
  448. exprasmlist^.concat(new(pai68k,op_const_reg(op,S_L,p^.right^.location.reference.offset and 31,
  449. hregister1)))
  450. else
  451. begin
  452. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,p^.right^.location.reference.offset and 31,
  453. R_D6)));
  454. exprasmlist^.concat(new(pai68k,op_reg_reg(op,S_L,R_D6,hregister1)));
  455. end;
  456. p^.location.loc:=LOC_REGISTER;
  457. p^.location.register:=hregister1;
  458. end
  459. else
  460. begin
  461. { load right operators in a register }
  462. if p^.right^.location.loc<>LOC_REGISTER then
  463. begin
  464. if p^.right^.location.loc=LOC_CREGISTER then
  465. begin
  466. hregister2:=getregister32;
  467. emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,
  468. hregister2);
  469. end
  470. else
  471. begin
  472. del_reference(p^.right^.location.reference);
  473. hregister2:=getregister32;
  474. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference),
  475. hregister2)));
  476. end;
  477. end
  478. else hregister2:=p^.right^.location.register;
  479. emit_reg_reg(op,S_L,hregister2,hregister1);
  480. p^.location.register:=hregister1;
  481. end;
  482. { this register is always used when shl/shr are present }
  483. usedinproc:=usedinproc or ($800 shr byte(R_D6));
  484. end;
  485. procedure secondrealconst(var p : ptree);
  486. var
  487. hp1 : pai;
  488. lastlabel : plabel;
  489. found : boolean;
  490. begin
  491. clear_reference(p^.location.reference);
  492. lastlabel:=nil;
  493. found:=false;
  494. { const already used ? }
  495. if p^.labnumber=-1 then
  496. begin
  497. { tries to found an old entry }
  498. hp1:=pai(consts^.first);
  499. while assigned(hp1) do
  500. begin
  501. if hp1^.typ=ait_label then
  502. lastlabel:=pai_label(hp1)^.l
  503. else
  504. begin
  505. if (hp1^.typ=p^.realtyp) and (lastlabel<>nil) then
  506. begin
  507. { Florian this caused a internalerror(10)=> no free reg !! }
  508. {if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) or
  509. ((p^.realtyp=ait_real_80bit) and (pai_extended(hp1)^.value=p^.valued)) or
  510. ((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then }
  511. if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) then
  512. found:=true;
  513. if ((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then
  514. found:=true;
  515. if ((p^.realtyp=ait_real_extended) and (pai_extended(hp1)^.value=p^.valued)) then
  516. found:=true;
  517. if found then
  518. begin
  519. { found! }
  520. p^.labnumber:=lastlabel^.nb;
  521. break;
  522. end;
  523. end;
  524. lastlabel:=nil;
  525. end;
  526. hp1:=pai(hp1^.next);
  527. end;
  528. { :-(, we must generate a new entry }
  529. if p^.labnumber=-1 then
  530. begin
  531. getlabel(lastlabel);
  532. p^.labnumber:=lastlabel^.nb;
  533. case p^.realtyp of
  534. ait_real_64bit : consts^.insert(new(pai_double,init(p^.valued)));
  535. ait_real_32bit : consts^.insert(new(pai_single,init(p^.valued)));
  536. ait_real_extended : consts^.insert(new(pai_extended,init(p^.valued)));
  537. else
  538. internalerror(10120);
  539. end;
  540. consts^.insert(new(pai_label,init(lastlabel)));
  541. end;
  542. end;
  543. stringdispose(p^.location.reference.symbol);
  544. p^.location.reference.symbol:=stringdup(lab2str(lastlabel));
  545. end;
  546. procedure secondfixconst(var p : ptree);
  547. begin
  548. { an fix comma const. behaves as a memory reference }
  549. p^.location.loc:=LOC_MEM;
  550. p^.location.reference.isintvalue:=true;
  551. p^.location.reference.offset:=p^.valuef;
  552. end;
  553. procedure secondordconst(var p : ptree);
  554. begin
  555. { an integer const. behaves as a memory reference }
  556. p^.location.loc:=LOC_MEM;
  557. p^.location.reference.isintvalue:=true;
  558. p^.location.reference.offset:=p^.value;
  559. end;
  560. procedure secondniln(var p : ptree);
  561. begin
  562. p^.location.loc:=LOC_MEM;
  563. p^.location.reference.isintvalue:=true;
  564. p^.location.reference.offset:=0;
  565. end;
  566. procedure secondstringconst(var p : ptree);
  567. var
  568. hp1 : pai;
  569. lastlabel : plabel;
  570. pc : pchar;
  571. same_string : boolean;
  572. i : word;
  573. begin
  574. clear_reference(p^.location.reference);
  575. lastlabel:=nil;
  576. { const already used ? }
  577. if p^.labstrnumber=-1 then
  578. begin
  579. { tries to found an old entry }
  580. hp1:=pai(consts^.first);
  581. while assigned(hp1) do
  582. begin
  583. if hp1^.typ=ait_label then
  584. lastlabel:=pai_label(hp1)^.l
  585. else
  586. begin
  587. if (hp1^.typ=ait_string) and (lastlabel<>nil) and
  588. (pai_string(hp1)^.len=length(p^.values^)+2) then
  589. begin
  590. same_string:=true;
  591. for i:=1 to length(p^.values^) do
  592. if pai_string(hp1)^.str[i]<>p^.values^[i] then
  593. begin
  594. same_string:=false;
  595. break;
  596. end;
  597. if same_string then
  598. begin
  599. { found! }
  600. p^.labstrnumber:=lastlabel^.nb;
  601. break;
  602. end;
  603. end;
  604. lastlabel:=nil;
  605. end;
  606. hp1:=pai(hp1^.next);
  607. end;
  608. { :-(, we must generate a new entry }
  609. if p^.labstrnumber=-1 then
  610. begin
  611. getlabel(lastlabel);
  612. p^.labstrnumber:=lastlabel^.nb;
  613. getmem(pc,length(p^.values^)+3);
  614. move(p^.values^,pc^,length(p^.values^)+1);
  615. pc[length(p^.values^)+1]:=#0;
  616. { we still will have a problem if there is a #0 inside the pchar }
  617. consts^.insert(new(pai_string,init_pchar(pc)));
  618. { to overcome this problem we set the length explicitly }
  619. { with the ending null char }
  620. pai_string(consts^.first)^.len:=length(p^.values^)+2;
  621. consts^.insert(new(pai_label,init(lastlabel)));
  622. end;
  623. end;
  624. stringdispose(p^.location.reference.symbol);
  625. p^.location.reference.symbol:=stringdup(lab2str(lastlabel));
  626. p^.location.loc := LOC_MEM;
  627. end;
  628. procedure secondumminus(var p : ptree);
  629. begin
  630. secondpass(p^.left);
  631. p^.location.loc:=LOC_REGISTER;
  632. case p^.left^.location.loc of
  633. LOC_REGISTER : begin
  634. p^.location.register:=p^.left^.location.register;
  635. exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_L,p^.location.register)));
  636. end;
  637. LOC_CREGISTER : begin
  638. p^.location.register:=getregister32;
  639. emit_reg_reg(A_MOVE,S_L,p^.location.register,
  640. p^.location.register);
  641. exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_L,p^.location.register)));
  642. end;
  643. LOC_REFERENCE,LOC_MEM :
  644. begin
  645. del_reference(p^.left^.location.reference);
  646. { change sign of a floating point }
  647. { in the case of emulation, get }
  648. { a free register, and change sign }
  649. { manually. }
  650. { otherwise simply load into an FPU}
  651. { register. }
  652. if (p^.left^.resulttype^.deftype=floatdef) and
  653. (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then
  654. begin
  655. { move to FPU }
  656. floatload(pfloatdef(p^.left^.resulttype)^.typ,
  657. p^.left^.location.reference,p^.location);
  658. if (cs_fp_emulation) in aktswitches then
  659. { if in emulation mode change sign manually }
  660. exprasmlist^.concat(new(pai68k,op_const_reg(A_BCHG,S_L,31,
  661. p^.location.fpureg)))
  662. else
  663. exprasmlist^.concat(new(pai68k,op_reg(A_FNEG,S_FX,
  664. p^.location.fpureg)));
  665. end
  666. else
  667. begin
  668. p^.location.register:=getregister32;
  669. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
  670. newreference(p^.left^.location.reference),
  671. p^.location.register)));
  672. exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_L,p^.location.register)));
  673. end;
  674. end;
  675. LOC_FPU : begin
  676. p^.location.loc:=LOC_FPU;
  677. p^.location.fpureg := p^.left^.location.fpureg;
  678. if (cs_fp_emulation) in aktswitches then
  679. exprasmlist^.concat(new(pai68k,op_const_reg(A_BCHG,S_L,31,p^.location.fpureg)))
  680. else
  681. exprasmlist^.concat(new(pai68k,op_reg(A_FNEG,S_FX,p^.location.fpureg)));
  682. end;
  683. end;
  684. { emitoverflowcheck;}
  685. end;
  686. { use of A6 is required only temp (ok) }
  687. procedure secondaddr(var p : ptree);
  688. begin
  689. secondpass(p^.left);
  690. p^.location.loc:=LOC_REGISTER;
  691. p^.location.register:=getregister32;
  692. {@ on a procvar means returning an address to the procedure that
  693. is stored in it.}
  694. { yes but p^.left^.symtableentry can be nil
  695. for example on @self !! }
  696. { symtableentry can be also invalid, if left is no tree node }
  697. if (p^.left^.treetype=loadn) and
  698. assigned(p^.left^.symtableentry) and
  699. (p^.left^.symtableentry^.typ=varsym) and
  700. (Pvarsym(p^.left^.symtableentry)^.definition^.deftype=
  701. procvardef) then
  702. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
  703. newreference(p^.left^.location.reference),
  704. p^.location.register)))
  705. else
  706. begin
  707. exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
  708. newreference(p^.left^.location.reference),R_A0)));
  709. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
  710. R_A0,p^.location.register)));
  711. end;
  712. { for use of other segments }
  713. { if p^.left^.location.reference.segment<>R_DEFAULT_SEG then
  714. p^.location.segment:=p^.left^.location.reference.segment;
  715. }
  716. del_reference(p^.left^.location.reference);
  717. end;
  718. { register a6 used as scratch }
  719. procedure seconddoubleaddr(var p : ptree);
  720. begin
  721. secondpass(p^.left);
  722. p^.location.loc:=LOC_REGISTER;
  723. del_reference(p^.left^.location.reference);
  724. p^.location.register:=getregister32;
  725. exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
  726. newreference(p^.left^.location.reference),R_A0)));
  727. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
  728. R_A0,p^.location.register)));
  729. end;
  730. procedure secondnot(var p : ptree);
  731. const
  732. flagsinvers : array[F_E..F_BE] of tresflags =
  733. (F_NE,F_E,F_LE,F_GE,F_L,F_G,F_NC,F_C,
  734. F_A,F_AE,F_B,F_BE);
  735. var
  736. hl : plabel;
  737. begin
  738. if (p^.resulttype^.deftype=orddef) and
  739. (porddef(p^.resulttype)^.typ=bool8bit) then
  740. begin
  741. case p^.location.loc of
  742. LOC_JUMP : begin
  743. hl:=truelabel;
  744. truelabel:=falselabel;
  745. falselabel:=hl;
  746. secondpass(p^.left);
  747. maketojumpbool(p^.left);
  748. hl:=truelabel;
  749. truelabel:=falselabel;
  750. falselabel:=hl;
  751. end;
  752. LOC_FLAGS : begin
  753. secondpass(p^.left);
  754. p^.location.resflags:=flagsinvers[p^.left^.location.resflags];
  755. end;
  756. LOC_REGISTER : begin
  757. secondpass(p^.left);
  758. p^.location.register:=p^.left^.location.register;
  759. exprasmlist^.concat(new(pai68k,op_const_reg(A_EOR,S_B,1,p^.location.register)));
  760. end;
  761. LOC_CREGISTER : begin
  762. secondpass(p^.left);
  763. p^.location.loc:=LOC_REGISTER;
  764. p^.location.register:=getregister32;
  765. emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,
  766. p^.location.register);
  767. exprasmlist^.concat(new(pai68k,op_const_reg(A_EOR,S_B,1,p^.location.register)));
  768. end;
  769. LOC_REFERENCE,LOC_MEM : begin
  770. secondpass(p^.left);
  771. del_reference(p^.left^.location.reference);
  772. p^.location.loc:=LOC_REGISTER;
  773. p^.location.register:=getregister32;
  774. if p^.left^.location.loc=LOC_CREGISTER then
  775. emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,
  776. p^.location.register)
  777. else
  778. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,
  779. newreference(p^.left^.location.reference),
  780. p^.location.register)));
  781. exprasmlist^.concat(new(pai68k,op_const_reg(A_EOR,S_B,1,p^.location.register)));
  782. end;
  783. end;
  784. end
  785. else
  786. begin
  787. secondpass(p^.left);
  788. p^.location.loc:=LOC_REGISTER;
  789. case p^.left^.location.loc of
  790. LOC_REGISTER : begin
  791. p^.location.register:=p^.left^.location.register;
  792. exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register)));
  793. end;
  794. LOC_CREGISTER : begin
  795. p^.location.register:=getregister32;
  796. emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
  797. p^.location.register);
  798. exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register)));
  799. end;
  800. LOC_REFERENCE,LOC_MEM :
  801. begin
  802. del_reference(p^.left^.location.reference);
  803. p^.location.register:=getregister32;
  804. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
  805. newreference(p^.left^.location.reference),
  806. p^.location.register)));
  807. exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register)));
  808. end;
  809. end;
  810. {if p^.left^.location.loc=loc_register then
  811. p^.location.register:=p^.left^.location.register
  812. else
  813. begin
  814. del_locref(p^.left^.location);
  815. p^.location.register:=getregister32;
  816. exprasmlist^.concat(new(pai68k,op_loc_reg(A_MOV,S_L,
  817. p^.left^.location,
  818. p^.location.register)));
  819. end;
  820. exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register)));}
  821. end;
  822. end;
  823. procedure secondnothing(var p : ptree);
  824. begin
  825. end;
  826. procedure secondassignment(var p : ptree);
  827. var
  828. opsize : topsize;
  829. withresult : boolean;
  830. otlabel,hlabel,oflabel : plabel;
  831. hregister : tregister;
  832. loc : tloc;
  833. begin
  834. otlabel:=truelabel;
  835. oflabel:=falselabel;
  836. getlabel(truelabel);
  837. getlabel(falselabel);
  838. withresult:=false;
  839. { calculate left sides }
  840. secondpass(p^.left);
  841. case p^.left^.location.loc of
  842. LOC_REFERENCE : begin
  843. { in case left operator uses too many registers }
  844. { but to few are free then LEA }
  845. if (p^.left^.location.reference.base<>R_NO) and
  846. (p^.left^.location.reference.index<>R_NO) and
  847. (usablereg32<p^.right^.registers32) then
  848. begin
  849. del_reference(p^.left^.location.reference);
  850. hregister:=getaddressreg;
  851. exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(
  852. p^.left^.location.reference),
  853. hregister)));
  854. clear_reference(p^.left^.location.reference);
  855. p^.left^.location.reference.base:=hregister;
  856. p^.left^.location.reference.index:=R_NO;
  857. end;
  858. loc:=LOC_REFERENCE;
  859. end;
  860. LOC_CREGISTER : loc:=LOC_CREGISTER;
  861. else
  862. begin
  863. Message(cg_e_illegal_expression);
  864. exit;
  865. end;
  866. end;
  867. { lets try to optimize this (PM) }
  868. { define a dest_loc that is the location }
  869. { and a ptree to verify that it is the right }
  870. { place to insert it }
  871. {$ifdef test_dest_loc}
  872. if (aktexprlevel<4) then
  873. begin
  874. dest_loc_known:=true;
  875. dest_loc:=p^.left^.location;
  876. dest_loc_tree:=p^.right;
  877. end;
  878. {$endif test_dest_loc}
  879. if (p^.right^.treetype=realconstn) then
  880. begin
  881. if p^.left^.resulttype^.deftype=floatdef then
  882. begin
  883. case pfloatdef(p^.left^.resulttype)^.typ of
  884. s32real : p^.right^.realtyp:=ait_real_32bit;
  885. s64real : p^.right^.realtyp:=ait_real_64bit;
  886. s80real : p^.right^.realtyp:=ait_real_extended;
  887. { what about f32bit and s64bit }
  888. end;
  889. end;
  890. end;
  891. secondpass(p^.right);
  892. {$ifdef test_dest_loc}
  893. dest_loc_known:=false;
  894. if in_dest_loc then
  895. begin
  896. truelabel:=otlabel;
  897. falselabel:=oflabel;
  898. in_dest_loc:=false;
  899. exit;
  900. end;
  901. {$endif test_dest_loc}
  902. if p^.left^.resulttype^.deftype=stringdef then
  903. begin
  904. { we do not need destination anymore }
  905. del_reference(p^.left^.location.reference);
  906. { only source if withresult is set }
  907. if not(withresult) then
  908. del_reference(p^.right^.location.reference);
  909. loadstring(p);
  910. ungetiftemp(p^.right^.location.reference);
  911. end
  912. else case p^.right^.location.loc of
  913. LOC_REFERENCE,
  914. LOC_MEM : begin
  915. { handle ordinal constants trimmed }
  916. if (p^.right^.treetype in [ordconstn,fixconstn]) or
  917. (loc=LOC_CREGISTER) then
  918. begin
  919. case p^.left^.resulttype^.size of
  920. 1 : opsize:=S_B;
  921. 2 : opsize:=S_W;
  922. 4 : opsize:=S_L;
  923. end;
  924. if loc=LOC_CREGISTER then
  925. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,
  926. newreference(p^.right^.location.reference),
  927. p^.left^.location.register)))
  928. else
  929. exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,opsize,
  930. p^.right^.location.reference.offset,
  931. newreference(p^.left^.location.reference))));
  932. {exprasmlist^.concat(new(pai68k,op_const_loc(A_MOV,opsize,
  933. p^.right^.location.reference.offset,
  934. p^.left^.location)));}
  935. end
  936. else
  937. begin
  938. concatcopy(p^.right^.location.reference,
  939. p^.left^.location.reference,p^.left^.resulttype^.size,
  940. withresult);
  941. ungetiftemp(p^.right^.location.reference);
  942. end;
  943. end;
  944. LOC_REGISTER,
  945. LOC_CREGISTER : begin
  946. case p^.right^.resulttype^.size of
  947. 1 : opsize:=S_B;
  948. 2 : opsize:=S_W;
  949. 4 : opsize:=S_L;
  950. end;
  951. { simplified with op_reg_loc }
  952. if loc=LOC_CREGISTER then
  953. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,opsize,
  954. p^.right^.location.register,
  955. p^.left^.location.register)))
  956. else
  957. exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,opsize,
  958. p^.right^.location.register,
  959. newreference(p^.left^.location.reference))));
  960. {exprasmlist^.concat(new(pai68k,op_reg_loc(A_MOV,opsize,
  961. p^.right^.location.register,
  962. p^.left^.location))); }
  963. end;
  964. LOC_FPU : begin
  965. if loc<>LOC_REFERENCE then
  966. internalerror(10010)
  967. else
  968. floatstore(pfloatdef(p^.left^.resulttype)^.typ,
  969. p^.right^.location,p^.left^.location.reference);
  970. end;
  971. LOC_JUMP : begin
  972. getlabel(hlabel);
  973. emitl(A_LABEL,truelabel);
  974. if loc=LOC_CREGISTER then
  975. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,
  976. 1,p^.left^.location.register)))
  977. else
  978. exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,
  979. 1,newreference(p^.left^.location.reference))));
  980. {exprasmlist^.concat(new(pai68k,op_const_loc(A_MOV,S_B,
  981. 1,p^.left^.location)));}
  982. emitl(A_JMP,hlabel);
  983. emitl(A_LABEL,falselabel);
  984. if loc=LOC_CREGISTER then
  985. exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_B,
  986. p^.left^.location.register)))
  987. else
  988. exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,
  989. 0,newreference(p^.left^.location.reference))));
  990. emitl(A_LABEL,hlabel);
  991. end;
  992. LOC_FLAGS : begin
  993. if loc=LOC_CREGISTER then
  994. begin
  995. exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.right^.location.resflags],S_B,
  996. p^.left^.location.register)));
  997. exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_B,p^.left^.location.register)));
  998. end
  999. else
  1000. begin
  1001. exprasmlist^.concat(new(pai68k,op_ref(flag_2_set[p^.right^.location.resflags],S_B,
  1002. newreference(p^.left^.location.reference))));
  1003. exprasmlist^.concat(new(pai68k,op_ref(A_NEG,S_B,newreference(p^.left^.location.reference))));
  1004. end;
  1005. end;
  1006. end;
  1007. truelabel:=otlabel;
  1008. falselabel:=oflabel;
  1009. end;
  1010. procedure secondderef(var p : ptree);
  1011. var
  1012. hr : tregister;
  1013. begin
  1014. secondpass(p^.left);
  1015. clear_reference(p^.location.reference);
  1016. case p^.left^.location.loc of
  1017. LOC_REGISTER : Begin
  1018. hr := getaddressreg;
  1019. emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
  1020. p^.location.reference.base:=hr;
  1021. ungetregister(p^.left^.location.register);
  1022. end;
  1023. LOC_CREGISTER : begin
  1024. { ... and reserve one for the pointer }
  1025. hr:=getaddressreg;
  1026. emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
  1027. p^.location.reference.base:=hr;
  1028. { LOC_REGISTER indicates that this is a
  1029. variable register which should not be freed. }
  1030. { ungetregister(p^.left^.location.register); }
  1031. end;
  1032. else
  1033. begin
  1034. { free register }
  1035. del_reference(p^.left^.location.reference);
  1036. { ...and reserve one for the pointer }
  1037. hr:=getaddressreg;
  1038. exprasmlist^.concat(new(pai68k,op_ref_reg(
  1039. A_MOVE,S_L,newreference(p^.left^.location.reference),
  1040. hr)));
  1041. p^.location.reference.base:=hr;
  1042. end;
  1043. end;
  1044. end;
  1045. { used D0, D1 as scratch (ok) }
  1046. { arrays ... }
  1047. { Sets up the array and string }
  1048. { references . }
  1049. procedure secondvecn(var p : ptree);
  1050. var
  1051. pushed : boolean;
  1052. ind : tregister;
  1053. _p : ptree;
  1054. procedure calc_emit_mul;
  1055. var
  1056. l1,l2 : longint;
  1057. begin
  1058. l1:=p^.resulttype^.size;
  1059. case l1 of
  1060. 1 : p^.location.reference.scalefactor:=l1;
  1061. 2 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,ind)));
  1062. 4 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,2,ind)));
  1063. 8 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,3,ind)));
  1064. else
  1065. begin
  1066. if ispowerof2(l1,l2) then
  1067. exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,l2,ind)))
  1068. else
  1069. begin
  1070. { use normal MC68000 signed multiply }
  1071. if (l1 >= -32768) and (l1 <= 32767) then
  1072. exprasmlist^.concat(new(pai68k,op_const_reg(A_MULS,S_W,l1,ind)))
  1073. else
  1074. { use long MC68020 long multiply }
  1075. if (aktoptprocessor
  1076. = MC68020) then
  1077. exprasmlist^.concat(new(pai68k,op_const_reg(A_MULS,S_L,l1,ind)))
  1078. else
  1079. { MC68000 long multiply }
  1080. begin
  1081. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,l1,R_D0)));
  1082. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,ind,R_D1)));
  1083. emitcall('LONGMUL',true);
  1084. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,ind)));
  1085. end;
  1086. end;
  1087. end; { else case }
  1088. end; { end case }
  1089. end; { calc_emit_mul }
  1090. var
  1091. extraoffset : longint;
  1092. t : ptree;
  1093. hp : preference;
  1094. tai:pai68k;
  1095. reg: tregister;
  1096. begin
  1097. secondpass(p^.left);
  1098. { RESULT IS IN p^.location.reference }
  1099. set_location(p^.location,p^.left^.location);
  1100. { offset can only differ from 0 if arraydef }
  1101. if p^.left^.resulttype^.deftype=arraydef then
  1102. dec(p^.location.reference.offset,
  1103. p^.resulttype^.size*
  1104. parraydef(p^.left^.resulttype)^.lowrange);
  1105. if p^.right^.treetype=ordconstn then
  1106. begin
  1107. { offset can only differ from 0 if arraydef }
  1108. if (p^.left^.resulttype^.deftype=arraydef) then
  1109. begin
  1110. if not(is_open_array(p^.left^.resulttype)) then
  1111. begin
  1112. if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or
  1113. (p^.right^.value<parraydef(p^.left^.resulttype)^.lowrange) then
  1114. Message(parser_e_range_check_error);
  1115. dec(p^.left^.location.reference.offset,
  1116. p^.resulttype^.size*parraydef(p^.left^.resulttype)^.lowrange);
  1117. end
  1118. else
  1119. begin
  1120. { range checking for open arrays }
  1121. end;
  1122. end;
  1123. inc(p^.left^.location.reference.offset,
  1124. p^.right^.value*p^.resulttype^.size);
  1125. p^.left^.resulttype:=p^.resulttype;
  1126. disposetree(p^.right);
  1127. _p:=p^.left;
  1128. putnode(p);
  1129. p:=_p;
  1130. end
  1131. else
  1132. begin
  1133. { quick hack, to overcome Delphi 2 }
  1134. if (cs_maxoptimieren in aktswitches) and
  1135. (p^.left^.resulttype^.deftype=arraydef) then
  1136. begin
  1137. extraoffset:=0;
  1138. if (p^.right^.treetype=addn) then
  1139. begin
  1140. if p^.right^.right^.treetype=ordconstn then
  1141. begin
  1142. extraoffset:=p^.right^.right^.value;
  1143. t:=p^.right^.left;
  1144. putnode(p^.right);
  1145. putnode(p^.right^.right);
  1146. p^.right:=t
  1147. end
  1148. else if p^.right^.left^.treetype=ordconstn then
  1149. begin
  1150. extraoffset:=p^.right^.left^.value;
  1151. t:=p^.right^.right;
  1152. putnode(p^.right);
  1153. putnode(p^.right^.left);
  1154. p^.right:=t
  1155. end;
  1156. end
  1157. else if (p^.right^.treetype=subn) then
  1158. begin
  1159. if p^.right^.right^.treetype=ordconstn then
  1160. begin
  1161. extraoffset:=p^.right^.right^.value;
  1162. t:=p^.right^.left;
  1163. putnode(p^.right);
  1164. putnode(p^.right^.right);
  1165. p^.right:=t
  1166. end
  1167. else if p^.right^.left^.treetype=ordconstn then
  1168. begin
  1169. extraoffset:=p^.right^.left^.value;
  1170. t:=p^.right^.right;
  1171. putnode(p^.right);
  1172. putnode(p^.right^.left);
  1173. p^.right:=t
  1174. end;
  1175. end;
  1176. inc(p^.location.reference.offset,
  1177. p^.resulttype^.size*extraoffset);
  1178. end;
  1179. { calculate from left to right }
  1180. if (p^.location.loc<>LOC_REFERENCE) and
  1181. (p^.location.loc<>LOC_MEM) then
  1182. Message(cg_e_illegal_expression);
  1183. pushed:=maybe_push(p^.right^.registers32,p);
  1184. secondpass(p^.right);
  1185. if pushed then restore(p);
  1186. case p^.right^.location.loc of
  1187. LOC_REGISTER : begin
  1188. ind:=p^.right^.location.register;
  1189. case p^.right^.resulttype^.size of
  1190. 1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
  1191. $ff,ind)));
  1192. 2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
  1193. $ffff,ind)));
  1194. end;
  1195. end;
  1196. LOC_CREGISTER : begin
  1197. ind:=getregister32;
  1198. emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,ind);
  1199. case p^.right^.resulttype^.size of
  1200. 1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
  1201. $ff,ind)));
  1202. 2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
  1203. $ffff,ind)));
  1204. end;
  1205. end;
  1206. LOC_FLAGS:
  1207. begin
  1208. ind:=getregister32;
  1209. exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.right^.location.resflags],S_B,ind)));
  1210. exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ff,ind)));
  1211. end
  1212. else { else outer case }
  1213. begin
  1214. del_reference(p^.right^.location.reference);
  1215. ind:=getregister32;
  1216. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
  1217. newreference(p^.right^.location.reference),ind)));
  1218. {Booleans are stored in an 8 bit memory location, so
  1219. the use of MOVL is not correct.}
  1220. case p^.right^.resulttype^.size of
  1221. 1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
  1222. $ff,ind)));
  1223. 2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
  1224. $ffff,ind)));
  1225. end; { end case }
  1226. end; { end else begin }
  1227. end;
  1228. { produce possible range check code: }
  1229. if cs_rangechecking in aktswitches then
  1230. begin
  1231. if p^.left^.resulttype^.deftype=arraydef then
  1232. begin
  1233. new(hp);
  1234. reset_reference(hp^);
  1235. parraydef(p^.left^.resulttype)^.genrangecheck;
  1236. hp^.symbol:=stringdup('R_'+tostr(parraydef(p^.left^.resulttype)^.rangenr));
  1237. emit_bounds_check(hp^,ind);
  1238. end;
  1239. end;
  1240. { ------------------------ HANDLE INDEXING ----------------------- }
  1241. { In Motorola 680x0 mode, displacement can only be of 64K max. }
  1242. { Therefore instead of doing a direct displacement, we must first }
  1243. { load the new address into an address register. Therefore the }
  1244. { symbol is not used. }
  1245. if assigned(p^.location.reference.symbol) then
  1246. begin
  1247. if p^.location.reference.base <> R_NO then
  1248. Message(cg_f_secondvecn_base_defined_twice);
  1249. p^.location.reference.base:=getaddressreg;
  1250. exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_LEA,S_L,newcsymbol(p^.location.reference.symbol^,0),
  1251. p^.location.reference.base)));
  1252. stringdispose(p^.location.reference.symbol);
  1253. end;
  1254. if (p^.location.reference.index=R_NO) then
  1255. begin
  1256. p^.location.reference.index:=ind;
  1257. calc_emit_mul;
  1258. { here we must check for the offset }
  1259. { and if out of bounds for the motorola }
  1260. { eg: out of signed d8 then reload index }
  1261. { with correct value. }
  1262. if p^.location.reference.offset > 127 then
  1263. begin
  1264. exprasmlist^.concat(new(pai68k,op_const_reg(A_ADD,S_L,p^.location.reference.offset,ind)));
  1265. p^.location.reference.offset := 0;
  1266. end
  1267. else
  1268. if p^.location.reference.offset < -128 then
  1269. begin
  1270. exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,S_L,-p^.location.reference.offset,ind)));
  1271. p^.location.reference.offset := 0;
  1272. end;
  1273. end
  1274. else
  1275. begin
  1276. if p^.location.reference.base=R_NO then
  1277. begin
  1278. case p^.location.reference.scalefactor of
  1279. 2 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,p^.location.reference.index)));
  1280. 4 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,2,p^.location.reference.index)));
  1281. 8 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,3,p^.location.reference.index)));
  1282. end;
  1283. calc_emit_mul;
  1284. { we must use address register to put index in base }
  1285. { compare with cgi386.pas }
  1286. reg := getaddressreg;
  1287. p^.location.reference.base := reg;
  1288. emit_reg_reg(A_MOVE,S_L,p^.location.reference.index,reg);
  1289. ungetregister(p^.location.reference.index);
  1290. p^.location.reference.index:=ind;
  1291. end
  1292. else
  1293. begin
  1294. reg := getaddressreg;
  1295. exprasmlist^.concat(new(pai68k,op_ref_reg(
  1296. A_LEA,S_L,newreference(p^.location.reference),
  1297. reg)));
  1298. ungetregister(p^.location.reference.base);
  1299. { the symbol offset is loaded, }
  1300. { so release the symbol name and set symbol }
  1301. { to nil }
  1302. stringdispose(p^.location.reference.symbol);
  1303. p^.location.reference.offset:=0;
  1304. calc_emit_mul;
  1305. p^.location.reference.base:=reg;
  1306. ungetregister32(p^.location.reference.index);
  1307. p^.location.reference.index:=ind;
  1308. end;
  1309. end;
  1310. end;
  1311. end;
  1312. { *************** Converting Types **************** }
  1313. { produces if necessary rangecheckcode }
  1314. procedure maybe_rangechecking(p : ptree;p2,p1 : pdef);
  1315. var
  1316. hp : preference;
  1317. hregister : tregister;
  1318. neglabel,poslabel : plabel;
  1319. begin
  1320. { convert from p2 to p1 }
  1321. { range check from enums is not made yet !!}
  1322. { and its probably not easy }
  1323. if (p1^.deftype<>orddef) or (p2^.deftype<>orddef) then
  1324. exit;
  1325. { range checking is different for u32bit }
  1326. { lets try to generate it allways }
  1327. if (cs_rangechecking in aktswitches) and
  1328. { with $R+ explicit type conversations in TP aren't range checked! }
  1329. (not(p^.explizit) or not(cs_tp_compatible in aktswitches)) and
  1330. ((porddef(p1)^.low>porddef(p2)^.low) or
  1331. (porddef(p1)^.high<porddef(p2)^.high) or
  1332. (porddef(p1)^.typ=u32bit) or
  1333. (porddef(p2)^.typ=u32bit)) then
  1334. begin
  1335. porddef(p1)^.genrangecheck;
  1336. if porddef(p2)^.typ=u8bit then
  1337. begin
  1338. if (p^.location.loc=LOC_REGISTER) or
  1339. (p^.location.loc=LOC_CREGISTER) then
  1340. begin
  1341. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,p^.location.register,R_D6)));
  1342. exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$FF,R_D6)));
  1343. end
  1344. else
  1345. begin
  1346. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.location.reference),R_D6)));
  1347. exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$FF,R_D6)));
  1348. end;
  1349. hregister:=R_D6;
  1350. end
  1351. else if porddef(p2)^.typ=s8bit then
  1352. begin
  1353. if (p^.location.loc=LOC_REGISTER) or
  1354. (p^.location.loc=LOC_CREGISTER) then
  1355. begin
  1356. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,p^.location.register,R_D6)));
  1357. { byte to long }
  1358. if aktoptprocessor = MC68020 then
  1359. exprasmlist^.concat(new(pai68k,op_reg(A_EXTB,S_L,R_D6)))
  1360. else
  1361. begin
  1362. exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_W,R_D6)));
  1363. exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,R_D6)));
  1364. end;
  1365. end
  1366. else
  1367. begin
  1368. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.location.reference),R_D6)));
  1369. { byte to long }
  1370. if aktoptprocessor = MC68020 then
  1371. exprasmlist^.concat(new(pai68k,op_reg(A_EXTB,S_L,R_D6)))
  1372. else
  1373. begin
  1374. exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_W,R_D6)));
  1375. exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,R_D6)));
  1376. end;
  1377. end; { end outermost else }
  1378. hregister:=R_D6;
  1379. end
  1380. { rangechecking for u32bit ?? !!!!!!}
  1381. { lets try }
  1382. else if (porddef(p2)^.typ=s32bit) or (porddef(p2)^.typ=u32bit) then
  1383. begin
  1384. if (p^.location.loc=LOC_REGISTER) or
  1385. (p^.location.loc=LOC_CREGISTER) then
  1386. hregister:=p^.location.register
  1387. else
  1388. begin
  1389. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),R_D6)));
  1390. hregister:=R_D6;
  1391. end;
  1392. end
  1393. { rangechecking for u32bit ?? !!!!!!}
  1394. else if porddef(p2)^.typ=u16bit then
  1395. begin
  1396. if (p^.location.loc=LOC_REGISTER) or
  1397. (p^.location.loc=LOC_CREGISTER) then
  1398. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,p^.location.register,R_D6)))
  1399. else
  1400. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),R_D6)));
  1401. { unisgned extend }
  1402. exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$FFFF,R_D6)));
  1403. hregister:=R_D6;
  1404. end
  1405. else if porddef(p2)^.typ=s16bit then
  1406. begin
  1407. if (p^.location.loc=LOC_REGISTER) or
  1408. (p^.location.loc=LOC_CREGISTER) then
  1409. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,p^.location.register,R_D6)))
  1410. else
  1411. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),R_D6)));
  1412. { sign extend }
  1413. exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,R_D6)));
  1414. hregister:=R_D6;
  1415. end
  1416. else internalerror(6);
  1417. new(hp);
  1418. reset_reference(hp^);
  1419. hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr));
  1420. if porddef(p1)^.low>porddef(p1)^.high then
  1421. begin
  1422. getlabel(neglabel);
  1423. getlabel(poslabel);
  1424. exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,hregister)));
  1425. emitl(A_BLT,neglabel);
  1426. end;
  1427. emit_bounds_check(hp^,hregister);
  1428. if porddef(p1)^.low>porddef(p1)^.high then
  1429. begin
  1430. new(hp);
  1431. reset_reference(hp^);
  1432. hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr+1));
  1433. emitl(A_JMP,poslabel);
  1434. emitl(A_LABEL,neglabel);
  1435. emit_bounds_check(hp^,hregister);
  1436. emitl(A_LABEL,poslabel);
  1437. end;
  1438. end;
  1439. end;
  1440. type
  1441. tsecondconvproc = procedure(p,hp : ptree;convtyp : tconverttype);
  1442. procedure second_nothing(p,hp : ptree;convtyp : tconverttype);
  1443. begin
  1444. end;
  1445. procedure second_only_rangecheck(p,hp : ptree;convtyp : tconverttype);
  1446. begin
  1447. maybe_rangechecking(p,hp^.resulttype,p^.resulttype);
  1448. end;
  1449. procedure second_bigger(p,hp : ptree;convtyp : tconverttype);
  1450. var
  1451. hregister : tregister;
  1452. opsize : topsize;
  1453. op : tasmop;
  1454. is_register : boolean;
  1455. begin
  1456. is_register:=p^.left^.location.loc=LOC_REGISTER;
  1457. if not(is_register) and (p^.left^.location.loc<>LOC_CREGISTER) then
  1458. begin
  1459. del_reference(p^.left^.location.reference);
  1460. { we can do this here as we need no temp inside second_bigger }
  1461. ungetiftemp(p^.left^.location.reference);
  1462. end;
  1463. { this is wrong !!!
  1464. gives me movl (%eax),%eax
  1465. for the length(string !!!
  1466. use only for constant values }
  1467. {Constanst cannot be loaded into registers using MOVZX!}
  1468. if (p^.left^.location.loc<>LOC_MEM) or (not p^.left^.location.reference.isintvalue) then
  1469. case convtyp of
  1470. tc_u8bit_2_s32bit,
  1471. tc_u8bit_2_u32bit,
  1472. tc_s8bit_2_u32bit,
  1473. tc_s8bit_2_s16bit,
  1474. tc_s8bit_2_s32bit,
  1475. tc_u8bit_2_u16bit,
  1476. tc_s8bit_2_u16bit,
  1477. tc_u8bit_2_s16bit: begin
  1478. if is_register then
  1479. hregister := p^.left^.location.register
  1480. else
  1481. hregister := getregister32;
  1482. if is_register then
  1483. emit_reg_reg(A_MOVE,S_B,p^.left^.location.register, hregister)
  1484. else
  1485. begin
  1486. if p^.left^.location.loc = LOC_CREGISTER then
  1487. emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,hregister)
  1488. else
  1489. exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE,S_B,
  1490. newreference(P^.left^.location.reference), hregister)));
  1491. end;
  1492. case convtyp of
  1493. tc_u8bit_2_s32bit,
  1494. tc_u8bit_2_u32bit:
  1495. exprasmlist^.concat(new(pai68k, op_const_reg(
  1496. A_AND,S_L,$FF,hregister)));
  1497. tc_s8bit_2_u32bit,
  1498. tc_s8bit_2_s32bit:
  1499. begin
  1500. if aktoptprocessor = MC68020 then
  1501. exprasmlist^.concat(new(pai68k,op_reg
  1502. (A_EXTB,S_L,hregister)))
  1503. else { else if aktoptprocessor }
  1504. begin
  1505. { byte to word }
  1506. exprasmlist^.concat(new(pai68k,op_reg
  1507. (A_EXT,S_W,hregister)));
  1508. { word to long }
  1509. exprasmlist^.concat(new(pai68k,op_reg
  1510. (A_EXT,S_L,hregister)));
  1511. end;
  1512. end;
  1513. tc_s8bit_2_u16bit,
  1514. tc_u8bit_2_s16bit,
  1515. tc_u8bit_2_u16bit:
  1516. exprasmlist^.concat(new(pai68k, op_const_reg(
  1517. A_AND,S_W,$FF,hregister)));
  1518. tc_s8bit_2_s16bit:
  1519. exprasmlist^.concat(new(pai68k, op_reg(
  1520. A_EXT, S_W, hregister)));
  1521. end; { inner case }
  1522. end;
  1523. tc_u16bit_2_u32bit,
  1524. tc_u16bit_2_s32bit,
  1525. tc_s16bit_2_u32bit,
  1526. tc_s16bit_2_s32bit: begin
  1527. if is_register then
  1528. hregister := p^.left^.location.register
  1529. else
  1530. hregister := getregister32;
  1531. if is_register then
  1532. emit_reg_reg(A_MOVE,S_W,p^.left^.location.register, hregister)
  1533. else
  1534. begin
  1535. if p^.left^.location.loc = LOC_CREGISTER then
  1536. emit_reg_reg(A_MOVE,S_W,p^.left^.location.register,hregister)
  1537. else
  1538. exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE,S_W,
  1539. newreference(P^.left^.location.reference), hregister)));
  1540. end;
  1541. if (convtyp = tc_u16bit_2_s32bit) or
  1542. (convtyp = tc_u16bit_2_u32bit) then
  1543. exprasmlist^.concat(new(pai68k, op_const_reg(
  1544. A_AND, S_L, $ffff, hregister)))
  1545. else { tc_s16bit_2_s32bit }
  1546. { tc_s16bit_2_u32bit }
  1547. exprasmlist^.concat(new(pai68k, op_reg(A_EXT,S_L,
  1548. hregister)));
  1549. end;
  1550. end { end case }
  1551. else
  1552. begin
  1553. case convtyp of
  1554. tc_u8bit_2_s32bit,
  1555. tc_s8bit_2_s32bit,
  1556. tc_u16bit_2_s32bit,
  1557. tc_s16bit_2_s32bit,
  1558. tc_u8bit_2_u32bit,
  1559. tc_s8bit_2_u32bit,
  1560. tc_u16bit_2_u32bit,
  1561. tc_s16bit_2_u32bit:
  1562. begin
  1563. hregister:=getregister32;
  1564. op:=A_MOVE;
  1565. opsize:=S_L;
  1566. end;
  1567. tc_s8bit_2_u16bit,
  1568. tc_s8bit_2_s16bit,
  1569. tc_u8bit_2_s16bit,
  1570. tc_u8bit_2_u16bit:
  1571. begin
  1572. hregister:=getregister32;
  1573. op:=A_MOVE;
  1574. opsize:=S_W;
  1575. end;
  1576. end;
  1577. if is_register then
  1578. begin
  1579. emit_reg_reg(op,opsize,p^.left^.location.register,hregister);
  1580. end
  1581. else
  1582. begin
  1583. if p^.left^.location.loc=LOC_CREGISTER then
  1584. emit_reg_reg(op,opsize,p^.left^.location.register,hregister)
  1585. else exprasmlist^.concat(new(pai68k,op_ref_reg(op,opsize,
  1586. newreference(p^.left^.location.reference),hregister)));
  1587. end;
  1588. end; { end elseif }
  1589. p^.location.loc:=LOC_REGISTER;
  1590. p^.location.register:=hregister;
  1591. maybe_rangechecking(p,p^.left^.resulttype,p^.resulttype);
  1592. end;
  1593. procedure second_string_string(p,hp : ptree;convtyp : tconverttype);
  1594. var
  1595. pushedregs : tpushed;
  1596. begin
  1597. stringdispose(p^.location.reference.symbol);
  1598. gettempofsizereference(p^.resulttype^.size,p^.location.reference);
  1599. del_reference(p^.left^.location.reference);
  1600. copystring(p^.location.reference,p^.left^.location.reference,pstringdef(p^.resulttype)^.len);
  1601. ungetiftemp(p^.left^.location.reference);
  1602. end;
  1603. procedure second_cstring_charpointer(p,hp : ptree;convtyp : tconverttype);
  1604. begin
  1605. p^.location.loc:=LOC_REGISTER;
  1606. p^.location.register:=getregister32;
  1607. inc(p^.left^.location.reference.offset);
  1608. exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
  1609. R_A0)));
  1610. emit_reg_reg(A_MOVE, S_L, R_A0, p^.location.register);
  1611. end;
  1612. procedure second_cchar_charpointer(p,hp : ptree;convtyp : tconverttype);
  1613. begin
  1614. {!!!!}
  1615. p^.location.loc:=LOC_REGISTER;
  1616. p^.location.register:=getregister32;
  1617. inc(p^.left^.location.reference.offset);
  1618. exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
  1619. R_A0)));
  1620. emit_reg_reg(A_MOVE, S_L, R_A0, p^.location.register);
  1621. end;
  1622. procedure second_string_chararray(p,hp : ptree;convtyp : tconverttype);
  1623. begin
  1624. inc(p^.location.reference.offset);
  1625. end;
  1626. procedure second_array_to_pointer(p,hp : ptree;convtyp : tconverttype);
  1627. begin
  1628. del_reference(p^.left^.location.reference);
  1629. p^.location.loc:=LOC_REGISTER;
  1630. p^.location.register:=getregister32;
  1631. exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
  1632. R_A0)));
  1633. emit_reg_reg(A_MOVE,S_L,R_A0, P^.location.register);
  1634. end;
  1635. procedure second_pointer_to_array(p,hp : ptree;convtyp : tconverttype);
  1636. var
  1637. reg: tregister;
  1638. begin
  1639. p^.location.loc:=LOC_REFERENCE;
  1640. clear_reference(p^.location.reference);
  1641. { here, after doing some arithmetic on the pointer }
  1642. { we put it back in an address register }
  1643. if p^.left^.location.loc=LOC_REGISTER then
  1644. begin
  1645. reg := getaddressreg;
  1646. { move the pointer in a data register back into }
  1647. { an address register. }
  1648. emit_reg_reg(A_MOVE, S_L, p^.left^.location.register,reg);
  1649. p^.location.reference.base:=reg;
  1650. ungetregister32(p^.left^.location.register);
  1651. end
  1652. else
  1653. begin
  1654. if p^.left^.location.loc=LOC_CREGISTER then
  1655. begin
  1656. p^.location.reference.base:=getaddressreg;
  1657. emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
  1658. p^.location.reference.base);
  1659. end
  1660. else
  1661. begin
  1662. del_reference(p^.left^.location.reference);
  1663. p^.location.reference.base:=getaddressreg;
  1664. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
  1665. p^.location.reference.base)));
  1666. end;
  1667. end;
  1668. end;
  1669. { generates the code for the type conversion from an array of char }
  1670. { to a string }
  1671. procedure second_chararray_to_string(p,hp : ptree;convtyp : tconverttype);
  1672. var
  1673. l : longint;
  1674. begin
  1675. { this is a type conversion which copies the data, so we can't }
  1676. { return a reference }
  1677. p^.location.loc:=LOC_MEM;
  1678. { first get the memory for the string }
  1679. stringdispose(p^.location.reference.symbol);
  1680. gettempofsizereference(256,p^.location.reference);
  1681. { calc the length of the array }
  1682. l:=parraydef(p^.left^.resulttype)^.highrange-
  1683. parraydef(p^.left^.resulttype)^.lowrange+1;
  1684. if l>255 then
  1685. Message(sym_e_type_mismatch);
  1686. { write the length }
  1687. exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,l,
  1688. newreference(p^.location.reference))));
  1689. { copy to first char of string }
  1690. inc(p^.location.reference.offset);
  1691. { generates the copy code }
  1692. { and we need the source never }
  1693. concatcopy(p^.left^.location.reference,p^.location.reference,l,true);
  1694. { correct the string location }
  1695. dec(p^.location.reference.offset);
  1696. end;
  1697. (* procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype);
  1698. begin
  1699. stringdispose(p^.location.reference.symbol);
  1700. gettempofsizereference(256,p^.location.reference);
  1701. { is it a char const ? }
  1702. if p^.left^.treetype=ordconstn then
  1703. exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_W,p^.left^.value*256+1,newreference(p^.location.reference))))
  1704. else
  1705. begin
  1706. { not so elegant (goes better with extra register }
  1707. { Here the conversion is done in one shot }
  1708. { i.e we convert to a string with a single word which }
  1709. { will be stored, the length followed by the char }
  1710. { This is of course, endian specific. }
  1711. if (p^.left^.location.loc=LOC_REGISTER) or
  1712. (p^.left^.location.loc=LOC_CREGISTER) then
  1713. begin
  1714. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,p^.left^.location.register,R_D6)));
  1715. exprasmlist^.concat(new(pai68k, op_const_reg(A_AND, S_W, $FF, R_D6)));
  1716. ungetregister32(p^.left^.location.register);
  1717. end
  1718. else
  1719. begin
  1720. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.left^.location.reference),R_D6)));
  1721. exprasmlist^.concat(new(pai68k, op_const_reg(A_AND, S_W, $FF, R_D6)));
  1722. del_reference(p^.left^.location.reference);
  1723. end;
  1724. if (aktoptprocessor = MC68020) then
  1725. { alignment is not a problem on the 68020 and higher processors }
  1726. Begin
  1727. { add length of string to word }
  1728. exprasmlist^.concat(new(pai68k,op_const_reg(A_OR,S_W,$0100,R_D6)));
  1729. { put back into mem ... }
  1730. exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_W,R_D6,newreference(p^.location.reference))));
  1731. end
  1732. else
  1733. Begin
  1734. { alignment can cause problems }
  1735. { add length of string to ref }
  1736. exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,1,newreference(p^.location.reference))));
  1737. if abs(p^.location.reference.offset) >= 1 then
  1738. Begin
  1739. { temporarily decrease offset }
  1740. Inc(p^.location.reference.offset);
  1741. exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_B,R_D6,newreference(p^.location.reference))));
  1742. Dec(p^.location.reference.offset);
  1743. { restore offset }
  1744. end
  1745. else
  1746. Begin
  1747. Comment(V_Debug,'SecondChar2String() internal error.');
  1748. internalerror(34);
  1749. end;
  1750. end;
  1751. end;
  1752. end;*)
  1753. procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype);
  1754. begin
  1755. stringdispose(p^.location.reference.symbol);
  1756. gettempofsizereference(256,p^.location.reference);
  1757. { call loadstring with correct left and right }
  1758. p^.right:=p^.left;
  1759. p^.left:=p;
  1760. loadstring(p);
  1761. p^.left:=nil; { reset left tree, which is empty }
  1762. end;
  1763. procedure second_int_real(p,hp : ptree;convtyp : tconverttype);
  1764. var
  1765. r : preference;
  1766. reg:tregister;
  1767. begin
  1768. emitloadord2reg(p^.left^.location, porddef(p^.left^.resulttype), R_D6, true);
  1769. ungetiftemp(p^.left^.location.reference);
  1770. if porddef(p^.left^.resulttype)^.typ=u32bit then
  1771. push_int(0);
  1772. emit_reg_reg(A_MOVE, S_L, R_D6, R_SPPUSH);
  1773. new(r);
  1774. reset_reference(r^);
  1775. r^.base := R_SP;
  1776. { no emulation }
  1777. { for u32bit a solution would be to push $0 and to load a
  1778. + comp
  1779. + if porddef(p^.left^.resulttype)^.typ=u32bit then
  1780. + exprasmlist^.concat(new(pai386,op_ref(A_FILD,S_IQ,r)))
  1781. + else}
  1782. p^.location.loc := LOC_FPU;
  1783. { get floating point register. }
  1784. if (cs_fp_emulation in aktswitches) then
  1785. begin
  1786. p^.location.fpureg := getregister32;
  1787. exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE, S_L, r, R_D0)));
  1788. emitcall('LONG2SINGLE',true);
  1789. emit_reg_reg(A_MOVE,S_L,R_D0,p^.location.fpureg);
  1790. end
  1791. else
  1792. begin
  1793. p^.location.fpureg := getfloatreg;
  1794. exprasmlist^.concat(new(pai68k, op_ref_reg(A_FMOVE, S_L, r, p^.location.fpureg)))
  1795. end;
  1796. if porddef(p^.left^.resulttype)^.typ=u32bit then
  1797. exprasmlist^.concat(new(pai68k,op_const_reg(A_ADD,S_L,8,R_SP)))
  1798. else
  1799. { restore the stack to the previous address }
  1800. exprasmlist^.concat(new(pai68k, op_const_reg(A_ADDQ, S_L, 4, R_SP)));
  1801. end;
  1802. procedure second_real_fix(p,hp : ptree;convtyp : tconverttype);
  1803. var
  1804. {hs : string;}
  1805. rreg : tregister;
  1806. ref : treference;
  1807. begin
  1808. rreg:=getregister32;
  1809. { Are we in a LOC_FPU, if not then use scratch registers }
  1810. { instead of allocating reserved registers. }
  1811. if (p^.left^.location.loc<>LOC_FPU) then
  1812. begin
  1813. if (cs_fp_emulation in aktswitches) then
  1814. begin
  1815. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),R_D0)));
  1816. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,65536,R_D1)));
  1817. emitcall('LONGMUL',true);
  1818. emit_reg_reg(A_MOVE,S_L,R_D0,rreg);
  1819. end
  1820. else
  1821. begin
  1822. exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,S_L,newreference(p^.left^.location.reference),R_FP0)));
  1823. exprasmlist^.concat(new(pai68k,op_const_reg(A_FMUL,S_L,65536,R_FP0)));
  1824. exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE,S_L,R_FP0,rreg)));
  1825. end;
  1826. end
  1827. else
  1828. begin
  1829. if (cs_fp_emulation in aktswitches) then
  1830. begin
  1831. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0)));
  1832. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,65536,R_D1)));
  1833. emitcall('LONGMUL',true);
  1834. emit_reg_reg(A_MOVE,S_L,R_D0,rreg);
  1835. end
  1836. else
  1837. begin
  1838. exprasmlist^.concat(new(pai68k,op_const_reg(A_FMUL,S_L,65536,p^.left^.location.fpureg)));
  1839. exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE,S_L,p^.left^.location.fpureg,rreg)));
  1840. end;
  1841. end;
  1842. p^.location.loc:=LOC_REGISTER;
  1843. p^.location.register:=rreg;
  1844. end;
  1845. procedure second_float_float(p,hp : ptree;convtyp : tconverttype);
  1846. begin
  1847. case p^.left^.location.loc of
  1848. LOC_FPU : begin
  1849. { reload }
  1850. p^.location.loc := LOC_FPU;
  1851. p^.location.fpureg := p^.left^.location.fpureg;
  1852. end;
  1853. LOC_MEM,
  1854. LOC_REFERENCE : floatload(pfloatdef(p^.left^.resulttype)^.typ,
  1855. p^.left^.location.reference,p^.location);
  1856. end;
  1857. { ALREADY HANDLED BY FLOATLOAD }
  1858. { p^.location.loc:=LOC_FPU; }
  1859. end;
  1860. procedure second_fix_real(p,hp : ptree;convtyp : tconverttype);
  1861. var
  1862. startreg : tregister;
  1863. hl : plabel;
  1864. r : treference;
  1865. reg1: tregister;
  1866. hl1,hl2,hl3,hl4,hl5,hl6,hl7,hl8,hl9: plabel;
  1867. begin
  1868. if (p^.left^.location.loc=LOC_REGISTER) or
  1869. (p^.left^.location.loc=LOC_CREGISTER) then
  1870. begin
  1871. startreg:=p^.left^.location.register;
  1872. ungetregister(startreg);
  1873. { move d0,d0 is removed by emit_reg_reg }
  1874. emit_reg_reg(A_MOVE,S_L,startreg,R_D0);
  1875. end
  1876. else
  1877. begin
  1878. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(
  1879. p^.left^.location.reference),R_D0)));
  1880. del_reference(p^.left^.location.reference);
  1881. startreg:=R_NO;
  1882. end;
  1883. reg1 := getregister32;
  1884. { Motorola 68000 equivalent of CDQ }
  1885. { we choose d1:d0 pair for quad word }
  1886. exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,R_D0)));
  1887. getlabel(hl1);
  1888. emitl(A_BPL,hl1);
  1889. { we copy all bits (-ve number) }
  1890. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,$ffffffff,R_D1)));
  1891. getlabel(hl2);
  1892. emitl(A_BRA,hl2);
  1893. emitl(A_LABEL,hl1);
  1894. exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,R_D0)));
  1895. emitl(A_LABEL,hl2);
  1896. { end CDQ }
  1897. exprasmlist^.concat(new(pai68k,op_reg_reg(A_EOR,S_L,R_D1,R_D0)));
  1898. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,reg1)));
  1899. getlabel(hl3);
  1900. emitl(A_BEQ,hl3);
  1901. { Motorola 68000 equivalent of RCL }
  1902. getlabel(hl4);
  1903. emitl(A_BCC,hl4);
  1904. exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,reg1)));
  1905. exprasmlist^.concat(new(pai68k,op_const_reg(A_OR,S_L,1,reg1)));
  1906. getlabel(hl5);
  1907. emitl(A_BRA,hl5);
  1908. emitl(A_LABEL,hl4);
  1909. exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,reg1)));
  1910. emitl(A_LABEL,hl5);
  1911. { end RCL }
  1912. { Motorola 68000 equivalent of BSR }
  1913. { save register }
  1914. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,R_D6)));
  1915. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,31,R_D0)));
  1916. getlabel(hl6);
  1917. emitl(A_LABEL,hl6);
  1918. exprasmlist^.concat(new(pai68k,op_reg_reg(A_BTST,S_L,R_D0,R_D1)));
  1919. getlabel(hl7);
  1920. emitl(A_BNE,hl7);
  1921. exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_B,1,R_D0)));
  1922. emitl(A_BPL,hl6);
  1923. { restore register }
  1924. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D6,R_D0)));
  1925. emitl(A_LABEL,hl7);
  1926. { end BSR }
  1927. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,32,R_D6)));
  1928. exprasmlist^.concat(new(pai68k,op_reg_reg(A_SUB,S_B,R_D1,R_D6)));
  1929. exprasmlist^.concat(new(pai68k,op_reg_reg(A_LSL,S_L,R_D6,R_D0)));
  1930. exprasmlist^.concat(new(pai68k,op_const_reg(A_ADD,S_W,1007,R_D1)));
  1931. exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,5,R_D1)));
  1932. { Motorola 68000 equivalent of SHLD }
  1933. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,11,R_D6)));
  1934. { save register }
  1935. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D1,R_A0)));
  1936. getlabel(hl8);
  1937. emitl(A_LABEL,hl8);
  1938. exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,R_D1)));
  1939. exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,reg1)));
  1940. exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_B,1,R_D6)));
  1941. emitl(A_BNE,hl8);
  1942. { restore register }
  1943. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A0,R_D1)));
  1944. { end Motorola equivalent of SHLD }
  1945. { Motorola 68000 equivalent of SHLD }
  1946. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,20,R_D6)));
  1947. { save register }
  1948. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,R_A0)));
  1949. getlabel(hl9);
  1950. emitl(A_LABEL,hl9);
  1951. exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,R_D0)));
  1952. exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,reg1)));
  1953. exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_B,1,R_D6)));
  1954. emitl(A_BNE,hl9);
  1955. { restore register }
  1956. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A0,R_D0)));
  1957. { end Motorola equivalent of SHLD }
  1958. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,20,R_D6)));
  1959. exprasmlist^.concat(new(pai68k,op_reg_reg(A_SUB,S_L,R_D6,R_D0)));
  1960. emitl(A_LABEL, hl3);
  1961. { create temp values and put on stack }
  1962. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,reg1,R_SPPUSH)));
  1963. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,R_SPPUSH)));
  1964. reset_reference(r);
  1965. r.base:=R_SP;
  1966. if (cs_fp_emulation in aktswitches) then
  1967. begin
  1968. p^.location.loc:=LOC_FPU;
  1969. p^.location.fpureg := getregister32;
  1970. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(r),
  1971. p^.left^.location.fpureg)))
  1972. end
  1973. else
  1974. begin
  1975. p^.location.loc:=LOC_FPU;
  1976. p^.location.fpureg := getfloatreg;
  1977. exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,S_L,newreference(r),
  1978. p^.left^.location.fpureg)))
  1979. end;
  1980. { clear temporary space }
  1981. exprasmlist^.concat(new(pai68k,op_const_reg(A_ADDQ,S_L,8,R_SP)));
  1982. ungetregister32(reg1);
  1983. { Alreadu handled above... }
  1984. { p^.location.loc:=LOC_FPU; }
  1985. end;
  1986. procedure second_int_fix(p,hp : ptree;convtyp : tconverttype);
  1987. var
  1988. {hs : string;}
  1989. hregister : tregister;
  1990. begin
  1991. if (p^.left^.location.loc=LOC_REGISTER) then
  1992. hregister:=p^.left^.location.register
  1993. else if (p^.left^.location.loc=LOC_CREGISTER) then
  1994. hregister:=getregister32
  1995. else
  1996. begin
  1997. del_reference(p^.left^.location.reference);
  1998. hregister:=getregister32;
  1999. case porddef(p^.left^.resulttype)^.typ of
  2000. s8bit : begin
  2001. exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE,S_B,
  2002. newreference(p^.left^.location.reference),hregister)));
  2003. if aktoptprocessor = MC68020 then
  2004. exprasmlist^.concat(new(pai68k, op_reg(A_EXTB,S_L,hregister)))
  2005. else
  2006. begin
  2007. exprasmlist^.concat(new(pai68k, op_reg(A_EXT,S_W,hregister)));
  2008. exprasmlist^.concat(new(pai68k, op_reg(A_EXT,S_L,hregister)));
  2009. end;
  2010. end;
  2011. u8bit : begin
  2012. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.left^.location.reference),
  2013. hregister)));
  2014. exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ff,hregister)));
  2015. end;
  2016. s16bit :begin
  2017. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.left^.location.reference),
  2018. hregister)));
  2019. exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,hregister)));
  2020. end;
  2021. u16bit : begin
  2022. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.left^.location.reference),
  2023. hregister)));
  2024. exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ffff,hregister)));
  2025. end;
  2026. s32bit,u32bit : exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
  2027. hregister)));
  2028. {!!!! u32bit }
  2029. end;
  2030. end;
  2031. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVEQ,S_L,16,R_D1)));
  2032. exprasmlist^.concat(new(pai68k,op_reg_reg(A_LSL,S_L,R_D1,hregister)));
  2033. p^.location.loc:=LOC_REGISTER;
  2034. p^.location.register:=hregister;
  2035. end;
  2036. procedure second_smaller(p,hp : ptree;convtyp : tconverttype);
  2037. var
  2038. hregister,destregister : tregister;
  2039. {opsize : topsize;}
  2040. ref : boolean;
  2041. hpp : preference;
  2042. begin
  2043. { !!!!!!!! Rangechecking }
  2044. ref:=false;
  2045. { problems with enums !! }
  2046. if (cs_rangechecking in aktswitches) and
  2047. { with $R+ explicit type conversations in TP aren't range checked! }
  2048. (not(p^.explizit) or not(cs_tp_compatible in aktswitches)) and
  2049. (p^.resulttype^.deftype=orddef) and
  2050. (hp^.resulttype^.deftype=orddef) and
  2051. ((porddef(p^.resulttype)^.low>porddef(hp^.resulttype)^.low) or
  2052. (porddef(p^.resulttype)^.high<porddef(hp^.resulttype)^.high)) then
  2053. begin
  2054. porddef(p^.resulttype)^.genrangecheck;
  2055. if porddef(hp^.resulttype)^.typ=s32bit then
  2056. begin
  2057. if (p^.location.loc=LOC_REGISTER) or
  2058. (p^.location.loc=LOC_CREGISTER) then
  2059. hregister:=p^.location.register
  2060. else
  2061. begin
  2062. hregister:=getregister32;
  2063. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),hregister)));
  2064. end;
  2065. end
  2066. { rangechecking for u32bit ?? !!!!!!}
  2067. else if porddef(hp^.resulttype)^.typ=u16bit then
  2068. begin
  2069. hregister:=getregister32;
  2070. if (p^.location.loc=LOC_REGISTER) or
  2071. (p^.location.loc=LOC_CREGISTER) then
  2072. begin
  2073. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,p^.location.register,hregister)));
  2074. end
  2075. else
  2076. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),hregister)));
  2077. { clear unused bits i.e unsigned extend}
  2078. exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L, $FFFF, hregister)));
  2079. end
  2080. else if porddef(hp^.resulttype)^.typ=s16bit then
  2081. begin
  2082. hregister:=getregister32;
  2083. if (p^.location.loc=LOC_REGISTER) or
  2084. (p^.location.loc=LOC_CREGISTER) then
  2085. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,p^.location.register,hregister)))
  2086. else
  2087. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),hregister)));
  2088. { sign extend }
  2089. exprasmlist^.concat(new(pai68k,op_reg(A_EXT, S_L, hregister)));
  2090. end
  2091. else internalerror(6);
  2092. new(hpp);
  2093. reset_reference(hpp^);
  2094. hpp^.symbol:=stringdup('R_'+tostr(porddef(p^.resulttype)^.rangenr));
  2095. emit_bounds_check(hpp^, hregister);
  2096. p^.location.loc:=LOC_REGISTER;
  2097. p^.location.register:=hregister;
  2098. exit;
  2099. end;
  2100. if (p^.left^.location.loc=LOC_REGISTER) or
  2101. (p^.left^.location.loc=LOC_CREGISTER) then
  2102. begin
  2103. { handled by secondpas by called routine ??? }
  2104. { p^.location.loc:=p^.left^.location.loc; }
  2105. p^.location.register:=p^.left^.location.register;
  2106. end;
  2107. end;
  2108. procedure second_proc_to_procvar(p,hp : ptree;convtyp : tconverttype);far;
  2109. begin
  2110. secondpass(hp);
  2111. p^.location.loc:=LOC_REGISTER;
  2112. del_reference(hp^.location.reference);
  2113. p^.location.register:=getregister32;
  2114. exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
  2115. newreference(hp^.location.reference),R_A0)));
  2116. emit_reg_reg(A_MOVE, S_L, R_A0, P^.location.register);
  2117. end;
  2118. procedure second_bool_to_int(p,hp : ptree;convtyp : tconverttype);
  2119. var
  2120. oldtruelabel,oldfalselabel,hlabel : plabel;
  2121. begin
  2122. oldtruelabel:=truelabel;
  2123. oldfalselabel:=falselabel;
  2124. getlabel(truelabel);
  2125. getlabel(falselabel);
  2126. secondpass(hp);
  2127. p^.location.loc:=LOC_REGISTER;
  2128. del_reference(hp^.location.reference);
  2129. p^.location.register:=getregister32;
  2130. case hp^.location.loc of
  2131. LOC_MEM,LOC_REFERENCE :
  2132. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,
  2133. newreference(hp^.location.reference),p^.location.register)));
  2134. LOC_REGISTER,LOC_CREGISTER :
  2135. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,
  2136. hp^.location.register,p^.location.register)));
  2137. LOC_FLAGS:
  2138. begin
  2139. exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[hp^.location.resflags],S_NO,
  2140. p^.location.register)))
  2141. end;
  2142. LOC_JUMP:
  2143. begin
  2144. getlabel(hlabel);
  2145. emitl(A_LABEL,truelabel);
  2146. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,
  2147. 1,p^.location.register)));
  2148. emitl(A_JMP,hlabel);
  2149. emitl(A_LABEL,falselabel);
  2150. exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_B,p^.location.register)));
  2151. emitl(A_LABEL,hlabel);
  2152. end;
  2153. else
  2154. internalerror(10060);
  2155. end;
  2156. truelabel:=oldtruelabel;
  2157. falselabel:=oldfalselabel;
  2158. end;
  2159. procedure second_int_to_bool(p,hp : ptree;convtyp : tconverttype);
  2160. begin
  2161. { !!!!!!!!!!!!!!! }
  2162. end;
  2163. procedure secondtypeconv(var p : ptree);
  2164. const
  2165. secondconvert : array[tc_u8bit_2_s32bit..tc_cchar_charpointer] of
  2166. tsecondconvproc = (second_bigger,second_only_rangecheck,
  2167. second_bigger,second_bigger,second_bigger,
  2168. second_smaller,second_smaller,
  2169. second_smaller,second_string_string,
  2170. second_cstring_charpointer,second_string_chararray,
  2171. second_array_to_pointer,second_pointer_to_array,
  2172. second_char_to_string,second_bigger,
  2173. second_bigger,second_bigger,
  2174. second_smaller,second_smaller,
  2175. second_smaller,second_smaller,
  2176. second_bigger,second_smaller,
  2177. second_only_rangecheck,second_bigger,
  2178. second_bigger,second_bigger,
  2179. second_bigger,second_only_rangecheck,
  2180. second_smaller,second_smaller,
  2181. second_smaller,second_smaller,
  2182. second_int_real,second_real_fix,
  2183. second_fix_real,second_int_fix,second_float_float,
  2184. second_bool_to_int,second_int_to_bool,
  2185. second_chararray_to_string,
  2186. second_proc_to_procvar,
  2187. { is constant char to pchar, is done by firstpass }
  2188. second_nothing);
  2189. begin
  2190. { this isn't good coding, I think tc_bool_2_u8bit, shouldn't be }
  2191. { type conversion (FK) }
  2192. { this is necessary, because second_bool_byte, have to change }
  2193. { true- and false label before calling secondpass }
  2194. if p^.convtyp<>tc_bool_2_int then
  2195. begin
  2196. secondpass(p^.left);
  2197. set_location(p^.location,p^.left^.location);
  2198. end;
  2199. if p^.convtyp<>tc_equal then
  2200. {the second argument only is for maybe_range_checking !}
  2201. secondconvert[p^.convtyp](p,p^.left,p^.convtyp)
  2202. end;
  2203. { save the size of pushed parameter }
  2204. var
  2205. pushedparasize : longint;
  2206. procedure secondcallparan(var p : ptree;defcoll : pdefcoll;
  2207. push_from_left_to_right : boolean);
  2208. var
  2209. size : longint;
  2210. stackref : treference;
  2211. otlabel,hlabel,oflabel : plabel;
  2212. { temporary variables: }
  2213. tempdeftype : tdeftype;
  2214. tempreference : treference;
  2215. r : preference;
  2216. s : topsize;
  2217. op : tasmop;
  2218. begin
  2219. { push from left to right if specified }
  2220. if push_from_left_to_right and assigned(p^.right) then
  2221. secondcallparan(p^.right,defcoll^.next,push_from_left_to_right);
  2222. otlabel:=truelabel;
  2223. oflabel:=falselabel;
  2224. getlabel(truelabel);
  2225. getlabel(falselabel);
  2226. secondpass(p^.left);
  2227. { in codegen.handleread.. defcoll^.data is set to nil }
  2228. if assigned(defcoll^.data) and
  2229. (defcoll^.data^.deftype=formaldef) then
  2230. begin
  2231. { allow @var }
  2232. if p^.left^.treetype=addrn then
  2233. begin
  2234. { allways a register }
  2235. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_SPPUSH)));
  2236. ungetregister32(p^.left^.location.register);
  2237. end
  2238. else
  2239. begin
  2240. if (p^.left^.location.loc<>LOC_REFERENCE) and
  2241. (p^.left^.location.loc<>LOC_MEM) then
  2242. Message(sym_e_type_mismatch)
  2243. else
  2244. begin
  2245. emitpushreferenceaddr(p^.left^.location.reference);
  2246. del_reference(p^.left^.location.reference);
  2247. end;
  2248. end;
  2249. inc(pushedparasize,4);
  2250. end
  2251. { handle call by reference parameter }
  2252. else if (defcoll^.paratyp=vs_var) then
  2253. begin
  2254. if (p^.left^.location.loc<>LOC_REFERENCE) then
  2255. Message(cg_e_var_must_be_reference);
  2256. { open array ? }
  2257. { defcoll^.data can be nil for read/write }
  2258. if assigned(defcoll^.data) and
  2259. is_open_array(defcoll^.data) then
  2260. begin
  2261. { push high }
  2262. if is_open_array(p^.left^.resulttype) then
  2263. begin
  2264. new(r);
  2265. reset_reference(r^);
  2266. r^.base:=highframepointer;
  2267. r^.offset:=highoffset+4;
  2268. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_SPPUSH)));
  2269. end
  2270. else
  2271. push_int(parraydef(p^.left^.resulttype)^.highrange-
  2272. parraydef(p^.left^.resulttype)^.lowrange);
  2273. inc(pushedparasize,4);
  2274. end;
  2275. emitpushreferenceaddr(p^.left^.location.reference);
  2276. del_reference(p^.left^.location.reference);
  2277. inc(pushedparasize,4);
  2278. end
  2279. else
  2280. begin
  2281. tempdeftype:=p^.resulttype^.deftype;
  2282. if tempdeftype=filedef then
  2283. Message(cg_e_file_must_call_by_reference);
  2284. if (defcoll^.paratyp=vs_const) and
  2285. dont_copy_const_param(p^.resulttype) then
  2286. begin
  2287. emitpushreferenceaddr(p^.left^.location.reference);
  2288. del_reference(p^.left^.location.reference);
  2289. inc(pushedparasize,4);
  2290. end
  2291. else
  2292. case p^.left^.location.loc of
  2293. LOC_REGISTER,
  2294. LOC_CREGISTER : begin
  2295. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
  2296. p^.left^.location.register,R_SPPUSH)));
  2297. inc(pushedparasize,4);
  2298. ungetregister32(p^.left^.location.register);
  2299. end;
  2300. LOC_FPU : begin
  2301. size:=pfloatdef(p^.left^.resulttype)^.size;
  2302. inc(pushedparasize,size);
  2303. exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_L,size,R_SP)));
  2304. new(r);
  2305. reset_reference(r^);
  2306. r^.base:=R_SP;
  2307. s:=getfloatsize(pfloatdef(p^.left^.resulttype)^.typ);
  2308. if (cs_fp_emulation in aktswitches) then
  2309. begin
  2310. { when in emulation mode... }
  2311. { only single supported!!! }
  2312. exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,
  2313. p^.left^.location.fpureg,r)));
  2314. end
  2315. else
  2316. { convert back from extended to normal type }
  2317. exprasmlist^.concat(new(pai68k,op_reg_ref(A_FMOVE,s,
  2318. p^.left^.location.fpureg,r)));
  2319. end;
  2320. LOC_REFERENCE,LOC_MEM :
  2321. begin
  2322. tempreference:=p^.left^.location.reference;
  2323. del_reference(p^.left^.location.reference);
  2324. case p^.resulttype^.deftype of
  2325. orddef : begin
  2326. case porddef(p^.resulttype)^.typ of
  2327. s32bit,u32bit :
  2328. begin
  2329. emit_push_mem(tempreference);
  2330. inc(pushedparasize,4);
  2331. end;
  2332. s8bit,u8bit,uchar,bool8bit,s16bit,u16bit : begin
  2333. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,
  2334. newreference(tempreference),R_SPPUSH)));
  2335. inc(pushedparasize,2);
  2336. end;
  2337. end;
  2338. end;
  2339. floatdef : begin
  2340. case pfloatdef(p^.resulttype)^.typ of
  2341. f32bit,
  2342. s32real :
  2343. begin
  2344. emit_push_mem(tempreference);
  2345. inc(pushedparasize,4);
  2346. end;
  2347. s64real:
  2348. {s64bit }
  2349. begin
  2350. inc(tempreference.offset,4);
  2351. emit_push_mem(tempreference);
  2352. dec(tempreference.offset,4);
  2353. emit_push_mem(tempreference);
  2354. inc(pushedparasize,8);
  2355. end;
  2356. {$ifdef use48}
  2357. s48real : begin
  2358. end;
  2359. {$endif}
  2360. s80real : begin
  2361. Message(cg_f_extended_cg68k_not_supported);
  2362. { inc(tempreference.offset,6);
  2363. emit_push_mem(tempreference);
  2364. dec(tempreference.offset,4);
  2365. emit_push_mem(tempreference);
  2366. dec(tempreference.offset,2);
  2367. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,
  2368. newreference(tempreference),R_SPPUSH)));
  2369. inc(pushedparasize,extended_size);}
  2370. end;
  2371. end;
  2372. end;
  2373. pointerdef,procvardef,
  2374. enumdef,classrefdef: begin
  2375. emit_push_mem(tempreference);
  2376. inc(pushedparasize,4);
  2377. end;
  2378. arraydef,recorddef,stringdef,setdef,objectdef :
  2379. begin
  2380. if ((p^.resulttype^.deftype=setdef) and
  2381. (psetdef(p^.resulttype)^.settype=smallset)) then
  2382. begin
  2383. emit_push_mem(tempreference);
  2384. inc(pushedparasize,4);
  2385. end
  2386. else
  2387. begin
  2388. size:=p^.resulttype^.size;
  2389. { Alignment }
  2390. {
  2391. if (size>=4) and ((size and 3)<>0) then
  2392. inc(size,4-(size and 3))
  2393. else if (size>=2) and ((size and 1)<>0) then
  2394. inc(size,2-(size and 1))
  2395. else
  2396. if size=1 then size:=2;
  2397. }
  2398. { create stack space }
  2399. if (size > 0) and (size < 9) then
  2400. exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_L,size,R_SP)))
  2401. else
  2402. exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBA,
  2403. S_L,size,R_SP)));
  2404. inc(pushedparasize,size);
  2405. { create stack reference }
  2406. stackref.symbol := nil;
  2407. clear_reference(stackref);
  2408. stackref.base:=R_SP;
  2409. { produce copy }
  2410. if p^.resulttype^.deftype=stringdef then
  2411. begin
  2412. copystring(stackref,p^.left^.location.reference,
  2413. pstringdef(p^.resulttype)^.len);
  2414. end
  2415. else
  2416. begin
  2417. concatcopy(p^.left^.location.reference,
  2418. stackref,p^.resulttype^.size,true);
  2419. end;
  2420. end;
  2421. end;
  2422. else Message(cg_e_illegal_expression);
  2423. end;
  2424. end;
  2425. LOC_JUMP : begin
  2426. getlabel(hlabel);
  2427. inc(pushedparasize,2);
  2428. emitl(A_LABEL,truelabel);
  2429. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,1,R_SPPUSH)));
  2430. emitl(A_JMP,hlabel);
  2431. emitl(A_LABEL,falselabel);
  2432. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,0,R_SPPUSH)));
  2433. emitl(A_LABEL,hlabel);
  2434. end;
  2435. LOC_FLAGS : begin
  2436. exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.left^.location.resflags],S_B,
  2437. R_D0)));
  2438. exprasmlist^.concat(new(pai68k,op_reg(A_NEG, S_B, R_D0)));
  2439. exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_W,$ff, R_D0)));
  2440. inc(pushedparasize,2);
  2441. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,R_D0,R_SPPUSH)));
  2442. end;
  2443. end;
  2444. end;
  2445. truelabel:=otlabel;
  2446. falselabel:=oflabel;
  2447. { push from right to left }
  2448. if not push_from_left_to_right and assigned(p^.right) then
  2449. secondcallparan(p^.right,defcoll^.next,push_from_left_to_right);
  2450. end;
  2451. procedure secondcalln(var p : ptree);
  2452. var
  2453. unusedregisters : tregisterset;
  2454. pushed : tpushed;
  2455. funcretref : treference;
  2456. hregister : tregister;
  2457. oldpushedparasize : longint;
  2458. { true if a5 must be loaded again after the subroutine }
  2459. loada5 : boolean;
  2460. { true if a virtual method must be called directly }
  2461. no_virtual_call : boolean;
  2462. { true if we produce a con- or destrutor in a call }
  2463. is_con_or_destructor : boolean;
  2464. { true if a constructor is called again }
  2465. extended_new : boolean;
  2466. { adress returned from an I/O-error }
  2467. iolabel : plabel;
  2468. { lexlevel count }
  2469. i : longint;
  2470. { help reference pointer }
  2471. r : preference;
  2472. pp,params : ptree;
  2473. { temp register allocation }
  2474. reg: tregister;
  2475. { help reference pointer }
  2476. ref: preference;
  2477. label
  2478. dont_call;
  2479. begin
  2480. extended_new:=false;
  2481. iolabel:=nil;
  2482. loada5:=true;
  2483. no_virtual_call:=false;
  2484. unusedregisters:=unused;
  2485. if not assigned(p^.procdefinition) then
  2486. exit;
  2487. { only if no proc var }
  2488. if not(assigned(p^.right)) then
  2489. is_con_or_destructor:=((p^.procdefinition^.options and poconstructor)<>0)
  2490. or ((p^.procdefinition^.options and podestructor)<>0);
  2491. { proc variables destroy all registers }
  2492. if (p^.right=nil) and
  2493. { virtual methods too }
  2494. ((p^.procdefinition^.options and povirtualmethod)=0) then
  2495. begin
  2496. if ((p^.procdefinition^.options and poiocheck)<>0)
  2497. and (cs_iocheck in aktswitches) then
  2498. begin
  2499. getlabel(iolabel);
  2500. emitl(A_LABEL,iolabel);
  2501. end
  2502. else iolabel:=nil;
  2503. { save all used registers }
  2504. pushusedregisters(pushed,p^.procdefinition^.usedregisters);
  2505. { give used registers through }
  2506. usedinproc:=usedinproc or p^.procdefinition^.usedregisters;
  2507. end
  2508. else
  2509. begin
  2510. pushusedregisters(pushed,$ffff);
  2511. usedinproc:=$ffff;
  2512. { no IO check for methods and procedure variables }
  2513. iolabel:=nil;
  2514. end;
  2515. { generate the code for the parameter and push them }
  2516. oldpushedparasize:=pushedparasize;
  2517. pushedparasize:=0;
  2518. if (p^.resulttype<>pdef(voiddef)) and
  2519. ret_in_param(p^.resulttype) then
  2520. begin
  2521. funcretref.symbol:=nil;
  2522. {$ifdef test_dest_loc}
  2523. if dest_loc_known and (dest_loc_tree=p) and
  2524. (dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then
  2525. begin
  2526. funcretref:=dest_loc.reference;
  2527. if assigned(dest_loc.reference.symbol) then
  2528. funcretref.symbol:=stringdup(dest_loc.reference.symbol^);
  2529. in_dest_loc:=true;
  2530. end
  2531. else
  2532. {$endif test_dest_loc}
  2533. gettempofsizereference(p^.procdefinition^.retdef^.size,funcretref);
  2534. end;
  2535. if assigned(p^.left) then
  2536. begin
  2537. pushedparasize:=0;
  2538. { be found elsewhere }
  2539. if assigned(p^.right) then
  2540. secondcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1,
  2541. (p^.procdefinition^.options and poleftright)<>0)
  2542. else
  2543. secondcallparan(p^.left,p^.procdefinition^.para1,
  2544. (p^.procdefinition^.options and poleftright)<>0);
  2545. end;
  2546. params:=p^.left;
  2547. p^.left:=nil;
  2548. if ret_in_param(p^.resulttype) then
  2549. begin
  2550. emitpushreferenceaddr(funcretref);
  2551. inc(pushedparasize,4);
  2552. end;
  2553. { overloaded operator have no symtable }
  2554. if (p^.right=nil) then
  2555. begin
  2556. { push self }
  2557. if assigned(p^.symtable) and
  2558. (p^.symtable^.symtabletype=withsymtable) then
  2559. begin
  2560. { dirty trick to avoid the secondcall below }
  2561. p^.methodpointer:=genzeronode(callparan);
  2562. p^.methodpointer^.location.loc:=LOC_REGISTER;
  2563. p^.methodpointer^.location.register:=R_A5;
  2564. { make a reference }
  2565. new(r);
  2566. reset_reference(r^);
  2567. r^.offset:=p^.symtable^.datasize;
  2568. r^.base:=procinfo.framepointer;
  2569. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_A5)));
  2570. end;
  2571. { push self }
  2572. if assigned(p^.symtable) and
  2573. ((p^.symtable^.symtabletype=objectsymtable) or
  2574. (p^.symtable^.symtabletype=withsymtable)) then
  2575. begin
  2576. if assigned(p^.methodpointer) then
  2577. begin
  2578. case p^.methodpointer^.treetype of
  2579. typen : begin
  2580. { direct call to inherited method }
  2581. if (p^.procdefinition^.options and poabstractmethod)<>0 then
  2582. begin
  2583. Message(cg_e_cant_call_abstract_method);
  2584. goto dont_call;
  2585. end;
  2586. { generate no virtual call }
  2587. no_virtual_call:=true;
  2588. if (p^.symtableprocentry^.properties and sp_static)<>0 then
  2589. begin
  2590. { well lets put the VMT address directly into a5 }
  2591. { it is kind of dirty but that is the simplest }
  2592. { way to accept virtual static functions (PM) }
  2593. loada5:=true;
  2594. exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,
  2595. newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_A5)));
  2596. concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
  2597. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
  2598. end
  2599. else
  2600. { this is a member call, so A5 isn't modfied }
  2601. loada5:=false;
  2602. if not(is_con_or_destructor and
  2603. pobjectdef(p^.methodpointer^.resulttype)^.isclass and
  2604. assigned(aktprocsym) and
  2605. ((aktprocsym^.definition^.options and
  2606. (poconstructor or podestructor))<>0)) then
  2607. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
  2608. { if an inherited con- or destructor should be }
  2609. { called in a con- or destructor then a warning }
  2610. { will be made }
  2611. { con- and destructors need a pointer to the vmt }
  2612. if is_con_or_destructor and
  2613. ((pobjectdef(p^.methodpointer^.resulttype)^.options and oois_class)=0) and
  2614. assigned(aktprocsym) then
  2615. begin
  2616. if not ((aktprocsym^.definition^.options
  2617. and (poconstructor or podestructor))<>0) then
  2618. Message(cg_w_member_cd_call_from_method);
  2619. end;
  2620. { con- and destructors need a pointer to the vmt }
  2621. if is_con_or_destructor then
  2622. begin
  2623. { classes need the mem ! }
  2624. if ((pobjectdef(p^.methodpointer^.resulttype)^.options and
  2625. oois_class)=0) then
  2626. push_int(0)
  2627. else
  2628. begin
  2629. exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,
  2630. S_L,newcsymbol(pobjectdef(p^.methodpointer^.
  2631. resulttype)^.vmt_mangledname,0),R_SPPUSH)));
  2632. concat_external(pobjectdef(p^.methodpointer^.resulttype)^.
  2633. vmt_mangledname,EXT_NEAR);
  2634. end;
  2635. end;
  2636. end;
  2637. hnewn : begin
  2638. { extended syntax of new }
  2639. { A5 must be zero }
  2640. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,0,R_A5)));
  2641. emit_reg_reg(A_MOVE,S_L,R_A5, R_SPPUSH);
  2642. { insert the vmt }
  2643. exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,
  2644. newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_SPPUSH)));
  2645. concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
  2646. extended_new:=true;
  2647. end;
  2648. hdisposen : begin
  2649. secondpass(p^.methodpointer);
  2650. { destructor with extended syntax called from dispose }
  2651. { hdisposen always deliver LOC_REFRENZ }
  2652. exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
  2653. newreference(p^.methodpointer^.location.reference),R_A5)));
  2654. del_reference(p^.methodpointer^.location.reference);
  2655. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
  2656. exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,
  2657. newcsymbol(pobjectdef
  2658. (p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_SPPUSH)));
  2659. concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
  2660. end;
  2661. else
  2662. begin
  2663. { call to a instance member }
  2664. if (p^.symtable^.symtabletype<>withsymtable) then
  2665. begin
  2666. secondpass(p^.methodpointer);
  2667. case p^.methodpointer^.location.loc of
  2668. LOC_REGISTER :
  2669. begin
  2670. ungetregister32(p^.methodpointer^.location.register);
  2671. emit_reg_reg(A_MOVE,S_L,p^.methodpointer^.location.register,R_A5);
  2672. end;
  2673. else
  2674. begin
  2675. if (p^.methodpointer^.resulttype^.deftype=objectdef) and
  2676. pobjectdef(p^.methodpointer^.resulttype)^.isclass then
  2677. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
  2678. newreference(p^.methodpointer^.location.reference),R_A5)))
  2679. else
  2680. exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
  2681. newreference(p^.methodpointer^.location.reference),R_A5)));
  2682. del_reference(p^.methodpointer^.location.reference);
  2683. end;
  2684. end;
  2685. end;
  2686. { when calling a class method, we have
  2687. to load ESI with the VMT !
  2688. But that's wrong, if we call a class method via self
  2689. }
  2690. if ((p^.procdefinition^.options and poclassmethod)<>0)
  2691. and not(p^.methodpointer^.treetype=selfn) then
  2692. begin
  2693. { class method needs current VMT }
  2694. new(r);
  2695. reset_reference(r^);
  2696. r^.base:=R_A5;
  2697. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_A5)));
  2698. end;
  2699. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
  2700. if is_con_or_destructor then
  2701. begin
  2702. { classes don't get a VMT pointer pushed }
  2703. if (p^.methodpointer^.resulttype^.deftype=objectdef) and
  2704. not(pobjectdef(p^.methodpointer^.resulttype)^.isclass) then
  2705. begin
  2706. if ((p^.procdefinition^.options and poconstructor)<>0) then
  2707. begin
  2708. { it's no bad idea, to insert the VMT }
  2709. exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,
  2710. newcsymbol(pobjectdef(
  2711. p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_SPPUSH)));
  2712. concat_external(pobjectdef(
  2713. p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
  2714. end
  2715. { destructors haven't to dispose the instance, if this is }
  2716. { a direct call }
  2717. else
  2718. push_int(0);
  2719. end;
  2720. end;
  2721. end;
  2722. end;
  2723. end
  2724. else
  2725. begin
  2726. if ((p^.procdefinition^.options and poclassmethod)<>0) and
  2727. not(
  2728. assigned(aktprocsym) and
  2729. ((aktprocsym^.definition^.options and poclassmethod)<>0)
  2730. ) then
  2731. begin
  2732. { class method needs current VMT }
  2733. new(r);
  2734. reset_reference(r^);
  2735. r^.base:=R_A5;
  2736. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_A5)));
  2737. end
  2738. else
  2739. begin
  2740. { member call, A5 isn't modified }
  2741. loada5:=false;
  2742. end;
  2743. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
  2744. { but a con- or destructor here would probably almost }
  2745. { always be placed wrong }
  2746. if is_con_or_destructor then
  2747. begin
  2748. Message(cg_w_member_cd_call_from_method);
  2749. { not insert VMT pointer } { VMT-Zeiger nicht eintragen }
  2750. push_int(0);
  2751. end;
  2752. end;
  2753. end;
  2754. { push base pointer ?}
  2755. if (lexlevel>1) and assigned(pprocdef(p^.procdefinition)^.parast) and
  2756. ((p^.procdefinition^.parast^.symtablelevel)>2) then
  2757. begin
  2758. { if we call a nested function in a method, we must }
  2759. { push also SELF! }
  2760. { THAT'S NOT TRUE, we have to load ESI via frame pointer }
  2761. { access }
  2762. {
  2763. begin
  2764. loadesi:=false;
  2765. exprasmlist^.concat(new(pai68k,op_reg(A_PUSH,S_L,R_ESI)));
  2766. end;
  2767. }
  2768. if lexlevel=(p^.procdefinition^.parast^.symtablelevel) then
  2769. begin
  2770. new(r);
  2771. reset_reference(r^);
  2772. r^.offset:=procinfo.framepointer_offset;
  2773. r^.base:=procinfo.framepointer;
  2774. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_SPPUSH)))
  2775. end
  2776. { this is only true if the difference is one !!
  2777. but it cannot be more !! }
  2778. else if lexlevel=(p^.procdefinition^.parast^.symtablelevel)-1 then
  2779. begin
  2780. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,procinfo.framepointer,R_SPPUSH)))
  2781. end
  2782. else if lexlevel>(p^.procdefinition^.parast^.symtablelevel) then
  2783. begin
  2784. hregister:=getaddressreg;
  2785. new(r);
  2786. reset_reference(r^);
  2787. r^.offset:=procinfo.framepointer_offset;
  2788. r^.base:=procinfo.framepointer;
  2789. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,hregister)));
  2790. for i:=(p^.procdefinition^.parast^.symtablelevel) to lexlevel-1 do
  2791. begin
  2792. new(r);
  2793. reset_reference(r^);
  2794. {we should get the correct frame_pointer_offset at each level
  2795. how can we do this !!! }
  2796. r^.offset:=procinfo.framepointer_offset;
  2797. r^.base:=hregister;
  2798. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,hregister)));
  2799. end;
  2800. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,hregister,R_SPPUSH)));
  2801. ungetregister32(hregister);
  2802. end
  2803. else
  2804. internalerror(25000);
  2805. end;
  2806. { exported methods should be never called direct }
  2807. if (p^.procdefinition^.options and poexports)<>0 then
  2808. Message(cg_e_dont_call_exported_direct);
  2809. if ((p^.procdefinition^.options and povirtualmethod)<>0) and
  2810. not(no_virtual_call) then
  2811. begin
  2812. { static functions contain the vmt_address in ESI }
  2813. { also class methods }
  2814. if assigned(aktprocsym) then
  2815. begin
  2816. if ((aktprocsym^.properties and sp_static)<>0) or
  2817. ((aktprocsym^.definition^.options and poclassmethod)<>0) or
  2818. ((p^.procdefinition^.options and postaticmethod)<>0) or
  2819. { A5 is already loaded }
  2820. ((p^.procdefinition^.options and poclassmethod)<>0)then
  2821. begin
  2822. new(r);
  2823. reset_reference(r^);
  2824. r^.base:=R_a5;
  2825. end
  2826. else
  2827. begin
  2828. new(r);
  2829. reset_reference(r^);
  2830. r^.base:=R_a5;
  2831. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_a0)));
  2832. new(r);
  2833. reset_reference(r^);
  2834. r^.base:=R_a0;
  2835. end;
  2836. end
  2837. else
  2838. begin
  2839. new(r);
  2840. reset_reference(r^);
  2841. r^.base:=R_a5;
  2842. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_a0)));
  2843. new(r);
  2844. reset_reference(r^);
  2845. r^.base:=R_a0;
  2846. end;
  2847. if p^.procdefinition^.extnumber=-1 then
  2848. internalerror($Da);
  2849. r^.offset:=p^.procdefinition^.extnumber*4+12;
  2850. if (cs_rangechecking in aktswitches) then
  2851. begin
  2852. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,r^.base,R_SPPUSH)));
  2853. emitcall('CHECK_OBJECT',true);
  2854. end;
  2855. exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,r)));
  2856. end
  2857. else
  2858. emitcall(p^.procdefinition^.mangledname,
  2859. p^.symtableproc^.symtabletype=unitsymtable);
  2860. if ((p^.procdefinition^.options and poclearstack)<>0) then
  2861. begin
  2862. if (pushedparasize > 0) and (pushedparasize < 9) then
  2863. { restore the stack, to its initial value }
  2864. exprasmlist^.concat(new(pai68k,op_const_reg(A_ADDQ,S_L,pushedparasize,R_SP)))
  2865. else
  2866. { restore the stack, to its initial value }
  2867. exprasmlist^.concat(new(pai68k,op_const_reg(A_ADDA,S_L,pushedparasize,R_SP)));
  2868. end;
  2869. end
  2870. else
  2871. begin
  2872. secondpass(p^.right);
  2873. case p^.right^.location.loc of
  2874. LOC_REGISTER,
  2875. LOC_CREGISTER : begin
  2876. if p^.right^.location.register in [R_D0..R_D7] then
  2877. begin
  2878. reg := getaddressreg;
  2879. emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,reg);
  2880. new(ref);
  2881. reset_reference(ref^);
  2882. ref^.base := reg;
  2883. exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,ref)));
  2884. ungetregister(reg);
  2885. end
  2886. else
  2887. begin
  2888. new(ref);
  2889. reset_reference(ref^);
  2890. ref^.base := p^.right^.location.register;
  2891. exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,ref)));
  2892. end;
  2893. ungetregister32(p^.right^.location.register);
  2894. end
  2895. else
  2896. begin
  2897. if assigned(p^.right^.location.reference.symbol) then
  2898. { Here we have a symbolic name to the routine, so solve }
  2899. { problem by loading the address first, and then emitting }
  2900. { the call. }
  2901. begin
  2902. exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
  2903. newreference(p^.right^.location.reference),R_A1)));
  2904. new(ref);
  2905. reset_reference(ref^);
  2906. ref^.base := R_A1;
  2907. exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,newreference(ref^))));
  2908. end
  2909. else
  2910. exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,newreference(p^.right^.location.reference))));
  2911. del_reference(p^.right^.location.reference);
  2912. end;
  2913. end;
  2914. end;
  2915. dont_call:
  2916. pushedparasize:=oldpushedparasize;
  2917. unused:=unusedregisters;
  2918. { handle function results }
  2919. if p^.resulttype<>pdef(voiddef) then
  2920. begin
  2921. { a contructor could be a function with boolean result }
  2922. if (p^.right=nil) and
  2923. ((p^.procdefinition^.options and poconstructor)<>0) and
  2924. { quick'n'dirty check if it is a class or an object }
  2925. (p^.resulttype^.deftype=orddef) then
  2926. begin
  2927. p^.location.loc:=LOC_FLAGS;
  2928. p^.location.resflags:=F_NE;
  2929. if extended_new then
  2930. begin
  2931. {$ifdef test_dest_loc}
  2932. if dest_loc_known and (dest_loc_tree=p) then
  2933. mov_reg_to_dest(p,S_L,R_EAX)
  2934. else
  2935. {$endif test_dest_loc}
  2936. hregister:=getregister32;
  2937. emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
  2938. p^.location.register:=hregister;
  2939. end;
  2940. end
  2941. { structed results are easy to handle.... }
  2942. else if ret_in_param(p^.resulttype) then
  2943. begin
  2944. p^.location.loc:=LOC_MEM;
  2945. stringdispose(p^.location.reference.symbol);
  2946. p^.location.reference:=funcretref;
  2947. end
  2948. else
  2949. begin
  2950. if (p^.resulttype^.deftype=orddef) then
  2951. begin
  2952. p^.location.loc:=LOC_REGISTER;
  2953. case porddef(p^.resulttype)^.typ of
  2954. s32bit,u32bit :
  2955. begin
  2956. hregister:=getregister32;
  2957. emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
  2958. p^.location.register:=hregister;
  2959. end;
  2960. uchar,u8bit,bool8bit,s8bit :
  2961. begin
  2962. hregister:=getregister32;
  2963. emit_reg_reg(A_MOVE,S_B,R_D0,hregister);
  2964. p^.location.register:=hregister;
  2965. end;
  2966. s16bit,u16bit :
  2967. begin
  2968. hregister:=getregister32;
  2969. emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
  2970. p^.location.register:=hregister;
  2971. end;
  2972. else internalerror(7);
  2973. end
  2974. end
  2975. else if (p^.resulttype^.deftype=floatdef) then
  2976. case pfloatdef(p^.resulttype)^.typ of
  2977. f32bit :
  2978. begin
  2979. p^.location.loc:=LOC_REGISTER;
  2980. hregister:=getregister32;
  2981. emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
  2982. p^.location.register:=hregister;
  2983. end;
  2984. s32real,s64bit,s64real,s80real: begin
  2985. if cs_fp_emulation in aktswitches then
  2986. begin
  2987. p^.location.loc:=LOC_FPU;
  2988. hregister:=getregister32;
  2989. emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
  2990. p^.location.fpureg:=hregister;
  2991. end
  2992. else
  2993. begin
  2994. { TRUE FPU mode }
  2995. p^.location.loc:=LOC_FPU;
  2996. { on exit of function result in R_FP0 }
  2997. p^.location.fpureg:=R_FP0;
  2998. end;
  2999. end;
  3000. else
  3001. begin
  3002. p^.location.loc:=LOC_FPU;
  3003. p^.location.fpureg:=R_FP0;
  3004. end;
  3005. end {end case }
  3006. else
  3007. begin
  3008. p^.location.loc:=LOC_REGISTER;
  3009. hregister:=getregister32;
  3010. emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
  3011. p^.location.register:=hregister;
  3012. end;
  3013. end;
  3014. end;
  3015. { perhaps i/o check ? }
  3016. if iolabel<>nil then
  3017. begin
  3018. exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,newcsymbol(lab2str(iolabel),0),R_SPPUSH)));
  3019. { this was wrong, probably an error due to diff3
  3020. emitcall(p^.procdefinition^.mangledname);}
  3021. emitcall('IOCHECK',true);
  3022. end;
  3023. { restore registers }
  3024. popusedregisters(pushed);
  3025. { at last, restore instance pointer (SELF) }
  3026. if loada5 then
  3027. maybe_loada5;
  3028. pp:=params;
  3029. while assigned(pp) do
  3030. begin
  3031. if assigned(pp^.left) then
  3032. if (pp^.left^.location.loc=LOC_REFERENCE) or
  3033. (pp^.left^.location.loc=LOC_MEM) then
  3034. ungetiftemp(pp^.left^.location.reference);
  3035. pp:=pp^.right;
  3036. end;
  3037. disposetree(params);
  3038. end;
  3039. { reverts the parameter list }
  3040. var nb_para : integer;
  3041. function reversparameter(p : ptree) : ptree;
  3042. var
  3043. hp1,hp2 : ptree;
  3044. begin
  3045. hp1:=nil;
  3046. nb_para := 0;
  3047. while assigned(p) do
  3048. begin
  3049. { pull out }
  3050. hp2:=p;
  3051. p:=p^.right;
  3052. inc(nb_para);
  3053. { pull in }
  3054. hp2^.right:=hp1;
  3055. hp1:=hp2;
  3056. end;
  3057. reversparameter:=hp1;
  3058. end;
  3059. procedure secondloadvmt(var p : ptree);
  3060. begin
  3061. p^.location.loc:=LOC_REGISTER;
  3062. p^.location.register:=getregister32;
  3063. exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,
  3064. S_L,newcsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname,0),
  3065. p^.location.register)));
  3066. end;
  3067. procedure secondinline(var p : ptree);
  3068. const in2size:array[in_inc_byte..in_dec_dword] of Topsize=
  3069. (S_B,S_W,S_L,S_B,S_W,S_L);
  3070. in2instr:array[in_inc_byte..in_dec_dword] of Tasmop=
  3071. (A_ADDQ,A_ADDQ,A_ADDQ,A_SUBQ,A_SUBQ,A_SUBQ);
  3072. { tfloattype = (f32bit,s32real,s64real,s80real,s64bit); }
  3073. float_name: array[tfloattype] of string[8]=
  3074. { ('FIXED','SINGLE','REAL','EXTENDED','COMP','FIXED'); }
  3075. { Since we only support the REAL (SINGLE IEEE) FLOAT }
  3076. { type, here is what we do... }
  3077. ('FIXED','REAL','REAL','REAL','COMP','FIXED');
  3078. var
  3079. opsize: topsize;
  3080. asmop: tasmop;
  3081. aktfile : treference;
  3082. ft : tfiletype;
  3083. pushed : tpushed;
  3084. dummycoll : tdefcoll;
  3085. { produces code for READ(LN) and WRITE(LN) }
  3086. procedure handlereadwrite(doread,callwriteln : boolean);
  3087. procedure loadstream;
  3088. const io:array[0..1] of string[7]=('_OUTPUT','_INPUT');
  3089. var r : preference;
  3090. begin
  3091. new(r);
  3092. reset_reference(r^);
  3093. r^.symbol:=stringdup('U_'+upper(target_info.system_unit)+io[byte(doread)]);
  3094. if not (cs_compilesystem in aktswitches) then
  3095. concat_external(r^.symbol^,EXT_NEAR);
  3096. exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,r,R_A0)))
  3097. end;
  3098. var
  3099. node,hp : ptree;
  3100. typedtyp,pararesult : pdef;
  3101. doflush,has_length : boolean;
  3102. dummycoll : tdefcoll;
  3103. iolabel : plabel;
  3104. npara : longint;
  3105. begin
  3106. { I/O check }
  3107. if cs_iocheck in aktswitches then
  3108. begin
  3109. getlabel(iolabel);
  3110. emitl(A_LABEL,iolabel);
  3111. end
  3112. else iolabel:=nil;
  3113. { no automatic call from flush }
  3114. doflush:=false;
  3115. { for write of real with the length specified }
  3116. has_length:=false;
  3117. hp:=nil;
  3118. { reserve temporary pointer to data variable }
  3119. aktfile.symbol:=nil;
  3120. gettempofsizereference(4,aktfile);
  3121. { first state text data }
  3122. ft:=ft_text;
  3123. { and state a parameter ? }
  3124. if p^.left=nil then
  3125. begin
  3126. { state screen address}
  3127. doflush:=true;
  3128. { the following instructions are for "writeln;" }
  3129. loadstream;
  3130. { save @Dateivarible in temporary variable }
  3131. exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,R_A0,newreference(aktfile))));
  3132. end
  3133. else
  3134. begin
  3135. { revers paramters }
  3136. node:=reversparameter(p^.left);
  3137. p^.left := node;
  3138. npara := nb_para;
  3139. { calculate data variable }
  3140. { is first parameter a file type ? }
  3141. if node^.left^.resulttype^.deftype=filedef then
  3142. begin
  3143. ft:=pfiledef(node^.left^.resulttype)^.filetype;
  3144. if ft=ft_typed then
  3145. typedtyp:=pfiledef(node^.left^.resulttype)^.typed_as;
  3146. secondpass(node^.left);
  3147. if codegenerror then
  3148. exit;
  3149. { save reference in temporary variables } { reference in tempor„re Variable retten }
  3150. if node^.left^.location.loc<>LOC_REFERENCE then
  3151. begin
  3152. Message(cg_e_illegal_expression);
  3153. exit;
  3154. end;
  3155. exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_A0)));
  3156. { skip to the next parameter }
  3157. node:=node^.right;
  3158. end
  3159. else
  3160. begin
  3161. { if we write to stdout/in then flush after the write(ln) }
  3162. doflush:=true;
  3163. loadstream;
  3164. end;
  3165. { save @Dateivarible in temporary variable }
  3166. exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,R_A0,newreference(aktfile))));
  3167. if doread then
  3168. { parameter by READ gives call by reference }
  3169. dummycoll.paratyp:=vs_var
  3170. { an WRITE Call by "Const" }
  3171. else dummycoll.paratyp:=vs_const;
  3172. { because of secondcallparan, which otherwise attaches }
  3173. if ft=ft_typed then
  3174. begin
  3175. { this is to avoid copy of simple const parameters }
  3176. dummycoll.data:=new(pformaldef,init);
  3177. { use var for write also }
  3178. { avoids problems with const passed by value }
  3179. { but will not accept untyped const }
  3180. { dummycoll.paratyp:=vs_var; }
  3181. end
  3182. else
  3183. { I think, this isn't a good solution (FK) }
  3184. dummycoll.data:=nil;
  3185. while assigned(node) do
  3186. begin
  3187. pushusedregisters(pushed,$ffff);
  3188. hp:=node;
  3189. node:=node^.right;
  3190. hp^.right:=nil;
  3191. if hp^.is_colon_para then
  3192. Message(parser_e_illegal_colon_qualifier);
  3193. if hp^.is_colon_para then
  3194. Message(parser_e_illegal_colon_qualifier);
  3195. if ft=ft_typed then
  3196. never_copy_const_param:=true;
  3197. secondcallparan(hp,@dummycoll,false);
  3198. if ft=ft_typed then
  3199. never_copy_const_param:=false;
  3200. hp^.right:=node;
  3201. if codegenerror then
  3202. exit;
  3203. emit_push_mem(aktfile);
  3204. if (ft=ft_typed) then
  3205. begin
  3206. { OK let's try this }
  3207. { first we must only allow the right type }
  3208. { we have to call blockread or blockwrite }
  3209. { but the real problem is that }
  3210. { reset and rewrite should have set }
  3211. { the type size }
  3212. { as recordsize for that file !!!! }
  3213. { how can we make that }
  3214. { I think that is only possible by adding }
  3215. { reset and rewrite to the inline list a call }
  3216. { allways read only one record by element }
  3217. push_int(typedtyp^.size);
  3218. if doread then
  3219. emitcall('TYPED_READ',true)
  3220. else
  3221. emitcall('TYPED_WRITE',true)
  3222. {!!!!!!!}
  3223. end
  3224. else
  3225. begin
  3226. { save current position }
  3227. pararesult:=hp^.left^.resulttype;
  3228. { handle possible field width }
  3229. { of course only for write(ln) }
  3230. if not doread then
  3231. begin
  3232. { handle total width parameter }
  3233. if assigned(node) and node^.is_colon_para then
  3234. begin
  3235. hp:=node;
  3236. node:=node^.right;
  3237. hp^.right:=nil;
  3238. secondcallparan(hp,@dummycoll,false);
  3239. hp^.right:=node;
  3240. if codegenerror then
  3241. exit;
  3242. has_length:=true;
  3243. end
  3244. else
  3245. if pararesult^.deftype<>floatdef then
  3246. push_int(0)
  3247. else
  3248. push_int(-32767);
  3249. { a second colon para for a float ? }
  3250. if assigned(node) and node^.is_colon_para then
  3251. begin
  3252. hp:=node;
  3253. node:=node^.right;
  3254. hp^.right:=nil;
  3255. secondcallparan(hp,@dummycoll,false);
  3256. hp^.right:=node;
  3257. if pararesult^.deftype<>floatdef then
  3258. Message(parser_e_illegal_colon_qualifier);
  3259. if codegenerror then
  3260. exit;
  3261. end
  3262. else
  3263. begin
  3264. if hp^.left^.resulttype^.deftype=floatdef then
  3265. push_int(-1);
  3266. end;
  3267. end;
  3268. case pararesult^.deftype of
  3269. stringdef : begin
  3270. if doread then
  3271. emitcall('READ_TEXT_STRING',true)
  3272. else
  3273. begin
  3274. emitcall('WRITE_TEXT_STRING',true);
  3275. {ungetiftemp(hp^.left^.location.reference);}
  3276. end;
  3277. end;
  3278. pointerdef : begin
  3279. if is_equal(ppointerdef(pararesult)^.definition,cchardef) then
  3280. begin
  3281. if doread then
  3282. emitcall('READ_TEXT_PCHAR_AS_POINTER',true)
  3283. else
  3284. emitcall('WRITE_TEXT_PCHAR_AS_POINTER',true);
  3285. end
  3286. else Message(parser_e_illegal_parameter_list);
  3287. end;
  3288. arraydef : begin
  3289. if (parraydef(pararesult)^.lowrange=0)
  3290. and is_equal(parraydef(pararesult)^.definition,cchardef) then
  3291. begin
  3292. if doread then
  3293. emitcall('READ_TEXT_PCHAR_AS_ARRAY',true)
  3294. else
  3295. emitcall('WRITE_TEXT_PCHAR_AS_ARRAY',true);
  3296. end
  3297. else Message(parser_e_illegal_parameter_list);
  3298. end;
  3299. floatdef : begin
  3300. if doread then
  3301. emitcall('READ_TEXT_REAL',true)
  3302. else
  3303. emitcall('WRITE_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true);
  3304. end;
  3305. orddef : begin
  3306. case porddef(pararesult)^.typ of
  3307. u8bit : if doread then
  3308. emitcall('READ_TEXT_BYTE',true);
  3309. s8bit : if doread then
  3310. emitcall('READ_TEXT_SHORTINT',true);
  3311. u16bit : if doread then
  3312. emitcall('READ_TEXT_WORD',true);
  3313. s16bit : if doread then
  3314. emitcall('READ_TEXT_INTEGER',true);
  3315. s32bit : if doread then
  3316. emitcall('READ_TEXT_LONGINT',true)
  3317. else
  3318. emitcall('WRITE_TEXT_LONGINT',true);
  3319. u32bit : if doread then
  3320. emitcall('READ_TEXT_CARDINAL',true)
  3321. else
  3322. emitcall('WRITE_TEXT_CARDINAL',true);
  3323. uchar : if doread then
  3324. emitcall('READ_TEXT_CHAR',true)
  3325. else
  3326. emitcall('WRITE_TEXT_CHAR',true);
  3327. bool8bit : if doread then
  3328. { emitcall('READ_TEXT_BOOLEAN',true) }
  3329. Message(parser_e_illegal_parameter_list)
  3330. else
  3331. emitcall('WRITE_TEXT_BOOLEAN',true);
  3332. else Message(parser_e_illegal_parameter_list);
  3333. end;
  3334. end;
  3335. else Message(parser_e_illegal_parameter_list);
  3336. end;
  3337. end;
  3338. { load A5 in methods again }
  3339. popusedregisters(pushed);
  3340. maybe_loada5;
  3341. end;
  3342. end;
  3343. if callwriteln then
  3344. begin
  3345. pushusedregisters(pushed,$ffff);
  3346. emit_push_mem(aktfile);
  3347. { pushexceptlabel; }
  3348. if ft<>ft_text then
  3349. Message(parser_e_illegal_parameter_list);
  3350. emitcall('WRITELN_TEXT',true);
  3351. popusedregisters(pushed);
  3352. maybe_loada5;
  3353. end;
  3354. if doflush and not(doread) then
  3355. begin
  3356. pushusedregisters(pushed,$ffff);
  3357. { pushexceptlabel; }
  3358. emitcall('FLUSH_STDOUT',true);
  3359. popusedregisters(pushed);
  3360. maybe_loada5;
  3361. end;
  3362. if iolabel<>nil then
  3363. begin
  3364. { registers are saved in the procedure }
  3365. exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,newcsymbol(lab2str(iolabel),0),R_SPPUSH)));
  3366. emitcall('IOCHECK',true);
  3367. end;
  3368. ungetiftemp(aktfile);
  3369. if assigned(p^.left) then
  3370. begin
  3371. p^.left:=reversparameter(p^.left);
  3372. if npara<>nb_para then
  3373. Message(cg_f_internal_error_in_secondinline);
  3374. hp:=p^.left;
  3375. while assigned(hp) do
  3376. begin
  3377. if assigned(hp^.left) then
  3378. if (hp^.left^.location.loc=LOC_REFERENCE) or
  3379. (hp^.left^.location.loc=LOC_MEM) then
  3380. ungetiftemp(hp^.left^.location.reference);
  3381. hp:=hp^.right;
  3382. end;
  3383. end;
  3384. end;
  3385. procedure handle_str;
  3386. var
  3387. hp,node,lentree,paratree : ptree;
  3388. dummycoll : tdefcoll;
  3389. is_real,has_length : boolean;
  3390. real_type : byte;
  3391. begin
  3392. pushusedregisters(pushed,$ffff);
  3393. node:=p^.left;
  3394. is_real:=false;
  3395. has_length:=false;
  3396. while assigned(node^.right) do node:=node^.right;
  3397. { if a real parameter somewhere then call REALSTR }
  3398. if (node^.left^.resulttype^.deftype=floatdef) then
  3399. is_real:=true;
  3400. node:=p^.left;
  3401. { we have at least two args }
  3402. { with at max 2 colon_para in between }
  3403. { first arg longint or float }
  3404. hp:=node;
  3405. node:=node^.right;
  3406. hp^.right:=nil;
  3407. dummycoll.data:=hp^.resulttype;
  3408. { string arg }
  3409. dummycoll.paratyp:=vs_var;
  3410. secondcallparan(hp,@dummycoll,false);
  3411. if codegenerror then
  3412. exit;
  3413. dummycoll.paratyp:=vs_const;
  3414. { second arg }
  3415. hp:=node;
  3416. node:=node^.right;
  3417. hp^.right:=nil;
  3418. { frac para }
  3419. if hp^.is_colon_para and assigned(node) and
  3420. node^.is_colon_para then
  3421. begin
  3422. dummycoll.data:=hp^.resulttype;
  3423. secondcallparan(hp,@dummycoll,false);
  3424. if codegenerror then
  3425. exit;
  3426. hp:=node;
  3427. node:=node^.right;
  3428. hp^.right:=nil;
  3429. has_length:=true;
  3430. end
  3431. else
  3432. if is_real then
  3433. push_int(-1);
  3434. { third arg, length only if is_real }
  3435. if hp^.is_colon_para then
  3436. begin
  3437. dummycoll.data:=hp^.resulttype;
  3438. secondcallparan(hp,@dummycoll,false);
  3439. if codegenerror then
  3440. exit;
  3441. hp:=node;
  3442. node:=node^.right;
  3443. hp^.right:=nil;
  3444. end
  3445. else
  3446. if is_real then
  3447. push_int(-32767)
  3448. else
  3449. push_int(-1);
  3450. { last arg longint or real }
  3451. secondcallparan(hp,@dummycoll,false);
  3452. if codegenerror then
  3453. exit;
  3454. if is_real then
  3455. emitcall('STR_'+float_name[pfloatdef(hp^.resulttype)^.typ],true)
  3456. else if porddef(hp^.resulttype)^.typ=u32bit then
  3457. emitcall('STR_CARDINAL',true)
  3458. else
  3459. emitcall('STR_LONGINT',true);
  3460. popusedregisters(pushed);
  3461. end;
  3462. var
  3463. r : preference;
  3464. begin
  3465. case p^.inlinenumber of
  3466. in_lo_word,
  3467. in_hi_word : begin
  3468. secondpass(p^.left);
  3469. p^.location.loc:=LOC_REGISTER;
  3470. if p^.left^.location.loc<>LOC_REGISTER then
  3471. begin
  3472. if p^.left^.location.loc=LOC_CREGISTER then
  3473. begin
  3474. p^.location.register:=getregister32;
  3475. emit_reg_reg(A_MOVE,S_W,p^.left^.location.register,
  3476. p^.location.register);
  3477. end
  3478. else
  3479. begin
  3480. del_reference(p^.left^.location.reference);
  3481. p^.location.register:=getregister32;
  3482. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,
  3483. newreference(p^.left^.location.reference),
  3484. p^.location.register)));
  3485. end;
  3486. end
  3487. else p^.location.register:=p^.left^.location.register;
  3488. if p^.inlinenumber=in_hi_word then
  3489. exprasmlist^.concat(new(pai68k,op_const_reg(A_LSR,S_W,8,p^.location.register)));
  3490. p^.location.register:=p^.location.register;
  3491. end;
  3492. in_high_x :
  3493. begin
  3494. if is_open_array(p^.left^.resulttype) then
  3495. begin
  3496. secondpass(p^.left);
  3497. del_reference(p^.left^.location.reference);
  3498. p^.location.register:=getregister32;
  3499. new(r);
  3500. reset_reference(r^);
  3501. r^.base:=highframepointer;
  3502. r^.offset:=highoffset+4;
  3503. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
  3504. r,p^.location.register)));
  3505. end
  3506. end;
  3507. in_sizeof_x,
  3508. in_typeof_x:
  3509. begin
  3510. { load vmt }
  3511. if p^.left^.treetype=typen then
  3512. begin
  3513. p^.location.register:=getregister32;
  3514. exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,
  3515. S_L,newcsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,0),
  3516. p^.location.register)));
  3517. end
  3518. else
  3519. begin
  3520. secondpass(p^.left);
  3521. del_reference(p^.left^.location.reference);
  3522. p^.location.loc:=LOC_REGISTER;
  3523. p^.location.register:=getregister32;
  3524. { load VMT pointer }
  3525. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
  3526. newreference(p^.left^.location.reference),
  3527. p^.location.register)));
  3528. end;
  3529. { in sizeof load size }
  3530. if p^.inlinenumber=in_sizeof_x then
  3531. begin
  3532. new(r);
  3533. reset_reference(r^);
  3534. { load the address in A0 }
  3535. { because now supposedly p^.location.register is an }
  3536. { address. }
  3537. emit_reg_reg(A_MOVE, S_L, p^.location.register, R_A0);
  3538. r^.base:=R_A0;
  3539. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,
  3540. p^.location.register)));
  3541. end;
  3542. end;
  3543. in_lo_long,
  3544. in_hi_long : begin
  3545. secondpass(p^.left);
  3546. p^.location.loc:=LOC_REGISTER;
  3547. if p^.left^.location.loc<>LOC_REGISTER then
  3548. begin
  3549. if p^.left^.location.loc=LOC_CREGISTER then
  3550. begin
  3551. p^.location.register:=getregister32;
  3552. emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
  3553. p^.location.register);
  3554. end
  3555. else
  3556. begin
  3557. del_reference(p^.left^.location.reference);
  3558. p^.location.register:=getregister32;
  3559. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
  3560. newreference(p^.left^.location.reference),
  3561. p^.location.register)));
  3562. end;
  3563. end
  3564. else p^.location.register:=p^.left^.location.register;
  3565. if p^.inlinenumber=in_hi_long then
  3566. begin
  3567. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVEQ, S_L, 16, R_D1)));
  3568. exprasmlist^.concat(new(pai68k,op_reg_reg(A_LSR,S_L,R_D1,p^.location.register)));
  3569. end;
  3570. p^.location.register:=p^.location.register;
  3571. end;
  3572. {We can now comment them out, as they are handled as typecast.
  3573. Saves an incredible amount of 8 bytes code.
  3574. I'am not lucky about this, because it's _not_ a type cast (FK) }
  3575. { in_ord_char,
  3576. in_chr_byte,}
  3577. in_length_string : begin
  3578. secondpass(p^.left);
  3579. set_location(p^.location,p^.left^.location);
  3580. end;
  3581. in_inc_byte..in_dec_dword:
  3582. begin
  3583. secondpass(p^.left);
  3584. exprasmlist^.concat(new(pai68k,op_const_ref(in2instr[p^.inlinenumber],
  3585. in2size[p^.inlinenumber],1,newreference(p^.left^.location.reference))));
  3586. emitoverflowcheck(p^.left);
  3587. end;
  3588. in_pred_x,
  3589. in_succ_x:
  3590. begin
  3591. secondpass(p^.left);
  3592. if p^.inlinenumber=in_pred_x then
  3593. asmop:=A_SUB
  3594. else
  3595. asmop:=A_ADD;
  3596. case p^.resulttype^.size of
  3597. 4 : opsize:=S_L;
  3598. 2 : opsize:=S_W;
  3599. 1 : opsize:=S_B;
  3600. else
  3601. internalerror(10080);
  3602. end;
  3603. p^.location.loc:=LOC_REGISTER;
  3604. if p^.left^.location.loc<>LOC_REGISTER then
  3605. begin
  3606. p^.location.register:=getregister32;
  3607. if p^.left^.location.loc=LOC_CREGISTER then
  3608. emit_reg_reg(A_MOVE,opsize,p^.left^.location.register,
  3609. p^.location.register)
  3610. else
  3611. if p^.left^.location.loc=LOC_FLAGS then
  3612. exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.left^.location.resflags],S_NO,
  3613. p^.location.register)))
  3614. else
  3615. begin
  3616. del_reference(p^.left^.location.reference);
  3617. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,newreference(p^.left^.location.reference),
  3618. p^.location.register)));
  3619. end;
  3620. end
  3621. else p^.location.register:=p^.left^.location.register;
  3622. exprasmlist^.concat(new(pai68k,op_reg(asmop,opsize,
  3623. p^.location.register)))
  3624. { here we should insert bounds check ? }
  3625. { and direct call to bounds will crash the program }
  3626. { if we are at the limit }
  3627. { we could also simply say that pred(first)=first and succ(last)=last }
  3628. { could this be usefull I don't think so (PM)
  3629. emitoverflowcheck;}
  3630. end;
  3631. in_assigned_x:
  3632. begin
  3633. secondpass(p^.left^.left);
  3634. p^.location.loc:=LOC_FLAGS;
  3635. if (p^.left^.left^.location.loc=LOC_REGISTER) or
  3636. (p^.left^.left^.location.loc=LOC_CREGISTER) then
  3637. begin
  3638. exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,
  3639. p^.left^.left^.location.register)));
  3640. ungetregister32(p^.left^.left^.location.register);
  3641. end
  3642. else
  3643. begin
  3644. exprasmlist^.concat(new(pai68k,op_ref(A_TST,S_L,
  3645. newreference(p^.left^.left^.location.reference))));
  3646. del_reference(p^.left^.left^.location.reference);
  3647. end;
  3648. p^.location.resflags:=F_NE;
  3649. end;
  3650. in_reset_typedfile,in_rewrite_typedfile :
  3651. begin
  3652. pushusedregisters(pushed,$ffff);
  3653. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,
  3654. pfiledef(p^.left^.resulttype)^.typed_as^.size,R_SPPUSH)));
  3655. secondload(p^.left);
  3656. emitpushreferenceaddr(p^.left^.location.reference);
  3657. if p^.inlinenumber=in_reset_typedfile then
  3658. emitcall('RESET_TYPED',true)
  3659. else
  3660. emitcall('REWRITE_TYPED',true);
  3661. popusedregisters(pushed);
  3662. end;
  3663. in_write_x :
  3664. handlereadwrite(false,false);
  3665. in_writeln_x :
  3666. handlereadwrite(false,true);
  3667. in_read_x :
  3668. handlereadwrite(true,false);
  3669. in_readln_x :
  3670. begin
  3671. handlereadwrite(true,false);
  3672. pushusedregisters(pushed,$ffff);
  3673. emit_push_mem(aktfile);
  3674. { pushexceptlabel; }
  3675. if ft<>ft_text then
  3676. Message(parser_e_illegal_parameter_list);
  3677. emitcall('READLN_TEXT',true);
  3678. popusedregisters(pushed);
  3679. maybe_loada5;
  3680. end;
  3681. in_str_x_string : begin
  3682. handle_str;
  3683. maybe_loada5;
  3684. end;
  3685. else internalerror(9);
  3686. end;
  3687. end;
  3688. procedure secondsubscriptn(var p : ptree);
  3689. var
  3690. hr: tregister;
  3691. begin
  3692. secondpass(p^.left);
  3693. if codegenerror then
  3694. exit;
  3695. { classes must be dereferenced implicit }
  3696. if (p^.left^.resulttype^.deftype=objectdef) and
  3697. pobjectdef(p^.left^.resulttype)^.isclass then
  3698. begin
  3699. clear_reference(p^.location.reference);
  3700. case p^.left^.location.loc of
  3701. LOC_REGISTER:
  3702. begin
  3703. { move it to an address register...}
  3704. hr:=getaddressreg;
  3705. emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
  3706. p^.location.reference.base:=hr;
  3707. { free register }
  3708. ungetregister(p^.left^.location.register);
  3709. end;
  3710. LOC_CREGISTER:
  3711. begin
  3712. { ... and reserve one for the pointer }
  3713. hr:=getaddressreg;
  3714. emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
  3715. p^.location.reference.base:=hr;
  3716. end;
  3717. else
  3718. begin
  3719. { free register }
  3720. del_reference(p^.left^.location.reference);
  3721. { ... and reserve one for the pointer }
  3722. hr:=getaddressreg;
  3723. exprasmlist^.concat(new(pai68k,op_ref_reg(
  3724. A_MOVE,S_L,newreference(p^.left^.location.reference),
  3725. hr)));
  3726. p^.location.reference.base:=hr;
  3727. end;
  3728. end;
  3729. end
  3730. else
  3731. set_location(p^.location,p^.left^.location);
  3732. inc(p^.location.reference.offset,p^.vs^.address);
  3733. end;
  3734. procedure secondselfn(var p : ptree);
  3735. begin
  3736. clear_reference(p^.location.reference);
  3737. p^.location.reference.base:=R_A5;
  3738. end;
  3739. procedure secondhdisposen(var p : ptree);
  3740. begin
  3741. secondpass(p^.left);
  3742. if codegenerror then
  3743. exit;
  3744. clear_reference(p^.location.reference);
  3745. case p^.left^.location.loc of
  3746. LOC_REGISTER,
  3747. LOC_CREGISTER : begin
  3748. p^.location.reference.index:=getregister32;
  3749. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
  3750. p^.left^.location.register,
  3751. p^.location.reference.index)));
  3752. end;
  3753. LOC_MEM,LOC_REFERENCE :
  3754. begin
  3755. del_reference(p^.left^.location.reference);
  3756. p^.location.reference.index:=getregister32;
  3757. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
  3758. p^.location.reference.index)));
  3759. end;
  3760. end;
  3761. end;
  3762. procedure secondhnewn(var p : ptree);
  3763. begin
  3764. end;
  3765. procedure secondnewn(var p : ptree);
  3766. begin
  3767. secondpass(p^.left);
  3768. if codegenerror then
  3769. exit;
  3770. p^.location.register:=p^.left^.location.register;
  3771. end;
  3772. procedure secondsimplenewdispose(var p : ptree);
  3773. var
  3774. pushed : tpushed;
  3775. begin
  3776. secondpass(p^.left);
  3777. if codegenerror then
  3778. exit;
  3779. pushusedregisters(pushed,$ffff);
  3780. { determines the size of the mem block }
  3781. push_int(ppointerdef(p^.left^.resulttype)^.definition^.size);
  3782. { push pointer adress }
  3783. case p^.left^.location.loc of
  3784. LOC_CREGISTER : exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
  3785. p^.left^.location.register,R_SPPUSH)));
  3786. LOC_REFERENCE : emitpushreferenceaddr(p^.left^.location.reference);
  3787. end;
  3788. { call the mem handling procedures }
  3789. case p^.treetype of
  3790. simpledisposen :
  3791. emitcall('FREEMEM',true);
  3792. simplenewn :
  3793. emitcall('GETMEM',true);
  3794. end;
  3795. popusedregisters(pushed);
  3796. { may be load ESI }
  3797. maybe_loada5;
  3798. end;
  3799. procedure secondsetcons(var p : ptree);
  3800. var
  3801. l : plabel;
  3802. i,smallsetvalue : longint;
  3803. hp : ptree;
  3804. href,sref : treference;
  3805. hl1,hl2: plabel;
  3806. begin
  3807. { this should be reimplemented for smallsets }
  3808. { differently (PM) }
  3809. { produce constant part }
  3810. href.symbol := Nil;
  3811. clear_reference(href);
  3812. getlabel(l);
  3813. href.symbol:=stringdup(lab2str(l));
  3814. stringdispose(p^.location.reference.symbol);
  3815. datasegment^.concat(new(pai_label,init(l)));
  3816. {if psetdef(p^.resulttype)=smallset then
  3817. begin
  3818. smallsetvalue:=(p^.constset^[3]*256)+p^.constset^[2];
  3819. smallsetvalue:=((smallset*256+p^.constset^[1])*256+p^.constset^[1];
  3820. datasegment^.concat(new(pai_const,init_32bit(smallsetvalue)));
  3821. hp:=p^.left;
  3822. if assigned(hp) then
  3823. begin
  3824. sref.symbol:=nil;
  3825. gettempofsizereference(32,sref);
  3826. concatcopy(href,sref,32,false);
  3827. while assigned(hp) do
  3828. begin
  3829. secondpass(hp^.left);
  3830. if codegenerror then
  3831. exit;
  3832. pushsetelement(hp^.left);
  3833. emitpushreferenceaddr(sref);
  3834. register is save in subroutine
  3835. emitcall('SET_SET_BYTE',true);
  3836. hp:=hp^.right;
  3837. end;
  3838. p^.location.reference:=sref;
  3839. end
  3840. else p^.location.reference:=href;
  3841. end
  3842. else }
  3843. begin
  3844. for i:=0 to 31 do
  3845. datasegment^.concat(new(pai_const,init_8bit(p^.constset^[i])));
  3846. hp:=p^.left;
  3847. if assigned(hp) then
  3848. begin
  3849. sref.symbol:=nil;
  3850. gettempofsizereference(32,sref);
  3851. concatcopy(href,sref,32,false);
  3852. while assigned(hp) do
  3853. begin
  3854. secondpass(hp^.left);
  3855. if codegenerror then
  3856. exit;
  3857. pushsetelement(hp^.left);
  3858. emitpushreferenceaddr(sref);
  3859. { register is save in subroutine }
  3860. emitcall('SET_SET_BYTE',true);
  3861. { here we must set the flags manually }
  3862. { on returne from the routine, because }
  3863. { falgs are corrupt when restoring the }
  3864. { stack }
  3865. exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_B,R_D0)));
  3866. getlabel(hl1);
  3867. emitl(A_BEQ,hl1);
  3868. exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_B,
  3869. $fe,R_CCR)));
  3870. getlabel(hl2);
  3871. emitl(A_BRA,hl2);
  3872. emitl(A_LABEL,hl1);
  3873. exprasmlist^.concat(new(pai68k,op_const_reg(A_OR,S_B,
  3874. $01,R_CCR)));
  3875. emitl(A_LABEL,hl2);
  3876. hp:=hp^.right;
  3877. end;
  3878. p^.location.reference:=sref;
  3879. end
  3880. else p^.location.reference:=href;
  3881. end;
  3882. end;
  3883. procedure secondcontinuen(var p : ptree);
  3884. begin
  3885. if aktcontinuelabel<>nil then
  3886. emitl(A_JMP,aktcontinuelabel)
  3887. else
  3888. Message(cg_e_continue_not_allowed);
  3889. end;
  3890. { var
  3891. hs : string; }
  3892. procedure secondexitn(var p : ptree);
  3893. var
  3894. is_mem : boolean;
  3895. {op : tasmop;
  3896. s : topsize;}
  3897. otlabel,oflabel : plabel;
  3898. label
  3899. do_jmp;
  3900. begin
  3901. if assigned(p^.left) then
  3902. begin
  3903. otlabel:=truelabel;
  3904. oflabel:=falselabel;
  3905. getlabel(truelabel);
  3906. getlabel(falselabel);
  3907. secondpass(p^.left);
  3908. case p^.left^.location.loc of
  3909. LOC_FPU : goto do_jmp;
  3910. LOC_MEM,LOC_REFERENCE : is_mem:=true;
  3911. LOC_CREGISTER,
  3912. LOC_REGISTER : is_mem:=false;
  3913. LOC_FLAGS : begin
  3914. exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.right^.location.resflags],S_B,R_D0)));
  3915. exprasmlist^.concat(new(pai68k,op_reg(A_NEG, S_B, R_D0)));
  3916. goto do_jmp;
  3917. end;
  3918. LOC_JUMP : begin
  3919. emitl(A_LABEL,truelabel);
  3920. exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,1,R_D0)));
  3921. emitl(A_JMP,aktexit2label);
  3922. exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_B,R_D0)));
  3923. goto do_jmp;
  3924. end;
  3925. else internalerror(2001);
  3926. end;
  3927. if (procinfo.retdef^.deftype=orddef) then
  3928. begin
  3929. case porddef(procinfo.retdef)^.typ of
  3930. s32bit,u32bit : if is_mem then
  3931. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
  3932. newreference(p^.left^.location.reference),R_D0)))
  3933. else
  3934. emit_reg_reg(A_MOVE,S_L,
  3935. p^.left^.location.register,R_D0);
  3936. u8bit,s8bit,uchar,bool8bit : if is_mem then
  3937. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,
  3938. newreference(p^.left^.location.reference),R_D0)))
  3939. else
  3940. emit_reg_reg(A_MOVE,S_B,
  3941. p^.left^.location.register,R_D0);
  3942. s16bit,u16bit : if is_mem then
  3943. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,
  3944. newreference(p^.left^.location.reference),R_D0)))
  3945. else
  3946. emit_reg_reg(A_MOVE,S_W,
  3947. p^.left^.location.register,R_D0);
  3948. end;
  3949. end
  3950. else
  3951. if (procinfo.retdef^.deftype in
  3952. [pointerdef,enumdef,procvardef]) then
  3953. begin
  3954. if is_mem then
  3955. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
  3956. newreference(p^.left^.location.reference),R_D0)))
  3957. else
  3958. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
  3959. p^.left^.location.register,R_D0)));
  3960. end
  3961. else
  3962. if (procinfo.retdef^.deftype=floatdef) then
  3963. { floating point return values .... }
  3964. { single are returned in d0 }
  3965. begin
  3966. if (pfloatdef(procinfo.retdef)^.typ=f32bit) or
  3967. (pfloatdef(procinfo.retdef)^.typ=s32real) then
  3968. begin
  3969. if is_mem then
  3970. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
  3971. newreference(p^.left^.location.reference),R_D0)))
  3972. else
  3973. begin
  3974. if pfloatdef(procinfo.retdef)^.typ=f32bit then
  3975. emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_D0)
  3976. else
  3977. begin
  3978. { single values are in the floating point registers }
  3979. if cs_fp_emulation in aktswitches then
  3980. emit_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0)
  3981. else
  3982. exprasmlist^.concat(
  3983. new(pai68k,op_reg_reg(A_FMOVE,S_FS,p^.left^.location.fpureg,R_D0)));
  3984. end;
  3985. end;
  3986. end
  3987. else
  3988. { this is only possible in real non emulation mode }
  3989. { LOC_MEM,LOC_REFERENCE }
  3990. if is_mem then
  3991. begin
  3992. exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,
  3993. getfloatsize(pfloatdef(procinfo.retdef)^.typ),newreference(p^.left^.location.reference),R_FP0)));
  3994. end
  3995. else
  3996. { LOC_FPU }
  3997. begin
  3998. { convert from extended to correct type }
  3999. { when storing }
  4000. exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE,
  4001. getfloatsize(pfloatdef(procinfo.retdef)^.typ),p^.left^.location.fpureg,R_FP0)));
  4002. end;
  4003. end;
  4004. do_jmp:
  4005. truelabel:=otlabel;
  4006. falselabel:=oflabel;
  4007. emitl(A_JMP,aktexit2label);
  4008. end
  4009. else
  4010. begin
  4011. emitl(A_JMP,aktexitlabel);
  4012. end;
  4013. end;
  4014. procedure secondgoto(var p : ptree);
  4015. begin
  4016. emitl(A_JMP,p^.labelnr);
  4017. end;
  4018. procedure secondlabel(var p : ptree);
  4019. begin
  4020. emitl(A_LABEL,p^.labelnr);
  4021. cleartempgen;
  4022. secondpass(p^.left);
  4023. end;
  4024. procedure secondasm(var p : ptree);
  4025. begin
  4026. exprasmlist^.concatlist(p^.p_asm);
  4027. end;
  4028. procedure secondcase(var p : ptree);
  4029. var
  4030. with_sign : boolean;
  4031. opsize : topsize;
  4032. jmp_gt,jmp_le,jmp_lee : tasmop;
  4033. hp : ptree;
  4034. { register with case expression }
  4035. hregister : tregister;
  4036. endlabel,elselabel : plabel;
  4037. { true, if we can omit the range check of the jump table }
  4038. jumptable_no_range : boolean;
  4039. procedure gentreejmp(p : pcaserecord);
  4040. var
  4041. lesslabel,greaterlabel : plabel;
  4042. begin
  4043. emitl(A_LABEL,p^._at);
  4044. { calculate labels for left and right }
  4045. if (p^.less=nil) then
  4046. lesslabel:=elselabel
  4047. else
  4048. lesslabel:=p^.less^._at;
  4049. if (p^.greater=nil) then
  4050. greaterlabel:=elselabel
  4051. else
  4052. greaterlabel:=p^.greater^._at;
  4053. { calculate labels for left and right }
  4054. { no range label: }
  4055. if p^._low=p^._high then
  4056. begin
  4057. exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^._low,hregister)));
  4058. if greaterlabel=lesslabel then
  4059. begin
  4060. emitl(A_BNE,lesslabel);
  4061. end
  4062. else
  4063. begin
  4064. emitl(jmp_le,lesslabel);
  4065. emitl(jmp_gt,greaterlabel);
  4066. end;
  4067. emitl(A_JMP,p^.statement);
  4068. end
  4069. else
  4070. begin
  4071. exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^._low,hregister)));
  4072. emitl(jmp_le,lesslabel);
  4073. exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^._high,hregister)));
  4074. emitl(jmp_gt,greaterlabel);
  4075. emitl(A_JMP,p^.statement);
  4076. end;
  4077. if assigned(p^.less) then
  4078. gentreejmp(p^.less);
  4079. if assigned(p^.greater) then
  4080. gentreejmp(p^.greater);
  4081. end;
  4082. procedure genlinearlist(hp : pcaserecord);
  4083. var
  4084. first : boolean;
  4085. last : longint;
  4086. procedure genitem(t : pcaserecord);
  4087. begin
  4088. if assigned(t^.less) then
  4089. genitem(t^.less);
  4090. if t^._low=t^._high then
  4091. begin
  4092. if (t^._low-last > 0) and (t^._low-last < 9) then
  4093. exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,opsize,t^._low-last,hregister)))
  4094. else
  4095. if (t^._low-last = 0) then
  4096. exprasmlist^.concat(new(pai68k,op_reg(A_TST,opsize,hregister)))
  4097. else
  4098. exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._low-last,hregister)));
  4099. last:=t^._low;
  4100. emitl(A_BEQ,t^.statement);
  4101. end
  4102. else
  4103. begin
  4104. { it begins with the smallest label, if the value }
  4105. { is even smaller then jump immediately to the }
  4106. { ELSE-label }
  4107. if first then
  4108. begin
  4109. if (t^._low-1 > 0) and (t^._low < 9) then
  4110. exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,opsize,t^._low-1,hregister)))
  4111. else
  4112. if t^._low-1=0 then
  4113. exprasmlist^.concat(new(pai68k,op_reg(A_TST,opsize,hregister)))
  4114. else
  4115. exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._low-1,hregister)));
  4116. if t^._low = 0 then
  4117. emitl(A_BLE,elselabel)
  4118. else
  4119. emitl(jmp_lee,elselabel);
  4120. end
  4121. { if there is no unused label between the last and the }
  4122. { present label then the lower limit can be checked }
  4123. { immediately. else check the range in between: }
  4124. else if (t^._low-last>1)then
  4125. begin
  4126. if ((t^._low-last-1) > 0) and ((t^._low-last-1) < 9) then
  4127. exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,opsize,t^._low-last-1,hregister)))
  4128. else
  4129. exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._low-last-1,hregister)));
  4130. emitl(jmp_lee,elselabel);
  4131. end;
  4132. exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._high-t^._low+1,hregister)));
  4133. emitl(jmp_lee,t^.statement);
  4134. last:=t^._high;
  4135. end;
  4136. first:=false;
  4137. if assigned(t^.greater) then
  4138. genitem(t^.greater);
  4139. end;
  4140. var
  4141. hr : tregister;
  4142. begin
  4143. { case register is modified by the list evalution }
  4144. if (p^.left^.location.loc=LOC_CREGISTER) then
  4145. begin
  4146. hr:=getregister32;
  4147. end;
  4148. last:=0;
  4149. first:=true;
  4150. genitem(hp);
  4151. emitl(A_JMP,elselabel);
  4152. end;
  4153. procedure genjumptable(hp : pcaserecord;min_,max_ : longint);
  4154. var
  4155. table : plabel;
  4156. last : longint;
  4157. hr : preference;
  4158. procedure genitem(t : pcaserecord);
  4159. var
  4160. i : longint;
  4161. begin
  4162. if assigned(t^.less) then
  4163. genitem(t^.less);
  4164. { fill possible hole }
  4165. for i:=last+1 to t^._low-1 do
  4166. datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
  4167. (elselabel)))));
  4168. for i:=t^._low to t^._high do
  4169. datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
  4170. (t^.statement)))));
  4171. last:=t^._high;
  4172. if assigned(t^.greater) then
  4173. genitem(t^.greater);
  4174. end;
  4175. begin
  4176. if not(jumptable_no_range) then
  4177. begin
  4178. exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,min_,hregister)));
  4179. { case expr less than min_ => goto elselabel }
  4180. emitl(jmp_le,elselabel);
  4181. exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,max_,hregister)));
  4182. emitl(jmp_gt,elselabel);
  4183. end;
  4184. getlabel(table);
  4185. { extend with sign }
  4186. if opsize=S_W then
  4187. begin
  4188. { word to long - unsigned }
  4189. exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ffff,hregister)));
  4190. end
  4191. else if opsize=S_B then
  4192. begin
  4193. { byte to long - unsigned }
  4194. exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ff,hregister)));
  4195. end;
  4196. new(hr);
  4197. reset_reference(hr^);
  4198. hr^.symbol:=stringdup(lab2str(table));
  4199. hr^.offset:=(-min_)*4;
  4200. { add scalefactor *4 to index }
  4201. exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,2,hregister)));
  4202. { hr^.scalefactor:=4; }
  4203. hr^.base:=getaddressreg;
  4204. emit_reg_reg(A_MOVE,S_L,hregister,hr^.base);
  4205. exprasmlist^.concat(new(pai68k,op_ref(A_JMP,S_NO,hr)));
  4206. { if not(cs_littlesize in aktswitches^ ) then
  4207. datasegment^.concat(new(pai68k,op_const(A_ALIGN,S_NO,4))); }
  4208. datasegment^.concat(new(pai_label,init(table)));
  4209. last:=min_;
  4210. genitem(hp);
  4211. if hr^.base <> R_NO then ungetregister(hr^.base);
  4212. { !!!!!!!
  4213. if not(cs_littlesize in aktswitches^ ) then
  4214. exprasmlist^.concat(new(pai68k,op_const(A_ALIGN,S_NO,4)));
  4215. }
  4216. end;
  4217. var
  4218. lv,hv,min_label,max_label,labels : longint;
  4219. max_linear_list : longint;
  4220. begin
  4221. getlabel(endlabel);
  4222. getlabel(elselabel);
  4223. with_sign:=is_signed(p^.left^.resulttype);
  4224. if with_sign then
  4225. begin
  4226. jmp_gt:=A_BGT;
  4227. jmp_le:=A_BLT;
  4228. jmp_lee:=A_BLE;
  4229. end
  4230. else
  4231. begin
  4232. jmp_gt:=A_BHI;
  4233. jmp_le:=A_BCS;
  4234. jmp_lee:=A_BLS;
  4235. end;
  4236. cleartempgen;
  4237. secondpass(p^.left);
  4238. { determines the size of the operand }
  4239. { determines the size of the operand }
  4240. opsize:=bytes2Sxx[p^.left^.resulttype^.size];
  4241. { copy the case expression to a register }
  4242. { copy the case expression to a register }
  4243. case p^.left^.location.loc of
  4244. LOC_REGISTER,
  4245. LOC_CREGISTER : hregister:=p^.left^.location.register;
  4246. LOC_MEM,LOC_REFERENCE : begin
  4247. del_reference(p^.left^.location.reference);
  4248. hregister:=getregister32;
  4249. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,newreference(
  4250. p^.left^.location.reference),hregister)));
  4251. end;
  4252. else internalerror(2002);
  4253. end;
  4254. { now generate the jumps }
  4255. if cs_optimize in aktswitches then
  4256. begin
  4257. { procedures are empirically passed on }
  4258. { consumption can also be calculated }
  4259. { but does it pay on the different }
  4260. { processors? }
  4261. { moreover can the size only be appro- }
  4262. { ximated as it is not known if rel8, }
  4263. { rel16 or rel32 jumps are used }
  4264. min_label:=case_get_min(p^.nodes);
  4265. max_label:=case_get_max(p^.nodes);
  4266. labels:=case_count_labels(p^.nodes);
  4267. { can we omit the range check of the jump table }
  4268. getrange(p^.left^.resulttype,lv,hv);
  4269. jumptable_no_range:=(lv=min_label) and (hv=max_label);
  4270. { optimize for size ? }
  4271. if cs_littlesize in aktswitches then
  4272. begin
  4273. if (labels<=2) or ((max_label-min_label)>3*labels) then
  4274. { a linear list is always smaller than a jump tree }
  4275. genlinearlist(p^.nodes)
  4276. else
  4277. { if the labels less or more a continuum then }
  4278. genjumptable(p^.nodes,min_label,max_label);
  4279. end
  4280. else
  4281. begin
  4282. if jumptable_no_range then
  4283. max_linear_list:=4
  4284. else
  4285. max_linear_list:=2;
  4286. if (labels<=max_linear_list) then
  4287. genlinearlist(p^.nodes)
  4288. else
  4289. begin
  4290. if ((max_label-min_label)>4*labels) then
  4291. begin
  4292. if labels>16 then
  4293. gentreejmp(p^.nodes)
  4294. else
  4295. genlinearlist(p^.nodes);
  4296. end
  4297. else
  4298. genjumptable(p^.nodes,min_label,max_label);
  4299. end;
  4300. end;
  4301. end
  4302. else
  4303. { it's always not bad }
  4304. genlinearlist(p^.nodes);
  4305. { now generate the instructions }
  4306. hp:=p^.right;
  4307. while assigned(hp) do
  4308. begin
  4309. cleartempgen;
  4310. secondpass(hp^.right);
  4311. emitl(A_JMP,endlabel);
  4312. hp:=hp^.left;
  4313. end;
  4314. emitl(A_LABEL,elselabel);
  4315. { ... and the else block }
  4316. if assigned(p^.elseblock) then
  4317. begin
  4318. cleartempgen;
  4319. secondpass(p^.elseblock);
  4320. end;
  4321. emitl(A_LABEL,endlabel);
  4322. end;
  4323. procedure secondtryexcept(var p : ptree);
  4324. begin
  4325. end;
  4326. procedure secondtryfinally(var p : ptree);
  4327. begin
  4328. end;
  4329. procedure secondfail(var p : ptree);
  4330. var hp : preference;
  4331. begin
  4332. {if procinfo.exceptions then
  4333. aktproccode.concat(gennasmrec(CALL,S_NO,'HELP_DESTRUCTOR_E'))
  4334. else }
  4335. { we should know if the constructor is called with a new or not,
  4336. how can we do that ???
  4337. exprasmlist^.concat(new(pai68k,op_csymbol(A_CALL,S_NO,newcsymbol('HELP_DESTRUCTOR',0))));
  4338. }
  4339. exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,R_A5)));
  4340. { also reset to zero in the stack }
  4341. new(hp);
  4342. reset_reference(hp^);
  4343. hp^.offset:=procinfo.ESI_offset;
  4344. hp^.base:=procinfo.framepointer;
  4345. exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,R_A5,hp)));
  4346. exprasmlist^.concat(new(pai_labeled,init(A_JMP,quickexitlabel)));
  4347. end;
  4348. procedure secondas(var p : ptree);
  4349. var
  4350. pushed : tpushed;
  4351. begin
  4352. set_location(p^.location,p^.left^.location);
  4353. { save all used registers }
  4354. pushusedregisters(pushed,$ffff);
  4355. { push the vmt of the class }
  4356. exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,
  4357. S_L,newcsymbol(pobjectdef(p^.right^.resulttype)^.vmt_mangledname,0),R_SPPUSH)));
  4358. concat_external(pobjectdef(p^.right^.resulttype)^.vmt_mangledname,EXT_NEAR);
  4359. emitpushreferenceaddr(p^.location.reference);
  4360. emitcall('DO_AS',true);
  4361. popusedregisters(pushed);
  4362. end;
  4363. procedure secondis(var p : ptree);
  4364. var
  4365. pushed : tpushed;
  4366. begin
  4367. { save all used registers }
  4368. pushusedregisters(pushed,$ffff);
  4369. secondpass(p^.left);
  4370. p^.location.loc:=LOC_FLAGS;
  4371. p^.location.resflags:=F_NE;
  4372. { push instance to check: }
  4373. case p^.left^.location.loc of
  4374. LOC_REGISTER,LOC_CREGISTER:
  4375. begin
  4376. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,
  4377. S_L,p^.left^.location.register,R_SPPUSH)));
  4378. ungetregister32(p^.left^.location.register);
  4379. end;
  4380. LOC_MEM,LOC_REFERENCE:
  4381. begin
  4382. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,
  4383. S_L,newreference(p^.left^.location.reference),R_SPPUSH)));
  4384. del_reference(p^.left^.location.reference);
  4385. end;
  4386. else internalerror(100);
  4387. end;
  4388. { generate type checking }
  4389. secondpass(p^.right);
  4390. case p^.right^.location.loc of
  4391. LOC_REGISTER,LOC_CREGISTER:
  4392. begin
  4393. exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,
  4394. S_L,p^.right^.location.register,R_SPPUSH)));
  4395. ungetregister32(p^.right^.location.register);
  4396. end;
  4397. LOC_MEM,LOC_REFERENCE:
  4398. begin
  4399. exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,
  4400. S_L,newreference(p^.right^.location.reference),R_SPPUSH)));
  4401. del_reference(p^.right^.location.reference);
  4402. end;
  4403. else internalerror(100);
  4404. end;
  4405. emitcall('DO_IS',true);
  4406. exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_B,R_D0)));
  4407. popusedregisters(pushed);
  4408. end;
  4409. procedure secondwith(var p : ptree);
  4410. var
  4411. ref : treference;
  4412. symtable : psymtable;
  4413. i : longint;
  4414. begin
  4415. if assigned(p^.left) then
  4416. begin
  4417. secondpass(p^.left);
  4418. ref.symbol:=nil;
  4419. gettempofsizereference(4,ref);
  4420. exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
  4421. newreference(p^.left^.location.reference),R_A0)));
  4422. exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,
  4423. R_A0,newreference(ref))));
  4424. del_reference(p^.left^.location.reference);
  4425. { the offset relative to (%ebp) is only needed here! }
  4426. symtable:=p^.withsymtable;
  4427. for i:=1 to p^.tablecount do
  4428. begin
  4429. symtable^.datasize:=ref.offset;
  4430. symtable:=symtable^.next;
  4431. end;
  4432. { p^.right can be optimize out !!! }
  4433. if p^.right<>nil then
  4434. secondpass(p^.right);
  4435. { clear some stuff }
  4436. ungetiftemp(ref);
  4437. end;
  4438. end;
  4439. procedure secondprocinline(var p:ptree);
  4440. begin
  4441. end;
  4442. procedure secondpass(var p : ptree);
  4443. const
  4444. procedures : array[ttreetyp] of secondpassproc =
  4445. (secondadd,secondadd,secondadd,secondmoddiv,secondadd,
  4446. secondmoddiv,secondassignment,secondload,secondnothing,
  4447. secondadd,secondadd,secondadd,secondadd,
  4448. secondadd,secondadd,secondin,secondadd,
  4449. secondadd,secondshlshr,secondshlshr,secondadd,
  4450. secondadd,secondsubscriptn,secondderef,secondaddr,
  4451. seconddoubleaddr,
  4452. secondordconst,secondtypeconv,secondcalln,secondnothing,
  4453. secondrealconst,secondfixconst,secondumminus,
  4454. secondasm,secondvecn,
  4455. secondstringconst,secondfuncret,secondselfn,
  4456. secondnot,secondinline,secondniln,seconderror,
  4457. secondnothing,secondhnewn,secondhdisposen,secondnewn,
  4458. secondsimplenewdispose,secondnothing,secondsetcons,secondblockn,
  4459. secondstatement,secondnothing,secondifn,secondbreakn,
  4460. secondcontinuen,second_while_repeatn,second_while_repeatn,secondfor,
  4461. secondexitn,secondwith,secondcase,secondlabel,
  4462. secondgoto,secondsimplenewdispose,secondtryexcept,secondraise,
  4463. secondnothing,secondtryfinally,secondis,secondas,seconderror,
  4464. secondfail,secondadd,secondprocinline,
  4465. secondnothing,secondloadvmt);
  4466. var
  4467. oldcodegenerror : boolean;
  4468. oldswitches : Tcswitches;
  4469. oldpos : tfileposinfo;
  4470. begin
  4471. oldcodegenerror:=codegenerror;
  4472. oldswitches:=aktswitches;
  4473. get_cur_file_pos(oldpos);
  4474. codegenerror:=false;
  4475. set_cur_file_pos(p^.fileinfo);
  4476. aktswitches:=p^.pragmas;
  4477. if not(p^.error) then
  4478. begin
  4479. procedures[p^.treetype](p);
  4480. p^.error:=codegenerror;
  4481. codegenerror:=codegenerror or oldcodegenerror;
  4482. end
  4483. else
  4484. codegenerror:=true;
  4485. aktswitches:=oldswitches;
  4486. set_cur_file_pos(oldpos);
  4487. end;
  4488. function do_secondpass(var p : ptree) : boolean;
  4489. begin
  4490. codegenerror:=false;
  4491. if not(p^.error) then
  4492. secondpass(p);
  4493. do_secondpass:=codegenerror;
  4494. end;
  4495. var
  4496. regvars : array[1..maxvarregs] of pvarsym;
  4497. regvars_para : array[1..maxvarregs] of boolean;
  4498. regvars_refs : array[1..maxvarregs] of longint;
  4499. parasym : boolean;
  4500. procedure searchregvars(p : psym);
  4501. var
  4502. i,j,k : longint;
  4503. begin
  4504. if (p^.typ=varsym) and ((pvarsym(p)^.var_options and vo_regable)<>0) then
  4505. begin
  4506. { walk through all momentary register variables }
  4507. for i:=1 to maxvarregs do
  4508. begin
  4509. { free register ? }
  4510. if regvars[i]=nil then
  4511. begin
  4512. regvars[i]:=pvarsym(p);
  4513. regvars_para[i]:=parasym;
  4514. break;
  4515. end;
  4516. { else throw out a variable ? }
  4517. j:=pvarsym(p)^.refs;
  4518. { parameter get a less value }
  4519. if parasym then
  4520. begin
  4521. if cs_littlesize in aktswitches then
  4522. dec(j,1)
  4523. else
  4524. dec(j,100);
  4525. end;
  4526. if (j>regvars_refs[i]) and (j>0) then
  4527. begin
  4528. for k:=maxvarregs-1 downto i do
  4529. begin
  4530. regvars[k+1]:=regvars[k];
  4531. regvars_para[k+1]:=regvars_para[k];
  4532. end;
  4533. { calc the new refs
  4534. pvarsym(p)^.refs:=j; }
  4535. regvars[i]:=pvarsym(p);
  4536. regvars_para[i]:=parasym;
  4537. regvars_refs[i]:=j;
  4538. break;
  4539. end;
  4540. end;
  4541. end;
  4542. end;
  4543. procedure generatecode(var p : ptree);
  4544. var
  4545. { *pass modifies with every node aktlinenr and current_module^.current_inputfile, }
  4546. { to constantly contain the right line numbers }
  4547. oldis : pinputfile;
  4548. oldnr,i : longint;
  4549. regsize : topsize;
  4550. regi : tregister;
  4551. hr : preference;
  4552. label
  4553. nextreg;
  4554. begin
  4555. cleartempgen;
  4556. oldis:=current_module^.current_inputfile;
  4557. oldnr:=current_module^.current_inputfile^.line_no;
  4558. { when size optimization only count occurrence }
  4559. if cs_littlesize in aktswitches then
  4560. t_times:=1
  4561. else
  4562. { reference for repetition is 100 }
  4563. t_times:=100;
  4564. { clear register count }
  4565. for regi:=R_D0 to R_A6 do
  4566. begin
  4567. reg_pushes[regi]:=0;
  4568. is_reg_var[regi]:=false;
  4569. end;
  4570. use_esp_stackframe:=false;
  4571. if not(do_firstpass(p)) then
  4572. begin
  4573. { max. optimizations }
  4574. { only if no asm is used }
  4575. if (cs_maxoptimieren in aktswitches) and
  4576. ((procinfo.flags and pi_uses_asm)=0) then
  4577. begin
  4578. { can we omit the stack frame ? }
  4579. { conditions:
  4580. 1. procedure (not main block)
  4581. 2. no constructor or destructor
  4582. 3. no call to other procedures
  4583. 4. no interrupt handler
  4584. }
  4585. if assigned(aktprocsym) then
  4586. begin
  4587. if (aktprocsym^.definition^.options and poconstructor+podestructor+poinline+pointerrupt=0) and
  4588. ((procinfo.flags and pi_do_call)=0) and (lexlevel>1) then
  4589. begin
  4590. { use ESP as frame pointer }
  4591. procinfo.framepointer:=R_SP;
  4592. use_esp_stackframe:=true;
  4593. { calc parameter distance new }
  4594. dec(procinfo.framepointer_offset,4);
  4595. dec(procinfo.ESI_offset,4);
  4596. dec(procinfo.retoffset,4);
  4597. dec(procinfo.call_offset,4);
  4598. aktprocsym^.definition^.parast^.call_offset:=procinfo.call_offset;
  4599. end;
  4600. end; { endif assigned }
  4601. if (p^.registers32<4) then
  4602. begin
  4603. for i:=1 to maxvarregs do
  4604. regvars[i]:=nil;
  4605. parasym:=false;
  4606. {$ifdef tp}
  4607. symtablestack^.foreach(searchregvars);
  4608. {$else}
  4609. symtablestack^.foreach(@searchregvars);
  4610. {$endif}
  4611. { copy parameter into a register ? }
  4612. parasym:=true;
  4613. {$ifdef tp}
  4614. symtablestack^.next^.foreach(searchregvars);
  4615. {$else}
  4616. symtablestack^.next^.foreach(@searchregvars);
  4617. {$endif}
  4618. { hold needed registers free }
  4619. for i:=maxvarregs downto maxvarregs-p^.registers32+1 do
  4620. regvars[i]:=nil;
  4621. { now assign register }
  4622. for i:=1 to maxvarregs do
  4623. begin
  4624. if assigned(regvars[i]) then
  4625. begin
  4626. { it is nonsens, to copy the variable to }
  4627. { a register because we need then much }
  4628. { pushes ? }
  4629. if reg_pushes[varregs[i]]>=regvars[i]^.refs then
  4630. begin
  4631. regvars[i]:=nil;
  4632. goto nextreg;
  4633. end;
  4634. { register is no longer available for }
  4635. { expressions }
  4636. { search the register which is the most }
  4637. { unused }
  4638. usableregs:=usableregs-[varregs[i]];
  4639. is_reg_var[varregs[i]]:=true;
  4640. dec(c_usableregs);
  4641. { possibly no 32 bit register are needed }
  4642. if (regvars[i]^.definition^.deftype=orddef) and
  4643. (
  4644. (porddef(regvars[i]^.definition)^.typ=bool8bit) or
  4645. (porddef(regvars[i]^.definition)^.typ=uchar) or
  4646. (porddef(regvars[i]^.definition)^.typ=u8bit) or
  4647. (porddef(regvars[i]^.definition)^.typ=s8bit)
  4648. ) then
  4649. begin
  4650. regvars[i]^.reg:=varregs[i];
  4651. regsize:=S_B;
  4652. end
  4653. else if (regvars[i]^.definition^.deftype=orddef) and
  4654. (
  4655. (porddef(regvars[i]^.definition)^.typ=u16bit) or
  4656. (porddef(regvars[i]^.definition)^.typ=s16bit)
  4657. ) then
  4658. begin
  4659. regvars[i]^.reg:=varregs[i];
  4660. regsize:=S_W;
  4661. end
  4662. else
  4663. begin
  4664. regvars[i]^.reg:=varregs[i];
  4665. regsize:=S_L;
  4666. end;
  4667. { parameter must be load }
  4668. if regvars_para[i] then
  4669. begin
  4670. { procinfo is there actual, }
  4671. { because we can't never be in a }
  4672. { nested procedure }
  4673. { when loading parameter to reg }
  4674. new(hr);
  4675. reset_reference(hr^);
  4676. hr^.offset:=pvarsym(regvars[i])^.address+procinfo.call_offset;
  4677. hr^.base:=procinfo.framepointer;
  4678. procinfo.aktentrycode^.concat(new(pai68k,op_ref_reg(A_MOVE,regsize,
  4679. hr,regvars[i]^.reg)));
  4680. unused:=unused - [regvars[i]^.reg];
  4681. end;
  4682. { procedure uses this register }
  4683. usedinproc:=usedinproc or ($800 shr word(varregs[i]));
  4684. end;
  4685. nextreg:
  4686. { dummy }
  4687. regsize:=S_W;
  4688. end;
  4689. if (verbosity and v_debug)=v_debug then
  4690. begin
  4691. for i:=1 to maxvarregs do
  4692. begin
  4693. if assigned(regvars[i]) then
  4694. Message3(cg_d_register_weight,reg2str(regvars[i]^.reg),
  4695. tostr(regvars[i]^.refs),regvars[i]^.name);
  4696. end;
  4697. end;
  4698. end;
  4699. end;
  4700. do_secondpass(p);
  4701. { all registers can be used again }
  4702. { contains both information on Address registers and data registers }
  4703. { even if they are allocated separately. }
  4704. usableregs:=[R_D0,R_D1,R_D2,R_D3,R_D4,R_D5,R_D6,R_D7,R_A0,R_A1,R_A2,R_A3,R_A4,
  4705. R_FP0,R_FP1,R_FP2,R_FP3,R_FP4,R_FP5,R_FP6,R_FP7];
  4706. c_usableregs:=4;
  4707. end;
  4708. procinfo.aktproccode^.concatlist(exprasmlist);
  4709. current_module^.current_inputfile:=oldis;
  4710. current_module^.current_inputfile^.line_no:=oldnr;
  4711. end;
  4712. end.
  4713. {
  4714. $Log$
  4715. Revision 1.8 1998-06-12 10:32:22 pierre
  4716. * column problem hopefully solved
  4717. + C vars declaration changed
  4718. Revision 1.7 1998/06/09 16:01:36 pierre
  4719. + added procedure directive parsing for procvars
  4720. (accepted are popstack cdecl and pascal)
  4721. + added C vars with the following syntax
  4722. var C calias 'true_c_name';(can be followed by external)
  4723. reason is that you must add the Cprefix
  4724. which is target dependent
  4725. Revision 1.6 1998/06/08 13:13:36 pierre
  4726. + temporary variables now in temp_gen.pas unit
  4727. because it is processor independent
  4728. * mppc68k.bat modified to undefine i386 and support_mmx
  4729. (which are defaults for i386)
  4730. Revision 1.5 1998/06/04 23:51:34 peter
  4731. * m68k compiles
  4732. + .def file creation moved to gendef.pas so it could also be used
  4733. for win32
  4734. Revision 1.4 1998/04/29 10:33:44 pierre
  4735. + added some code for ansistring (not complete nor working yet)
  4736. * corrected operator overloading
  4737. * corrected nasm output
  4738. + started inline procedures
  4739. + added starstarn : use ** for exponentiation (^ gave problems)
  4740. + started UseTokenInfo cond to get accurate positions
  4741. Revision 1.3 1998/04/07 22:45:03 florian
  4742. * bug0092, bug0115 and bug0121 fixed
  4743. + packed object/class/array
  4744. Revision 1.2 1998/03/28 23:09:54 florian
  4745. * secondin bugfix (m68k and i386)
  4746. * overflow checking bugfix (m68k and i386) -- pretty useless in
  4747. secondadd, since everything is done using 32-bit
  4748. * loading pointer to routines hopefully fixed (m68k)
  4749. * flags problem with calls to RTL internal routines fixed (still strcmp
  4750. to fix) (m68k)
  4751. * #ELSE was still incorrect (didn't take care of the previous level)
  4752. * problem with filenames in the command line solved
  4753. * problem with mangledname solved
  4754. * linking name problem solved (was case insensitive)
  4755. * double id problem and potential crash solved
  4756. * stop after first error
  4757. * and=>test problem removed
  4758. * correct read for all float types
  4759. * 2 sigsegv fixes and a cosmetic fix for Internal Error
  4760. * push/pop is now correct optimized (=> mov (%esp),reg)
  4761. Revision 1.1.1.1 1998/03/25 11:18:16 root
  4762. * Restored version
  4763. Revision 1.51 1998/03/22 12:45:37 florian
  4764. * changes of Carl-Eric to m68k target commit:
  4765. - wrong nodes because of the new string cg in intel, I had to create
  4766. this under m68k also ... had to work it out to fix potential alignment
  4767. problems --> this removes the crash of the m68k compiler.
  4768. - added absolute addressing in m68k assembler (required for Amiga startup)
  4769. - fixed alignment problems (because of byte return values, alignment
  4770. would not be always valid) -- is this ok if i change the offset if odd in
  4771. setfirsttemp ?? -- it seems ok...
  4772. Revision 1.50 2036/02/07 09:29:32 florian
  4773. * patch of Carl applied
  4774. Revision 1.49 1998/03/10 16:27:36 pierre
  4775. * better line info in stabs debug
  4776. * symtabletype and lexlevel separated into two fields of tsymtable
  4777. + ifdef MAKELIB for direct library output, not complete
  4778. + ifdef CHAINPROCSYMS for overloaded seach across units, not fully
  4779. working
  4780. + ifdef TESTFUNCRET for setting func result in underfunction, not
  4781. working
  4782. Revision 1.48 1998/03/10 15:25:31 carl
  4783. + put back $L switch for debugging
  4784. Revision 1.47 1998/03/10 04:19:24 carl
  4785. - removed string:=char optimization because would give A LOT of
  4786. register problems
  4787. Revision 1.46 1998/03/10 01:17:15 peter
  4788. * all files have the same header
  4789. * messages are fully implemented, EXTDEBUG uses Comment()
  4790. + AG... files for the Assembler generation
  4791. Revision 1.45 1998/03/09 10:44:33 peter
  4792. + string='', string<>'', string:='', string:=char optimizes (the first 2
  4793. were already in cg68k2)
  4794. Revision 1.44 1998/03/06 00:51:57 peter
  4795. * replaced all old messages from errore.msg, only ExtDebug and some
  4796. Comment() calls are left
  4797. * fixed options.pas
  4798. Revision 1.43 1998/03/05 04:37:46 carl
  4799. + small optimization
  4800. Revision 1.42 1998/03/03 04:13:31 carl
  4801. - removed generate_xxxx and put them in cga68k
  4802. Revision 1.41 1998/03/03 01:08:17 florian
  4803. * bug0105 and bug0106 problem solved
  4804. Revision 1.40 1998/03/02 16:25:25 carl
  4805. * bugfix #95
  4806. Revision 1.39 1998/03/02 01:48:11 peter
  4807. * renamed target_DOS to target_GO32V1
  4808. + new verbose system, merged old errors and verbose units into one new
  4809. verbose.pas, so errors.pas is obsolete
  4810. Revision 1.38 1998/02/25 02:36:29 carl
  4811. * small bugfix with range checking
  4812. Revision 1.37 1998/02/24 16:49:48 peter
  4813. * stackframe ommiting generated 'ret $-4'
  4814. + timer.pp bp7 version
  4815. * innr.inc are now the same files
  4816. Revision 1.36 1998/02/24 16:42:49 carl
  4817. + reinstated __EXIT
  4818. Revision 1.35 1998/02/23 02:56:38 carl
  4819. * bugfix of writing real type values qith m68k target
  4820. Revision 1.34 1998/02/22 23:03:05 peter
  4821. * renamed msource->mainsource and name->unitname
  4822. * optimized filename handling, filename is not seperate anymore with
  4823. path+name+ext, this saves stackspace and a lot of fsplit()'s
  4824. * recompiling of some units in libraries fixed
  4825. * shared libraries are working again
  4826. + $LINKLIB <lib> to support automatic linking to libraries
  4827. + libraries are saved/read from the ppufile, also allows more libraries
  4828. per ppufile
  4829. Revision 1.33 1998/02/22 18:50:12 carl
  4830. * bugfix of stupid diffs!!!!! Recursive crash fix!
  4831. Revision 1.30 1998/02/19 12:22:29 daniel
  4832. * Optimized a statement that did pain to my eyes.
  4833. Revision 1.29 1998/02/17 21:20:31 peter
  4834. + Script unit
  4835. + __EXIT is called again to exit a program
  4836. - target_info.link/assembler calls
  4837. * linking works again for dos
  4838. * optimized a few filehandling functions
  4839. * fixed stabs generation for procedures
  4840. Revision 1.28 1998/02/15 21:16:04 peter
  4841. * all assembler outputs supported by assemblerobject
  4842. * cleanup with assembleroutputs, better .ascii generation
  4843. * help_constructor/destructor are now added to the externals
  4844. - generation of asmresponse is not outputformat depended
  4845. Revision 1.27 1998/02/14 05:06:47 carl
  4846. + now works with TP with overlays
  4847. Revision 1.26 1998/02/14 01:45:06 peter
  4848. * more fixes
  4849. - pmode target is removed
  4850. - search_as_ld is removed, this is done in the link.pas/assemble.pas
  4851. + findexe() to search for an executable (linker,assembler,binder)
  4852. Revision 1.25 1998/02/13 10:34:40 daniel
  4853. * Made Motorola version compilable.
  4854. * Fixed optimizer
  4855. Revision 1.24 1998/02/12 11:49:45 daniel
  4856. Yes! Finally! After three retries, my patch!
  4857. Changes:
  4858. Complete rewrite of psub.pas.
  4859. Added support for DLL's.
  4860. Compiler requires less memory.
  4861. Platform units for each platform.
  4862. Revision 1.23 1998/02/07 18:00:45 carl
  4863. * bugfix in secondin (from Peter Vreman a while ago)
  4864. Revision 1.21 1998/02/05 00:58:05 carl
  4865. + secondas and secondis now work as expected.
  4866. - moved secondas to cg68k2, otherwise problems with symbols
  4867. Revision 1.20 1998/02/01 19:38:41 florian
  4868. * bug0029 fixed, Carl please check it !!!
  4869. Revision 1.19 1998/01/24 21:05:41 carl
  4870. * nested comment bugfix
  4871. Revision 1.18 1998/01/24 00:37:47 florian
  4872. * small fix for DOM
  4873. Revision 1.17 1998/01/21 21:29:46 florian
  4874. * some fixes for Delphi classes
  4875. Revision 1.16 1998/01/20 23:51:59 carl
  4876. * bugfix 74 (FINAL, Pierre's one was incomplete under BP)
  4877. Revision 1.15 1998/01/19 10:25:21 pierre
  4878. * bug in object function call in main program or unit init fixed
  4879. Revision 1.14 1998/01/16 22:34:23 michael
  4880. * Changed 'conversation' to 'conversion'. Waayyy too much chatting going on
  4881. in this compiler :)
  4882. Revision 1.13 1998/01/16 02:18:25 carl
  4883. * second_char_to_string align problem fix (N/A for MC68020 target)
  4884. Revision 1.12 1998/01/13 23:11:02 florian
  4885. + class methods
  4886. Revision 1.11 1998/01/11 03:36:14 carl
  4887. * fixed indexing problem with stack
  4888. * reference on stack bugfix
  4889. * second_bigger sign extension bugfix
  4890. * array scaling bugfix
  4891. * secondderef bugfix
  4892. * bugfix with MOVEQ opcode
  4893. * bugfix of linear list generation
  4894. Revision 1.6 1997/12/10 23:07:12 florian
  4895. * bugs fixed: 12,38 (also m68k),39,40,41
  4896. + warning if a system unit is without -Us compiled
  4897. + warning if a method is virtual and private (was an error)
  4898. * some indentions changed
  4899. + factor does a better error recovering (omit some crashes)
  4900. + problem with @type(x) removed (crashed the compiler)
  4901. Revision 1.5 1997/12/09 13:28:48 carl
  4902. + added s80 real (will presently stop the compiler though)
  4903. + renamed some stuff
  4904. * some bugfixes (can't remember what exactly..)
  4905. Revision 1.4 1997/12/05 14:51:09 carl
  4906. * bugfix of secondfor
  4907. cmpreg was never initialized.
  4908. one of the jump conditionals was wrong (downto would not work)
  4909. Revision 1.3 1997/12/04 14:47:05 carl
  4910. + updated tov09...
  4911. Revision 1.2 1997/11/28 18:14:20 pierre
  4912. working version with several bug fixes
  4913. Revision 1.1.1.1 1997/11/27 08:32:51 michael
  4914. FPC Compiler CVS start
  4915. Pre-CVS log:
  4916. CEC Carl-Eric Codere
  4917. FK Florian Klaempfl
  4918. PM Pierre Muller
  4919. + feature added
  4920. - removed
  4921. * bug fixed or changed
  4922. History (started with version 0.9.0):
  4923. 23th october 1996:
  4924. + some emit calls replaced (FK)
  4925. 24th october 1996:
  4926. * for bug fixed (FK)
  4927. 26th october 1996:
  4928. * english comments (FK)
  4929. 5th november 1996:
  4930. * new init and terminate code (FK)
  4931. ...... some items missed
  4932. 19th september 1997:
  4933. * a call to a function procedure a;[ C ]; doesn't crash the stack
  4934. furthermore (FK)
  4935. 22th september 1997:
  4936. * stack layout for nested procedures in methods modified:
  4937. ESI is no more pushed (must be loaded via framepointer) (FK)
  4938. 27th september 1997:
  4939. + Start of conversion to motorola MC68000 (CEC)
  4940. 29th september 1997:
  4941. + Updated to version 0.9.4 of Intel code generator (CEC)
  4942. 3th october 1997:
  4943. + function second_bool_to_byte for ord(boolean) (PM)
  4944. 4th october 1997: (CEC)
  4945. + first compilation
  4946. 5th octover 1997:
  4947. check floating point negate when i can test everything,
  4948. to see if it makes any sense , according SINGLE_NEG from
  4949. sozobon, it does not.??
  4950. 8th october 1997:
  4951. + ord(x) support (FK)
  4952. + some stuff for typed file support (FK)
  4953. 9 october 1997:
  4954. + converted code to motorola for v096 (CEC)
  4955. 18 october 1997:
  4956. +* removed bugs relating to floating point condition codes. (CEC).
  4957. (in secondadd).
  4958. + had to put secondadd in another routine to compile in tp. (CEC).
  4959. + updated second_bool_to_byte,secondtypeconv and secondinline, secondvecn to v097 (CEC)
  4960. + updated secondload and secondstringconst (merging duplicate strings),secondfor to v95/v97 (CEC).
  4961. + finally converted second_fix_real (very difficult and untested!). (CEC)
  4962. 23 october 1997:
  4963. * bugfix of address register in usableregs set. (They were not defined...) (CEC).
  4964. 24 october 1997:
  4965. * bugfix of scalefactor, allowed unrolled using lsl. (CEC).
  4966. 27th october 1997:
  4967. + now all general purpose registers are in the unused list, so this fixes problems
  4968. regarding pushing registers (such as d0) which were actually never used. (CEC)
  4969. + added secondin (FK) (all credit goes to him).
  4970. + converted second_real_fix thanks to Daniel Mantione for the information
  4971. he gave me on the fixed format. Thanks to W. Metzenthen who did WMEmu
  4972. (which in turn gave me information on the control word of the intel fpu). (CEC)
  4973. 23rd november 1997:
  4974. + changed second_int_real to apply correct calling conventions of rtl.
  4975. 26th november 1997:
  4976. + changed secondmoddiv to apply correct calling conventions of rtl
  4977. and also optimized it a bit.
  4978. }