12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882888388848885888688878888888988908891889288938894889588968897889888998900890189028903890489058906890789088909891089118912891389148915891689178918891989208921892289238924892589268927892889298930893189328933893489358936893789388939894089418942894389448945894689478948894989508951895289538954895589568957895889598960896189628963896489658966896789688969897089718972897389748975897689778978897989808981898289838984898589868987898889898990899189928993899489958996899789988999900090019002900390049005900690079008900990109011901290139014901590169017901890199020902190229023902490259026902790289029903090319032903390349035903690379038903990409041904290439044904590469047904890499050905190529053905490559056905790589059906090619062906390649065906690679068906990709071907290739074907590769077907890799080908190829083908490859086908790889089909090919092909390949095909690979098909991009101910291039104910591069107910891099110911191129113911491159116911791189119912091219122912391249125912691279128912991309131913291339134913591369137913891399140914191429143914491459146914791489149915091519152915391549155915691579158915991609161916291639164916591669167916891699170917191729173917491759176917791789179918091819182918391849185918691879188918991909191919291939194919591969197919891999200920192029203920492059206920792089209921092119212921392149215921692179218921992209221922292239224922592269227922892299230923192329233923492359236923792389239924092419242924392449245924692479248924992509251925292539254925592569257925892599260926192629263926492659266926792689269927092719272927392749275927692779278927992809281928292839284928592869287928892899290929192929293929492959296929792989299930093019302930393049305930693079308930993109311931293139314931593169317931893199320932193229323932493259326932793289329933093319332933393349335933693379338933993409341934293439344934593469347934893499350935193529353935493559356935793589359936093619362936393649365936693679368936993709371937293739374937593769377937893799380938193829383938493859386938793889389939093919392939393949395939693979398939994009401940294039404940594069407940894099410941194129413941494159416941794189419942094219422942394249425942694279428942994309431943294339434943594369437943894399440944194429443944494459446944794489449945094519452945394549455945694579458945994609461946294639464946594669467946894699470947194729473947494759476947794789479948094819482948394849485948694879488948994909491949294939494949594969497949894999500950195029503950495059506950795089509951095119512951395149515951695179518951995209521952295239524952595269527952895299530953195329533953495359536953795389539954095419542954395449545954695479548954995509551955295539554955595569557955895599560956195629563956495659566956795689569957095719572957395749575957695779578957995809581958295839584958595869587958895899590959195929593959495959596959795989599960096019602960396049605960696079608960996109611961296139614961596169617961896199620962196229623962496259626962796289629963096319632963396349635963696379638963996409641964296439644964596469647964896499650965196529653965496559656965796589659966096619662966396649665966696679668966996709671967296739674967596769677967896799680968196829683968496859686968796889689969096919692969396949695969696979698969997009701970297039704970597069707970897099710971197129713971497159716971797189719972097219722972397249725972697279728972997309731973297339734973597369737973897399740974197429743974497459746974797489749975097519752975397549755975697579758975997609761976297639764976597669767976897699770977197729773977497759776977797789779978097819782978397849785978697879788978997909791979297939794979597969797979897999800980198029803980498059806980798089809981098119812981398149815981698179818981998209821982298239824982598269827982898299830983198329833983498359836983798389839984098419842984398449845984698479848984998509851985298539854985598569857985898599860986198629863986498659866986798689869987098719872987398749875987698779878987998809881988298839884988598869887988898899890989198929893989498959896989798989899990099019902990399049905990699079908990999109911991299139914991599169917991899199920992199229923992499259926992799289929993099319932993399349935993699379938993999409941994299439944994599469947994899499950995199529953995499559956995799589959996099619962996399649965996699679968996999709971997299739974997599769977997899799980998199829983998499859986998799889989999099919992999399949995999699979998999910000100011000210003100041000510006100071000810009100101001110012100131001410015100161001710018100191002010021100221002310024100251002610027100281002910030100311003210033100341003510036100371003810039100401004110042100431004410045100461004710048100491005010051100521005310054100551005610057100581005910060100611006210063100641006510066100671006810069100701007110072100731007410075100761007710078100791008010081100821008310084100851008610087100881008910090100911009210093100941009510096100971009810099101001010110102101031010410105101061010710108101091011010111101121011310114101151011610117101181011910120101211012210123101241012510126101271012810129101301013110132101331013410135101361013710138101391014010141101421014310144101451014610147101481014910150101511015210153101541015510156101571015810159 |
- MODULE FoxSemanticChecker; (* AUTHOR "fof & fn"; PURPOSE "Oberon Compiler: Semantic Checker"; *)
- (* (c) fof ETHZ 2009 *)
- IMPORT D := Debugging, Basic := FoxBasic, Scanner := FoxScanner, SyntaxTree := FoxSyntaxTree,
- Diagnostics, Global := FoxGlobal, Printout:= FoxPrintout, Formats := FoxFormats, SYSTEM, Strings;
- CONST
- Trace = FALSE;
- Infinity = MAX(LONGINT); (* for type distance *)
- MaxTensorIndexOperatorSize = 4;
- UndefinedPhase = 0; DeclarationPhase=1; InlinePhase=2; ImplementationPhase=3;
- TYPE
- Position=SyntaxTree.Position;
- FileName=ARRAY 256 OF CHAR;
- LateFix= POINTER TO RECORD (* contains a late fix to be resolved in a later step: type fixes and implementations *)
- p: ANY; scope: SyntaxTree.Scope;
- next: LateFix;
- END;
- LateFixList = OBJECT (* fifo queue for items to be resolved later on - deferred fixes *)
- VAR first,last: LateFix;
- PROCEDURE & Init;
- BEGIN first := NIL; last := NIL;
- END Init;
- (* get and remove element from list *)
- PROCEDURE Get(VAR scope: SyntaxTree.Scope): ANY;
- VAR p: ANY;
- BEGIN
- IF first # NIL THEN p := first.p; scope := first.scope; first := first.next ELSE p := NIL; END;
- IF first = NIL THEN last := NIL END;
- RETURN p;
- END Get;
- (* add unresolved type to list *)
- PROCEDURE Add(p: ANY; scope: SyntaxTree.Scope);
- VAR next: LateFix;
- BEGIN
- ASSERT(scope # NIL);
- NEW(next); next.p := p; next.scope := scope;
- next.next := NIL;
- IF first = NIL THEN first := next; last := next;
- ELSE last.next := next; last := next
- END;
- END Add;
- END LateFixList;
- WithEntry = POINTER TO RECORD
- previous: WithEntry;
- symbol: SyntaxTree.Symbol;
- type: SyntaxTree.Type;
- END;
- Replacement*= POINTER TO RECORD
- name*: Basic.SegmentedName;
- expression*: SyntaxTree.Expression;
- used*: BOOLEAN;
- next*: Replacement;
- END;
- (** checker object: used to check and resolve a module
- - resolves types
- - resolves expressions
- - resolves designators
- - resolves declarations
- - resolves statements
- - resolves implementations (bodies)
- **)
- Checker*= OBJECT (SyntaxTree.Visitor)
- VAR
- module: SyntaxTree.Module;
- diagnostics: Diagnostics.Diagnostics;
- useDarwinCCalls: BOOLEAN;
- cooperative: BOOLEAN;
- error-: BOOLEAN;
- VerboseErrorMessage: BOOLEAN;
- typeFixes, pointerFixes: LateFixList;
- importCache-: SyntaxTree.ModuleScope; (* contains global imports, did not take ImportList as it was much slower, for whatever reasons *)
- arrayBaseImported: BOOLEAN;
- phase: LONGINT;
- system-: Global.System;
- symbolFileFormat-: Formats.SymbolFileFormat;
- backendName-: ARRAY 32 OF CHAR;
- (* temporary variables for the visitors
- they replace variables on a stack during use of the visitor pattern and may only be
- - set in AcceptXXX procedures
- - set and read in ResolveXXX procedures
- *)
- resolvedType: SyntaxTree.Type; (** temporary used for type resolution **)
- resolvedExpression: SyntaxTree.Expression; (** temporary variable used for expression resolution **)
- resolvedStatement: SyntaxTree.Statement; (** used for statement resolution **)
- currentScope-: SyntaxTree.Scope;
- currentIsRealtime: BOOLEAN;
- currentIsUnreachable: BOOLEAN;
- currentIsCellNet: BOOLEAN;
- currentIsBodyProcedure: BOOLEAN;
- currentIsExclusive: BOOLEAN;
- global: SyntaxTree.ModuleScope;
- withEntries: WithEntry;
- activeCellsStatement: BOOLEAN;
- replacements*: Replacement;
- cellsAreObjects: BOOLEAN;
- variableAccessed: BOOLEAN;
- PROCEDURE &InitChecker*(diagnostics: Diagnostics.Diagnostics; verboseErrorMessage,useDarwinCCalls,cooperative: BOOLEAN; system: Global.System; symbolFileFormat: Formats.SymbolFileFormat; VAR importCache: SyntaxTree.ModuleScope; CONST backend: ARRAY OF CHAR);
- BEGIN
- SELF.diagnostics := diagnostics;
- SELF.useDarwinCCalls := useDarwinCCalls;
- SELF.cooperative := cooperative;
- SELF.system := system;
- SELF.symbolFileFormat := symbolFileFormat;
- error := FALSE;
- NEW(typeFixes);
- NEW(pointerFixes);
- resolvedType := NIL;
- resolvedExpression := NIL;
- resolvedStatement := NIL;
- currentScope := NIL;
- IF importCache = NIL THEN importCache := SyntaxTree.NewModuleScope() END;
- SELF.importCache := importCache;
- arrayBaseImported := FALSE;
- SELF.VerboseErrorMessage := verboseErrorMessage;
- global := NIL;
- phase := UndefinedPhase;
- currentIsRealtime := FALSE;
- currentIsUnreachable := FALSE;
- currentIsCellNet := FALSE;
- currentIsBodyProcedure := FALSE;
- currentIsExclusive := FALSE;
- withEntries := NIL;
- SELF.cellsAreObjects := system.cellsAreObjects;
- COPY(backend, backendName);
- END InitChecker;
- (** report error **)
- PROCEDURE Error(position: Position; CONST message: ARRAY OF CHAR);
- VAR errModule: SyntaxTree.Module;
- BEGIN
- ASSERT(currentScope # NIL);
- IF module # NIL THEN errModule := module ELSE errModule := currentScope.ownerModule END;
- Basic.ErrorC(diagnostics, errModule.sourceName, position, Diagnostics.Invalid, message);
- error := TRUE;
- END Error;
- PROCEDURE Warning(position: Position; CONST message: ARRAY OF CHAR);
- VAR errModule: SyntaxTree.Module;
- BEGIN
- IF module # NIL THEN errModule := module ELSE errModule := currentScope.ownerModule END;
- Basic.Warning(diagnostics, errModule.sourceName, position, message);
- END Warning;
- PROCEDURE ErrorSS(position: Position; CONST msg,msg2: ARRAY OF CHAR);
- VAR errorMessage: ARRAY 256 OF CHAR;
- BEGIN
- Basic.Concat(errorMessage,msg," ", msg2);
- Basic.Error(diagnostics, currentScope.ownerModule.sourceName, position, errorMessage);
- error := TRUE;
- END ErrorSS;
- PROCEDURE InfoSS(position: Position; CONST msg1: ARRAY OF CHAR; CONST s: Basic.String);
- VAR msg, msg2: ARRAY 256 OF CHAR;
- BEGIN
- COPY(msg1, msg);
- Strings.Append(msg, " = ");
- Basic.GetString(s, msg2);
- Strings.Append(msg, msg2);
- Basic.Information(diagnostics, currentScope.ownerModule.sourceName, position, msg);
- END InfoSS;
- (*** symbol lookup ***)
- (** find a symbol in the current scope, traverse to outer scope if traverse=true and no symbol found yet
- **)
- PROCEDURE Find(inScope: SyntaxTree.Scope; name: SyntaxTree.Identifier; traverse: BOOLEAN): SyntaxTree.Symbol;
- VAR
- scope,baseScope: SyntaxTree.Scope;
- symbol, s: SyntaxTree.Symbol;
- ownerRecord,base: SyntaxTree.RecordType;
- BEGIN
- scope := inScope;
- symbol := NIL;
- WHILE (scope # NIL) & (symbol = NIL) DO
- symbol := scope.FindSymbol(name);
- s := NIL;
- IF (symbol # NIL) & (symbol.access * SyntaxTree.Public = {}) & (symbol.scope IS SyntaxTree.CellScope) (* hidden copies of parameters *) THEN
- s := symbol.scope(SyntaxTree.CellScope).ownerCell.FindParameter(name);
- ELSIF (symbol = NIL) & (scope IS SyntaxTree.CellScope) THEN
- symbol := scope(SyntaxTree.CellScope).ownerCell.FindParameter(name);
- END;
- IF (symbol # NIL) & (symbol IS SyntaxTree.Parameter) & (symbol.scope IS SyntaxTree.CellScope) THEN (* ok, symbol auto-export in scope *)
- ELSIF s # NIL THEN (* hidden variable shadows port parameter *)
- ELSE
- WHILE (symbol # NIL) & (symbol.scope.ownerModule # currentScope.ownerModule) & (symbol.access * SyntaxTree.Public = {}) DO
- (* found symbol in different module, but is it not exported, can we go on searching in record base scopes ? *)
- symbol.MarkUsed;
- IF (symbol.scope IS SyntaxTree.RecordScope) THEN
- ownerRecord := symbol.scope(SyntaxTree.RecordScope).ownerRecord;
- base := RecordBase(ownerRecord);
- IF (base # NIL) THEN
- baseScope := base.recordScope;
- symbol := Find(baseScope,name,FALSE);
- ELSE
- symbol := NIL;
- END;
- ELSE
- symbol := NIL;
- END;
- END;
- END;
- IF traverse THEN scope := scope.outerScope ELSE scope := NIL END;
- END;
- IF (symbol # NIL) THEN
- IF ~(SyntaxTree.Resolved IN symbol.state) THEN
- ASSERT(phase = DeclarationPhase);
- ResolveSymbol(symbol)
- END;
- symbol.MarkUsed;
- END;
- RETURN symbol
- END Find;
- (*** types ***)
- (** find type declaration with name qualifiedIdentifier and return resolved type
- - check qualified identifier prefix, set scope to module scope if appropriate
- - check suffix in scope
- **)
- PROCEDURE ResolveNamedType(qualifiedIdentifier: SyntaxTree.QualifiedIdentifier; VAR typeDeclaration: SyntaxTree.TypeDeclaration): SyntaxTree.Type;
- VAR prevScope: SyntaxTree.Scope; symbol: SyntaxTree.Symbol; result:SyntaxTree.Type;
- BEGIN
- result := NIL;
- prevScope := currentScope;
- IF (qualifiedIdentifier.prefix # SyntaxTree.invalidIdentifier) THEN
- symbol := Find(currentScope,qualifiedIdentifier.prefix,TRUE);
- IF (symbol # NIL) & (symbol IS SyntaxTree.Import) THEN
- IF symbol(SyntaxTree.Import).module = NIL THEN
- Error(qualifiedIdentifier.position,"module not loaded");
- result := SyntaxTree.invalidType;
- symbol := NIL;
- ELSE
- currentScope := symbol(SyntaxTree.Import).module.moduleScope;
- symbol := Find(currentScope,qualifiedIdentifier.suffix,FALSE);
-
- IF (symbol = NIL) OR (symbol.access * SyntaxTree.Public = {}) THEN
- IF VerboseErrorMessage THEN
- Printout.Info("scope", currentScope);
- Printout.Info("symbol", symbol);
- END;
- Error(qualifiedIdentifier.position,"undeclared identifier (prefix-suffix)")
- END;
- END;
- ELSE
- D.Str0(qualifiedIdentifier.prefix);D.Ln;
- Error(qualifiedIdentifier.position,"prefix does not denote a module name");
- symbol := NIL;
- END;
- ELSE
- symbol := Find(currentScope,qualifiedIdentifier.suffix,TRUE);
- IF symbol = NIL THEN
- Error(qualifiedIdentifier.position,"undeclared identifier (qualident suffix)");
- IF VerboseErrorMessage THEN
- Printout.Info("Qualident",qualifiedIdentifier);
- Printout.Info("in scope",currentScope) ;
- END;
- END;
- END;
- IF symbol = NIL THEN (* error already handled *)
- typeDeclaration := NIL;
- result := SyntaxTree.invalidType;
- ELSIF ~(symbol IS SyntaxTree.TypeDeclaration) THEN
- Error(qualifiedIdentifier.position,"symbol does not denote a type");
- typeDeclaration := NIL;
- result := SyntaxTree.invalidType;
- ELSE
- currentScope := symbol.scope;
- typeDeclaration := symbol(SyntaxTree.TypeDeclaration);
- result := ResolveType(typeDeclaration.declaredType);
- symbol.MarkUsed;
- ASSERT(result # NIL);
- END;
- currentScope := prevScope;
- RETURN result
- END ResolveNamedType;
- (** Check if a node has already been resolved. If not then mark as currently being resolved.
- If node is currently being resolved then emit a cyclic definition error.
- Return TRUE only if node is fully resolved.
- **)
- PROCEDURE TypeNeedsResolution(x: SyntaxTree.Type): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- IF SyntaxTree.Resolved IN x.state THEN
- result := FALSE
- ELSIF SyntaxTree.BeingResolved IN x.state THEN
- Error(x.position,"cyclic definition");
- result := FALSE;
- ELSE
- result := TRUE;
- x.SetState(SyntaxTree.BeingResolved)
- END;
- RETURN result
- END TypeNeedsResolution;
- (** Return invalid type if x is currently being resolved, return x otherwise**)
- PROCEDURE ResolvedType(x: SyntaxTree.Type): SyntaxTree.Type;
- BEGIN
- IF SyntaxTree.Resolved IN x.state THEN
- RETURN x
- ELSE
- RETURN SyntaxTree.invalidType
- END;
- END ResolvedType;
- PROCEDURE VisitType(x: SyntaxTree.Type);
- BEGIN
- ASSERT(x = SyntaxTree.invalidType);
- END VisitType;
- (** resolve basic type **)
- PROCEDURE VisitBasicType(x: SyntaxTree.BasicType);
- BEGIN
- IF TypeNeedsResolution(x) THEN
- x.SetState(SyntaxTree.Resolved);
- END;
- resolvedType := ResolvedType(x)
- END VisitBasicType;
- PROCEDURE VisitByteType(x: SyntaxTree.ByteType);
- BEGIN
- VisitBasicType(x);
- END VisitByteType;
- (** resolve character type **)
- PROCEDURE VisitCharacterType(x: SyntaxTree.CharacterType);
- BEGIN
- VisitBasicType(x);
- END VisitCharacterType;
- PROCEDURE VisitBooleanType(x: SyntaxTree.BooleanType);
- BEGIN
- VisitBasicType(x);
- END VisitBooleanType;
- PROCEDURE VisitSetType(x: SyntaxTree.SetType);
- BEGIN
- VisitBasicType(x);
- END VisitSetType;
- PROCEDURE VisitAddressType(x: SyntaxTree.AddressType);
- BEGIN
- VisitBasicType(x);
- END VisitAddressType;
- PROCEDURE VisitSizeType(x: SyntaxTree.SizeType);
- BEGIN
- VisitBasicType(x);
- END VisitSizeType;
- PROCEDURE VisitAnyType(x: SyntaxTree.AnyType);
- BEGIN
- VisitBasicType(x);
- END VisitAnyType;
- PROCEDURE VisitObjectType(x: SyntaxTree.ObjectType);
- BEGIN
- VisitBasicType(x);
- END VisitObjectType;
- PROCEDURE VisitNilType(x: SyntaxTree.NilType);
- BEGIN
- VisitBasicType(x);
- END VisitNilType;
- (** resolve integer type **)
- PROCEDURE VisitIntegerType(x: SyntaxTree.IntegerType);
- BEGIN
- VisitBasicType(x);
- END VisitIntegerType;
- (** resolve real type **)
- PROCEDURE VisitFloatType(x: SyntaxTree.FloatType);
- BEGIN
- VisitBasicType(x);
- END VisitFloatType;
- (** resolve complex type **)
- PROCEDURE VisitComplexType(x: SyntaxTree.ComplexType);
- BEGIN
- VisitBasicType(x);
- END VisitComplexType;
- (**
- resolve string type: nothing to be done
- **)
- PROCEDURE VisitStringType(x: SyntaxTree.StringType);
- BEGIN
- IF TypeNeedsResolution(x) THEN
- x.SetState(SyntaxTree.Resolved);
- END;
- resolvedType := ResolvedType(x)
- END VisitStringType;
- (**
- check enumeration scope: enter symbols and check for duplicate names
- **)
- PROCEDURE CheckEnumerationScope(x: SyntaxTree.EnumerationScope; VAR highest: LONGINT);
- VAR e: SyntaxTree.Constant; value: SyntaxTree.Expression; nextHighest: LONGINT; prevScope: SyntaxTree.Scope;
- BEGIN
- prevScope := currentScope;
- currentScope := x;
- e := x.firstConstant;
- WHILE (e # NIL) DO
- Register(e,x,FALSE);
- IF SymbolNeedsResolution(e) THEN
- IF e.value # NIL THEN
- value := ConstantExpression(e.value);
- value := NewConversion(e.position,value,x.ownerEnumeration,NIL);
- ELSE
- value := SyntaxTree.NewEnumerationValue(e.position,highest+1);
- value.SetType(x.ownerEnumeration);
- END;
- IF (value.resolved # NIL) & (value.resolved IS SyntaxTree.EnumerationValue) THEN
- nextHighest := value.resolved(SyntaxTree.EnumerationValue).value;
- IF nextHighest > highest THEN highest := nextHighest END;
- END;
- e.SetValue(value);
- CheckSymbolVisibility(e);
- e.SetType(x.ownerEnumeration);
- e.SetState(SyntaxTree.Resolved);
- END;
- e := e.nextConstant;
- END;
- currentScope := prevScope;
- END CheckEnumerationScope;
- (**
- resolve enumeration type: check enumeration scope
- **)
- PROCEDURE VisitEnumerationType(x: SyntaxTree.EnumerationType);
- VAR position: Position; baseScope: SyntaxTree.EnumerationScope; baseType,resolved: SyntaxTree.Type; enumerationBase: SyntaxTree.EnumerationType;
- lowest, highest: LONGINT;
- BEGIN
- IF TypeNeedsResolution(x) THEN
- IF x.enumerationBase # NIL THEN
- position := x.enumerationBase.position;
- baseType := ResolveType(x.enumerationBase);
- resolved := baseType.resolved;
- baseScope := NIL;
- IF resolved = SyntaxTree.invalidType THEN (* error already handled *)
- ELSIF ~(resolved IS SyntaxTree.EnumerationType) THEN
- Error(position, "base type is no enumeration type");
- ELSE
- enumerationBase := resolved(SyntaxTree.EnumerationType);
- lowest := enumerationBase.rangeHighest+1;
- END;
- x.SetEnumerationBase(baseType);
- ELSE lowest := 0;
- END;
- highest := lowest-1;
- CheckEnumerationScope(x.enumerationScope, highest);
- x.SetRange(lowest, highest);
- x.SetState(SyntaxTree.Resolved);
- END;
- resolvedType := ResolvedType(x);
- END VisitEnumerationType;
- (**
- resolve range type: nothing to be done
- **)
- PROCEDURE VisitRangeType(x: SyntaxTree.RangeType);
- BEGIN
- IF TypeNeedsResolution(x) THEN
- x.SetState(SyntaxTree.Resolved);
- END;
- resolvedType := ResolvedType(x)
- END VisitRangeType;
- (**
- resolve qualified type
- - find and resolve named type and set resolved type
- **)
- PROCEDURE VisitQualifiedType(x: SyntaxTree.QualifiedType);
- VAR type: SyntaxTree.Type; typeDeclaration: SyntaxTree.TypeDeclaration;
- BEGIN
- IF TypeNeedsResolution(x) THEN
- type := ResolveNamedType(x.qualifiedIdentifier, typeDeclaration);
- x.SetResolved(type.resolved);
- x.SetState(SyntaxTree.Resolved);
- x.SetTypeDeclaration (typeDeclaration);
- ELSIF ~(SyntaxTree.Resolved IN x.state) THEN
- x.SetResolved(SyntaxTree.invalidType);
- END;
- resolvedType := x;
- END VisitQualifiedType;
- (**
- resolve array type
- - check base type
- - array of math array forbidden
- - static array of open array forbidden
- **)
- PROCEDURE VisitArrayType(x: SyntaxTree.ArrayType);
- VAR arrayBase: SyntaxTree.Type; e: SyntaxTree.Expression; pointerType: SyntaxTree.PointerType;
- BEGIN
- IF TypeNeedsResolution(x) THEN
- x.SetArrayBase(ResolveType(x.arrayBase));
- IF x.arrayBase.resolved.isRealtime THEN x.SetRealtime(TRUE) END;
- arrayBase := x.arrayBase.resolved;
- IF (arrayBase IS SyntaxTree.CellType) (*& (cellsAreObjects)*) THEN
- pointerType := SyntaxTree.NewPointerType(x.position, x.scope);
- pointerType.SetPointerBase(arrayBase);
- pointerType.SetHidden(TRUE);
- IF x.arrayBase IS SyntaxTree.QualifiedType THEN
- x.arrayBase(SyntaxTree.QualifiedType).SetResolved(pointerType)
- ELSE
- x.SetArrayBase(pointerType);
- END;
- END;
- IF x.length # NIL THEN
-
- variableAccessed := FALSE;
- e := ResolveExpression(x.length);
-
- IF (e.resolved = NIL) THEN
- IF variableAccessed THEN
- Error(e.position, "forbidden variable access");
- END;
- x.SetLength(e); x.SetForm(SyntaxTree.SemiDynamic);
- ELSE
- x.SetLength(ConstantIntegerGeq0(e (*x.length*)));
- END;
- END;
- IF arrayBase IS SyntaxTree.ArrayType THEN
- IF (x.form = SyntaxTree.Static) & (arrayBase(SyntaxTree.ArrayType).form = SyntaxTree.Open) THEN
- Error(x.position,"forbidden static array of dynamic array");
- END;
- ELSIF arrayBase IS SyntaxTree.MathArrayType THEN
- Error(x.position,"forbidden array mixed form");
- END;
- x.SetHasPointers(arrayBase.hasPointers);
- x.SetState(SyntaxTree.Resolved);
- END;
- resolvedType := ResolvedType(x);
- END VisitArrayType;
- PROCEDURE ImportModule(name: SyntaxTree.Identifier; position: Position);
- VAR module: SyntaxTree.Module; import, duplicate: SyntaxTree.Import; moduleScope: SyntaxTree.ModuleScope;
- BEGIN
- module := currentScope.ownerModule;
- IF module.name=name THEN
- (* do nothing *)
- ELSE
- moduleScope := module.moduleScope;
- import := moduleScope.FindImport(name);
- IF import = NIL THEN
- import := SyntaxTree.NewImport(position,name,name,TRUE);
- moduleScope.AddImport(import);
- Register(import,moduleScope,FALSE);
- IF import.context = SyntaxTree.invalidIdentifier THEN import.SetContext(SELF.module.context) END;
- VisitImport(import);
- ELSIF import.direct=FALSE THEN
- import.SetScope(module.moduleScope);
- import.SetDirect(TRUE);
- IF moduleScope.FindSymbol(import.name) = NIL THEN
- duplicate := SyntaxTree.NewImport(Basic.invalidPosition,import.name, import.name,FALSE);
- duplicate.SetContext(import.context);
- duplicate.SetModule(import.module);
- Register(duplicate,moduleScope,TRUE);
- VisitImport(duplicate);
- END;
- END;
- import.MarkUsed
- END;
- END ImportModule;
- (**
- resolve math array type
- - check base type
- - open math array of array forbidden
- - math array of tensor forbidden
- - static array of open array forbidden
- **)
- PROCEDURE VisitMathArrayType(x: SyntaxTree.MathArrayType);
- VAR arrayBase: SyntaxTree.Type;
- BEGIN
- IF TypeNeedsResolution(x) THEN
- x.SetArrayBase(ResolveType(x.arrayBase));
- IF x.length # NIL THEN
- x.SetLength(ConstantIntegerGeq0(x.length));
- END;
- arrayBase := x.arrayBase;
- IF arrayBase # NIL THEN
- arrayBase := arrayBase.resolved;
- IF arrayBase = SyntaxTree.invalidType THEN
- (* error already handled *)
- ELSIF arrayBase IS SyntaxTree.ArrayType THEN
- Error(x.position,"forbidden array mixed form");
- ELSIF arrayBase IS SyntaxTree.MathArrayType THEN
- IF (x.form = SyntaxTree.Tensor) OR (arrayBase(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) THEN
- Error(x.position,"forbidden Tensor Array mix")
- ELSIF (x.form=SyntaxTree.Static) & (arrayBase(SyntaxTree.MathArrayType).form # SyntaxTree.Static) THEN
- Error(x.position,"forbidden static array of dynamic array")
- END;
- END;
- IF x.form = SyntaxTree.Static THEN
- x.SetIncrement(system.SizeOf(arrayBase));
- END;
- x.SetHasPointers((x.form # SyntaxTree.Static) OR arrayBase.hasPointers);
- END;
- x.SetState(SyntaxTree.Resolved);
- END;
- resolvedType := ResolvedType(x);
- END VisitMathArrayType;
- (* anonymous type declarations are used for variables that use an anonymous type. They are not used for records that are
- pointed to by a pointer to record. The following diagram shows the possible cases for records and pointer to records.
- (1) Rec = RECORD ... END; Ptr <---> Rec
- Ptr = POINTER TO Rec; ^ |
- | |
- TypeDesc TypeDesc
- (2) Obj = POINTER TO RECORD .. END; Obj <---> Record
- ^ /
- | /
- TypeDesc <-- /
- *)
- PROCEDURE AnonymousTypeDeclaration(x: SyntaxTree.Type; CONST prefix: ARRAY OF CHAR);
- VAR typeDeclaration: SyntaxTree.TypeDeclaration; name,number: Scanner.IdentifierString;
- BEGIN
- Strings.IntToStr(x.position.start,number);
- COPY(prefix,name);
- Strings.Append(name,"@");
- Strings.Append(name,number);
- typeDeclaration := SyntaxTree.NewTypeDeclaration(x.position,SyntaxTree.NewIdentifier(name));
- typeDeclaration.SetDeclaredType(x);
- typeDeclaration.SetAccess(SyntaxTree.Hidden);
- x.SetTypeDeclaration(typeDeclaration);
- currentScope.AddTypeDeclaration(typeDeclaration);
- typeDeclaration.SetScope(currentScope);
- END AnonymousTypeDeclaration;
- (**
- deferred pointer type resolving
- - resolve base type
- - check that base type is a record or array type
- - if error then set base type to invalid type
- **)
- PROCEDURE FixPointerType(type: SyntaxTree.PointerType);
- VAR resolved, base: SyntaxTree.Type; position: Position; recordType: SyntaxTree.RecordType;
- BEGIN
- ASSERT(type.pointerBase # NIL);
- position := type.pointerBase.position;
- IF (type.pointerBase IS SyntaxTree.RecordType) THEN (* direct POINTER TO RECORD *)
- type.pointerBase(SyntaxTree.RecordType).SetPointerType(type);
- (* not for pointers, a type is needed for the records only
- IF type.typeDeclaration = NIL THEN
- AnonymousTypeDeclaration(type);
- END;
- *)
- END;
- resolved := ResolveType(type.pointerBase);
- IF (resolved.resolved IS SyntaxTree.RecordType) OR (resolved.resolved IS SyntaxTree.ArrayType) OR (resolved.resolved IS SyntaxTree.CellType) THEN
- type.SetPointerBase(resolved);
- IF (resolved.resolved IS SyntaxTree.RecordType) THEN
- recordType := resolved.resolved(SyntaxTree.RecordType);
- IF recordType.isObject & (recordType.baseType # NIL) THEN
- IF type.isRealtime & ~recordType.baseType.resolved.isRealtime THEN
- Error(position, "base type of object must be a realtime object");
- ELSIF ~type.isRealtime & recordType.baseType.resolved.isRealtime THEN
- Error(position, "extensions of realtime objects must be explicitly declared as realtime objects");
- END;
- END;
- END;
- IF type.isRealtime & ~resolved.resolved.isRealtime THEN
- Error(position, "realtime object contains references to non-realtime objects");
- END;
- IF type.isUnsafe & (resolved.resolved IS SyntaxTree.ArrayType) THEN
- (*IF ~IsOpenArray(resolved.resolved, base) THEN
- Error(position, "forbidden unsafe at static array");
- ELS
- *)
- IF IsOpenArray(resolved.resolved(SyntaxTree.ArrayType).arrayBase, base) THEN
- Error(position, "forbidden unsafe at multidimensional array");
- END;
- END;
- ELSE
- Error(position, "forbidden pointer base type");
- type.SetPointerBase(SyntaxTree.invalidType)
- END
- END FixPointerType;
- (**
- resolve pointer type
- - enter pointer type to list of deferred fixes (to avoid infinite loops in the declaration phase)
- **)
- PROCEDURE VisitPointerType(x: SyntaxTree.PointerType);
- VAR recordType: SyntaxTree.RecordType; recordBaseType: SyntaxTree.Type;
- modifiers: SyntaxTree.Modifier; position: Position;
- BEGIN
- IF TypeNeedsResolution(x) THEN
- modifiers := x.modifiers;
- x.SetRealtime(HasFlag(modifiers,Global.NameRealtime, position));
- x.SetPlain(HasFlag(modifiers,Global.NamePlain,position));
- x.SetDisposable(HasFlag(modifiers,Global.NameDisposable, position));
- x.SetUnsafe(HasFlag(modifiers,Global.NameUnsafe,position));
- (* inheritance cycle check
- example:
- A=POINTER TO RECORD(B) END;
- B=POINTER TO RECORD(A) END;
- *)
- IF x.pointerBase IS SyntaxTree.RecordType THEN
- recordType := x.pointerBase(SyntaxTree.RecordType);
- IF x.isRealtime THEN recordType.SetRealtime(TRUE) END;
- recordBaseType := ResolveType(recordType.baseType);
- recordType.SetBaseType(recordBaseType);
- recordType.SetProtected(HasFlag(modifiers, Global.NameExclusive, position));
- END;
- CheckModifiers(modifiers, TRUE);
- typeFixes.Add(x,currentScope);
- x.SetState(SyntaxTree.Resolved);
- END;
- resolvedType := ResolvedType(x)
- END VisitPointerType;
- (**
- resolve port type
- - enter port type to list of deferred fixes (to avoid infinite loops in the declaration phase)
- **)
- PROCEDURE VisitPortType(x: SyntaxTree.PortType);
- VAR value: LONGINT;
- BEGIN
- IF TypeNeedsResolution(x) THEN
- x.SetCellsAreObjects(cellsAreObjects);
- x.SetSizeExpression(ResolveExpression(x.sizeExpression));
- IF (x.sizeExpression # NIL) & CheckPositiveIntegerValue(x.sizeExpression,value,FALSE) THEN
- x.SetSize(value)
- ELSE
- x.SetSize(system.SizeOf(system.longintType));
- END;
- x.SetState(SyntaxTree.Resolved);
- END;
- resolvedType := ResolvedType(x)
- END VisitPortType;
- (**
- deferred procedure type resolving
- - resolve return type
- - traverse and resolve parameters
- **)
- PROCEDURE FixProcedureType(procedureType: SyntaxTree.ProcedureType);
- VAR resolved: SyntaxTree.Type; parameter: SyntaxTree.Parameter;
- BEGIN
- resolved := ResolveType(procedureType.returnType);
- IF (resolved # NIL) & (resolved.resolved IS SyntaxTree.ArrayType) & (resolved.resolved(SyntaxTree.ArrayType).length = NIL) THEN
- Error(procedureType.position,"forbidden open array return type");
- ELSIF (resolved # NIL) & (procedureType.noReturn) THEN
- Error(procedureType.position,"procedure with return type does not return");
- END;
- procedureType.SetReturnType(resolved);
- IF (resolved # NIL) & StructuredReturnType (procedureType) THEN
- parameter := SyntaxTree.NewParameter(procedureType.position,procedureType,Global.ResultName, SyntaxTree.VarParameter);
- parameter.SetType(procedureType.returnType);
- parameter.SetAccess(SyntaxTree.Hidden);
- parameter.SetUntraced(procedureType.hasUntracedReturn);
- VisitParameter(parameter);
- procedureType.SetReturnParameter(parameter); (* return parameter serves as a cache only *)
- END;
- (* process parameters *)
- parameter :=procedureType.firstParameter;
- WHILE (parameter # NIL) DO
- VisitParameter(parameter);
- parameter := parameter.nextParameter;
- END;
- parameter := procedureType.selfParameter;
- IF parameter # NIL THEN
- VisitParameter(parameter)
- END;
- END FixProcedureType;
- PROCEDURE HasFlag(VAR modifiers: SyntaxTree.Modifier; name: SyntaxTree.Identifier; VAR position: Position): BOOLEAN;
- VAR prev,this: SyntaxTree.Modifier;
- BEGIN
- this := modifiers;prev := NIL;
- WHILE (this # NIL) & (this.identifier # name) DO
- prev := this; this := this.nextModifier;
- END;
- IF this # NIL THEN
- IF this.expression # NIL THEN
- Error(this.position,"unexpected expression");
- END;
- this.Resolved;
- position := this.position;
- RETURN TRUE
- ELSE
- RETURN FALSE
- END;
- END HasFlag;
- PROCEDURE HasValue(modifiers: SyntaxTree.Modifier; name: SyntaxTree.Identifier; VAR position: Position; VAR value: LONGINT): BOOLEAN;
- VAR prev,this: SyntaxTree.Modifier;
- BEGIN
- this := modifiers;prev := NIL;
- WHILE (this # NIL) & (this.identifier # name) DO
- prev := this; this := this.nextModifier;
- END;
- IF this # NIL THEN
- IF this.expression = NIL THEN
- Error(this.position,"expected expression value");
- ELSE
- this.SetExpression(ConstantExpression(this.expression));
- IF CheckIntegerValue(this.expression,value) THEN END;
- END;
- this.Resolved;
- position := this.position;
- RETURN TRUE
- ELSE RETURN FALSE
- END;
- END HasValue;
- PROCEDURE HasStringValue(modifiers: SyntaxTree.Modifier; name: SyntaxTree.Identifier; VAR position: Position; VAR value: ARRAY OF CHAR): BOOLEAN;
- VAR prev,this: SyntaxTree.Modifier;
- BEGIN
- this := modifiers;prev := NIL;
- WHILE (this # NIL) & (this.identifier # name) DO
- prev := this; this := this.nextModifier;
- END;
- IF this # NIL THEN
- IF this.expression = NIL THEN
- Error(this.position,"expected expression value");
- ELSE
- this.SetExpression(ConstantExpression(this.expression));
- IF CheckStringValue(this.expression,value) THEN END;
- END;
- this.Resolved;
- position := this.position;
- RETURN TRUE
- ELSE RETURN FALSE
- END;
- END HasStringValue;
- PROCEDURE SkipImplementation*(x: SyntaxTree.CellType): BOOLEAN;
- VAR svalue: ARRAY 32 OF CHAR; position: Position;
- BEGIN
- IF cellsAreObjects THEN RETURN FALSE END;
- IF HasStringValue(x.modifiers, Global.NameRuntime, position, svalue) THEN
- IF svalue = "A2" THEN
- RETURN TRUE
- END;
- END;
- IF (x.baseType # NIL) & (x.baseType.resolved IS SyntaxTree.CellType) THEN
- RETURN SkipImplementation(x.baseType.resolved(SyntaxTree.CellType));
- END;
- RETURN FALSE;
- (*
- (*IF cellsAreObjects THEN RETURN FALSE END;*)
- IF (backendName = "TRM") & x.isCellNet THEN RETURN TRUE END;
- IF HasStringValue(x.modifiers,Global.NameBackend,position,svalue) THEN
- IF svalue[0] = "~" THEN
- Strings.TrimLeft(svalue, "~");
- IF svalue = backendName THEN
- RETURN TRUE;
- END;
- ELSIF svalue # backendName THEN
- RETURN TRUE;
- END;
- END;
- IF (x.baseType # NIL) & (x.baseType.resolved IS SyntaxTree.CellType) THEN
- RETURN SkipImplementation(x.baseType.resolved(SyntaxTree.CellType));
- END;
- RETURN FALSE;
- *)
- END SkipImplementation;
- PROCEDURE CheckModifiers(modifiers: SyntaxTree.Modifier; checkUse: BOOLEAN);
- VAR this: SyntaxTree.Modifier;
- BEGIN
- this := modifiers;
- WHILE this # NIL DO
- IF ~this.resolved THEN
- IF checkUse THEN
- Error(this.position,"unexpected modifier");
- ELSE
- this.SetExpression(ResolveExpression(this.expression));
- this.Resolved;
- (*! sanity check for "unqualified" modifiers, as for example used in ActiveCells Engine parameterization *)
- END;
- END;
- this := this.nextModifier
- END;
- END CheckModifiers;
- (**
- resolve procedure type
- - enter procedure to list of deferred fixes (to avoid infinite loops in the declaration phase)
- **)
- PROCEDURE VisitProcedureType(procedureType: SyntaxTree.ProcedureType);
- VAR modifiers: SyntaxTree.Modifier; value: LONGINT; position: Position;
- BEGIN
- IF TypeNeedsResolution(procedureType) THEN
- modifiers := procedureType.modifiers;
- IF HasFlag(modifiers, Global.NameWinAPI,position) THEN procedureType.SetCallingConvention(SyntaxTree.WinAPICallingConvention)
- ELSIF HasFlag(modifiers, Global.NameInterrupt,position) THEN
- procedureType.SetInterrupt(TRUE);
- procedureType.SetCallingConvention(SyntaxTree.InterruptCallingConvention)
- ELSIF HasFlag(modifiers,Global.NameC,position) THEN
- IF useDarwinCCalls THEN (*fld*)
- procedureType.SetCallingConvention(SyntaxTree.DarwinCCallingConvention)
- ELSE
- procedureType.SetCallingConvention(SyntaxTree.CCallingConvention)
- END
- ELSIF HasFlag(modifiers, Global.NameNoReturn,position) THEN
- procedureType.SetNoReturn(TRUE);
- END;
- IF HasValue(modifiers,Global.NameStackAligned,position,value) THEN procedureType.SetStackAlignment(value) END;
- IF HasFlag(modifiers, Global.NameDelegate,position) THEN procedureType.SetDelegate(TRUE) END;
- IF HasFlag(modifiers, Global.NameRealtime,position) THEN procedureType.SetRealtime(TRUE) END;
- CheckModifiers(modifiers, TRUE);
-
- modifiers := procedureType.returnTypeModifiers;
- procedureType.SetUntracedReturn(HasFlag(modifiers, Global.NameUntraced, position));
- CheckModifiers(modifiers, TRUE);
-
- typeFixes.Add(procedureType,currentScope);
- procedureType.SetHasPointers(procedureType.isDelegate);
- procedureType.SetState(SyntaxTree.Resolved);
- END;
- resolvedType := ResolvedType(procedureType)
- END VisitProcedureType;
- (** check and resolve record type
- - check base type: must be record, math array or array-structured object type
- - check declarations
- - every record type is guaranteed to have a type declaration in the module scope (anonymous or not)
- **)
- PROCEDURE VisitRecordType(x: SyntaxTree.RecordType);
- VAR resolved, baseType: SyntaxTree.Type; position: Position;
- numberMethods: LONGINT; recordBase, recordType: SyntaxTree.RecordType; procedure: SyntaxTree.Procedure;
- symbol: SyntaxTree.Symbol; isRealtime: BOOLEAN;
- hasPointers: BOOLEAN;
- modifiers: SyntaxTree.Modifier;
- value: LONGINT;
- PROCEDURE IsPointerToRecord(type: SyntaxTree.Type; VAR recordType: SyntaxTree.RecordType): BOOLEAN;
- BEGIN
- type := type.resolved;
- IF (type IS SyntaxTree.PointerType) &
- (type(SyntaxTree.PointerType).pointerBase.resolved # NIL) &
- (type(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType) THEN
- recordType := type(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
- RETURN TRUE
- ELSE
- RETURN FALSE
- END;
- END IsPointerToRecord;
- BEGIN
- IF TypeNeedsResolution(x) THEN
- hasPointers := FALSE;
-
- modifiers := x.modifiers;
- IF HasValue(modifiers,Global.NameAligned,position,value) THEN x.SetAlignmentInBits(value*system.dataUnit) END;
- CheckModifiers(modifiers, TRUE);
-
- IF x.baseType # NIL THEN
- position := x.baseType.position;
- baseType := ResolveType(x.baseType);
- resolved := baseType.resolved;
- hasPointers := hasPointers OR resolved.hasPointers;
- IF x.isObject THEN (* object *)
- ASSERT(x.pointerType # NIL);
- IF resolved = SyntaxTree.invalidType THEN (* error already handled *)
- ELSIF resolved IS SyntaxTree.ObjectType THEN (* the type denoted by the <<OBJECT>> alone *)
- baseType := NIL
- ELSIF IsPointerToRecord(resolved,recordType) THEN
- IF ~recordType.isObject THEN Warning(position, "deprecated extension of record to object"); END;
- ELSIF resolved IS SyntaxTree.MathArrayType THEN
- ELSE
- Error(position,"object does not extend pointer to record, object or math array ")
- END;
- ELSIF x.pointerType # NIL THEN (* record with type declaration POINTER TO RECORD *)
- IF resolved = SyntaxTree.invalidType THEN (* error already handled *)
- ELSIF IsPointerToRecord(resolved,recordType) THEN
- IF recordType.isObject THEN Error(position,"pointer to record extends object") END;
- ELSIF resolved IS SyntaxTree.RecordType THEN
- ELSE
- Error(position,"pointer to record does not extend pointer to record or record")
- END;
- ELSE
- IF resolved IS SyntaxTree.RecordType THEN
- ELSE
- Error(position,"record does not extend record")
- END;
- END;
- x.SetBaseType(baseType);
- IF x.Level() > 15 THEN
- Error(position, "record/object inheritance level too high");
- (* note:
- the restriction to inheritance with a maximum level of 15 is caused by the implementation of the
- runtime structures: type tests are very efficient and rely on the fact that each type descriptor contains the whole
- inheritance history of a type.
- Example: let inhertitance oe given by B(A), C(B), D(C) etc.
- Then the type descriptor of G contains: A|B|C|D|E|F|G|0|0|0...
- while the type decriptor of D contains: A|B|C|D|0|0|0|0|0|0...
- *)
- END;
- IF (x.pointerType # NIL) & (resolved IS SyntaxTree.PointerType) & (x.pointerType.isDisposable # resolved(SyntaxTree.PointerType).isDisposable) THEN
- Error(position, "invalid inheritance of disposable types");
- END;
- END;
- Declarations(x.recordScope, FALSE, FALSE, TRUE);
-
- x.SetState(SyntaxTree.Resolved);
-
- Declarations(x.recordScope, FALSE, TRUE, FALSE);
- ResolveArrayStructure(x);
- (* computation of sizes and offsets skipped -> done in backend / system *)
- recordBase := x.GetBaseRecord();
- IF recordBase = NIL THEN numberMethods := 0
- ELSE numberMethods := recordBase.recordScope.numberMethods
- END;
- isRealtime := TRUE;
- IF x.isRealtime & (x.recordScope.bodyProcedure # NIL) THEN
- x.recordScope.bodyProcedure.type.SetRealtime(TRUE)
- END;
- symbol := x.recordScope.firstSymbol; (* sorted symbols, important to go through procedures in a sorted way here !*)
- WHILE symbol # NIL DO
- isRealtime := isRealtime & symbol.type.resolved.isRealtime;
- IF symbol IS SyntaxTree.Variable THEN
- hasPointers := hasPointers OR symbol.type.resolved.hasPointers & ~symbol(SyntaxTree.Variable).untraced;
- END;
- IF symbol IS SyntaxTree.Procedure THEN
- procedure := symbol(SyntaxTree.Procedure);
- IF procedure.super # NIL THEN
- procedure.SetMethodNumber(procedure.super.methodNumber)
- ELSIF InMethodTable(procedure) THEN (* not a static method *)
- procedure.SetMethodNumber(numberMethods);
- INC(numberMethods);
- END;
- IF ~x.isRealtime & procedure.type.resolved.isRealtime THEN
- Error(procedure.position,"realtime procedure in non-realtime object")
- END;
- END;
- IF x.isRealtime & ~symbol.type.resolved.isRealtime THEN
- Error(symbol.position,"non-realtime symbol in realtime object")
- END;
- symbol := symbol.nextSymbol;
- END;
- IF isRealtime THEN x.SetRealtime(TRUE) END;
- x.recordScope.SetNumberMethods(numberMethods);
- (* TODO: is this needed anymore? *)
- IF (x.isObject) & (x.baseType # NIL) & (x.baseType.resolved IS SyntaxTree.RecordType) THEN
- Error(x.position,"object extends a record")
- END;
- IF (x.typeDeclaration = NIL) THEN
- IF (x.pointerType # NIL) & (x.pointerType.resolved.typeDeclaration # NIL) THEN
- x.SetTypeDeclaration(x.pointerType.resolved.typeDeclaration);
- (*
- x.pointerType.resolved.typeDeclaration.name.GetString(name);
- AnonymousTypeDeclaration(x,name);
- *)
- ELSE
- AnonymousTypeDeclaration(x,"Anonymous");
- END;
- END;
- x.SetHasPointers(hasPointers);
- x.SetState(SyntaxTree.Resolved);
- END;
- resolvedType := ResolvedType(x);
- END VisitRecordType;
- (** check and resolve cell type
- - check base type: must be cell
- - check declarations
- - every cell type is guaranteed to have a type declaration in the module scope (anonymous or not)
- **)
- PROCEDURE VisitCellType(x: SyntaxTree.CellType);
- VAR
- symbol: SyntaxTree.Symbol; isRealtime: BOOLEAN; parameter: SyntaxTree.Parameter; type: SyntaxTree.Type; len: LONGINT;
- modifier: SyntaxTree.Modifier; position: Position; value: LONGINT; isEngine: BOOLEAN; property: SyntaxTree.Property;
- qualifiedIdentifier: SyntaxTree.QualifiedIdentifier;
- recordBase: SyntaxTree.RecordType;
- numberMethods, int: LONGINT;
- real: LONGREAL;
- bool: BOOLEAN;
- set: SET;
- v: SyntaxTree.Expression;
- str: Scanner.StringType;
- atype: SyntaxTree.ArrayType;
- prev: SyntaxTree.Scope;
- skip: BOOLEAN;
- svalue: ARRAY 32 OF CHAR;
-
- BEGIN
- IF TypeNeedsResolution(x) THEN
- recordBase := NIL;
- IF cellsAreObjects THEN
- IF x.baseType = NIL THEN
- qualifiedIdentifier := SyntaxTree.NewQualifiedIdentifier(x.position, SyntaxTree.NewIdentifier("ActiveCellsRuntime"), SyntaxTree.NewIdentifier("Cell"));
- ImportModule(qualifiedIdentifier.prefix, x.position);
- x.SetBaseType(SyntaxTree.NewQualifiedType(x.position, currentScope, qualifiedIdentifier));
- x.SetBaseType(ResolveType(x.baseType));
- recordBase := x.GetBaseRecord();
- IF recordBase = NIL THEN
- Error(x.position,"ActiveCellsRuntime.Cell not present");
- END;
- ELSE
- x.SetBaseType(ResolveType(x.baseType));
- END;
- ELSE
- x.SetBaseType(ResolveType(x.baseType));
- END;
-
- IF recordBase = NIL THEN numberMethods := 0
- ELSE numberMethods := recordBase.recordScope.numberMethods
- END;
- modifier := x.modifiers;
- (*IF ~x.isCellNet THEN*)
- IF HasValue(modifier,Global.NameDataMemorySize,position,value) THEN END;
- IF HasValue(modifier,Global.NameCodeMemorySize,position,value) THEN END;
- IF HasFlag(modifier, Global.NameEngine, position) THEN isEngine := TRUE ELSE isEngine := FALSE END;
- IF HasFlag(modifier, Global.NameVector,position) THEN END;
- IF HasFlag(modifier, Global.NameFloatingPoint, position) THEN END;
- IF HasFlag(modifier, Global.NameNoMul,position) THEN END;
- IF HasFlag(modifier, Global.NameNonBlockingIO,position) THEN END;
- IF HasFlag(modifier, Global.NameTRM, position) THEN END;
- IF HasFlag(modifier, Global.NameTRMS, position) THEN END;
- symbol := system.activeCellsCapabilities;
- WHILE symbol # NIL DO
- IF HasFlag(modifier, symbol.name, position) THEN END;
- symbol := symbol.nextSymbol;
- END;
-
- modifier := x.modifiers;
- WHILE (modifier # NIL) DO
-
- property := SyntaxTree.NewProperty(modifier.position, modifier.identifier);
-
- IF modifier.expression # NIL THEN
- v := ConstantExpression(modifier.expression);
- property.SetValue(v);
- IF IsIntegerValue(modifier.expression, int) THEN
- (*property.SetValue(modifier.expression);*)
- modifier.SetExpression(NewConversion(modifier.position, modifier.expression, system.longintType, NIL));
- property.SetType(system.longintType);
- ELSIF IsRealValue(modifier.expression, real) THEN
- modifier.SetExpression(NewConversion(modifier.position, modifier.expression, system.longrealType, NIL));
- property.SetType(system.longrealType);
- ELSIF IsBooleanValue(modifier.expression, bool) THEN
- property.SetType(system.booleanType);
- ELSIF IsSetValue(modifier.expression, set) THEN
- property.SetType(system.setType);
- ELSIF IsStringValue(modifier.expression, str) THEN
- (*property.SetValue(modifier.expression);*)
- atype := SyntaxTree.NewArrayType(Basic.invalidPosition, NIL, SyntaxTree.Static);
- atype.SetArrayBase(modifier.expression.type(SyntaxTree.StringType).baseType);
- atype.SetLength(Global.NewIntegerValue(system,Basic.invalidPosition, (* type(SyntaxTree.StringType).length *) 256 (*! check if this is a good idea *) ));
- property.SetType(atype);
-
- ELSE
- Error(modifier.position, "unsupported property type");
- END;
- ELSE (* flag property *)
- (*property.SetValue(SyntaxTree.NewBooleanValue(position,TRUE));*)
- property.SetType(system.booleanType);
- END;
- (* property.SetScope(x.cellScope); *) (* not required, will be done during entry *)
- (* property.SetState(SyntaxTree.Resolved); *) (* not required, will be done during entry *)
-
- x.AddProperty(property);
-
- modifier := modifier.nextModifier;
- END;
- CheckModifiers(modifier, FALSE);
- Declarations(x.cellScope, SkipImplementation(x),TRUE,TRUE);
-
- (* process parameters *)
- prev := currentScope;
- currentScope := x.cellScope;
- parameter :=x.firstParameter;
- WHILE (parameter # NIL) DO
- VisitParameter(parameter);
- type := parameter.type.resolved;
- IF ~(type IS SyntaxTree.PortType) THEN
- WHILE IsStaticArray(type, type, len) DO
- IF IsDynamicArray(type, type) THEN Error(parameter.position, "invalid mixture of dynamic and static array of ports") END;
- END;
- WHILE IsDynamicArray(type, type) DO
- IF IsStaticArray(type, type, len) THEN Error(parameter.position, "invalid mixture of dynamic and static array of ports") END;
- END;
- IF (* ~IsStaticArray(type,type,len) OR*) ~(type IS SyntaxTree.PortType) THEN
- Error(parameter.position, "invalid type, must be port or static array of port ");
- END;
- END;
- parameter := parameter.nextParameter;
- END;
-
- currentScope := prev;
- symbol := x.cellScope.firstSymbol; (* sorted symbols, important to go through procedures in a sorted way here !*)
- WHILE symbol # NIL DO
- IF symbol IS SyntaxTree.Variable THEN
- isRealtime := isRealtime & symbol.type.resolved.isRealtime;
- END;
- symbol := symbol.nextSymbol;
- END;
- IF isRealtime THEN x.SetRealtime(TRUE) END;
- IF (x.typeDeclaration = NIL) THEN
- AnonymousTypeDeclaration(x,"Anonymous");
- END;
- x.SetState(SyntaxTree.Resolved);
- IF (x.cellScope.bodyProcedure = NIL) & (~isEngine)THEN
- Warning(x.position, "Forbidden empty Body.");
- ELSIF (x.cellScope.bodyProcedure # NIL) & (isEngine)THEN
- Warning(x.position, "Non-empty body for an engine?");
- END;
- END;
- resolvedType := ResolvedType(x);
- END VisitCellType;
- (* check if an object is an array-structured object type
- - determine the array structure
- - collect operators from top to bottom in the inheritance hierarchy
- - check if LEN operator is declared
- - determine number of possible index operators
- - for non-tensors, check if index operators on ranges (RANGE, RANGE, ... RANGE) are present
- - for tensors, check if general index operators (ARRAY [*] OF RANGE) are present
- *)
- PROCEDURE ResolveArrayStructure*(recordType: SyntaxTree.RecordType);
- VAR
- indexOperatorCount, i: LONGINT;
- arrayAccessOperators: SyntaxTree.ArrayAccessOperators;
- isTensor: BOOLEAN;
- BEGIN
- IF recordType.isObject & (recordType.baseType # NIL) THEN
- (* determine array structure *)
- recordType.SetArrayStructure(MathArrayStructureOfType(recordType.baseType.resolved))
- END;
- IF recordType.HasArrayStructure() THEN
- (* the object is an ASOT *)
- isTensor := recordType.arrayStructure.form = SyntaxTree.Tensor;
- (* reset array access operators *)
- arrayAccessOperators.len := NIL;
- arrayAccessOperators.generalRead := NIL;
- arrayAccessOperators.generalWrite := NIL;
- IF isTensor THEN
- (* all operators of dimensionalities 1 to max *)
- indexOperatorCount := TwoToThePowerOf(MaxTensorIndexOperatorSize + 1) - 2
- ELSE
- (* all operators of certain dimensionality *)
- indexOperatorCount := TwoToThePowerOf(recordType.arrayStructure.Dimensionality())
- END;
- NEW(arrayAccessOperators.read, indexOperatorCount);
- NEW(arrayAccessOperators.write, indexOperatorCount);
- FOR i := 0 TO indexOperatorCount - 1 DO
- arrayAccessOperators.read[i] := NIL;
- arrayAccessOperators.write[i] := NIL
- END;
- (* collect access operators in the record scope *)
- CollectArrayAccessOperators(recordType.recordScope, recordType.arrayStructure, arrayAccessOperators);
- IF arrayAccessOperators.len = NIL THEN
- (* TODO: think about making this operator optional for static array structures *)
- Error(recordType.position, "LEN operator missing")
- END;
- (* show error messages *)
- IF isTensor THEN
- (* require ARRAY [*] OF RANGE *)
- IF arrayAccessOperators.generalRead = NIL THEN Error(recordType.position, "general read operator missing") END;
- IF arrayAccessOperators.generalWrite = NIL THEN Error(recordType.position, "general write operator missing") END;
- ELSE
- (* forbid ARRAY [*] OF RANGE *)
- IF arrayAccessOperators.generalRead # NIL THEN Error(recordType.position, "general read operator not applicable") END;
- IF arrayAccessOperators.generalWrite # NIL THEN Error(recordType.position, "general write operator not applicable") END;
- (* require RANGE, RANGE, ... RANGE *)
- IF arrayAccessOperators.read[indexOperatorCount - 1] = NIL THEN Error(recordType.position, "read operator on ranges missing") END;
- IF arrayAccessOperators.write[indexOperatorCount - 1] = NIL THEN Error(recordType.position, "write operator on ranges missing") END;
- END;
- recordType.SetArrayAccessOperators(arrayAccessOperators)
- ELSE
- (* make sure record scopes of non-ASOT object types do not contain operator declarations *)
- IF recordType.recordScope.firstOperator # NIL THEN
- RETURN;
- Error(recordType.recordScope.firstOperator.position, "operator declared for record type without array structure")
- END
- END
- END ResolveArrayStructure;
- (** collect array access operators in a record scope **)
- PROCEDURE CollectArrayAccessOperators(recordScope: SyntaxTree.RecordScope; arrayStructure: SyntaxTree.MathArrayType; VAR arrayAccessOperators: SyntaxTree.ArrayAccessOperators);
- VAR
- baseType: SyntaxTree.Type;
- operator: SyntaxTree.Operator;
- isReadOperator, isGeneralOperator: BOOLEAN;
- indexListSize, indexListKind, hashValue: LONGINT;
- BEGIN
- (* if a parent record scope exists, collect the operators there first *)
- baseType := recordScope.ownerRecord.baseType;
- IF (baseType # NIL) & (baseType.resolved IS SyntaxTree.PointerType) THEN
- baseType := baseType.resolved(SyntaxTree.PointerType).pointerBase.resolved
- END;
- IF (baseType # NIL) & (baseType.resolved IS SyntaxTree.RecordType) THEN
- CollectArrayAccessOperators(baseType(SyntaxTree.RecordType).recordScope, arrayStructure, arrayAccessOperators);
- END;
- (* go through all operators in the current record scope *)
- operator := recordScope.firstOperator;
- WHILE operator # NIL DO
- IF operator.name=SyntaxTree.NewIdentifier("LEN") THEN
- IF CheckLenOperator(operator, arrayStructure) THEN arrayAccessOperators.len := operator END
- ELSIF operator.name = SyntaxTree.NewIdentifier("[]") THEN
- IF CheckIndexOperator(operator, arrayStructure, isReadOperator, isGeneralOperator, indexListSize, indexListKind) THEN
- IF isGeneralOperator THEN
- IF isReadOperator THEN
- arrayAccessOperators.generalRead := operator
- ELSE
- arrayAccessOperators.generalWrite := operator
- END
- ELSE
- hashValue := IndexOperatorHash(indexListSize, indexListKind, arrayStructure.form = SyntaxTree.Tensor);
- IF isReadOperator THEN
- arrayAccessOperators.read[hashValue] := operator
- ELSE
- arrayAccessOperators.write[hashValue] := operator
- END
- END
- END
- ELSE
- Error(operator.position, 'invalid operator')
- END;
- operator := operator.nextOperator
- END
- END CollectArrayAccessOperators;
- (** the hash value of an index operator **)
- PROCEDURE IndexOperatorHash(indexListSize, indexListKind: LONGINT; isTensor: BOOLEAN): LONGINT;
- VAR result: LONGINT;
- BEGIN
- IF isTensor THEN
- IF indexListSize > MaxTensorIndexOperatorSize THEN
- result := -1 (* no fixed-dim. index operator may exist for this scenario: thus, no hash value *)
- ELSE
- result := TwoToThePowerOf(indexListSize) - 2 + indexListKind
- END
- ELSE
- result := indexListKind
- END;
- RETURN result
- END IndexOperatorHash;
- (** 2 to the power of exponent **)
- PROCEDURE TwoToThePowerOf(exponent: LONGINT): LONGINT;
- VAR result, i: LONGINT;
- BEGIN
- result := 1;
- FOR i := 1 TO exponent DO
- result := result * 2;
- END;
- RETURN result
- END TwoToThePowerOf;
- (** check if a LEN operator has a correct signature. i.e.
- for non-tensors: 'OPERATOR "LEN"(): ARRAY [<Dimensionality>] OF LONGINT;'
- for tensors (or non-tensors): 'OPERATOR "LEN"(): ARRAY [*] OF LONGINT;'
- **)
- PROCEDURE CheckLenOperator(operator: SyntaxTree.Operator; arrayStructure: SyntaxTree.MathArrayType): BOOLEAN;
- VAR
- procedureType: SyntaxTree.ProcedureType;
- returnedArrayType: SyntaxTree.MathArrayType;
- result: BOOLEAN;
- BEGIN
- result := FALSE;
- procedureType := operator.type.resolved(SyntaxTree.ProcedureType);
- IF (procedureType.numberParameters = 0) THEN
- IF (procedureType.returnType # NIL) & (procedureType.returnType.resolved IS SyntaxTree.MathArrayType) THEN
- returnedArrayType := procedureType.returnType.resolved(SyntaxTree.MathArrayType);
- IF system.longintType.SameType(returnedArrayType.arrayBase.resolved) THEN
- IF returnedArrayType.form = SyntaxTree.Open THEN
- (* ARRAY [*] OF LONGINT: acceptable for both tensors and non-tensors *)
- result := TRUE
- ELSIF arrayStructure.form # SyntaxTree.Tensor THEN
- (* ARRAY [<Dimensionality>] OF LONGINT: only acceptable for non-tensors *)
- IF (returnedArrayType.form = SyntaxTree.Static) & (returnedArrayType.staticLength = arrayStructure.Dimensionality()) THEN
- result := TRUE
- END
- END
- END
- END
- END;
- IF result THEN
- (* export symbol automatically *)
- operator.SetAccess(SyntaxTree.Public + SyntaxTree.Protected + SyntaxTree.Internal)
- ELSE
- Error(operator.position, "LEN operator with invalid signature");
- END;
- RETURN result
- END CheckLenOperator;
- (** check if an index operator has a correct signature. i.e.
- - for read operators: 'OPERATOR "[]"(<IndexParameters>): <DataType>;'
- - for write operators: 'OPERATOR "[]"(<IndexParameters>; rhs: <DataType>);'
- - for general operators: <IndexParameters> = ARRAY [*] OF RANGE
- - for fixed-dim. operators: <IndexParameters> = i0: <LONGINT/RANGE>; i1: <LONGINT/RANGE>; ...; in: <LONGINT/RANGE>
- - determine if it is a read or write operator (existance of return type)
- - check index parameters
- - for fixed-dim. operators, determine the size of the index lists, the operator handles
- - for fixed-dim. operators, determine the kind of the index list this operator handles. index lists kinds are calculated as follows:
- [LONGINT] -> binary 0 -> 0
- [RANGE] -> binary 1 -> 1
- [LONGINT, LONGINT] -> binary 00 -> 0
- [LONGINT, RANGE] -> binary 01 -> 1
- [RANGE, LONGINT] -> binary 10 -> 2
- [RANGE, RANGE] -> binary 11 -> 3
- etc.
- - for fixed-dim. operators and non-tensors, check if number of index parameters equals the ASOT's dimensionality
- - for read operators, check if return type matches the type of data that is read
- - for write operators, check if last parameter type matches the type of data that is written
- **)
- PROCEDURE CheckIndexOperator(operator: SyntaxTree.Operator; arrayStructure: SyntaxTree.MathArrayType; VAR isReadOperator, isGeneralOperator: BOOLEAN; VAR indexListSize, indexListKind: LONGINT): BOOLEAN;
- VAR
- elementType, otherElementType, dataType: SyntaxTree.Type;
- procedureType: SyntaxTree.ProcedureType;
- mathArrayType: SyntaxTree.MathArrayType;
- parameter: SyntaxTree.Parameter;
- parameterCount, rangeCount, i: LONGINT;
- hasTypeError: BOOLEAN;
- BEGIN
- procedureType := operator.type.resolved(SyntaxTree.ProcedureType);
- parameterCount := procedureType.numberParameters; (* true parameter count *)
- (* determine if it is a read or write operator *)
- isReadOperator := (procedureType.returnType # NIL);
- IF isReadOperator THEN
- indexListSize := parameterCount;
- ELSE
- indexListSize := parameterCount - 1;
- END;
- IF indexListSize < 1 THEN
- Error(operator.position, "index operator with too few parameters");
- RETURN FALSE
- END;
- IF procedureType.firstParameter.type.resolved IS SyntaxTree.MathArrayType THEN
- (* general operator *)
- isGeneralOperator := TRUE;
- IF indexListSize > 1 THEN
- Error(operator.position, "index operator with too many parameters");
- RETURN FALSE
- END;
- (* ARRAY [*] OF RANGE*)
- mathArrayType := procedureType.firstParameter.type.resolved(SyntaxTree.MathArrayType);
- IF ~((mathArrayType.arrayBase.resolved IS SyntaxTree.RangeType) & (mathArrayType.form = SyntaxTree.Open)) THEN
- Error(operator.position, "index parameter not dynamic math array of range");
- RETURN FALSE
- END;
- parameter := procedureType.firstParameter.nextParameter
- ELSE
- (* fixed-dim. operator *)
- isGeneralOperator := FALSE;
- (* check number of index parameters *)
- IF arrayStructure.form = SyntaxTree.Tensor THEN
- (* for tensors, limited to a certain size *)
- IF indexListSize > MaxTensorIndexOperatorSize THEN
- Error(operator.position, "too many index parameters for tensor");
- RETURN FALSE
- END
- ELSE
- (* for non-tensors, depends on dimensionality *)
- IF indexListSize # arrayStructure.Dimensionality() THEN
- Error(operator.position, "index parameter count does not match dimensionality");
- RETURN FALSE
- END
- END;
- (* go through all index parameters
- - count the number of ranges
- - determine the index list kind number
- *)
- indexListKind := 0;
- rangeCount := 0;
- parameter := procedureType.firstParameter;
- FOR i := 1 TO indexListSize DO
- indexListKind := indexListKind * 2;
- IF parameter.type.resolved IS SyntaxTree.IntegerType THEN
- ELSIF parameter.type.resolved IS SyntaxTree.RangeType THEN
- INC(indexListKind);
- INC(rangeCount)
- ELSE
- Error(parameter.position, "integer or range expected");
- RETURN FALSE
- END;
- parameter := parameter.nextParameter
- END;
- END;
- (*
- - for read operators: check type of last parameter
- - for write operators: check return type
- *)
- IF isReadOperator THEN
- dataType := procedureType.returnType (* the return type *)
- ELSE
- dataType := parameter.type (* the type of the last non-hidden parameter *)
- END;
- elementType := arrayStructure.ElementType();
- hasTypeError := FALSE;
- IF isGeneralOperator THEN
- (* ARRAY [?] OF <Element> *)
- IF dataType.resolved IS SyntaxTree.MathArrayType THEN
- mathArrayType := dataType.resolved(SyntaxTree.MathArrayType);
- IF ~((mathArrayType.arrayBase.resolved = elementType.resolved) & (mathArrayType.form = SyntaxTree.Tensor)) THEN
- hasTypeError := TRUE
- END
- ELSE
- hasTypeError := TRUE
- END
- ELSE
- IF rangeCount = 0 THEN
- (* <Element> *)
- IF dataType.resolved # elementType.resolved THEN hasTypeError := TRUE END
- ELSE
- (* ARRAY [*, *, ..., *] OF <Element> *)
- IF dataType.resolved IS SyntaxTree.MathArrayType THEN
- mathArrayType := dataType.resolved(SyntaxTree.MathArrayType);
- IF mathArrayType.IsFullyDynamic() THEN
- IF mathArrayType.Dimensionality() = rangeCount THEN
- otherElementType := mathArrayType.ElementType();
- IF otherElementType.resolved # elementType.resolved THEN hasTypeError := TRUE END
- ELSE
- hasTypeError := TRUE
- END
- ELSE
- hasTypeError := TRUE
- END
- ELSE
- hasTypeError := TRUE
- END
- END
- END;
- IF hasTypeError THEN
- IF isReadOperator THEN
- Error(operator.position, "return type does not match")
- ELSE
- Error(parameter.position, "type of last parameter does not match")
- END;
- RETURN FALSE
- END;
- (* export symbol automatically *)
- operator.SetAccess(SyntaxTree.Public + SyntaxTree.Protected + SyntaxTree.Internal);
- RETURN TRUE
- END CheckIndexOperator;
- (** resolve all pending types (late resolving).
- - type fixes are resolved at the end of the declaration phase
- - type fixes may imply new type fixes that are also entered at the end of the list
- **)
- PROCEDURE FixTypes;
- VAR p: ANY; prevScope: SyntaxTree.Scope;
- BEGIN
- prevScope := currentScope;
- p := typeFixes.Get(currentScope);
- WHILE p # NIL DO
- ASSERT(currentScope # NIL);
- ASSERT(p IS SyntaxTree.Type);
- IF p IS SyntaxTree.PointerType THEN
- FixPointerType(p(SyntaxTree.PointerType))
- ELSIF p IS SyntaxTree.ProcedureType THEN
- FixProcedureType(p(SyntaxTree.ProcedureType))
- ELSE
- HALT(100);
- END;
- p := typeFixes.Get(currentScope);
- END;
- currentScope :=prevScope;
- END FixTypes;
- (**
- resolve type x
- - if x is nil then return nil
- - if x cannot be resolved then the result is invalidType else the result is x
- - the resolved type is entered into x.resolved
- **)
- PROCEDURE ResolveType(x: SyntaxTree.Type): SyntaxTree.Type;
- VAR prev,resolved: SyntaxTree.Type;
- BEGIN
- prev := resolvedType;
- resolvedType := SyntaxTree.invalidType;
- IF x = NIL THEN resolvedType := NIL
- ELSE x.Accept(SELF); ASSERT(resolvedType # NIL); (* in error cases it must be invalidType *)
- END;
- resolved := resolvedType;
- resolvedType := prev;
- ASSERT((resolved = NIL) OR (resolved.resolved # NIL));
- RETURN resolved
- END ResolveType;
- (*** compatibility rules ***)
- (**
- return a regular type: if type is invalid, NIL, importType or typeDeclarationType then return invalidType else return type
- **)
- PROCEDURE RegularType(position: Position; type: SyntaxTree.Type): SyntaxTree.Type;
- VAR result: SyntaxTree.Type;
- BEGIN
- result := SyntaxTree.invalidType;
- IF type = NIL THEN Error(position, "expression of type NIL");
- ELSIF type = SyntaxTree.invalidType THEN (* error already handled *)
- ELSIF type.resolved = SyntaxTree.importType THEN Error(position, "expression is an import");
- ELSIF type.resolved = SyntaxTree.typeDeclarationType THEN Error(position, "expression is a type");
- ELSE result := type.resolved
- END;
- RETURN result
- END RegularType;
- (** returns signature compatibility of procedure types this and to
- - if not compatible then error is reported
- - compatibility means type equality
- **)
- PROCEDURE SignatureCompatible(position: Position; this, to: SyntaxTree.ProcedureType): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := SameType(to,this);
- IF ~result THEN
- Error(position, "signature incompatible");
- IF VerboseErrorMessage THEN
- Printout.Info("this",this);
- Printout.Info("to",to);
- END;
- ELSIF (to(SyntaxTree.ProcedureType).isRealtime) & ~(this(SyntaxTree.ProcedureType).isRealtime) THEN
- Error(position, "signature incompatible: realtime flag must be inherited");
- END;
- RETURN result
- END SignatureCompatible;
- (** check parameter compatibility for expressions of the form P(actual) where P = PROCEDURE([VAR|CONST] formal)
- - for var parameters compatibility means same type except for
- - formal is of open array of system byte
- - formal is of record type
- - formal is of open array type
- - formal is of open math array type
- - for value parameters compatibllity means assignment compatibility except for
- - formal is of open array type
- if compatible the return true else report error and return false
- **)
- PROCEDURE ParameterCompatible(formal: SyntaxTree.Parameter; actual: SyntaxTree.Expression): BOOLEAN;
- VAR formalType, actualType: SyntaxTree.Type; result,error: BOOLEAN;
- BEGIN
- formalType := RegularType(formal.position,formal.type);
- actualType := RegularType(actual.position,actual.type);
- error := FALSE;
- IF actualType = SyntaxTree.invalidType THEN (* error already handled *)
- ELSIF (formal.kind = SyntaxTree.VarParameter) THEN
- IF (actual IS SyntaxTree.SymbolDesignator) & (actual(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Variable) THEN
- actual(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Variable).UsedAsReference;
- END;
- IF (formal.ownerType(SyntaxTree.ProcedureType).callingConvention = SyntaxTree.WinAPICallingConvention) & (actualType IS SyntaxTree.NilType) THEN
- result := TRUE; (* special rule for WINAPI parameters, needed to be able to pass NIL address to var parameters *)
- ELSIF ~IsVariable(actual) THEN
- result := FALSE; error := TRUE;
- IF actual IS SyntaxTree.ProcedureCallDesignator THEN
- Error(actual.position,"not a variable: no operator for writing");
- ELSE
- Error(actual.position,"is not a variable");
- END;
- IF VerboseErrorMessage THEN
- Printout.Info("actual",actual);
- Printout.Info("formal",formal);
- END;
- ELSIF (formalType IS SyntaxTree.ByteType) OR (formalType IS SyntaxTree.RecordType) & (~formalType(SyntaxTree.RecordType).isObject) THEN
- result := CompatibleTo(system,actualType,formalType);
- ELSIF (formalType IS SyntaxTree.ArrayType) & (formalType(SyntaxTree.ArrayType).form = SyntaxTree.Open) THEN
- result := OpenArrayCompatible(formalType(SyntaxTree.ArrayType),actualType);
- ELSIF (formalType IS SyntaxTree.MathArrayType) THEN
- IF IsArrayStructuredObjectType(actualType) THEN
- actualType := MathArrayStructureOfType(actualType)
- END;
- result := MathArrayCompatible(formalType(SyntaxTree.MathArrayType),actualType);
- IF result & (formalType(SyntaxTree.MathArrayType).form = SyntaxTree.Static) & (actualType(SyntaxTree.MathArrayType).form # SyntaxTree.Static) THEN
- Error(actual.position,"incompatible non-static actual type");
- END;
- IF result & (actualType(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) & (formalType(SyntaxTree.MathArrayType).form # SyntaxTree.Tensor) THEN
- Error(actual.position,"incompatible tensor (use a range expression)");
- END;
- ELSE
- result := SameType(actualType,formalType)
- END
- ELSE
- IF (formalType IS SyntaxTree.CharacterType) & (actualType IS SyntaxTree.StringType) & (actualType(SyntaxTree.StringType).length = 2) THEN
- actualType := system.characterType;
- END;
- IF (formal.ownerType(SyntaxTree.ProcedureType).callingConvention = SyntaxTree.WinAPICallingConvention) & ((actualType IS SyntaxTree.NilType) OR (actualType IS SyntaxTree.AnyType)) THEN
- result := TRUE; (* special rule for WINAPI parameters *)
- ELSIF (formalType IS SyntaxTree.ArrayType) & (formalType(SyntaxTree.ArrayType).form = SyntaxTree.Open) THEN
- result := OpenArrayCompatible(formalType(SyntaxTree.ArrayType),actualType);
- ELSE
- result := CompatibleTo(system,actualType,formalType);
- IF result & (formalType IS SyntaxTree.MathArrayType) & (formalType(SyntaxTree.MathArrayType).form = SyntaxTree.Static) & (actualType(SyntaxTree.MathArrayType).form # SyntaxTree.Static) THEN
- Error(actual.position,"incompatible non-static actual type");
- END;
- END;
- END;
- IF ~result & ~error THEN
- Error(actual.position,"incompatible parameter");
- IF VerboseErrorMessage THEN
- Printout.Info("actual",actual);
- Printout.Info("formal",formal);
- END;
- END;
- RETURN result
- END ParameterCompatible;
- (** check compatibility for expressions of the form left := right
- - if compatible then return true else error report and return false
- - check if left is variable
- - check compatiblity
- **)
- PROCEDURE AssignmentCompatible(left: SyntaxTree.Designator; right: SyntaxTree.Expression): BOOLEAN;
- VAR leftType,rightType: SyntaxTree.Type; VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- leftType := RegularType(left.position,left.type);
- rightType := RegularType(right.position,right.type);
- IF (leftType IS SyntaxTree.CharacterType) & (rightType IS SyntaxTree.StringType) & (rightType(SyntaxTree.StringType).length = 2) THEN
- rightType := system.characterType; (* conversion character "x" -> string "x" *)
- END;
- (* special rule: a type is assignment compatible to an ASOT if it is assignment compatible to its structure *)
- IF IsArrayStructuredObjectType(leftType) THEN leftType := MathArrayStructureOfType(leftType) END;
- IF (leftType = SyntaxTree.invalidType) OR (rightType = SyntaxTree.invalidType) THEN
- (* error already handled *)
- result := TRUE;
- ELSIF ~IsVariable(left) THEN
- Error(left.position,"is not a variable");
- IF VerboseErrorMessage THEN
- Printout.Info("left",left);
- Printout.Info("right",right);
- END;
- ELSIF (leftType IS SyntaxTree.AddressType) & IsAddressValue(right) THEN
- result := TRUE;
- ELSIF IsUnsignedIntegerType(leftType) & IsUnsignedValue(right, leftType.sizeInBits) THEN
- result := TRUE
- ELSIF ~CompatibleTo(system,rightType,leftType) THEN
- Error(left.position,"incompatible assignment");
- IF VerboseErrorMessage THEN
- Printout.Info("left",left);
- Printout.Info("right",right);
- END;
- ELSIF (right IS SyntaxTree.SymbolDesignator) & (right(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Procedure) &
- (right(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Procedure).scope IS SyntaxTree.ProcedureScope) THEN
- Error(right.position,"forbidden assignment of a nested procedure");
- ELSE
- result := TRUE
- END;
- RETURN result
- END AssignmentCompatible;
- (*** values ***)
- (** check and resolve integer value **)
- PROCEDURE VisitIntegerValue(value: SyntaxTree.IntegerValue);
- VAR hugeint: HUGEINT;
- BEGIN
- hugeint := value(SyntaxTree.IntegerValue).hvalue;
- value.SetType(Global.GetIntegerType(system,hugeint));
- resolvedExpression := value
- END VisitIntegerValue;
- (** check and resolve real value **)
- PROCEDURE VisitRealValue(value: SyntaxTree.RealValue);
- VAR subtype: LONGINT; type: SyntaxTree.Type;
- BEGIN
- subtype := value(SyntaxTree.RealValue).subtype;
- IF subtype = Scanner.Real THEN
- type := system.realType
- ELSIF subtype = Scanner.Longreal THEN
- type := system.longrealType
- ELSE
- HALT(100)
- END;
- value.SetType(type);
- resolvedExpression := value
- END VisitRealValue;
- (** check and resolve complex value **)
- PROCEDURE VisitComplexValue(value: SyntaxTree.ComplexValue);
- VAR subtype: LONGINT; type: SyntaxTree.Type;
- BEGIN
- subtype := value(SyntaxTree.ComplexValue).subtype;
- IF subtype = Scanner.Real THEN
- type := system.complexType
- ELSIF subtype = Scanner.Longreal THEN
- type := system.longcomplexType
- ELSE
- HALT(100)
- END;
- value.SetType(type);
- resolvedExpression := value
- END VisitComplexValue;
- (** check and resolve set value **)
- PROCEDURE VisitSetValue(value: SyntaxTree.SetValue);
- BEGIN
- value.SetType(system.setType);
- resolvedExpression := value
- END VisitSetValue;
- (** check and resolve set value **)
- PROCEDURE VisitMathArrayValue(value: SyntaxTree.MathArrayValue);
- BEGIN
- value.SetType(SyntaxTree.invalidType);
- resolvedExpression := value
- END VisitMathArrayValue;
- (** check and resolve boolean value **)
- PROCEDURE VisitBooleanValue(value: SyntaxTree.BooleanValue);
- BEGIN
- value.SetType(system.booleanType);
- resolvedExpression := value
- END VisitBooleanValue;
- (** check and resolve string value **)
- PROCEDURE VisitStringValue(value: SyntaxTree.StringValue);
- BEGIN
- value.SetType(ResolveType(SyntaxTree.NewStringType(value.position,system.characterType,value.length)));
- resolvedExpression := value
- END VisitStringValue;
- (** check and resolve character value **)
- PROCEDURE VisitCharacterValue(value: SyntaxTree.CharacterValue);
- BEGIN
- value.SetType(system.characterType);
- resolvedExpression := value
- END VisitCharacterValue;
- (** check and resolve nil value **)
- PROCEDURE VisitNilValue(value: SyntaxTree.NilValue);
- BEGIN
- value.SetType(system.nilType);
- resolvedExpression := value
- END VisitNilValue;
- (** check and resolve enumerator value **)
- PROCEDURE VisitEnumerationValue(value: SyntaxTree.EnumerationValue);
- BEGIN
- value.SetType(currentScope(SyntaxTree.EnumerationScope).ownerEnumeration);
- ASSERT(value.type # NIL);
- resolvedExpression := value
- END VisitEnumerationValue;
- (*** expressions ***)
- (** check and resolve a Set expression of the form {Expression, Expression, ...}
- - check all elements on integer type
- - if element range is constant, then check lower and upper bound
- - if all elements constant then return constant set value else return set expression (via global variable resolvedExpression)
- if an error occurs then report error and return invalidExpression
- **)
- PROCEDURE VisitSet(set: SyntaxTree.Set);
- VAR
- i: LONGINT;
- element: SyntaxTree.Expression;
- constant: BOOLEAN;
- elements: SyntaxTree.ExpressionList;
- s: SET;
- result: SyntaxTree.Expression;
- value: SyntaxTree.Value;
- PROCEDURE CheckElement(element: SyntaxTree.Expression): SyntaxTree.Expression;
- VAR
- left, right: SyntaxTree.Expression;
- elementResult: SyntaxTree.Expression;
- leftInteger, rightInteger, temp: LONGINT;
- BEGIN
- (* set context of range *)
- IF element IS SyntaxTree.RangeExpression THEN
- element(SyntaxTree.RangeExpression).SetContext(SyntaxTree.SetElement)
- END;
- elementResult := ResolveExpression(element); (* implies checking of subexpressions in binary expressions *)
- IF elementResult = SyntaxTree.invalidExpression THEN
- (* error already reported *)
- constant := FALSE
- ELSIF elementResult IS SyntaxTree.RangeExpression THEN
- (* the element is a range expression *)
- (* extract left and right hand side of range *)
- left := elementResult(SyntaxTree.RangeExpression).first;
- right := elementResult(SyntaxTree.RangeExpression).last;
- (* guaranteed by VisitRangeExpression: *)
- ASSERT((left # NIL) & (right # NIL));
- ASSERT(system.longintType.SameType(left.type.resolved) & system.longintType.SameType(right.type.resolved));
- ELSE
- (* the element is not a range expression *)
- (* check type and add conversion if needed *)
- IF IsIntegerType(elementResult.type.resolved) THEN
- elementResult := NewConversion(elementResult.position, elementResult, system.sizeType, NIL)
- ELSE
- Error(elementResult.position, "non integer element in set");
- elementResult := SyntaxTree.invalidExpression;
- constant := FALSE
- END;
- left := elementResult;
- right := elementResult
- END;
- IF elementResult # SyntaxTree.invalidExpression THEN
- IF IsIntegerValue(left,leftInteger) & IsIntegerValue(right,rightInteger) THEN
- IF (leftInteger<0) OR (leftInteger >= system.setType.sizeInBits) THEN
- Error(left.position,"not allowed set integer value");
- IF (rightInteger<0) OR (rightInteger >= system.setType.sizeInBits) THEN
- Error(right.position,"not allowed set integer value");
- END
- ELSIF (rightInteger<0) OR (rightInteger >= system.setType.sizeInBits) THEN
- Error(right.position,"not allowed set integer value");
- ELSE
- IF (leftInteger > MAX(SET)) OR (rightInteger <0) THEN
- s := {};
- ELSE
- IF rightInteger > MAX(SET) THEN rightInteger := MAX(SET) END;
- IF leftInteger < 0 THEN leftInteger := 0 END;
- (*!!!!!!!!! this is a hack !!!!!!! *)
- (*! in case of MAX(SET) =31 and --bits=64 some kind of sign extension
- extends the range x..31 to x..63 !!!!!! *)
- s := s + {leftInteger..rightInteger};
- END;
- END;
- ELSE
- constant := FALSE;
- END
- END;
- RETURN elementResult
- END CheckElement;
- BEGIN
- result := set; constant := TRUE; s := {}; elements := set.elements;
- IF elements # NIL THEN
- FOR i := 0 TO elements.Length()-1 DO
- element := elements.GetExpression(i);
- element := CheckElement(element);
- IF element = SyntaxTree.invalidExpression THEN
- result := SyntaxTree.invalidExpression
- END;
- elements.SetExpression(i,element);
- END;
- END;
- IF constant THEN
- value := SyntaxTree.NewSetValue(set.position,s);
- value.SetType(system.setType);
- result.SetResolved(value);
- END;
- (* optimization possible
- convert {a,b,1,2,3,4,c,d} into {a,b,c,d} + {1,2,3,4}
- left this to the programmer...
- *)
- result.SetType(system.setType);
- resolvedExpression := result;
- END VisitSet;
- (*
- old variant: quite generic but needs better conversion handling, do this?
- PROCEDURE VisitMathArrayExpression(x: SyntaxTree.MathArrayExpression);
- VAR type: SyntaxTree.Type; position,numberElements,i: LONGINT; expression: SyntaxTree.Expression; isValue: BOOLEAN;
- value: SyntaxTree.MathArrayValue; arrayType: SyntaxTree.MathArrayType;
- BEGIN
- type := NIL;
- numberElements := x.elements.Length();
- FOR i := 0 TO numberElements-1 DO
- expression := x.elements.GetExpression(i);
- position := expression.position;
- expression := ResolveExpression(x.elements.GetExpression(i));
- x.elements.SetExpression(i,de);
- IF type = NIL THEN
- type := expression.type;
- ELSIF CompatibleTo(system,expression.type,type) THEN
- (* ok *)
- ELSIF CompatibleTo(system,type,expression.type) THEN
- type := expression.type
- ELSE
- Error(expression.position, "incompatible element types");
- type := SyntaxTree.invalidType;
- END;
- END;
- isValue := TRUE;
- FOR i := 0 TO numberElements-1 DO
- expression := NewConversion(position,x.elements.GetExpression(i),type);
- x.elements.SetExpression(i,expression);
- isValue := isValue & (expression.resolved # NIL);
- END;
- arrayType := SyntaxTree.NewMathArrayType(x.position,NIL, SyntaxTree.Static);
- arrayType.SetArrayBase(type);
- arrayType.SetLength(Global.NewIntegerValue(system,NewIntegerValue(system,rElements));
- IF isValue THEN
- value := SyntaxTree.NewMathArrayValue(position);
- value.SetElements(x.elements);
- x.SetResolved(value);
- END;
- x.SetType(arrayType);
- resolvedExpression := x;
- END VisitMathArrayExpression;
- *)
- PROCEDURE VisitMathArrayExpression(x: SyntaxTree.MathArrayExpression);
- VAR type: SyntaxTree.Type; isValue: BOOLEAN;
- value: SyntaxTree.MathArrayValue; arrayType: SyntaxTree.Type;
- PROCEDURE RecursivelyFindType(x: SyntaxTree.MathArrayExpression);
- VAR position: Position; numberElements,i: LONGINT; expression: SyntaxTree.Expression;
- BEGIN
- numberElements := x.elements.Length();
- FOR i := 0 TO numberElements-1 DO
- expression := x.elements.GetExpression(i);
- IF expression IS SyntaxTree.MathArrayExpression THEN
- RecursivelyFindType(expression(SyntaxTree.MathArrayExpression))
- ELSE
- position := expression.position;
- expression := ResolveExpression(x.elements.GetExpression(i));
- x.elements.SetExpression(i,expression);
- IF type = NIL THEN
- type := expression.type;
- ELSIF CompatibleTo(system,expression.type,type) THEN
- (* ok *)
- ELSIF CompatibleTo(system,type,expression.type) THEN
- type := expression.type
- ELSE
- Error(expression.position, "incompatible element types");
- type := SyntaxTree.invalidType;
- END;
- END;
- END;
- END RecursivelyFindType;
- PROCEDURE RecursivelySetExpression(x: SyntaxTree.MathArrayExpression);
- VAR position: Position; numberElements,i: LONGINT; expression: SyntaxTree.Expression;
- BEGIN
- numberElements := x.elements.Length();
- FOR i := 0 TO numberElements-1 DO
- expression := x.elements.GetExpression(i);
- IF expression IS SyntaxTree.MathArrayExpression THEN
- RecursivelySetExpression(expression(SyntaxTree.MathArrayExpression));
- ELSE
- position := expression.position;
- expression := NewConversion(position,x.elements.GetExpression(i),type,NIL);
- x.elements.SetExpression(i,expression);
- isValue := isValue & (expression.resolved # NIL);
- END;
- END;
- END RecursivelySetExpression;
- PROCEDURE RecursivelySetType(x: SyntaxTree.MathArrayExpression): SyntaxTree.Type;
- VAR numberElements,i,size,gsize: LONGINT; baseType: SyntaxTree.Type;expression: SyntaxTree.Expression;
- arrayType: SyntaxTree.MathArrayType;
- BEGIN
- numberElements := x.elements.Length();
- baseType := NIL;
- gsize := 0;
- FOR i := 0 TO numberElements-1 DO
- expression := x.elements.GetExpression(i);
- IF expression IS SyntaxTree.MathArrayExpression THEN
- size := expression(SyntaxTree.MathArrayExpression).elements.Length();
- IF i=0 THEN
- gsize := size;
- baseType := RecursivelySetType(expression(SyntaxTree.MathArrayExpression));
- ELSIF (baseType = type) OR (gsize # size) THEN Error(expression.position, "invalid array dimensions");
- ELSE expression.SetType(baseType)
- END;
- ELSIF baseType = NIL THEN baseType := type;
- ELSIF baseType # type THEN Error(expression.position, "invalid array dimensions");
- END;
- END;
- arrayType := SyntaxTree.NewMathArrayType(x.position,NIL, SyntaxTree.Static);
- arrayType.SetArrayBase(baseType);
- arrayType.SetLength(Global.NewIntegerValue(system,x.position,numberElements));
- RETURN ResolveType(arrayType);
- END RecursivelySetType;
- BEGIN
- type := NIL;
- RecursivelyFindType(x);
- isValue := TRUE;
- RecursivelySetExpression(x);
- arrayType := RecursivelySetType(x);
- x.SetType(arrayType);
- IF isValue THEN
- value := SyntaxTree.NewMathArrayValue(x.position);
- value.SetArray(x);
- x.SetResolved(value);
- value.SetType(arrayType);
- END;
- x.SetType(arrayType);
- resolvedExpression := x;
- END VisitMathArrayExpression;
- (** check and resolve unary expression **)
- PROCEDURE VisitUnaryExpression(unaryExpression: SyntaxTree.UnaryExpression);
- VAR
- left: SyntaxTree.Expression;
- int: HUGEINT; real, imaginary: LONGREAL; set: SET; operator: LONGINT;
- bool: BOOLEAN;
- result: SyntaxTree.Expression; type: SyntaxTree.Type; operatorCall: SyntaxTree.Expression;
- value: SyntaxTree.Value;
- BEGIN
- type := SyntaxTree.invalidType;
- left := ResolveExpression(unaryExpression.left);
- unaryExpression.SetLeft(left);
- operator := unaryExpression.operator;
- result := unaryExpression;
- IF ~system.operatorDefined[operator] THEN
- Error(left.position,"Operator Not Defined");
- RETURN
- ELSIF left.type = NIL THEN
- Error(left.position,"Invalid Nil Argument in Unary Expression");
- resolvedExpression := SyntaxTree.invalidExpression;
- RETURN
- ELSIF left = SyntaxTree.invalidExpression THEN (* error already handled *)
- RETURN
- END;
- IF ~(left.type.resolved IS SyntaxTree.BasicType) OR (left.type.resolved IS SyntaxTree.ComplexType) THEN
- operatorCall := NewOperatorCall(unaryExpression.position, operator,left,NIL,NIL);
- END;
- IF operatorCall # NIL THEN
- result := operatorCall;
- type := operatorCall.type;
- (* admissible operators
- Minus number, set
- Not boolean
- *)
- ELSE
- CASE unaryExpression.operator OF
- |Scanner.Minus:
- IF IsIntegerType(left.type.resolved) THEN
- IF left.resolved # NIL THEN
- int := -left.resolved(SyntaxTree.IntegerValue).hvalue;
- value := SyntaxTree.NewIntegerValue(unaryExpression.position,int);
- result.SetResolved(value);
- type := Global.GetIntegerType(system,int);
- value.SetType(type);
- ELSE
- type := left.type
- END
- ELSIF left.type.resolved IS SyntaxTree.FloatType THEN
- IF IsRealValue(left,real) THEN
- value := SyntaxTree.NewRealValue(unaryExpression.position,-real);
- result.SetResolved(value);
- type := left.type;
- value.SetType(type);
- ELSE
- type := left.type;
- END;
- ELSIF left.type.resolved IS SyntaxTree.SetType THEN
- IF IsSetValue(left,set) THEN
- value := SyntaxTree.NewSetValue(unaryExpression.position,-set);
- result.SetResolved(value);
- type := left.type;
- value.SetType(type);
- ELSE
- type := left.type;
- END;
- ELSIF left.type.resolved IS SyntaxTree.ComplexType THEN
- IF IsComplexValue(left, real, imaginary) THEN
- value := SyntaxTree.NewComplexValue(unaryExpression.position,-real, -imaginary);
- result.SetResolved(value);
- type := left.type;
- value.SetType(type);
- value(SyntaxTree.ComplexValue).SetSubtype(left.resolved(SyntaxTree.ComplexValue).subtype) (* reuse subtype *)
- ELSE
- type := left.type;
- END
- ELSE
- Error(left.position,"unary operator not applicable");
- END;
- |Scanner.Not:
- IF left.type.resolved IS SyntaxTree.BooleanType THEN
- IF IsBooleanValue(left,bool) THEN
- value := SyntaxTree.NewBooleanValue(unaryExpression.position,~bool);
- result.SetResolved(value);
- type := system.booleanType;
- value.SetType(type);
- ELSE
- type := system.booleanType;
- END;
- ELSE
- Error(left.position,"unary operator not applicable");
- END;
- |Scanner.Plus:
- IF (left.type.resolved IS SyntaxTree.NumberType) THEN
- result := left; type := left.type;
- ELSE
- Error(left.position,"unary operator not applicable");
- END;
- (* ADDRESS OF *)
- |Scanner.Address:
- IF HasAddress(left) THEN
- type := system.addressType;
- ELSE
- type := SyntaxTree.invalidType;
- Error(left.position,"has no address");
- Printout.Info("par", left);
- END;
- (* SIZE OF *)
- |Scanner.Size:
- IF (left.type = SyntaxTree.typeDeclarationType) THEN
- type := left(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType;
- int := system.SizeOf(type.resolved) DIV 8 (* in bytes *);
- value := SyntaxTree.NewIntegerValue(left.position, int);
- result.SetResolved(value);
- type := Global.GetIntegerType(system,int);
- value.SetType(type)
- (* was Int16 in paco but should be systemSize (conflict with current release) *)
- ELSE
- (* for variables, system sizeof could represent the physically occupied size
- determined via the type descriptor, implement that ? *)
- Error(left.position,"is not a type symbol");
- END
- (* ALIAS OF *)
- |Scanner.Alias:
- type := left.type.resolved;
- IF ~(type IS SyntaxTree.MathArrayType) THEN
- type := SyntaxTree.invalidType;
- Error(left.position,"alias on non math array type");
- END;
- ELSE
- Error(left.position,"unary operator not defined");
- END;
- END;
- result.SetType(type);
- resolvedExpression := result
- END VisitUnaryExpression;
- PROCEDURE MathArrayConversion(position: Position; expression: SyntaxTree.Expression; type: SyntaxTree.Type): SyntaxTree.Expression;
- VAR
- result: SyntaxTree.Expression;
- array: SyntaxTree.MathArrayExpression;
- value: SyntaxTree.MathArrayValue;
- isValue: BOOLEAN;
- PROCEDURE BaseType(type: SyntaxTree.Type): SyntaxTree.Type;
- BEGIN
- type := type.resolved;
- WHILE (type # NIL) & (type IS SyntaxTree.MathArrayType) DO
- type := Resolved(type(SyntaxTree.MathArrayType).arrayBase);
- END;
- WHILE (type # NIL) & (type IS SyntaxTree.ArrayType) DO
- type := Resolved(type(SyntaxTree.ArrayType).arrayBase);
- END;
- RETURN type
- END BaseType;
- PROCEDURE RecursivelyConvert(x, to: SyntaxTree.MathArrayExpression);
- VAR position: Position; numberElements,i: LONGINT; expression: SyntaxTree.Expression; array: SyntaxTree.MathArrayExpression;
- BEGIN
- numberElements := x.elements.Length();
- FOR i := 0 TO numberElements-1 DO
- expression := x.elements.GetExpression(i);
- IF expression IS SyntaxTree.MathArrayExpression THEN
- array := SyntaxTree.NewMathArrayExpression(position);
- RecursivelyConvert(expression(SyntaxTree.MathArrayExpression), array);
- expression := array;
- ELSE
- position := expression.position;
- expression := NewConversion(position,x.elements.GetExpression(i),type,NIL);
- isValue := isValue & (expression.resolved # NIL);
- END;
- to.elements.AddExpression(expression);
- END;
- END RecursivelyConvert;
- PROCEDURE RecursivelySetType(x: SyntaxTree.MathArrayExpression): SyntaxTree.Type;
- VAR numberElements,i,size,gsize: LONGINT; baseType: SyntaxTree.Type;expression: SyntaxTree.Expression;
- arrayType: SyntaxTree.MathArrayType;
- BEGIN
- numberElements := x.elements.Length();
- baseType := NIL;
- gsize := 0;
- FOR i := 0 TO numberElements-1 DO
- expression := x.elements.GetExpression(i);
- IF expression IS SyntaxTree.MathArrayExpression THEN
- size := expression(SyntaxTree.MathArrayExpression).elements.Length();
- IF i=0 THEN
- gsize := size;
- baseType := RecursivelySetType(expression(SyntaxTree.MathArrayExpression));
- ELSIF (baseType = type) OR (gsize # size) THEN Error(expression.position, "invalid array dimensions");
- ELSE expression.SetType(baseType)
- END;
- ELSIF baseType = NIL THEN baseType := type;
- ELSIF baseType # type THEN Error(expression.position, "invalid array dimensions");
- END;
- END;
- arrayType := SyntaxTree.NewMathArrayType(x.position,NIL, SyntaxTree.Static);
- arrayType.SetArrayBase(baseType);
- arrayType.SetLength(Global.NewIntegerValue(system,x.position,numberElements));
- RETURN ResolveType(arrayType);
- END RecursivelySetType;
- BEGIN
- result := SyntaxTree.invalidExpression;
- IF (BaseType(type)=NIL) OR (BaseType(expression.type.resolved).SameType(BaseType(type))) THEN
- result := expression (* do not convert *)
- ELSIF (expression.resolved # NIL) & (BaseType(type) IS SyntaxTree.BasicType) THEN (* compliance has already been checked *)
- isValue := TRUE;
- type := BaseType(type);
- array := SyntaxTree.NewMathArrayExpression(expression.position);
- RecursivelyConvert(expression(SyntaxTree.MathArrayValue).array(SyntaxTree.MathArrayExpression), array);
- value := SyntaxTree.NewMathArrayValue(array.position);
- value.SetArray(array);
- value.SetType(RecursivelySetType(array));
- result := value;
- IF ~isValue THEN Error(position, "incompatible array conversion") END;
- ELSE (* should the search for operators be restricted to the ArrayBase module here ? *)
- result := NewOperatorCall(position,Global.Conversion,expression,NIL,type);
- IF result = NIL THEN
- result := SyntaxTree.invalidExpression;
- Error(position, "incompatible conversion");
- IF VerboseErrorMessage THEN
- Printout.Info("expression",expression);
- Printout.Info("type",type);
- END;
- END;
- END;
- RETURN result
- END MathArrayConversion;
- PROCEDURE ConvertValue(position: Position; expression: SyntaxTree.Value; type: SyntaxTree.Type): SyntaxTree.Expression;
- VAR result: SyntaxTree.Expression; int: HUGEINT; real, imaginary: LONGREAL; set: SET; char: CHAR; string: Scanner.StringType;
- BEGIN
- result := expression; type := type.resolved;
- IF (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.ByteType) THEN
- (* skip, no conversion *)
- ELSIF (expression IS SyntaxTree.IntegerValue) THEN
- int := expression(SyntaxTree.IntegerValue).hvalue;
- IF (type IS SyntaxTree.IntegerType) OR (type IS SyntaxTree.SizeType) THEN
- int := Global.ConvertSigned(int,system.SizeOf(type));
- result := SyntaxTree.NewIntegerValue(position,int);
- result.SetType(type);
- ELSIF (type IS SyntaxTree.AddressType) OR IsUnsafePointer(type) THEN
- int := Global.ConvertUnsigned(int,system.SizeOf(type));
- result := SyntaxTree.NewIntegerValue(position,int);
- result.SetType(type);
- ELSIF (type IS SyntaxTree.FloatType) THEN
- result := SyntaxTree.NewRealValue(expression.position,int);
- result.SetType(type);
- ELSIF (type IS SyntaxTree.ComplexType) THEN
- result := SyntaxTree.NewComplexValue(expression.position, int, 0);
- result.SetType(type);
- ELSIF (type IS SyntaxTree.SetType) THEN
- result := SyntaxTree.NewSetValue(expression.position,SYSTEM.VAL(SET,int));
- result.SetType(type);
- ELSIF (type IS SyntaxTree.CharacterType) OR (type IS SyntaxTree.ByteType) THEN
- result := SyntaxTree.NewCharacterValue(expression.position,SYSTEM.VAL(CHAR,int));
- result.SetType(type);
- ELSIF (type IS SyntaxTree.EnumerationType) THEN
- IF (int > MAX(LONGINT)) OR (int < MIN(LONGINT)) THEN
- Error(position, "huge integer value incompatible to enumeration");
- END;
- result := SyntaxTree.NewEnumerationValue(expression.position,SHORT(int));
- result.SetType(type);
- ELSIF (type IS SyntaxTree.PortType) THEN
- result := ConvertValue(position, expression, system.integerType);
-
- ELSE
- Error(position, "integer value cannot be converted");
- result := SyntaxTree.invalidExpression;
- IF VerboseErrorMessage THEN
- Printout.Info("expression",expression);
- Printout.Info("type",type);
- END;
- END;
- ELSIF IsRealValue(expression,real) THEN
- IF (type IS SyntaxTree.IntegerType) & (type.sizeInBits < 64) THEN
- int := Global.ConvertSigned(ENTIER(real),system.SizeOf(type));
- result := SyntaxTree.NewIntegerValue(expression.position,int);
- result.SetType(type);
- ELSIF (type IS SyntaxTree.IntegerType) THEN
- int := ENTIERH(real);
- result := SyntaxTree.NewIntegerValue(expression.position,int);
- result.SetType(type);
- ELSIF (type IS SyntaxTree.FloatType) THEN
- result := SyntaxTree.NewRealValue(position,real);
- result.SetType(type);
- ELSIF (type IS SyntaxTree.ComplexType) THEN
- result := SyntaxTree.NewComplexValue(expression.position, real, 0);
- result.SetType(type);
- result(SyntaxTree.ComplexValue).UpdateSubtype;
- ELSIF (type IS SyntaxTree.PortType) THEN
- result := ConvertValue(position, expression, system.integerType);
- ELSE
- Error(position, "real value cannot be converted");
- result := SyntaxTree.invalidExpression;
- END
- ELSIF IsComplexValue(expression, real, imaginary) THEN
- IF (type IS SyntaxTree.ComplexType) THEN
- result := SyntaxTree.NewComplexValue(expression.position, real, imaginary);
- result.SetType(type);
- result(SyntaxTree.ComplexValue).SetSubtype(expression.resolved(SyntaxTree.ComplexValue).subtype) (* reuse subtype *)
- ELSE
- Error(position, "complex value cannot be converted");
- result := SyntaxTree.invalidExpression;
- END
- ELSIF IsSetValue(expression,set) THEN
- IF (type IS SyntaxTree.IntegerType) THEN
- result := SyntaxTree.NewIntegerValue(expression.position,SYSTEM.VAL(LONGINT,set));
- result.SetType(type);
- ELSIF (type IS SyntaxTree.CharacterType) OR (type IS SyntaxTree.ByteType) THEN (* for example: possible via ch = CHR(SYSTEM.VAL(LONGINT,set)) *)
- result := SyntaxTree.NewCharacterValue(expression.position,SYSTEM.VAL(CHAR,set));
- result.SetType(type);
- ELSIF (type IS SyntaxTree.PortType) THEN
- result := ConvertValue(position, expression, system.integerType);
- ELSE
- Error(position, "set value cannot be converted");
- result := SyntaxTree.invalidExpression;
- END;
- ELSIF IsStringValue(expression,string) THEN
- IF ((type IS SyntaxTree.CharacterType) OR (type IS SyntaxTree.ByteType)) & (string[1]=0X) THEN
- result := SyntaxTree.NewCharacterValue(expression.position,string[0]);
- result.SetType(type);
- ELSIF (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.CharacterType) THEN (* nothing to be done *)
- ELSE
- Error(position, "string value cannot be converted");
- result := SyntaxTree.invalidExpression;
- END;
- ELSIF IsCharacterValue(expression,char) THEN
- IF (type IS SyntaxTree.StringType) OR (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.CharacterType) THEN
- string[0] := char; string[1] := 0X;
- type := SyntaxTree.NewStringType(Basic.invalidPosition,system.characterType,2);
- result := SyntaxTree.NewStringValue(expression.position,string);
- result.SetType(type);
- ELSIF (type IS SyntaxTree.ByteType) THEN
- (* do not simply set the new type as this could invalidate types of constants *)
- result := SyntaxTree.NewCharacterValue(expression.position,char);
- result.SetType(type)
- ELSIF (type IS SyntaxTree.IntegerType) THEN
- result := SyntaxTree.NewIntegerValue(expression.position,SYSTEM.VAL(LONGINT,char));
- result.SetType(type);
- ELSIF (type IS SyntaxTree.SetType) THEN
- result := SyntaxTree.NewSetValue(expression.position,SYSTEM.VAL(SET,char));
- result.SetType(type);
- ELSIF (type IS SyntaxTree.CharacterType) THEN
- result := SyntaxTree.NewCharacterValue(expression.position,char);
- result.SetType(type);
- ELSIF (type IS SyntaxTree.PortType) THEN
- result := ConvertValue(position, expression, system.integerType);
- ELSE
- Error(position, "character value cannot be converted");
- result := SyntaxTree.invalidExpression;
- END;
- ELSIF expression IS SyntaxTree.NilValue THEN
- IF type IS SyntaxTree.AddressType THEN
- result := SyntaxTree.NewIntegerValue(position,0);
- result.SetType(type);
- ELSE
- result := expression;
- END;
- (* nothing to be done *)
- ELSIF expression IS SyntaxTree.MathArrayValue THEN
- result := MathArrayConversion(position, expression,type);
- ELSIF expression IS SyntaxTree.EnumerationValue THEN
- int := expression(SyntaxTree.EnumerationValue).value;
- IF (type IS SyntaxTree.IntegerType) OR (type IS SyntaxTree.SizeType) THEN
- int := Global.ConvertSigned(int,system.SizeOf(type));
- result := SyntaxTree.NewIntegerValue(position,int);
- result.SetType(type);
- ELSE
- result := expression;
- END;
- (* nothing to be done *)
- ELSE
- Error(position, "expression cannot be converted");
- IF VerboseErrorMessage THEN
- Printout.Info("expression",expression);
- Printout.Info("type",type);
- END;
- result := SyntaxTree.invalidExpression;
- END;
- RETURN result
- END ConvertValue;
- (**
- return a conversion of an expression to a given type
- - if expression is already of same type then return expression
- - if incompatible conversion then report error and return invalidExpression
- **)
- PROCEDURE NewConversion*(position: Position; expression: SyntaxTree.Expression; type: SyntaxTree.Type; reference: SyntaxTree.Expression): SyntaxTree.Expression;
- VAR result: SyntaxTree.Expression; value: SyntaxTree.Expression; expressionList: SyntaxTree.ExpressionList; typeDeclaration: SyntaxTree.TypeDeclaration; typeSymbol: SyntaxTree.Designator;
- BEGIN
- type := type.resolved;
- ASSERT(type # NIL); ASSERT(~(type IS SyntaxTree.QualifiedType));
- result := expression;
- IF expression = SyntaxTree.invalidExpression THEN (* error already handled *)
- ELSIF expression = NIL THEN (* NIL expression *)
- ELSIF expression.type = NIL THEN
- Error(position, "expression of type NIL cannot be converted");
- ELSIF expression.type.SameType(type) THEN (* nothing to be done ! *)
- ELSIF IsPointerType(expression.type) & IsPointerType(type) THEN (* nothing to be done *)
- ELSIF (expression.type.resolved IS SyntaxTree.AnyType) THEN (*! binary symbol file problem: ANY and OBJECT cannot be distinguished *)
- ELSIF (expression.type.resolved IS SyntaxTree.ObjectType) & (type IS SyntaxTree.AnyType) THEN (*! binary symbol file problem *)
- ELSIF expression.resolved # NIL THEN (* value *)
- value := ConvertValue(position,expression.resolved(SyntaxTree.Value),type);
- IF value IS SyntaxTree.Value THEN
- result := SyntaxTree.NewConversion(expression.position,expression,type,reference);
- result.SetResolved(value(SyntaxTree.Value));
- result.SetType(value.type);
- ELSE
- result := value
- END;
- ELSIF (type IS SyntaxTree.ByteType) THEN (* do not convert *)
- expressionList := SyntaxTree.NewExpressionList();
- typeDeclaration := SyntaxTree.NewTypeDeclaration(expression.position,SyntaxTree.NewIdentifier("@byte"));
- typeDeclaration.SetDeclaredType(type);
- typeSymbol := SyntaxTree.NewSymbolDesignator(Basic.invalidPosition,NIL,typeDeclaration);
- typeSymbol.SetType(typeDeclaration.type);
- expressionList.AddExpression(typeSymbol); (* type declaration symbol skipped *)
- expressionList.AddExpression(expression);
- result := SyntaxTree.NewBuiltinCallDesignator(expression.position,Global.systemVal,NIL,expressionList);
- result.SetType(type);
- ELSIF IsArrayStructuredObjectType(type) THEN
- (* no type can be converted to an array-structured object type *)
- HALT(100)
- ELSIF (type IS SyntaxTree.MathArrayType) THEN
- IF expression.type.resolved IS SyntaxTree.MathArrayType THEN
- result := MathArrayConversion(position, expression,type);
- ELSIF IsArrayStructuredObjectType(expression.type) THEN
- expression := ConvertToMathArray(expression);
- type := MathArrayStructureOfType(type);
- result := MathArrayConversion(position, expression, type)
- ELSE
- Error(expression.position,"cannot convert non array type to array type")
- END;
- ELSIF (expression.type.resolved IS SyntaxTree.MathArrayType) THEN
- IF (expression.type.resolved(SyntaxTree.MathArrayType).form # SyntaxTree.Static)
- OR ~(type IS SyntaxTree.ArrayType) THEN
- Error(expression.position,"cannot convert array type to non-array type")
- END;
- ELSIF IsPointerType(type) & ~IsPointerType(expression.type.resolved) THEN
- result := SyntaxTree.NewConversion(expression.position,expression,system.addressType,reference);
- ELSIF ~(type IS SyntaxTree.BasicType) & ~(expression.type.resolved IS SyntaxTree.CharacterType) THEN
- (*skip, no conversion*)
- ELSIF (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.ByteType) THEN
- (* skip, no conversion *)
- ELSE
- ASSERT(~(type IS SyntaxTree.RangeType));
- result := SyntaxTree.NewConversion(expression.position,expression,type,reference);
- ASSERT(type # NIL);
- END;
- RETURN result
- END NewConversion;
- PROCEDURE CompatibleConversion(position: Position; expression: SyntaxTree.Expression; type: SyntaxTree.Type): SyntaxTree.Expression;
- BEGIN
- IF CompatibleTo(system,expression.type, type) THEN
- RETURN NewConversion(position, expression, type, NIL);
- ELSE
- Error(expression.position, "incompatible expression");
- RETURN SyntaxTree.invalidExpression
- END;
- END CompatibleConversion;
- (**
- convert operands left and right to a type that both operands are compatible with, if no such type exists then report error
- **)
- PROCEDURE ConvertOperands(VAR left,right: SyntaxTree.Expression);
- VAR leftType,rightType: SyntaxTree.Type;
- BEGIN
- IF left.type = NIL THEN Error(left.position,"no type")
- ELSIF right.type= NIL THEN Error(right.position,"no type")
- ELSIF (left = SyntaxTree.invalidExpression) OR (right = SyntaxTree.invalidExpression) THEN
- (* error already handled *)
- ELSE
- leftType := left.type.resolved; rightType := right.type.resolved;
- IF (leftType IS SyntaxTree.AddressType) & IsAddressExpression(right) THEN
- right := NewConversion(right.position, right, leftType, NIL);
- ELSIF (rightType IS SyntaxTree.AddressType) & IsAddressExpression(left) THEN
- left := NewConversion(left.position,left,rightType,NIL);
- ELSIF (leftType IS SyntaxTree.SizeType) & IsSizeExpression(right) THEN
- right := NewConversion(right.position, right, leftType, NIL);
- ELSIF (rightType IS SyntaxTree.SizeType) & IsSizeExpression(left) THEN
- left := NewConversion(left.position,left,rightType,NIL);
- ELSIF CompatibleTo(system,leftType,rightType) THEN
- left := NewConversion(left.position,left,right.type.resolved,NIL);
- ELSIF CompatibleTo(system,rightType,leftType) THEN
- right := NewConversion(right.position,right,left.type.resolved,NIL);
- ELSIF
- (leftType IS SyntaxTree.ComplexType) & (rightType IS SyntaxTree.FloatType) OR
- (leftType IS SyntaxTree.FloatType) & (rightType IS SyntaxTree.ComplexType) THEN
- (* must be the case LONGREAL / COMPLEX ) *)
- left := NewConversion(left.position, left, Global.Complex128, NIL);
- right := NewConversion(right.position, right, Global.Complex128, NIL);
- ELSE
- Error(left.position,"incompatible operands");
- END;
- END;
- END ConvertOperands;
- (** find and return best operator matching to parameter list (nil, if none)
- - search current module scope and all (directly or indirectly) imported modules for matching operator
- - take operator with smalles distance, where signature distance is computed in procedure Distance
- **)
- PROCEDURE FindOperator*(system: Global.System; operator: LONGINT; actualParameters: SyntaxTree.ExpressionList; returnType: SyntaxTree.Type): SyntaxTree.Operator;
- VAR bestOperator: SyntaxTree.Operator; bestDistance: LONGINT; import: SyntaxTree.Import; numberParameters: LONGINT; procedureType: SyntaxTree.ProcedureType;
- identifier: SyntaxTree.Identifier;
- PROCEDURE FindInScope(scope: SyntaxTree.ModuleScope; access: SET);
- VAR operator: SyntaxTree.Operator; distance,i: LONGINT;
- BEGIN
- operator := scope.firstOperator;
- WHILE(operator # NIL) DO
- IF (operator.name=identifier) & (operator.access * access # {}) THEN
- procedureType := operator.type(SyntaxTree.ProcedureType);
- distance := Distance(system, procedureType,actualParameters);
- IF (distance < Infinity) THEN
- IF returnType # NIL THEN
- IF procedureType.returnType = NIL THEN
- distance := Infinity
- ELSE
- i := TypeDistance(system,returnType,procedureType.returnType,TRUE);
- IF i = Infinity THEN distance := Infinity ELSE INC(distance,i) END;
- END;
- END;
- END;
- (*
- IF distance < Infinity THEN
- TRACE(distance, operator);
- Printout.Info("potential operator",operator);
- ELSE
- Printout.Info("operator not possible",operator);
- END;
- *)
- IF distance < bestDistance THEN
- bestDistance := distance;
- bestOperator := operator;
- END;
- END;
- operator := operator.nextOperator;
- END;
- (*
- Printout.Info("taken operator",bestOperator);
- *)
- END FindInScope;
- BEGIN
- bestDistance := Infinity; bestOperator := NIL; numberParameters := actualParameters.Length();
- identifier := Global.GetIdentifier(operator,currentScope.ownerModule.case);
- FindInScope(currentScope.ownerModule.moduleScope,SyntaxTree.ReadOnly);
- import := currentScope.ownerModule.moduleScope.firstImport;
- WHILE (bestDistance > 0) & (import # NIL) DO
- IF import.module # NIL THEN
- identifier := Global.GetIdentifier(operator,import.module.case);
- FindInScope(import.module.moduleScope,SyntaxTree.Public);
- END;
- import := import.nextImport;
- END;
- RETURN bestOperator
- END FindOperator;
- PROCEDURE SetCurrentScope*(scope: SyntaxTree.Scope);
- BEGIN
- currentScope := scope;
- END SetCurrentScope;
- (**
- return a procedure call designator for the best matching operator procedure of the form "op"(leftExpression,rightExpression) (if any)
- - handle LEN and DIM operator for array-structured object types
- - find operator, if found then
- - if in other module then add import designator
- - create symbol designator for operator
- - if error then return invalidExpression, if no operator then return NIL
- **)
- PROCEDURE NewOperatorCall*(position: Position; op: LONGINT; leftExpression, rightExpression: SyntaxTree.Expression; resultType: SyntaxTree.Type): SyntaxTree.Expression;
- VAR
- operator: SyntaxTree.Operator;
- import: SyntaxTree.Import;
- expression, result: SyntaxTree.Expression;
- designator: SyntaxTree.Designator;
- actualParameters, tempList: SyntaxTree.ExpressionList;
- recordType: SyntaxTree.RecordType;
- castReturnType : SyntaxTree.MathArrayType;
- BEGIN
- IF (leftExpression = SyntaxTree.invalidExpression) OR (rightExpression = SyntaxTree.invalidExpression) THEN
- result := SyntaxTree.invalidExpression
- ELSIF leftExpression = NIL THEN
- result := NIL
- ELSIF IsArrayStructuredObjectType(leftExpression.type) & ((op = Global.Len) OR (op = Global.Dim)) THEN
- (* LEN or DIM operator on array-structured object type *)
- ASSERT(leftExpression.type.resolved IS SyntaxTree.PointerType);
- recordType := leftExpression.type.resolved(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
- IF recordType.arrayAccessOperators.len = NIL THEN
- Error(position, "call of undeclared LEN operator");
- result := SyntaxTree.invalidExpression
- ELSE
- ASSERT(leftExpression IS SyntaxTree.Designator);
- designator := leftExpression(SyntaxTree.Designator);
- expression := NewSymbolDesignator(Basic.invalidPosition, NewDereferenceDesignator(position, designator), recordType.arrayAccessOperators.len);
- ASSERT(expression IS SyntaxTree.Designator);
- designator := NewProcedureCallDesignator(Basic.invalidPosition, expression(SyntaxTree.Designator), SyntaxTree.NewExpressionList());
- IF (op = Global.Len) & (rightExpression = NIL) THEN
- (* LEN(OBJECT) -> OBJECT^."LEN"() *)
- result := designator
- ELSIF (op = Global.Len) & (rightExpression # NIL) & (rightExpression.type.resolved IS SyntaxTree.IntegerType) THEN
- (* LEN(OBJECT, LONGINT) -> OBJECT^."LEN"()[LONGINT] *)
- tempList := SyntaxTree.NewExpressionList();
- tempList.AddExpression(rightExpression);
- result := ResolveDesignator(SyntaxTree.NewBracketDesignator(Basic.invalidPosition, designator, tempList))
- ELSIF (op = Global.Dim) & (rightExpression = NIL) THEN
- (* DIM(OBJECT) -> LEN(OBJECT^."LEN"(), 0) *)
- tempList := SyntaxTree.NewExpressionList();
- tempList.AddExpression(designator);
- tempList.AddExpression(SyntaxTree.NewIntegerValue(Basic.invalidPosition, 0));
- designator := SyntaxTree.NewIdentifierDesignator(Basic.invalidPosition, Global.GetIdentifier(Global.Len, module.case));
- result := ResolveExpression(SyntaxTree.NewParameterDesignator(Basic.invalidPosition, designator, tempList))
- END
- END;
- ELSE
- (* import OCArrayBase if needed *)
- IF ~arrayBaseImported THEN
- IF (leftExpression # NIL) & IsComplexType(leftExpression.type) THEN
- (* operators on complex numbers *)
- ImportModule(Global.ArrayBaseName,position);
- arrayBaseImported := TRUE;
- ELSIF (leftExpression # NIL) & IsMathArrayType(leftExpression.type) OR (rightExpression # NIL) & IsMathArrayType(rightExpression.type) THEN
- IF op = Global.Dim THEN
- (* not existing in OCArrayBase *)
- ELSIF (op = Global.Len) & (rightExpression # NIL) THEN
- (* not existing in OCArrayBase *)
- ELSE
- ImportModule(Global.ArrayBaseName,position);
- arrayBaseImported := TRUE;
- END
- ELSIF (leftExpression # NIL) & IsArrayStructuredObjectType(leftExpression.type) OR (rightExpression # NIL) & IsArrayStructuredObjectType(rightExpression.type) THEN
- ImportModule(Global.ArrayBaseName,position);
- arrayBaseImported := TRUE
- END;
- IF (op = Global.Len) & (leftExpression # NIL) & IsRangeType(leftExpression.type) & (rightExpression = NIL) THEN
- (* LEN(RANGE) *)
- ImportModule(Global.ArrayBaseName,position);
- arrayBaseImported := TRUE;
- END;
- END;
- actualParameters := SyntaxTree.NewExpressionList();
- actualParameters.AddExpression(leftExpression);
- IF rightExpression # NIL THEN
- actualParameters.AddExpression(rightExpression)
- END;
- operator := FindOperator(system,op,actualParameters,resultType);
- IF operator # NIL THEN
- designator := NIL;
- IF operator.scope.ownerModule # currentScope.ownerModule THEN
- import := currentScope.ownerModule.moduleScope.firstImport;
- WHILE(import # NIL) & (import.module # operator.scope.ownerModule) DO
- import := import.nextImport;
- END;
- expression := NewSymbolDesignator(position,NIL,import);
- designator := expression(SyntaxTree.Designator);
- END;
- expression := NewSymbolDesignator(position,designator,operator);
- designator := expression(SyntaxTree.Designator);
- result := NewProcedureCallDesignator(position,designator,actualParameters);
- IF op = Scanner.Alias THEN (* hard type cast to same type *)
- castReturnType := SyntaxTree.NewMathArrayType(Basic.invalidPosition, expression.type.scope,SyntaxTree.Tensor);
- castReturnType.SetArrayBase(ArrayBase(leftExpression.type.resolved,MAX(LONGINT)));
- result.SetType(castReturnType);
- END;
- ELSE
- result := NIL;
- END;
- END;
- RETURN result
- END NewOperatorCall;
- (** check and resolve binary expression **)
- (*! clean up *)
- PROCEDURE VisitBinaryExpression(binaryExpression: SyntaxTree.BinaryExpression);
- VAR left,right,result: SyntaxTree.Expression;
- leftType, rightType: SyntaxTree.Type;
- il,ir: LONGINT; rl,rr,a,b,c,d,divisor: LONGREAL; hl,hr: HUGEINT;bl,br: BOOLEAN; sl,sr: SET; strl,strr: Scanner.StringType;
- cl,cr: CHAR;
- operator: LONGINT; operatorCall: SyntaxTree.Expression;
- type: SyntaxTree.Type;
- value: SyntaxTree.Value;
- leftFirst, leftLast, leftStep, rightFirst, rightLast, rightStep: LONGINT;
- integerConstantFolding: BOOLEAN;
- list: SyntaxTree.ExpressionList;
- PROCEDURE NewBool(v: BOOLEAN);
- BEGIN
- value := SyntaxTree.NewBooleanValue(binaryExpression.position,v);
- value.SetType(system.booleanType);
- result.SetResolved(value);
- type := system.booleanType
- END NewBool;
- PROCEDURE NewSet(v: SET);
- BEGIN
- value := SyntaxTree.NewSetValue(binaryExpression.position,v);
- value.SetType(system.setType);
- result.SetResolved(value);
- type := system.setType;
- END NewSet;
- PROCEDURE NewInteger(v: HUGEINT; t: SyntaxTree.Type);
- BEGIN
- value := Global.NewIntegerValue(system,binaryExpression.position,v);
- (* type cast to "larger" type only if the value is still in the range *)
- IF (t IS SyntaxTree.AddressType) & IsAddressValue(value) THEN
- value.SetType(t);
- END;
- result.SetResolved(value);
- type := value.type;
- END NewInteger;
- PROCEDURE NewReal(v: LONGREAL; t: SyntaxTree.Type);
- BEGIN
- value := SyntaxTree.NewRealValue(binaryExpression.position,v);
- value.SetType(t);
- result.SetResolved(value);
- type := t;
- END NewReal;
- PROCEDURE NewComplex(realValue, imagValue: LONGREAL; t: SyntaxTree.Type);
- BEGIN
- value := SyntaxTree.NewComplexValue(binaryExpression.position, realValue, imagValue);
- value.SetType(t);
- value(SyntaxTree.ComplexValue).UpdateSubtype;
- result.SetResolved(value);
- type := t;
- END NewComplex;
- BEGIN
- type := SyntaxTree.invalidType;
- left := ResolveExpression(binaryExpression.left);
- right := ResolveExpression(binaryExpression.right);
- binaryExpression.SetLeft(left);
- binaryExpression.SetRight(right);
- result := binaryExpression;
- operator := binaryExpression.operator;
- IF ~system.operatorDefined[operator] THEN
- Error(left.position,"Operator Not Defined");
- result := SyntaxTree.invalidExpression;
- RETURN
- END;
- IF left.type = NIL THEN
- Error(left.position,"Expression has no result type");
- result := SyntaxTree.invalidExpression;
- RETURN;
- END;
- IF right.type = NIL THEN
- Error(right.position,"Expression has no result type");
- result := SyntaxTree.invalidExpression;
- RETURN;
- END;
- leftType := left.type.resolved; rightType := right.type.resolved;
- IF ~(leftType IS SyntaxTree.BasicType) OR ~(rightType IS SyntaxTree.BasicType) OR (leftType IS SyntaxTree.ComplexType) OR (rightType IS SyntaxTree.ComplexType) THEN
- operatorCall := NewOperatorCall(binaryExpression.position,operator,left,right,NIL);
- END;
- IF (operatorCall = NIL) & IsPointerToObject(left.type) THEN
- list := SyntaxTree.NewExpressionList();
- list.AddExpression(right);
- operatorCall := NewObjectOperatorCall(binaryExpression.position, left, operator, NIL, right);
- END;
- IF operatorCall # NIL THEN
- result := operatorCall;
- type := operatorCall.type;
- (* admissible operators:
- Times, Plus, Minus numeric numeric numeric
- set set set
- Slash numeric numeric real /complex
- set set set
- Div , Mod integer integer integer
- And, Or bool bool bool
- Equal, Unequal basic basic bool
- pointer pointer bool
- object object bool
- record record bool
- string string bool
- enumerator enumerator bool
- Less, LessEqual,
- Greater, GreaterEqual integer/real integer/real bool
- enumerator enumerator bool
- In integer set bool
- Is pointer type bool
- object type bool
- record type bool
- Upto: special abbreviation for a..b
- *)
- ELSIF (left.type = NIL) THEN
- Error(left.position,"type (left operand) = NIL in binary expression");
- D.Str("nil type in "); D.Type(left); D.Ln;
- result := SyntaxTree.invalidExpression;
- ELSIF (right.type = NIL) THEN
- Error(right.position,"type (right operand) = NIL in binary expression");
- result := SyntaxTree.invalidExpression;
- ELSIF (leftType = SyntaxTree.invalidType) OR (rightType = SyntaxTree.invalidType) THEN (* error already handled *)
- result := SyntaxTree.invalidExpression;
- ELSIF operator = Scanner.Upto THEN (* left .. right: now solved as RangeExpression*)
- HALT(100);
- ELSIF operator = Scanner.Is THEN (* left IS right: now solved as IsExpression *)
- type := system.booleanType;
- IF ~(rightType = SyntaxTree.typeDeclarationType) THEN
- Error(right.position,"is not a type ");
- ELSIF ~IsTypeExtension(leftType, right(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType.resolved) THEN
- Error(binaryExpression.position,"is not a type extension of ");
- IF VerboseErrorMessage THEN
- Printout.Info("left",left);
- Printout.Info("right",right);
- END;
- ELSIF IsUnsafePointer(left.type) THEN
- Error(binaryExpression.position,"forbidden type test on unsafe pointer");
- ELSIF (leftType.SameType(right(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType.resolved)) THEN
- NewBool(TRUE)
- ELSIF right(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType.resolved IS SyntaxTree.AnyType THEN
- NewBool(TRUE);
- ELSIF IsUnextensibleRecord(left) THEN
- NewBool(FALSE)
- END
- ELSIF (right IS SyntaxTree.SymbolDesignator) & (right(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.TypeDeclaration) THEN
- Error(right.position,"must not be a type");
- ELSIF (left IS SyntaxTree.SymbolDesignator) & (left(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.TypeDeclaration) THEN
- Error(left.position,"must not be a type");
- ELSIF operator = Scanner.In THEN (* left IN right *)
- IF IsIntegerType(leftType) & (rightType IS SyntaxTree.SetType) THEN
- IF IsIntegerValue(left,il) & IsSetValue(right,sr) THEN
- NewBool(il IN sr);
- ELSE
- IF leftType.sizeInBits # system.longintType.sizeInBits THEN
- left := NewConversion(left.position, left, system.longintType,NIL);
- binaryExpression.SetLeft(left)
- END;
- type := system.booleanType;
- END
- ELSE
- Error(binaryExpression.position, "incompatible operands");
- END
- ELSIF (leftType IS SyntaxTree.ProcedureType) OR (rightType IS SyntaxTree.ProcedureType) THEN
- IF ~CompatibleTo(system,leftType,rightType) & ~CompatibleTo(system,rightType,leftType) THEN
- Error(binaryExpression.position,"incompatible operands");
- END;
- IF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) THEN type := system.booleanType
- ELSE Error(binaryExpression.position,"operator not defined 1")
- END
- ELSIF IsPointerType(leftType) OR IsPointerType(rightType) THEN
- IF ~CompatibleTo(system,leftType,rightType) & ~CompatibleTo(system,rightType,leftType) THEN
- (* IsPointerType(leftType) OR ~IsPointerType(rightType) THEN *)
- Error(binaryExpression.position,"incompatible operands");
- IF VerboseErrorMessage THEN Printout.Info("leftType",leftType); Printout.Info("right",rightType) END
- ELSIF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) THEN
- ConvertOperands(left, right);
- binaryExpression.SetLeft(left);
- binaryExpression.SetRight(right);
- IF (left IS SyntaxTree.NilValue) & (right IS SyntaxTree.NilValue) THEN
- IF operator = Scanner.Equal THEN NewBool(TRUE) ELSE NewBool(FALSE) END;
- END;
- type := system.booleanType;
- ELSE
- Error(binaryExpression.position,"operator not defined 3");
- END
- ELSIF (left.resolved# NIL) & (left.resolved IS SyntaxTree.NilValue) THEN Error(binaryExpression.position,"operator not defined");
- ELSIF (right.resolved # NIL) & (right.resolved IS SyntaxTree.NilValue) THEN Error(binaryExpression.position,"operator not defined");
- ELSIF IsStringType(leftType) & IsStringType(rightType) THEN (* string ops*)
- IF IsStringType(leftType) & IsStringType(rightType) THEN (*ok*)
- IF IsStringValue(left,strl) & IsStringValue(right,strr) THEN
- CASE operator OF
- |Scanner.Equal: NewBool(strl^=strr^);
- |Scanner.Unequal:NewBool(strl^#strr^);
- |Scanner.Less: NewBool(strl^<strr^);
- |Scanner.LessEqual: NewBool(strl^<=strr^);
- |Scanner.Greater: NewBool(strl^>strr^);
- |Scanner.GreaterEqual: NewBool(strl^>=strr^);
- ELSE
- Error(binaryExpression.position,"operator not defined 4");
- END;
- END;
- ELSIF (operator = Scanner.Equal) OR (operator=Scanner.Unequal) OR (operator = Scanner.Less)
- OR (operator = Scanner.LessEqual) OR (operator = Scanner.Greater) OR (operator = Scanner.GreaterEqual) THEN
- type := system.booleanType
- ELSE
- Error(binaryExpression.position,"operator not defined 5");
- END;
- IF (operator = Scanner.Equal) OR (operator=Scanner.Unequal)
- OR (operator = Scanner.Less) OR (operator = Scanner.LessEqual)
- OR (operator = Scanner.Greater) OR (operator = Scanner.GreaterEqual) THEN
- type := system.booleanType;
- ELSE
- Error(binaryExpression.position,"operator not defined 6");
- END
- ELSIF (leftType IS SyntaxTree.EnumerationType) OR (rightType IS SyntaxTree.EnumerationType) THEN
- IF IsEnumerationExtension(left.type,right.type) OR IsEnumerationExtension(right.type,left.type) THEN
- IF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) OR (operator = Scanner.Less) OR (operator = Scanner.LessEqual)
- OR (operator = Scanner.Greater) OR (operator = Scanner.GreaterEqual) THEN
- type := system.booleanType
- ELSE
- Error(binaryExpression.position,"operator not defined for enumerators");
- END;
- ELSE
- Error(binaryExpression.position,"operator not applicable between different enumerators");
- END;
- ELSIF (leftType IS SyntaxTree.PortType) & ((operator = Scanner.Questionmarks) OR (operator = Scanner.ExclamationMarks) OR (operator = Scanner.LessLessQ)) THEN
- type := system.booleanType;
- ELSIF (rightType IS SyntaxTree.PortType) & (operator = Scanner.LessLessQ) THEN
- type := system.booleanType;
- ELSIF (leftType IS SyntaxTree.BasicType) & (rightType IS SyntaxTree.BasicType)
- OR IsCharacterType(leftType) & IsCharacterType(rightType)
- THEN
- integerConstantFolding := IsIntegerValue(left,il) & IsIntegerValue(right,ir);
- IF (leftType # rightType) THEN
- IF ~integerConstantFolding THEN (* no conversions for constant folding on integer values *)
- ConvertOperands(left,right); (* operands must be of the same type here *)
- END;
- binaryExpression.SetLeft(left);
- binaryExpression.SetRight(right);
- leftType := left.type.resolved;
- rightType := right.type.resolved;
- END;
- type := leftType;
- IF ~integerConstantFolding & ~leftType.SameType(rightType) THEN
- Error(binaryExpression.position,"conversion failed ?");
- IF VerboseErrorMessage THEN
- Printout.Info("left",left);
- Printout.Info("right",right);
- END;
- ELSIF IsIntegerType(leftType) THEN
- IF IsIntegerValue(right,ir) (* & (right.type.sizeInBits < 64) *) THEN
- hr := right.resolved(SyntaxTree.IntegerValue).hvalue;
- IF (hr=0) & ((operator = Scanner.Mod) OR (operator = Scanner.Div) OR (operator = Scanner.Slash)) THEN
- Error(binaryExpression.position,"division by zero");
- ELSIF (hr<0) & ((operator = Scanner.Mod) OR (operator = Scanner.Div))THEN
- Error(binaryExpression.position,"integer division by negative number");
- END;
- END;
- (* constant folding *)
- (* bootstrap64
- IF IsIntegerValue(left,il) & IsIntegerValue(right,ir) & (type.sizeInBits < 64) THEN
- CASE operator OF
- |Scanner.Plus: NewInteger(il+ir,left.type);
- |Scanner.Minus: NewInteger(il-ir,left.type);
- |Scanner.Times: NewInteger(il*ir,left.type);
- |Scanner.Slash:
- IF ir # 0 THEN
- NewReal(il/ir, system.realType);
- END;
- |Scanner.Mod:
- IF ir > 0 THEN
- NewInteger(il MOD ir,left.type);
- END;
- |Scanner.Div:
- IF ir > 0 THEN
- NewInteger(il DIV ir,left.type);
- END;
- |Scanner.Equal: NewBool(il=ir);
- |Scanner.Unequal:NewBool(il#ir);
- |Scanner.Less: NewBool(il<ir);
- |Scanner.LessEqual: NewBool(il<=ir);
- |Scanner.Greater: NewBool(il>ir);
- |Scanner.GreaterEqual: NewBool(il>=ir);
- ELSE Error(binaryExpression.position,"operator not defined 7");
- END;
- ELS*)
- IF IsIntegerValue(left,il) & IsIntegerValue(right,ir) (* bootstrap64 & (type.sizeInBits = 64)*) THEN
- hl := left.resolved(SyntaxTree.IntegerValue).hvalue;
- hr := right.resolved(SyntaxTree.IntegerValue).hvalue;
- CASE operator OF
- |Scanner.Plus: NewInteger(hl+hr,left.type);
- |Scanner.Minus: NewInteger(hl-hr,left.type);
- |Scanner.Times: NewInteger(hl*hr,left.type);
- |Scanner.Slash:
- IF hr = 0 THEN
- Error(binaryExpression.position,"division by zero");
- ELSE
- IF type.sizeInBits = 64 THEN
- NewReal(hl/hr,system.longrealType);
- ELSE
- NewReal(hl/hr,system.realType)
- END
- END;
- (* do the bootstrapping for this kind of expression on hugeint values , then enable: *)
- |Scanner.Mod:
- IF hr = 0 THEN
- Error(binaryExpression.position,"division by zero");
- ELSE
- NewInteger(hl MOD hr, left.type);
- (* bootstrap64
- NewInteger(hl - Machine.DivH(hl,hr)*hr,left.type);
- *)
- END;
- |Scanner.Div:
- IF hr = 0 THEN
- Error(binaryExpression.position,"division by zero");
- ELSE
- NewInteger(hl DIV hr, left.type);
- (* bootstrap64
- NewInteger(Machine.DivH(hl,hr),left.type);
- *)
- END;
- (* *)
- |Scanner.Equal: NewBool(hl=hr);
- |Scanner.Unequal: NewBool(hl#hr);
- |Scanner.Less: NewBool(hl<hr);
- |Scanner.LessEqual: NewBool(hl<=hr);
- |Scanner.Greater: NewBool(hl>hr);
- |Scanner.GreaterEqual:NewBool(hl>=hr);
- ELSE Error(binaryExpression.position,"operator not defined 8");
- END;
- ELSIF (operator = Scanner.Plus) OR (operator = Scanner.Minus) OR (operator = Scanner.Times) OR
- (operator = Scanner.Mod) OR (operator = Scanner.Div) THEN
- type := left.type
- ELSIF (operator = Scanner.Slash) THEN
- left := NewConversion(left.position,left,system.realType,NIL);
- right := NewConversion(right.position,right,system.realType,NIL);
- binaryExpression.SetLeft(left);
- binaryExpression.SetRight(right);
- type := system.realType
- ELSIF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) OR (operator = Scanner.Less) OR (operator = Scanner.LessEqual)
- OR (operator = Scanner.Greater) OR (operator = Scanner.GreaterEqual) THEN
- type := system.booleanType
- ELSE
- Error(binaryExpression.position,"operator not defined 9");
- END;
- ELSIF (leftType IS SyntaxTree.FloatType) THEN
- IF IsRealValue(left,rl) & IsRealValue(right,rr) THEN
- CASE operator OF
- |Scanner.Plus: NewReal(rl+rr,leftType);
- |Scanner.Minus: NewReal(rl-rr,leftType);
- |Scanner.Times:NewReal(rl*rr,leftType);
- |Scanner.Slash:
- IF rr = 0 THEN
- Error(binaryExpression.position,"division by zero");
- ELSE
- NewReal(rl/rr,leftType);
- END
- |Scanner.Equal: NewBool(rl=rr);
- |Scanner.Unequal: NewBool(rl#rr);
- |Scanner.Less: NewBool(rl<rr);
- |Scanner.LessEqual: NewBool(rl<=rr);
- |Scanner.Greater: NewBool(rl>rr);
- |Scanner.GreaterEqual: NewBool(rl>=rr);
- ELSE Error(binaryExpression.position,"operator not defined 10");
- END;
- ELSIF (operator = Scanner.Plus) OR (operator = Scanner.Minus) OR (operator = Scanner.Times) OR (operator = Scanner.Slash) THEN
- type := left.type
- ELSIF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) OR (operator = Scanner.Less) OR (operator = Scanner.LessEqual)
- OR (operator = Scanner.Greater) OR (operator = Scanner.GreaterEqual) THEN
- type := system.booleanType
- ELSE
- Error(binaryExpression.position,"operator not defined 11");
- IF VerboseErrorMessage THEN
- Printout.Info("left",left);
- Printout.Info("right",right);
- END;
- END;
- ELSIF (leftType IS SyntaxTree.ComplexType) THEN
- CASE operator OF
- |Scanner.Plus, Scanner.Minus, Scanner.Times, Scanner.Slash: type := left.type
- |Scanner.Equal, Scanner.Unequal: type := system.booleanType
- ELSE
- Error(binaryExpression.position,"operator not defined");
- IF VerboseErrorMessage THEN
- Printout.Info("left", left);
- Printout.Info("right", right)
- END;
- END;
- IF ~error THEN
- IF (operator = Scanner.Slash) & IsComplexValue(right, c, d) & (c = 0) & (d = 0) THEN
- Error(binaryExpression.position,"division by zero")
- ELSIF IsComplexValue(left, a, b) & IsComplexValue(right, c, d) THEN
- (* do constant folding *)
- CASE operator OF
- |Scanner.Plus: NewComplex(a + b, c + d, leftType)
- |Scanner.Minus: NewComplex(a - b, c - d, leftType)
- |Scanner.Times: NewComplex(a * c - b * d, b * c + a * d, leftType)
- |Scanner.Slash:
- divisor := c * c + d * d;
- ASSERT(divisor # 0);
- NewComplex((a * c + b * d) / divisor, (b * c - a * d) / divisor, leftType)
- |Scanner.Equal: NewBool((a = c) & (b = d))
- |Scanner.Unequal: NewBool((a # c) OR (b # d))
- END
- END
- END
- ELSIF (leftType IS SyntaxTree.BooleanType) THEN
- IF IsBooleanValue(left,bl) & IsBooleanValue(right,br) THEN
- CASE operator OF
- |Scanner.And: NewBool(bl & br);
- |Scanner.Or: NewBool(bl OR br);
- |Scanner.Equal: NewBool(bl = br);
- |Scanner.Unequal: NewBool(bl # br);
- ELSE Error(binaryExpression.position,"operator not defined 12");
- END;
- ELSIF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) OR (operator = Scanner.And) OR (operator = Scanner.Or) THEN
- type := system.booleanType
- ELSE
- Error(binaryExpression.position,"operator not defined 13");
- END;
- ELSIF left.type.resolved IS SyntaxTree.RangeType THEN
- (* constant folding *)
- IF IsStaticRange(left, leftFirst, leftLast, leftStep) & IsStaticRange(right, rightFirst, rightLast, rightStep) THEN
- IF operator = Scanner.Equal THEN
- NewBool((leftFirst = rightFirst) & (leftLast = rightLast) & (leftStep = rightStep))
- ELSIF operator = Scanner.Unequal THEN
- NewBool((leftFirst # rightFirst) OR (leftLast # rightLast) OR (leftStep # rightStep))
- END;
- END;
- IF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) THEN
- type := system.booleanType;
- ELSE
- Error(binaryExpression.position, "operator not defined");
- END;
- ELSIF (leftType IS SyntaxTree.SetType) THEN
- IF IsSetValue(left,sl) & IsSetValue(right,sr) THEN
- CASE operator OF
- |Scanner.Plus: NewSet(sl + sr);
- |Scanner.Minus: NewSet(sl - sr);
- |Scanner.Times: NewSet(sl * sr);
- |Scanner.Slash: NewSet(sl / sr);
- |Scanner.Equal: NewBool(sl=sr);
- |Scanner.Unequal: NewBool(sl#sr);
- |Scanner.Less: NewBool( (sl * sr = sl) & (sl#sr));
- |Scanner.LessEqual: NewBool(sl*sr = sl);
- |Scanner.Greater: NewBool( (sl * sr = sr) & (sl # sr));
- |Scanner.GreaterEqual: NewBool(sl*sr = sr);
- ELSE Error(binaryExpression.position,"operator not defined 14");
- END;
- ELSIF (operator = Scanner.Equal) OR (operator = Scanner.Unequal)
- OR (operator = Scanner.Less) OR (operator = Scanner.LessEqual)
- OR (operator = Scanner.Greater) OR (operator = Scanner.GreaterEqual) (* implement inclusion *)
- THEN
- type := system.booleanType
- ELSIF (operator = Scanner.Plus) OR (operator = Scanner.Minus) OR (operator = Scanner.Times) OR (operator = Scanner.Slash) THEN
- type := left.type
- ELSE
- Error(binaryExpression.position,"operator not defined 15");
- END;
- ELSIF IsCharacterType(left.type) THEN
- IF IsCharacterValue(left,cl) & IsCharacterValue(right,cr) THEN
- CASE operator OF
- |Scanner.Equal: NewBool(cl=cr);
- |Scanner.Unequal: NewBool(cl#cr);
- |Scanner.Less: NewBool(cl<cr);
- |Scanner.LessEqual: NewBool(cl<=cr);
- |Scanner.Greater: NewBool(cl>cr);
- |Scanner.GreaterEqual: NewBool(cl>=cr);
- ELSE Error(binaryExpression.position,"operator not defined 16");
- END;
- ELSIF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) OR (operator = Scanner.Less) OR (operator = Scanner.LessEqual)
- OR (operator = Scanner.Greater) OR (operator = Scanner.GreaterEqual) THEN
- type := system.booleanType
- ELSE
- Error(binaryExpression.position,"operator not defined 17");
- END;
- ELSE
- Error(binaryExpression.position,"operator not defined 18");
- END;
- ELSE
- Error(binaryExpression.position,"operator not defined 19");
- END;
- IF type = SyntaxTree.invalidType THEN
- result := SyntaxTree.invalidExpression
- ELSE
- result.SetType(type)
- END;
- resolvedExpression := result
- END VisitBinaryExpression;
- (** resolve a range expression of the from <<first .. last BY step>>
- - depending on the context different things are checked:
- ArrayIndex:
- - components must be integers
- - replace missing lower bound with 0
- - replace missing upper bound with MAX(LONGINT)
- - replace missing step size with 1
- SetElement:
- - components must be integers
- - replace missing lower bound with 0
- - replace missing upper bound with MAX(SET)
- - must not have step size
- CaseGuard:
- - components must be constant
- - components must be integers or characters
- - must have lower and upper bound present
- - components are made compatible
- - must not have step size
- - if error: return invalidExpression
- **)
- PROCEDURE VisitRangeExpression(x: SyntaxTree.RangeExpression);
- VAR
- hasError: BOOLEAN;
- first, last, step: SyntaxTree.Expression;
- BEGIN
- hasError := FALSE;
- first := x.first;
- last := x.last;
- step := x.step;
- (* check lower bound *)
- IF x.context = SyntaxTree.CaseGuard THEN
- IF first = NIL THEN
- Error(x.position, "missing lower bound");
- hasError := TRUE
- ELSE
- first := ResolveExpression(first);
- IF ~(first.type.resolved IS SyntaxTree.IntegerType) & ~IsCharacterType(first.type.resolved) THEN
- Error(first.position, "lower bound not integer or character");
- hasError := TRUE
- ELSE
- IF first IS SyntaxTree.StringValue THEN
- (* add conversion from string to character *)
- first := ConvertValue(first.position, first(SyntaxTree.Value), system.characterType)
- END
- END;
- (* check if expression is constant *)
- IF ConstantExpression(first) = SyntaxTree.invalidExpression THEN
- (* error already reported *)
- hasError := TRUE
- END
- END
- ELSE (* ArrayIndex, SetElement *)
- IF first = NIL THEN
- first := SyntaxTree.NewIntegerValue(x.position, 0);
- END;
- first := ResolveExpression(first);
- IF first.type.resolved IS SyntaxTree.IntegerType THEN
- first := NewConversion(first.position, first, system.longintType, NIL)
- ELSE
- Error(first.position, "lower bound not integer");
- hasError := TRUE
- END
- END;
- (* check upper bound *)
- IF x.context = SyntaxTree.CaseGuard THEN
- IF last = NIL THEN
- Error(x.position, "missing upper bound");
- hasError := TRUE
- ELSE
- last := ResolveExpression(last);
- IF ~(last.type.resolved IS SyntaxTree.IntegerType) & ~IsCharacterType(last.type.resolved) THEN
- Error(last.position, "lower bound not integer or character");
- hasError := TRUE
- ELSE
- IF last IS SyntaxTree.StringValue THEN
- (* add conversion from string to character *)
- last := ConvertValue(last.position, last(SyntaxTree.Value), system.characterType)
- END
- END;
- (* check if expression is constant *)
- IF ConstantExpression(last) = SyntaxTree.invalidExpression THEN
- (* error already reported *)
- hasError := TRUE
- ELSE
- (* try to make lower and upper bound compatible *)
- ConvertOperands(first, last);
- IF first.type.resolved # last.type.resolved THEN
- Error(x.position, "lower and upper bounds incompatible");
- hasError := TRUE
- END
- END
- END
- ELSE (* ArrayIndex, SetElement *)
- IF last = NIL THEN
- IF x.context = SyntaxTree.ArrayIndex THEN
- last := SyntaxTree.NewIntegerValue(x.position, MAX(LONGINT))
- ELSE
- last := SyntaxTree.NewIntegerValue(x.position, MAX(SET))
- END
- END;
- last := ResolveExpression(last);
- IF last.type.resolved IS SyntaxTree.IntegerType THEN
- last := NewConversion(last.position, last, system.longintType, NIL)
- ELSE
- Error(last.position, "upper bound not integer");
- hasError := TRUE
- END
- END;
- (* check step size *)
- IF x.context = SyntaxTree.ArrayIndex THEN
- IF step = NIL THEN
- step := SyntaxTree.NewIntegerValue(x.position, 1)
- END;
- step := ResolveExpression(step);
- IF step.type.resolved IS SyntaxTree.IntegerType THEN
- step := NewConversion(step.position, step, system.longintType, NIL)
- ELSE
- Error(step.position, "step size not integer");
- hasError := TRUE
- END
- ELSE (* SetElement, CaseGuard *)
- IF step # NIL THEN
- Error(last.position, "step size not allowed in this context");
- hasError := TRUE
- END
- END;
- IF hasError THEN
- resolvedExpression := SyntaxTree.invalidExpression
- ELSE
- x.SetFirst(first);
- x.SetLast(last);
- x.SetStep(step);
- x.SetType(system.rangeType);
- resolvedExpression := x;
- resolvedExpression.SetAssignable(FALSE) (* range expressions may never be assigned to *)
- END
- END VisitRangeExpression;
- PROCEDURE VisitTensorRangeExpression(x: SyntaxTree.TensorRangeExpression);
- BEGIN
- x.SetType(NIL);
- resolvedExpression := x;
- END VisitTensorRangeExpression;
- (** resolve the expression d and return result as designator
- - resolve expression
- - if expression is a designator then return designator else error message and return invalidDesignator
- **)
- PROCEDURE ResolveDesignator*(d: SyntaxTree.Expression): SyntaxTree.Designator;
- VAR result: SyntaxTree.Designator; resolved: SyntaxTree.Expression;
- BEGIN
- IF Trace THEN D.Str("ResolveDesignator"); D.Ln; END;
- resolved := ResolveExpression(d);
- IF resolved = SyntaxTree.invalidExpression THEN
- (* error should already have been reported *)
- result := SyntaxTree.invalidDesignator;
- ELSIF resolved IS SyntaxTree.Designator THEN
- result := resolved(SyntaxTree.Designator);
- ELSE
- Error(d.position,"is no designator ! ");
- result := SyntaxTree.invalidDesignator;
- END;
- (* result.type might be nil. *)
- RETURN result
- END ResolveDesignator;
- (**
- symbol designator generated in this module
- nothing to be resolved
- **)
- PROCEDURE VisitSymbolDesignator(x: SyntaxTree.SymbolDesignator);
- BEGIN
- resolvedExpression := x;
- END VisitSymbolDesignator;
- (**
- self designator generated in this module
- nothing to be resolved
- **)
- PROCEDURE VisitSelfDesignator(x: SyntaxTree.SelfDesignator);
- VAR scope: SyntaxTree.Scope; record: SyntaxTree.RecordType; type: SyntaxTree.Type; cell: SyntaxTree.CellType;
- BEGIN
- (* check if in record scope *)
- scope := currentScope;
- WHILE (scope # NIL) & ~(scope IS SyntaxTree.RecordScope) &~(scope IS SyntaxTree.CellScope) DO
- scope := scope.outerScope;
- END;
- IF scope = NIL THEN (* in module scope *)
- x.SetType(system.anyType);
- ELSIF scope IS SyntaxTree.CellScope THEN
- cell := scope(SyntaxTree.CellScope).ownerCell;
- x.SetType(cell);
- ELSE (* in record scope *)
- record := scope(SyntaxTree.RecordScope).ownerRecord;
- IF (record # NIL) & (record.pointerType # NIL) THEN
- type := ResolveType(record.pointerType);
- x.SetType(type);
- ELSE
- x.SetType(record);
- END;
- END;
- resolvedExpression := x;
- END VisitSelfDesignator;
- PROCEDURE VisitResultDesignator(x: SyntaxTree.ResultDesignator);
- VAR scope: SyntaxTree.Scope; procedure: SyntaxTree.Procedure; procedureType: SyntaxTree.ProcedureType; returnType: SyntaxTree.Type;
- BEGIN
- scope := currentScope;
- IF (scope # NIL) & (scope IS SyntaxTree.ProcedureScope) THEN
- procedure := scope(SyntaxTree.ProcedureScope).ownerProcedure;
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- returnType := procedureType.returnType;
- IF IsPointerType(returnType) OR IsArrayType(returnType) OR IsMathArrayType(returnType)
- THEN
- x.SetType(returnType);
- ELSE
- Error(x.position,"forbidden access to result designator (only pointer, array and math array)");
- x.SetType(SyntaxTree.invalidType);
- END;
- ELSE
- Error(x.position,"forbidden access to result designator");
- x.SetType(SyntaxTree.invalidType);
- END;
- x.SetAssignable(TRUE);
- resolvedExpression := x;
- END VisitResultDesignator;
- (**
- return symbol designator as an expression
- - if symbol is a constant then return the constant value expression
- - else
- - if no left designator present then do auto-self if in record scope identifier-> SELF.identiifer
- - if symbol is a guarded variable then return a TypeGuardDesignator
- - else return a symbol designator
- **)
- PROCEDURE NewSymbolDesignator*(position: Position; left: SyntaxTree.Designator; symbol: SyntaxTree.Symbol): SyntaxTree.Expression;
- VAR result: SyntaxTree.Expression; assignable: BOOLEAN; scope: SyntaxTree.Scope;
- guardType: SyntaxTree.Type;
- BEGIN
- IF Trace THEN D.Str("NewSymbolDesignator "); D.Ln; END;
- result := SyntaxTree.invalidExpression;
- ASSERT(symbol # NIL);
- (*
- not necessary any more since a type declaration is of type SyntaxTree.typeDeclarationType now
- IF symbol IS SyntaxTree.TypeDeclaration THEN
- Error(position, "type not allowed here");
- ELS *)
- (* not needed any more as values are stored in the expression
- IF symbol IS SyntaxTree.Constant THEN
- result := symbol(SyntaxTree.Constant).value
- IF symbol(SyntaxTree.Constant).value # NIL THEN
- IF symbol(SyntaxTree.Constant).value IS SyntaxTree.Value THEN
- result := symbol(SyntaxTree.Constant).value(SyntaxTree.Value).Copy(position);
- ELSE
- result := symbol(SyntaxTree.Constant).value
- END;
- ELSE
- *)
- IF (left = NIL) & (symbol.scope IS SyntaxTree.RecordScope)
- OR (left = NIL) & (symbol.scope IS SyntaxTree.CellScope) & cellsAreObjects
- THEN
- left := ResolveDesignator(SyntaxTree.NewSelfDesignator(position)); (* auto self *)
- IF (IsPointerType(left.type) OR (left.type.resolved IS SyntaxTree.CellType) & cellsAreObjects) &~(symbol IS SyntaxTree.Import) THEN
- left := NewDereferenceDesignator(position,left);
- left.SetHidden(TRUE);
- END;
- ELSIF (symbol.scope IS SyntaxTree.ProcedureScope) THEN
- scope := currentScope;
- WHILE (scope # NIL) & (scope # symbol.scope) & ~(scope IS SyntaxTree.RecordScope) DO
- scope := scope.outerScope;
- END;
- IF (scope # NIL) & (scope # symbol.scope) & ~(symbol IS SyntaxTree.Constant) THEN
- Error(position, "forbidden access to symbol in parent procedure scope");
- END;
- END;
- assignable := (left = NIL) OR left.assignable OR (left IS SyntaxTree.DereferenceDesignator) OR (left IS SyntaxTree.SelfDesignator) OR (left IS SyntaxTree.SymbolDesignator) & (left(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Import);
- IF (currentScope # NIL) & (symbol.scope.ownerModule # currentScope.ownerModule) THEN
- assignable := assignable & (SyntaxTree.PublicWrite IN symbol.access);
- ELSE
- assignable := assignable & (SyntaxTree.InternalWrite IN symbol.access);
- END;
-
- assignable := assignable & ((symbol IS SyntaxTree.Variable) OR (symbol IS SyntaxTree.Parameter)
- & (symbol(SyntaxTree.Parameter).kind # SyntaxTree.ConstParameter) & ~(symbol(SyntaxTree.Parameter).ownerType IS SyntaxTree.CellType));
- result := SyntaxTree.NewSymbolDesignator(position,left,symbol);
- result.SetType(symbol.type);
- result.SetAssignable(assignable);
- symbol.MarkUsed;
- IF symbol IS SyntaxTree.Constant THEN
- result.SetResolved(symbol(SyntaxTree.Constant).value.resolved);
- END;
-
- IF (symbol IS SyntaxTree.Variable) & ~(symbol IS SyntaxTree.Property) THEN
- variableAccessed := TRUE
- END;
- IF (left = NIL) OR (left IS SyntaxTree.SelfDesignator) OR (left IS SyntaxTree.DereferenceDesignator) & (left(SyntaxTree.DereferenceDesignator).left IS SyntaxTree.SelfDesignator) THEN
- IF GetGuard(symbol,guardType) THEN
- result := NewTypeGuardDesignator(position,result(SyntaxTree.SymbolDesignator),guardType, result);
- END;
- END;
- ASSERT(result.type # NIL);
- RETURN result
- END NewSymbolDesignator;
- (** check and resolve an identifier designator "identifier"
- - if identifier = self then return SelfDesignator
- - else find symbol in current scope
- - if symbol found then return SymbolDesignator, else error message and return invalidDesignator
- **)
- PROCEDURE VisitIdentifierDesignator(identifierDesignator: SyntaxTree.IdentifierDesignator);
- VAR symbol: SyntaxTree.Symbol;
- BEGIN
- IF Trace THEN D.Str("VisitIdentifierDesignator "); D.Ln; END;
- symbol := Find(currentScope,identifierDesignator.identifier,TRUE);
- IF symbol # NIL THEN
- ResolveSymbol(symbol);
- ASSERT(symbol.type # NIL);
- resolvedExpression := NewSymbolDesignator(identifierDesignator.position,NIL,symbol);
- ELSE
- Error(identifierDesignator.position,"Undeclared Identifier");
- IF VerboseErrorMessage THEN
- Printout.Info("undeclared identifier designator",identifierDesignator);
- END;
- resolvedExpression := SyntaxTree.invalidDesignator;
- END;
- END VisitIdentifierDesignator;
- (** check and resolve a selector designator of the form left.designator
- - if left is a pointer type then do auto dereferenciation
- - left denotes a search scope:
- - if left type is import type then set search scope to respective module
- - if left type is enumeration type then set search scope to respective enumeration scope
- - elsif left type is record type then set search scope to record scope
- - search symbol in computed scope
- returns selector designator (via global variable resolvedExpression) if symbol found, else error message is given and invalidDesignator is returned
- **)
- PROCEDURE VisitSelectorDesignator(selectorDesignator: SyntaxTree.SelectorDesignator);
- VAR
- symbol: SyntaxTree.Symbol; left: SyntaxTree.Designator; scope: SyntaxTree.Scope;
- module: SyntaxTree.Module; result: SyntaxTree.Expression; type: SyntaxTree.Type;
- BEGIN
- IF Trace THEN D.Str("VisitSelectorDesignator"); D.Ln; END;
- left := ResolveDesignator(selectorDesignator.left);
- result := SyntaxTree.invalidDesignator;
- IF left # NIL THEN
- IF (left.type # NIL) & IsPointerType(left.type.resolved) THEN
- left := NewDereferenceDesignator(selectorDesignator.position,left);
- END;
- scope := NIL;
- IF left.type = NIL THEN
- Error(selectorDesignator.position,"field on nil typed designator");
- IF VerboseErrorMessage THEN Printout.Info("nil typed designator",left) END;
- ELSIF left.type.resolved = SyntaxTree.invalidType THEN (* error already handled *)
- ELSIF left.type.resolved = SyntaxTree.importType THEN
- symbol := left(SyntaxTree.SymbolDesignator).symbol;
- module := symbol(SyntaxTree.Import).module;
- IF module # NIL THEN
- scope := module.moduleScope
- ELSE
- Error(left.position,"module not loaded");
- IF VerboseErrorMessage THEN Printout.Info("unloaded module",symbol) END;
- END;
- ELSIF left.type.resolved IS SyntaxTree.RecordType THEN
- scope := left.type.resolved(SyntaxTree.RecordType).recordScope;
- ASSERT(scope # NIL)
- ELSIF left.type.resolved = SyntaxTree.typeDeclarationType THEN
- symbol := left(SyntaxTree.SymbolDesignator).symbol;
- type := symbol(SyntaxTree.TypeDeclaration).declaredType.resolved;
- IF type IS SyntaxTree.EnumerationType THEN
- scope := type(SyntaxTree.EnumerationType).enumerationScope;
- ELSE
- Error(selectorDesignator.position,"field on non-enumeration type declaration");
- IF VerboseErrorMessage THEN Printout.Info("non-record type designator",left) END;
- END;
- ELSIF left.type.resolved IS SyntaxTree.CellType THEN
- scope := left.type.resolved(SyntaxTree.CellType).cellScope;
- ELSE
- Error(selectorDesignator.position,"field on non-record type designator");
- IF VerboseErrorMessage THEN Printout.Info("non-record type designator",left) END;
- END;
- symbol := NIL;
- IF scope # NIL THEN
- symbol := Find(scope,selectorDesignator.identifier,FALSE (* do not visit nested scopes *));
- IF symbol # NIL THEN
- ResolveSymbol(symbol);
- result := NewSymbolDesignator(selectorDesignator.position,left,symbol);
- symbol.MarkUsed
- ELSE
- Error(selectorDesignator.position,"undeclared identifier (selector)");
- IF VerboseErrorMessage THEN
- D.Str("IDENT = "); D.Str0(selectorDesignator.identifier); D.Ln;
- Printout.Info("scope", scope);
- Printout.Info("left", left);
- Printout.Info("undeclared identifier",selectorDesignator);
- Printout.Info("left resolved designator",left);
- END
- END;
- END;
- END;
- resolvedExpression := result;
- END VisitSelectorDesignator;
- PROCEDURE IndexCheck(index,length: SyntaxTree.Expression);
- VAR len,idx: LONGINT;
- BEGIN
- IF (index # NIL) & IsIntegerValue(index,idx) THEN
- IF idx < 0 THEN
- Error(index.position,"index out of bounds (too small)")
- ELSE
- IF (length # NIL) & IsIntegerValue(length,len) & (idx >= len) THEN
- Error(index.position,"index out of bounds (too large)");
- END;
- END;
- END;
- END IndexCheck;
- (*
- - if index designator has not type, use newBaseType as its type
- - otherwise, replace the element type (last base type of math array chain) with newBaseType
- - special rule: if static array of dynamic array occurs, make it all dynamic
- index designator type: new base type: new index designator type:
- NIL z z
- ARRAY [x, y] z ARRAY [x, y] OF z
- ARRAY [x, y] ARRAY [z] ARRAY [x, y, z]
- ARRAY [x, y] ARRAY [*] ARRAY [*, *, *]
- *)
- PROCEDURE SetIndexBaseType(indexDesignator: SyntaxTree.IndexDesignator; newBaseType: SyntaxTree.Type);
- VAR
- mathArrayType: SyntaxTree.MathArrayType;
- makeDynamic: BOOLEAN;
- BEGIN
- IF indexDesignator.type = NIL THEN
- indexDesignator.SetType(newBaseType)
- ELSE
- (* index designator must be a of math array type *)
- ASSERT(indexDesignator.type.resolved IS SyntaxTree.MathArrayType);
- mathArrayType := indexDesignator.type.resolved(SyntaxTree.MathArrayType);
- (* determine if all arrays have to be made dynamic *)
- makeDynamic :=
- (newBaseType.resolved IS SyntaxTree.MathArrayType) &
- (newBaseType.resolved(SyntaxTree.MathArrayType).form # SyntaxTree.Static);
- WHILE (mathArrayType.arrayBase # NIL) & (mathArrayType.arrayBase IS SyntaxTree.MathArrayType) DO
- IF makeDynamic THEN mathArrayType.SetForm(SyntaxTree.Open) END;
- mathArrayType := mathArrayType.arrayBase(SyntaxTree.MathArrayType)
- END;
- IF makeDynamic THEN mathArrayType.SetForm(SyntaxTree.Open) END;
- mathArrayType.SetArrayBase(newBaseType)
- END
- END SetIndexBaseType;
- (** check and append index list element to index designator of math array
- - check validity of single index or array range
- - compute new type
- - if range then create new array type (calculate length of resulting array)
- - otherwise take sourceArray.arrayBase as new type
- - type is not only replaced but might have to be inserted when resolving expressions of the form A[*,i,j,*]
- **)
- PROCEDURE AppendMathIndex(position: Position; indexDesignator: SyntaxTree.IndexDesignator; indexListItem: SyntaxTree.Expression; sourceArray: SyntaxTree.MathArrayType);
- VAR
- targetArray: SyntaxTree.MathArrayType;
- first, last, step: SyntaxTree.Expression;
- firstValue, lastValue, stepValue, length: LONGINT;
- rangeExpression: SyntaxTree.RangeExpression;
- BEGIN
- IF indexListItem.type = SyntaxTree.invalidType THEN
- (* error already handled *)
- indexDesignator.parameters.AddExpression(indexListItem)
- ELSIF indexListItem IS SyntaxTree.TensorRangeExpression THEN
- indexDesignator.HasRange;
- indexDesignator.HasTensorRange;
- indexDesignator.parameters.AddExpression(indexListItem);
- indexDesignator.SetType(SyntaxTree.NewMathArrayType(position, NIL, SyntaxTree.Tensor))
- ELSIF indexListItem.type.resolved IS SyntaxTree.IntegerType THEN
- IndexCheck(indexListItem, sourceArray.length);
- indexListItem := NewConversion(Basic.invalidPosition, indexListItem, system.sizeType, NIL);
- indexDesignator.parameters.AddExpression(indexListItem)
- ELSIF indexListItem.type.resolved IS SyntaxTree.RangeType THEN
- indexDesignator.HasRange;
- (* if the range is given as an array range expression, check the validity of its components *)
- IF indexListItem IS SyntaxTree.RangeExpression THEN
- rangeExpression := indexListItem(SyntaxTree.RangeExpression);
- first := rangeExpression.first;
- last := rangeExpression.last;
- step := rangeExpression.step;
- (* perform static checks on range components *)
- IF IsIntegerValue(first, firstValue) & (firstValue < 0) THEN
- Error(indexListItem.position,"lower bound of array range too small")
- END;
- IF IsIntegerValue(last, lastValue) & (lastValue # MAX(LONGINT)) THEN
- IF (sourceArray.length # NIL) & IsIntegerValue(sourceArray.length, length) & (lastValue > (length - 1)) THEN
- Error(indexListItem.position,"upper bound of array range too large")
- END
- END;
- IF IsIntegerValue(step, stepValue) & (stepValue < 1) THEN
- Error(indexListItem.position,"invalid step size")
- END;
- (* add conversions to size type *)
- (* TODO: needed? *)
- rangeExpression.SetFirst(NewConversion(Basic.invalidPosition, first, system.sizeType, NIL));
- rangeExpression.SetLast(NewConversion(Basic.invalidPosition, last, system.sizeType, NIL));
- rangeExpression.SetStep(NewConversion(Basic.invalidPosition, step, system.sizeType, NIL));
- END;
- IF indexDesignator.hasTensorRange THEN
- (* the index designator's base type is a tensor: leave it as is *)
- ELSE
- (* append a new math array to the index designator's base type *)
- targetArray := SyntaxTree.NewMathArrayType(position, NIL, SyntaxTree.Open);
- IF ~error THEN
- (*
- (* optimization: calculate length of target array for static ranges *)
- IF indexListItem IS SyntaxTree.RangeExpression THEN
- IF IsStaticallyOpenRange(rangeExpression) THEN
- (* range is open ('*'): reuse source array length as target array length *)
- targetArray.SetLength(sourceArray.length); (* the length may or may not be static *)
- targetArray.SetIncrement(sourceArray.staticIncrementInBits)
- ELSIF IsStaticRange(rangeExpression, firstValue, lastValue, stepValue) THEN
- IF lastValue = MAX(LONGINT) THEN
- IF IsIntegerValue(sourceArray.length, length) THEN
- lastValue := length - 1;
- isStaticTargetArrayLength := TRUE
- ELSE
- isStaticTargetArrayLength := FALSE
- END
- ELSE
- isStaticTargetArrayLength := TRUE
- END;
- IF isStaticTargetArrayLength THEN
- (* calculate static target array length *)
- IF firstValue > lastValue THEN
- length := 0
- ELSE
- length := 1 + lastValue - firstValue;
- IF length MOD stepValue = 0 THEN
- length := length DIV stepValue
- ELSE
- length := length DIV stepValue + 1
- END
- END;
- targetArray.SetLength(Global.NewIntegerValue(system, position, length));
- targetArray.SetIncrement(sourceArray.staticIncrementInBits * stepValue);
- ASSERT(targetArray.form = SyntaxTree.Static)
- END
- END
- END
- *)
- END;
- SetIndexBaseType(indexDesignator, targetArray)
- END;
- indexDesignator.parameters.AddExpression(indexListItem)
- ELSE
- Error(position,"invalid index list item");
- END;
- END AppendMathIndex;
- PROCEDURE AppendIndex(position: Position; index: SyntaxTree.IndexDesignator; expression: SyntaxTree.Expression; over: SyntaxTree.Type);
- VAR parameters: SyntaxTree.ExpressionList;
- BEGIN
- parameters := index.parameters;
- IF (expression.type = NIL) THEN
- Error(position, "invalid index");
- ELSIF IsIntegerType(expression.type.resolved) THEN
- IF over IS SyntaxTree.ArrayType THEN
- IndexCheck(expression,over(SyntaxTree.ArrayType).length);
- ELSIF over IS SyntaxTree.StringType THEN
- IndexCheck(expression,Global.NewIntegerValue(system, position, over(SyntaxTree.StringType).length));
- END;
- expression := NewConversion(Basic.invalidPosition,expression,system.sizeType,NIL);
- parameters.AddExpression(expression);
- ELSE
- Error(position, "invalid index");
- END;
- END AppendIndex;
- (** convert an expression to math array type
- if expression is of math array type: return expression itself
- if expression is of array-structured object type: return an index operator call on it
- e.g. if expression is 3-dim. ASOT: expression -> expression^."[]"( * , * , * )
- otherwise: return invalid expression
- **)
- PROCEDURE ConvertToMathArray(expression: SyntaxTree.Expression): SyntaxTree.Expression;
- VAR
- result: SyntaxTree.Expression;
- mathArrayType: SyntaxTree.MathArrayType;
- BEGIN
- IF expression.type = NIL THEN
- result := SyntaxTree.invalidExpression
- ELSIF expression.type.resolved IS SyntaxTree.MathArrayType THEN
- (* expression of math array type *)
- result := expression
- ELSIF IsArrayStructuredObjectType(expression.type) THEN
- (* expression of array-structured object type *)
- mathArrayType := MathArrayStructureOfType(expression.type);
- result := NewIndexOperatorCall(Basic.invalidPosition, expression, ListOfOpenRanges(mathArrayType.Dimensionality()), NIL)
- ELSE
- result := SyntaxTree.invalidExpression
- END;
- RETURN result
- END ConvertToMathArray;
- (** get an expression list containing a certain amount of open ranges, e.g. [*, *, *, *] **)
- PROCEDURE ListOfOpenRanges(itemCount: LONGINT): SyntaxTree.ExpressionList;
- VAR
- result: SyntaxTree.ExpressionList;
- i: LONGINT;
- BEGIN
- result := SyntaxTree.NewExpressionList();
- FOR i := 1 TO itemCount DO
- result.AddExpression(ResolveExpression(SyntaxTree.NewRangeExpression(Basic.invalidPosition, NIL, NIL, NIL)))
- END;
- RETURN result
- END ListOfOpenRanges;
- (** create a procedure call designator for an index operator call on an array-structured object type
- - use given index list as actual parameters
- - if rhs parameter is not NIL: call write operator, otherwise read operator
- **)
- PROCEDURE NewIndexOperatorCall*(position: Position; left: SyntaxTree.Expression; indexList: SyntaxTree.ExpressionList; rhs: SyntaxTree.Expression): SyntaxTree.Designator;
- VAR
- operator: SyntaxTree.Operator;
- expression: SyntaxTree.Expression;
- actualParameters, tempList: SyntaxTree.ExpressionList;
- tempMathArrayExpression: SyntaxTree.MathArrayExpression;
- result, tempDesignator: SyntaxTree.Designator;
- recordType: SyntaxTree.RecordType;
- containsNonRange, usesPureRangeOperator, usesGeneralOperator, needsReshaping: BOOLEAN;
- i, hashValue, indexListSize, indexListKind: LONGINT;
- castReturnType: SyntaxTree.MathArrayType;
- BEGIN
- ASSERT(IsArrayStructuredObjectType(left.type));
- ASSERT(left.type.resolved IS SyntaxTree.PointerType);
- recordType := left.type.resolved(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
- (* determine hash value of optimal index operator and if index list contains non-range item *)
- indexListSize := indexList.Length();
- indexListKind := 0;
- containsNonRange := FALSE;
- FOR i := 0 TO indexList.Length() - 1 DO
- indexListKind := indexListKind * 2;
- expression := indexList.GetExpression(i);
- IF expression.type.resolved IS SyntaxTree.RangeType THEN
- INC(indexListKind)
- ELSE
- containsNonRange := TRUE
- END
- END;
- hashValue := IndexOperatorHash(indexListSize, indexListKind, recordType.arrayStructure.form = SyntaxTree.Tensor);
- (* select applicable index operator
- - try to look up optimal index operator
- - if not present, use operator on ranges
- - for non-tensors, use fixed-dim. operator: (RANGE, RANGE, ... RANGE)
- - for tensors, use general operator: (ARRAY [*] OF RANGE)
- *)
- usesGeneralOperator := FALSE;
- IF rhs # NIL THEN
- (* write operator *)
- IF hashValue = -1 THEN
- operator := NIL
- ELSE
- operator := recordType.arrayAccessOperators.write[hashValue];
- END;
- IF operator = NIL THEN
- usesPureRangeOperator := TRUE;
- IF recordType.arrayStructure.form = SyntaxTree.Tensor THEN
- operator := recordType.arrayAccessOperators.generalWrite;
- usesGeneralOperator := TRUE
- ELSE
- hashValue := TwoToThePowerOf(indexListSize) - 1;
- operator := recordType.arrayAccessOperators.write[hashValue];
- END
- END
- ELSE
- (* read operator *)
- IF hashValue = -1 THEN
- operator := NIL
- ELSE
- operator := recordType.arrayAccessOperators.read[hashValue];
- END;
- IF operator = NIL THEN
- usesPureRangeOperator := TRUE;
- IF recordType.arrayStructure.form = SyntaxTree.Tensor THEN
- operator := recordType.arrayAccessOperators.generalRead;
- usesGeneralOperator := TRUE
- ELSE
- hashValue := TwoToThePowerOf(indexListSize) - 1;
- operator := recordType.arrayAccessOperators.read[hashValue];
- END
- END
- END;
- IF operator = NIL THEN
- Error(position, "call of undeclared [] operator");
- result := SyntaxTree.invalidDesignator;
- ELSE
- (* determine if reshaping is needed *)
- needsReshaping := containsNonRange & usesPureRangeOperator;
- (* import OCArrayBase if reshaping is needed *)
- IF needsReshaping & ~arrayBaseImported THEN
- ImportModule(Global.ArrayBaseName, Basic.invalidPosition);
- arrayBaseImported := TRUE
- END;
- (* add the index list item to the list of actual parameters
- - for general operators: add a single inline array containing the index list items as parameter
- - otherwise: add all index list items as individual parameters
- *)
- actualParameters := SyntaxTree.NewExpressionList();
- IF usesGeneralOperator THEN
- tempMathArrayExpression := SyntaxTree.NewMathArrayExpression(Basic.invalidPosition);
- END;
- FOR i := 0 TO indexListSize - 1 DO
- expression := indexList.GetExpression(i);
- IF (expression.type.resolved IS SyntaxTree.IntegerType) & needsReshaping THEN
- (* convert integer to range using OCArrayBase.RangeFromInteger *)
- tempList := SyntaxTree.NewExpressionList();
- tempList.AddExpression(expression);
- tempDesignator := SyntaxTree.NewIdentifierDesignator(Basic.invalidPosition, Global.ArrayBaseName);
- tempDesignator := SyntaxTree.NewSelectorDesignator(Basic.invalidPosition, tempDesignator, SyntaxTree.NewIdentifier("RangeFromInteger"));
- expression := ResolveExpression(SyntaxTree.NewParameterDesignator(Basic.invalidPosition, tempDesignator, tempList));
- END;
- IF usesGeneralOperator THEN
- tempMathArrayExpression.elements.AddExpression(expression);
- ELSE
- actualParameters.AddExpression(expression)
- END
- END;
- IF usesGeneralOperator THEN
- actualParameters.AddExpression(tempMathArrayExpression)
- END;
- IF rhs # NIL THEN
- (* add actual parameter for RHS *)
- IF needsReshaping THEN
- (* reshape using OCArrayBase.ExpandDimensions *)
- tempList := SyntaxTree.NewExpressionList();
- (* source array *)
- IF rhs.type.resolved IS SyntaxTree.MathArrayType THEN
- tempList.AddExpression(rhs);
- ELSE
- (* convert scalar to one-dimensional array *)
- tempMathArrayExpression := SyntaxTree.NewMathArrayExpression(Basic.invalidPosition);
- tempMathArrayExpression.elements.AddExpression(rhs);
- tempList.AddExpression(tempMathArrayExpression)
- END;
- (* list of kept dimensions *)
- tempMathArrayExpression := SyntaxTree.NewMathArrayExpression(Basic.invalidPosition);
- FOR i := 0 TO indexListSize - 1 DO
- expression := indexList.GetExpression(i);
- IF expression.type.resolved IS SyntaxTree.IntegerType THEN
- tempMathArrayExpression.elements.AddExpression(SyntaxTree.NewBooleanValue(Basic.invalidPosition, FALSE)) (* insert dimension *)
- ELSE
- tempMathArrayExpression.elements.AddExpression(SyntaxTree.NewBooleanValue(Basic.invalidPosition, TRUE)) (* keep dimension *)
- END
- END;
- tempList.AddExpression(tempMathArrayExpression);
- tempDesignator := SyntaxTree.NewIdentifierDesignator(Basic.invalidPosition, Global.ArrayBaseName);
- tempDesignator := SyntaxTree.NewSelectorDesignator(Basic.invalidPosition, tempDesignator, SyntaxTree.NewIdentifier("ExpandDimensions"));
- expression := ResolveExpression(SyntaxTree.NewParameterDesignator(Basic.invalidPosition, tempDesignator, tempList));
- IF expression.type.resolved IS SyntaxTree.MathArrayType THEN
- (* change the base type of the returned tensor from SYSTEM.ALL to the array structure's element type *)
- castReturnType := SyntaxTree.NewMathArrayType(Basic.invalidPosition,expression.type.scope,SyntaxTree.Tensor);
- castReturnType.SetArrayBase(ArrayBase(rhs.type.resolved,MAX(LONGINT)));
- expression.SetType(castReturnType);
- ELSE
- Error(expression.position, "problem with resolving ArrayBase.ExpandDimensions");
- END;
- actualParameters.AddExpression(expression)
- ELSE
- actualParameters.AddExpression(rhs)
- END
- END;
- (* add dereference operator and create procedure call designator *)
- ASSERT(left IS SyntaxTree.Designator);
- expression := NewSymbolDesignator(Basic.invalidPosition, NewDereferenceDesignator(Basic.invalidPosition, left(SyntaxTree.Designator)), operator);
- ASSERT(expression IS SyntaxTree.Designator);
- result := NewProcedureCallDesignator(Basic.invalidPosition, expression(SyntaxTree.Designator), actualParameters);
- IF (rhs = NIL) & needsReshaping THEN
- (* reshape using an additional bracket designator with zeros and open ranges at the end; e.g. designator[0, *, *, 0] *)
- tempList := SyntaxTree.NewExpressionList();
- FOR i := 0 TO indexList.Length() - 1 DO
- expression := indexList.GetExpression(i);
- IF expression.type.resolved IS SyntaxTree.IntegerType THEN
- tempList.AddExpression(SyntaxTree.NewIntegerValue(Basic.invalidPosition, 0))
- ELSE
- tempList.AddExpression(SyntaxTree.NewRangeExpression(Basic.invalidPosition, NIL, NIL, NIL))
- END
- END;
- result := ResolveDesignator(SyntaxTree.NewBracketDesignator(Basic.invalidPosition, result, tempList))
- END;
- IF rhs = NIL THEN
- (* special rule: index read operator calls are considered to be assignable *)
- result.SetAssignable(TRUE)
- END;
- (* put information about this index operator call into the resulting designator *)
- result.SetRelatedAsot(left);
- result.SetRelatedIndexList(indexList)
- END;
- RETURN result
- END NewIndexOperatorCall;
- PROCEDURE NewObjectOperatorCall*(position: Position; left: SyntaxTree.Expression; oper: LONGINT; parameters: SyntaxTree.ExpressionList; rhs: SyntaxTree.Expression): SyntaxTree.Designator;
- VAR type: SyntaxTree.Type; expression: SyntaxTree.Expression; op: SyntaxTree.Operator; recordType: SyntaxTree.RecordType;
- actualParameters: SyntaxTree.ExpressionList; i: LONGINT; result: SyntaxTree.Designator;
- PROCEDURE FindOperator(recordType: SyntaxTree.RecordType; identifier: SyntaxTree.Identifier; actualParameters: SyntaxTree.ExpressionList): SyntaxTree.Operator;
- VAR bestOperator: SyntaxTree.Operator; bestDistance: LONGINT; numberParameters: LONGINT; procedureType: SyntaxTree.ProcedureType;
- PROCEDURE FindInScope(scope: SyntaxTree.RecordScope; access: SET);
- VAR operator: SyntaxTree.Operator; distance,i: LONGINT;
- CONST trace = FALSE;
- BEGIN
- IF trace THEN
- FOR i := 0 TO actualParameters.Length()-1 DO
- Printout.Info("par", actualParameters.GetExpression(i));
- END;
- END;
- operator := scope.firstOperator;
- WHILE(operator # NIL) DO
- IF (operator.name=identifier) & (operator.access * access # {}) THEN
- procedureType := operator.type(SyntaxTree.ProcedureType);
- distance := Distance(system, procedureType,actualParameters);
- IF trace THEN Printout.Info("check op ",operator) END;
- IF distance < bestDistance THEN
- IF trace THEN Printout.Info("taken op",operator) END;
- bestDistance := distance;
- bestOperator := operator;
- END;
- END;
- operator := operator.nextOperator;
- END;
- END FindInScope;
- BEGIN
- bestDistance := Infinity; bestOperator := NIL; numberParameters := actualParameters.Length();
- IF oper = 0 THEN (* index *)
- identifier := SyntaxTree.NewIdentifier("[]");
- ELSE
- identifier := Global.GetIdentifier(oper,currentScope.ownerModule.case);
- END;
-
- WHILE (recordType # NIL) DO
- FindInScope(recordType.recordScope,SyntaxTree.ReadOnly);
- recordType := recordType.GetBaseRecord();
- END;
- RETURN bestOperator
- END FindOperator;
- BEGIN
- type := left.type.resolved;
- IF ~(type IS SyntaxTree.PointerType) THEN RETURN NIL END;
- recordType := type(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
- actualParameters := SyntaxTree.NewExpressionList();
- IF parameters # NIL THEN
- FOR i := 0 TO parameters.Length()-1 DO
- expression := ResolveExpression(parameters.GetExpression(i));
- actualParameters.AddExpression(expression);
- END;
- END;
- IF rhs # NIL THEN actualParameters.AddExpression(rhs) END;
- op := FindOperator(recordType, SyntaxTree.NewIdentifier("[]"), actualParameters);
- IF op # NIL THEN
- expression := NewSymbolDesignator(position, NewDereferenceDesignator(Basic.invalidPosition, left(SyntaxTree.Designator)) , op);
- ASSERT(expression IS SyntaxTree.Designator);
- result := NewProcedureCallDesignator(position, expression(SyntaxTree.Designator), actualParameters);
- result.SetRelatedAsot(left);
- result.SetRelatedIndexList(parameters);
- (* check if write operator exists, for var parameters *)
- IF (rhs = NIL) & (op.type(SyntaxTree.ProcedureType).returnType # NIL) THEN
- actualParameters := SyntaxTree.NewExpressionList();
- FOR i := 0 TO parameters.Length()-1 DO
- expression := ResolveExpression(parameters.GetExpression(i));
- actualParameters.AddExpression(expression);
- END;
- rhs := SyntaxTree.NewDesignator(); rhs.SetType(op.type(SyntaxTree.ProcedureType).returnType); (* only a stub to test for existence of operator *)
- actualParameters.AddExpression(rhs);
- op := FindOperator(recordType, SyntaxTree.NewIdentifier("[]"), actualParameters);
- IF op = NIL THEN rhs := NIL END;
- END;
- IF rhs # NIL THEN result.SetAssignable(TRUE) END;
- ELSE
- result := NIL;
- END;
- RETURN result;
- END NewObjectOperatorCall;
- (** check and semantically resolve a bracket designator of the form 'left[expression, ..., expression]'
- 1. convert bracket designator chains into a single one that contains separators
- e.g.: left[a, b, c][d, e][f] -> left[a, b, c, |, d, e, |, f]
- 2. convert single bracket designator into a chain of index- , dereference- and procedure call designators
- e.g.: left[a, b, c, |, d, e, |, f] -> left^[a]^."[]"(b, c, d)[e, f]
- - if an array or math array is indexed over, create index designator
- a[x, |, y] -> a[x][y] (split at separator if 'x' contains range or 'a' is tensor math array)
- a[x, |, y] -> a[x, y] (otherwise, combine into single one)
- - if a pointer is indexed over, splitting and auto-dereferencing takes place:
- a[x, y] -> a[x]^[y] (a: ARRAY OF POINTER TO ARRAY OF INTEGER)
- - if an array-structured object type is indexed over, create procedure call designator
- e.g.: a[x, y] -> a^."[]"(x, y)
- Note 1: for math arrays, there can be a difference between a[x, y] and [y, x]:
- - a[i, *] = a[i][*]
- - a[*, i] # a[*][i]
- Because:
- - 'i-th row' = a[*][i] = a[*][i, *] = a[i, *] = a[i] = a[i][*] = a[i][*][*] = a[i][*][*][*]
- - 'i-th column' = a[*, i]
- Note 2: math arrays of arrays (and vice versa) are forbidden by the type system.
- However, pointers are permitted: e.g. ARRAY [10] OF POINTER TO ARRAY is a valid type.
- Note 3: while this compiler tries to combine multiple bracket designators into a single index designator,
- older Oberon compilers did this the other way around: a[x, y, z] -> A[x][y][z].
- **)
- PROCEDURE VisitBracketDesignator(bracketDesignator: SyntaxTree.BracketDesignator);
- VAR
- leftBracketDesignator: SyntaxTree.BracketDesignator;
- indexDesignator: SyntaxTree.IndexDesignator;
- designator: SyntaxTree.Designator;
- type: SyntaxTree.Type;
- recordType: SyntaxTree.RecordType;
- expression, rhs: SyntaxTree.Expression;
- indexList: SyntaxTree.ExpressionList;
- i: LONGINT;
- hasError, done: BOOLEAN;
- PROCEDURE FinalizeIndexDesignator;
- BEGIN
- IF indexDesignator # NIL THEN
- (* the end of a tensor has been reached: *)
- IF IsTensor(type) THEN type := type(SyntaxTree.MathArrayType).arrayBase.resolved END;
- SetIndexBaseType(indexDesignator, type);
- indexDesignator.SetType(ResolveType(indexDesignator.type));
- designator := indexDesignator;
- type := designator.type.resolved;
- indexDesignator := NIL;
- ASSERT(SyntaxTree.Resolved IN type.state)
- END
- END FinalizeIndexDesignator;
- BEGIN
- IF Trace THEN D.Str("VisitBracketDesignator"); D.Ln; END;
- IF bracketDesignator.left IS SyntaxTree.BracketDesignator THEN
- leftBracketDesignator := bracketDesignator.left(SyntaxTree.BracketDesignator);
- (* copy all index list entries including a separator to the left bracket designator *)
- leftBracketDesignator.parameters.AddExpression(SyntaxTree.indexListSeparator);
- FOR i := 0 TO bracketDesignator.parameters.Length() - 1 DO
- leftBracketDesignator.parameters.AddExpression(bracketDesignator.parameters.GetExpression(i))
- END;
- (* propagate the related RHS *)
- leftBracketDesignator.SetRelatedRhs(bracketDesignator.relatedRhs); (* for 'left[a][b] := rhs;' *)
- (* only resolve left bracket designator and use as final result *)
- resolvedExpression := ResolveExpression(leftBracketDesignator)
- ELSE
- ASSERT(~(bracketDesignator.left IS SyntaxTree.BracketDesignator));
- designator := ResolveDesignator(bracketDesignator.left);
- type := designator.type.resolved;
- indexDesignator := NIL;
- (*!!! clean up *)
- IF (type IS SyntaxTree.PointerType) & (type(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType) & ~IsArrayStructuredObjectType(type) THEN
- resolvedExpression := NewObjectOperatorCall(bracketDesignator.position, designator, 0, bracketDesignator.parameters,bracketDesignator.relatedRhs);
- IF resolvedExpression = NIL THEN
- Error(bracketDesignator.position,"undefined operator");
- resolvedExpression := SyntaxTree.invalidDesignator
- END;
- RETURN;
- END;
- i := 0;
- WHILE i <= bracketDesignator.parameters.Length() - 1 DO
- expression := bracketDesignator.parameters.GetExpression(i);
- expression := ResolveExpression(expression);
- bracketDesignator.parameters.SetExpression(i, expression);
- IF expression = SyntaxTree.indexListSeparator THEN
- (* finalize an existing index designator if needed *)
- IF IsTensor(type) OR (indexDesignator # NIL) & (indexDesignator.hasRange) THEN FinalizeIndexDesignator END;
- INC(i)
- ELSE
- (* do auto-dereferencing if needed *)
- IF (type IS SyntaxTree.PointerType) & ~IsArrayStructuredObjectType(type)
- (*OR (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.SemiDynamic) & cellsAreObjects
- & (i=0)*)
- THEN
- (* expression of the form A[x,...] over ARRAY [...] OF POINTER TO ARRAY OF ... *)
- IF (indexDesignator # NIL) & indexDesignator.hasRange THEN
- Error(expression.position, "forbidden range valued indexer over pointer to array");
- designator := SyntaxTree.invalidDesignator;
- type := SyntaxTree.invalidType
- ELSE
- FinalizeIndexDesignator;
- designator := NewDereferenceDesignator(bracketDesignator.position, designator);
- type := designator.type.resolved
- END
- END;
- (* create a new index designator, if needed *)
- IF (indexDesignator = NIL) & ((type IS SyntaxTree.ArrayType) OR (type IS SyntaxTree.MathArrayType) OR (type IS SyntaxTree.StringType)) THEN
- indexDesignator := SyntaxTree.NewIndexDesignator(bracketDesignator.position, designator);
- indexDesignator.SetAssignable(designator.assignable);
- indexDesignator.SetType(NIL); (* type will be re-set when index designator is finalized *)
- (* designator := indexDesignator *)
- END;
- IF type = SyntaxTree.invalidType THEN
- (* error already handled *)
- INC(i)
- ELSIF type IS SyntaxTree.ArrayType THEN
- (* indexing over an array *)
- ASSERT(indexDesignator # NIL);
- AppendIndex(expression.position, indexDesignator, expression, type(SyntaxTree.ArrayType));
- type := type(SyntaxTree.ArrayType).arrayBase.resolved;
- INC(i)
- ELSIF type IS SyntaxTree.StringType THEN
- (* indexing over an array *)
- ASSERT(indexDesignator # NIL);
- AppendIndex(expression.position, indexDesignator, expression, type);
- type := type(SyntaxTree.StringType).baseType.resolved;
- INC(i)
- ELSIF type IS SyntaxTree.MathArrayType THEN
- (* indexing over a math array *)
- ASSERT(indexDesignator # NIL);
- AppendMathIndex(expression.position, indexDesignator, expression, type(SyntaxTree.MathArrayType));
- IF type(SyntaxTree.MathArrayType).form # SyntaxTree.Tensor THEN type := type(SyntaxTree.MathArrayType).arrayBase.resolved END;
- INC(i)
- ELSIF IsArrayStructuredObjectType(type) THEN
- (* indexing over ASOTs *)
- FinalizeIndexDesignator;
- ASSERT(type IS SyntaxTree.PointerType);
- recordType := type(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
- (*
- - collect index list items from bracket designator that belong to ASOT
- - check for errors
- *)
- indexList := SyntaxTree.NewExpressionList();
- hasError := FALSE;
- IF recordType.arrayStructure.form = SyntaxTree.Tensor THEN
- (* indexing over tensor ASOT:
- - stop at index list end or separator
- - dimensionality is given by number of index list items
- *)
- done := FALSE;
- WHILE ~done DO
- IF i > bracketDesignator.parameters.Length() - 1 THEN
- done := TRUE;
- ELSE
- expression := bracketDesignator.parameters.GetExpression(i);
- IF expression = SyntaxTree.indexListSeparator THEN
- done := TRUE;
- ELSE
- expression := ResolveExpression(expression);
- IF expression IS SyntaxTree.TensorRangeExpression THEN
- Error(expression.position, "tensor range expression not supported for tensor ASOTs");
- hasError := TRUE
- ELSIF ~(expression.type.resolved IS SyntaxTree.IntegerType) & ~(expression.type.resolved IS SyntaxTree.RangeType) THEN
- Error(expression.position, "integer or range expected");
- expression := SyntaxTree.invalidExpression;
- hasError := TRUE
- END;
- indexList.AddExpression(expression)
- END;
- INC(i)
- END
- END
- ELSE
- (* indexing over non-tensor ASOT:
- - ignore separators
- - make sure that the number of index items matches the ASOT's dimensionality by appending open ranges ('*')
- *)
- WHILE indexList.Length() < recordType.arrayStructure.Dimensionality() DO
- IF i <= bracketDesignator.parameters.Length() - 1 THEN
- expression := bracketDesignator.parameters.GetExpression(i);
- ELSE
- expression := SyntaxTree.NewRangeExpression(Basic.invalidPosition, NIL, NIL, NIL)
- END;
- IF expression # SyntaxTree.indexListSeparator THEN
- expression := ResolveExpression(expression);
- IF ~(expression.type.resolved IS SyntaxTree.IntegerType) & ~(expression.type.resolved IS SyntaxTree.RangeType) THEN
- Error(expression.position, "integer or range expected");
- expression := SyntaxTree.invalidExpression;
- hasError := TRUE
- END;
- indexList.AddExpression(expression)
- END;
- INC(i)
- END;
- END;
- IF hasError THEN
- designator := SyntaxTree.invalidDesignator;
- type := SyntaxTree.invalidType;
- ELSE
- (* determine if read or write mode applies: write mode applies if there is a related RHS
- and the last entry in the index list belongs to the array-structured object type in question.
- E.g.: for a 2-dimensional array-structured object type:
- - 'lhs := asot[1, 2]' -> read mode
- - 'asot[1, 2] := rhs' -> write mode
- - 'asot[1, 2, 3] := rhs' -> read mode
- *)
- IF (bracketDesignator.relatedRhs # NIL) & (i > bracketDesignator.parameters.Length() - 1) THEN
- rhs := bracketDesignator.relatedRhs
- ELSE
- rhs := NIL
- END;
- designator := NewIndexOperatorCall(bracketDesignator.position, designator, indexList, rhs);
- type := designator.type
- END
- ELSE
- Error(expression.position,"indexing over non-array type");
- designator := SyntaxTree.invalidDesignator;
- type := SyntaxTree.invalidType;
- INC(i)
- END
- END
- END;
- IF type # SyntaxTree.invalidType THEN FinalizeIndexDesignator END;
- resolvedExpression := designator
- END
- END VisitBracketDesignator;
- (** check and resolve expression list
- - resolve each expression in an expression list
- - returns true if and only if all statements could have successfully been resolved
- **)
- PROCEDURE ExpressionList(expressionList: SyntaxTree.ExpressionList): BOOLEAN;
- VAR i: LONGINT; expression: SyntaxTree.Expression; result: BOOLEAN;
- BEGIN
- result := TRUE;
- FOR i := 0 TO expressionList.Length()-1 DO
- expression := ResolveExpression(expressionList.GetExpression(i));
- IF expression = SyntaxTree.invalidExpression THEN result := FALSE END;
- expressionList.SetExpression(i,expression);
- END;
- RETURN result
- END ExpressionList;
- PROCEDURE CanPassInRegister*(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- type := type.resolved;
- IF (type IS SyntaxTree.BasicType) & ~type.IsPointer() & ~type.IsComposite() OR (type IS SyntaxTree.PortType) THEN
- RETURN TRUE
- ELSIF system.CanPassInRegister # NIL THEN
- RETURN system.CanPassInRegister(type);
- ELSE
- RETURN FALSE
- END;
- END CanPassInRegister;
- (** return procedure call designator left(actualParameters)
- - check realtime procedure call in realtime procedure
- - check number of parameters
- - check parameter compatibility
- return invalidDesignator if error
- **)
- PROCEDURE NewProcedureCallDesignator(position: Position; left: SyntaxTree.Designator; actualParameters:SyntaxTree.ExpressionList): SyntaxTree.Designator;
- VAR result: SyntaxTree.Designator;
- numberFormalParameters, numberActualParameters: LONGINT;
- formalType: SyntaxTree.ProcedureType;
- formalParameter: SyntaxTree.Parameter;
- actualParameter: SyntaxTree.Expression;
- i: LONGINT;
- self: SyntaxTree.Expression;
- BEGIN
- IF Trace THEN D.Str("ProcedureCallDesignator"); D.Ln; END;
- result := SyntaxTree.invalidDesignator;
- formalType := left.type.resolved(SyntaxTree.ProcedureType); (* type checked in VisitParameterDesignator *)
- numberFormalParameters := formalType.numberParameters;
- numberActualParameters := actualParameters.Length();
- IF (currentIsRealtime) & ~(formalType.isRealtime) THEN
- Error(position, "forbidden call of non-realtime procedure in realtime block");
- END;
-
- IF (formalType.selfParameter # NIL) & (formalType.selfParameter.kind = SyntaxTree.VarParameter) THEN
- self := left.left;
- IF (self # NIL) & ~IsVariable(self) THEN
- Error(self.position, "Non-variable expression on variable receiver");
- END;
- END;
-
- IF ~ExpressionList(actualParameters) THEN
- result := SyntaxTree.invalidDesignator
- ELSE
- IF numberActualParameters <= numberFormalParameters THEN
- formalParameter := formalType.firstParameter;
- FOR i := 0 TO numberActualParameters-1 DO
- actualParameter := actualParameters.GetExpression(i);
- IF (actualParameter = SyntaxTree.invalidExpression) THEN
- ELSIF ~ParameterCompatible(formalParameter,actualParameter) THEN
- ELSIF (currentIsRealtime) & ~actualParameter.type.resolved.isRealtime THEN
- Error(position, "non-realtime actual parameter in context of realtime procedure");
- ELSE
- IF ~formalParameter.type.SameType(actualParameter.type.resolved) THEN
- actualParameter := NewConversion(actualParameter.position,actualParameter,formalParameter.type,NIL);
- END;
- actualParameters.SetExpression(i,actualParameter);
- END;
- formalParameter := formalParameter.nextParameter;
- END;
- WHILE (formalParameter # NIL) DO
- IF formalParameter.defaultValue # NIL THEN
- actualParameters.AddExpression(formalParameter.defaultValue);
- formalParameter := formalParameter.nextParameter
- ELSE
- Error(position, "less actual than formal parameters");
- formalParameter := NIL;
- END;
- END;
- ELSE
- Error(position, "more actual than formal parameters")
- END;
- result := SyntaxTree.NewProcedureCallDesignator(position,left,actualParameters);
- result.SetAssignable(FALSE);
- result.SetType(left.type.resolved(SyntaxTree.ProcedureType).returnType);
- END;
- RETURN result
- END NewProcedureCallDesignator;
- (**
- builtin call designator generated in VisitParameterDesignator
- -> nothing to be resolved
- **)
- PROCEDURE VisitTypeGuardDesignator(x: SyntaxTree.TypeGuardDesignator);
- BEGIN
- resolvedExpression := x;
- END VisitTypeGuardDesignator;
- (**
- builtin call designator generated in VisitParameterDesignator
- -> nothing to be resolved
- **)
- PROCEDURE VisitBuiltinCallDesignator(x: SyntaxTree.BuiltinCallDesignator);
- BEGIN
- IF (x.returnType # NIL) & ExpressionList(x.parameters) THEN
- resolvedExpression := NewBuiltinCallDesignator(x.position,NIL, x.parameters,NIL, ResolveType(x.returnType));
- ASSERT(resolvedExpression.type # NIL);
- ELSIF ExpressionList(x.parameters) THEN
- resolvedExpression := x;
- END;
- END VisitBuiltinCallDesignator;
- (**
- procedure call designator generated in VisitParameterDesignator
- -> nothing to be resolved
- **)
- PROCEDURE VisitProcedureCallDesignator(x: SyntaxTree.ProcedureCallDesignator);
- BEGIN
- x.SetType(x.left.type.resolved(SyntaxTree.ProcedureType).returnType);
- resolvedExpression := x;
- END VisitProcedureCallDesignator;
- (** return true if x is a variable else return false and report error **)
- PROCEDURE CheckVariable(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := TRUE;
- IF x = SyntaxTree.invalidExpression THEN
- result := FALSE;
- ELSIF ~IsVariable(x) THEN
- Error(x.position,"non variable expression");
- IF VerboseErrorMessage THEN Printout.Info("non variable",x) END;
- result := FALSE;
- END;
- RETURN result
- END CheckVariable;
- (**
- if expression x is of basic type then return true else report error and return false
- **)
- PROCEDURE CheckBasicType(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF ~IsBasicType(x.type) THEN
- Error(x.position,"is no basic type");
- result := FALSE
- ELSE result := TRUE
- END;
- RETURN result
- END CheckBasicType;
- (**
- if expression x is of number type then return true else report error and return false
- **)
- PROCEDURE CheckNumberType(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF ~(x.type.resolved IS SyntaxTree.NumberType) THEN
- Error(x.position,"is non number type");
- ELSE result := TRUE
- END;
- RETURN result
- END CheckNumberType;
- (**
- if expression x is of number or size type but not complex then return true else report error and return false
- **)
- PROCEDURE CheckNonComplexNumberSizeType(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF x.type.resolved IS SyntaxTree.ComplexType THEN
- Error(x.position,"is complex type");
- ELSIF ~(x.type.resolved IS SyntaxTree.NumberType) & ~(x.type.resolved IS SyntaxTree.SizeType) THEN
- Error(x.position,"is non number type");
- ELSE result := TRUE
- END;
- RETURN result
- END CheckNonComplexNumberSizeType;
- PROCEDURE CheckAddressType(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN; type: SyntaxTree.Type;
- BEGIN
- result := FALSE; type := x.type.resolved;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF ~(type IS SyntaxTree.AddressType) & ~(type IS SyntaxTree.NilType) & ~(type IS SyntaxTree.SizeType) & ~( (type IS SyntaxTree.IntegerType) & (type.sizeInBits <= system.addressType.sizeInBits)) & ~IsAddressValue(x) & ~IsUnsafePointer(type) THEN
- TRACE(type.sizeInBits);
- TRACE(system.addressType.sizeInBits);
- Error(x.position,"is no address type");
- ELSE result := TRUE
- END;
- RETURN result
- END CheckAddressType;
- PROCEDURE CheckSizeType(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN; type: SyntaxTree.Type;
- BEGIN
- result := FALSE; type := x.type.resolved;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF ~(type IS SyntaxTree.SizeType) & ~( (type IS SyntaxTree.IntegerType) & (type.sizeInBits <= system.sizeType.sizeInBits)) THEN
- Error(x.position,"is no size type");
- ELSE result := TRUE
- END;
- RETURN result
- END CheckSizeType;
- PROCEDURE CheckObjectType(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN; type: SyntaxTree.Type;
- BEGIN
- result := FALSE; type := x.type.resolved;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF ~(type IS SyntaxTree.NilType) & ~(type IS SyntaxTree.ObjectType) & (~(type IS SyntaxTree.PointerType) OR ~(type(SyntaxTree.PointerType).pointerBase IS SyntaxTree.RecordType) OR ~type(SyntaxTree.PointerType).pointerBase(SyntaxTree.RecordType).isObject) THEN
- Error(x.position,"is no object type");
- ELSE result := TRUE
- END;
- RETURN result
- END CheckObjectType;
- (**
- if expression x is of integer type then return true else report error and return false
- **)
- PROCEDURE CheckIntegerType(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN; type: SyntaxTree.Type;
- BEGIN
- result := FALSE; type := x.type.resolved;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF ~(type IS SyntaxTree.IntegerType) & ~(type IS SyntaxTree.ByteType) & ~(type IS SyntaxTree.AddressType) & ~(type IS SyntaxTree.SizeType) THEN
- Error(x.position,"is no integer type");
- ELSE result := TRUE
- END;
- RETURN result
- END CheckIntegerType;
- (**
- if expression x is of character type then return true else report error and return false
- **)
- PROCEDURE CheckCharacterType(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF ~(x.type.resolved IS SyntaxTree.CharacterType) & ~(x.type.resolved IS SyntaxTree.ByteType) & ~IsCharacterType(x.type.resolved) THEN
- Error(x.position,"is no character type");
- ELSE result := TRUE
- END;
- RETURN result
- END CheckCharacterType;
- (**
- if expression x is of real type then return true else report error and return false
- **)
- PROCEDURE CheckRealType(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF ~(x.type.resolved IS SyntaxTree.FloatType) THEN
- Error(x.position,"is no float type");
- ELSE result := TRUE
- END;
- RETURN result
- END CheckRealType;
- (**
- if expression x is of range type then return true else report error and return false
- **)
- PROCEDURE CheckRangeType(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF ~(x.type.resolved IS SyntaxTree.RangeType) THEN
- Error(x.position,"is no range type");
- ELSE result := TRUE
- END;
- RETURN result
- END CheckRangeType;
- (**
- if expression x is of boolean type then return true else report error and return false
- **)
- PROCEDURE CheckBooleanType(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF ~(x.type.resolved IS SyntaxTree.BooleanType) THEN
- Error(x.position,"is no boolean type");
- ELSE result := TRUE
- END;
- RETURN result
- END CheckBooleanType;
- (**
- if expression x is of set type then return true else report error and return false
- **)
- PROCEDURE CheckSetType(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF ~(x.type.resolved IS SyntaxTree.SetType) THEN
- Error(x.position,"is no set type");
- ELSE result := TRUE
- END;
- RETURN result
- END CheckSetType;
- (**
- if expression x is of string or array of character type then return true else report error and return false
- **)
- PROCEDURE CheckStringType(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF ~IsStringType(x.type.resolved) THEN
- Error(x.position,"is no string type");
- ELSE result := TRUE
- END;
- RETURN result
- END CheckStringType;
- (**
- if expression x is a type declaration type return true else report error and return false
- **)
- PROCEDURE CheckTypeDeclarationType(x: SyntaxTree.Expression): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF (x.type.resolved # SyntaxTree.typeDeclarationType) THEN
- Error(x.position,"is not a type declaration");
- ELSE result := TRUE
- END;
- RETURN result
- END CheckTypeDeclarationType;
- PROCEDURE CheckIntegerValue(x: SyntaxTree.Expression; VAR value: LONGINT): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF (x.resolved # NIL) & (x.resolved IS SyntaxTree.IntegerValue) THEN
- result := TRUE;
- value := x.resolved(SyntaxTree.IntegerValue).value;
- ELSE
- Error(x.position,"expression is not an integer constant");
- END;
- RETURN result;
- END CheckIntegerValue;
- PROCEDURE CheckStringValue(x: SyntaxTree.Expression; VAR value: ARRAY OF CHAR): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF (x.resolved # NIL) & (x.resolved IS SyntaxTree.StringValue) THEN
- result := TRUE;
- COPY(x.resolved(SyntaxTree.StringValue).value^, value);
- ELSE
- Error(x.position,"expression is not an integer constant");
- END;
- RETURN result;
- END CheckStringValue;
- PROCEDURE IsUnsignedValue(x: SyntaxTree.Expression; maxSizeInBits: LONGINT): BOOLEAN;
- BEGIN
- IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.IntegerValue) THEN
- RETURN Global.IsUnsignedInteger(x.resolved(SyntaxTree.IntegerValue).hvalue, maxSizeInBits)
- ELSE
- RETURN FALSE
- END;
- END IsUnsignedValue;
- PROCEDURE IsAddressValue(x: SyntaxTree.Expression): BOOLEAN;
- BEGIN
- IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.IntegerValue) THEN
- RETURN Global.IsUnsignedInteger(x.resolved(SyntaxTree.IntegerValue).hvalue, system.addressType.sizeInBits)
- ELSE
- RETURN FALSE
- END
- END IsAddressValue;
- PROCEDURE IsAddressExpression(x: SyntaxTree.Expression): BOOLEAN;
- BEGIN
- RETURN IsAddressType(x.type.resolved, system.addressSize) OR IsAddressValue(x)
- END IsAddressExpression;
- PROCEDURE IsSizeExpression(x: SyntaxTree.Expression): BOOLEAN;
- BEGIN
- RETURN IsSizeType(x.type.resolved, system.addressSize) OR IsAddressValue(x)
- END IsSizeExpression;
- PROCEDURE CheckEnumerationValue(x: SyntaxTree.Expression; VAR value: LONGINT): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF (x.resolved # NIL) & (x.resolved IS SyntaxTree.EnumerationValue) THEN
- result := TRUE;
- value := x.resolved(SyntaxTree.EnumerationValue).value;
- ELSE
- Error(x.position,"expression is not an integer constant");
- END;
- RETURN result;
- END CheckEnumerationValue;
- PROCEDURE CheckCharacterValue(x: SyntaxTree.Expression; VAR value: CHAR): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF (x.resolved # NIL) & (x.resolved IS SyntaxTree.CharacterValue) THEN
- result := TRUE;
- value := x.resolved(SyntaxTree.CharacterValue).value;
- ELSIF (x.resolved # NIL) & (x.resolved IS SyntaxTree.StringValue) & (x.resolved(SyntaxTree.StringValue).length =2) THEN
- result := TRUE;
- value := x.resolved(SyntaxTree.StringValue).value[0];
- ELSE
- Error(x.position,"expression is not a character constant");
- END;
- RETURN result;
- END CheckCharacterValue;
- PROCEDURE CheckPositiveIntegerValue(x: SyntaxTree.Expression; VAR value: LONGINT; includeZero: BOOLEAN): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSIF (x.resolved # NIL) & (x.resolved IS SyntaxTree.IntegerValue) THEN
- value := x.resolved(SyntaxTree.IntegerValue).value;
- IF (value > 0) OR includeZero & (value = 0) THEN
- result := TRUE;
- ELSE
- Error(x.position,"integer is not positive");
- END
- ELSE
- Error(x.position,"expression is not an integer constant");
- END;
- RETURN result;
- END CheckPositiveIntegerValue;
- PROCEDURE CheckPortType(x: SyntaxTree.Expression; VAR portType: SyntaxTree.PortType): BOOLEAN;
- VAR type: SyntaxTree.Type; result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF x = SyntaxTree.invalidExpression THEN
- ELSE
- type := x.type.resolved;
- IF (type # NIL) & (type IS SyntaxTree.PortType) THEN
- portType := type(SyntaxTree.PortType);
- result := TRUE
- ELSE
- Error(x.position,"no port type");
- END;
- END;
- RETURN result
- END CheckPortType;
- (* move to builtin procedure call statement ?
- remove builtin procedure call designator ?
- *)
- PROCEDURE NewBuiltinCallDesignator(position: Position; builtin: SyntaxTree.Builtin; actualParameters:SyntaxTree.ExpressionList; left: SyntaxTree.Designator; returnType: SyntaxTree.Type): SyntaxTree.Expression;
- VAR
- numberActualParameters,numberFormalParameters: LONGINT;
- formalParameter: SyntaxTree.Parameter;
- actualParameter: SyntaxTree.Expression;
- procedureType: SyntaxTree.ProcedureType;
- parameter0, parameter1, parameter2, result: SyntaxTree.Expression;
- inPort, outPort: SyntaxTree.PortType;
- constructor: SyntaxTree.Procedure;
- type0,type1,type2: SyntaxTree.Type;
- type,base,parameterType: SyntaxTree.Type;
- arrayType: SyntaxTree.ArrayType;
- i,i0,i1: LONGINT;
- r,r0,r1,im: LONGREAL;
- c: CHAR;
- id: LONGINT;
- b: BOOLEAN;
- first: LONGINT;
- mathArrayType: SyntaxTree.MathArrayType;
- customBuiltin: SyntaxTree.CustomBuiltin;
- PROCEDURE CheckArity(from,to: LONGINT): BOOLEAN;
- VAR resultB: BOOLEAN;
- BEGIN
- IF numberActualParameters < from THEN
- Error(position, "less actual than formal parameters");
- result := SyntaxTree.invalidExpression;
- resultB := FALSE;
- ELSIF numberActualParameters > to THEN
- Error(position, "more actual than formal parameters");
- result := SyntaxTree.invalidExpression;
- resultB := FALSE;
- ELSE
- resultB := TRUE;
- END;
- RETURN resultB
- END CheckArity;
-
- PROCEDURE CheckModifiers(cellType: SyntaxTree.CellType; modifier: SyntaxTree.Modifier);
- VAR propertyType, modifierType: SyntaxTree.Type; symbol: SyntaxTree.Symbol;
- BEGIN
- WHILE modifier # NIL DO
- symbol := cellType.FindProperty(modifier.identifier);
- IF (symbol # NIL) & (symbol IS SyntaxTree.Property) THEN
- propertyType := symbol.type.resolved;
- modifierType := modifier.expression.type.resolved;
- IF ~CompatibleTo(system, modifierType, propertyType) &
- ~(
- (modifierType IS SyntaxTree.ArrayType) & (propertyType IS SyntaxTree.ArrayType) &
- OpenArrayCompatible(modifierType(SyntaxTree.ArrayType), propertyType(SyntaxTree.ArrayType))) THEN
- Error(modifier.position,"incompatible to cell property");
- END;
- ELSE
- Error(modifier.position, "undefined property");
- END;
- modifier := modifier.nextModifier;
- END;
- END CheckModifiers;
-
- BEGIN
- type := NIL; result := NIL;
- type0 := NIL; type1 := NIL; type2 := NIL;
- numberActualParameters := actualParameters.Length();
- IF numberActualParameters>0 THEN
- parameter0 := actualParameters.GetExpression(0);
- IF parameter0.type # NIL THEN type0 := parameter0.type.resolved ELSE
- Error(parameter0.position,"forbidden type-less argument");
- result := SyntaxTree.invalidExpression
- END
- END;
- IF numberActualParameters >1 THEN
- parameter1 := actualParameters.GetExpression(1);
- IF parameter1.type # NIL THEN type1 := parameter1.type.resolved
- ELSE
- Error(parameter1.position,"forbidden type-less argument");
- result := SyntaxTree.invalidExpression
- END
- END;
- IF numberActualParameters >2 THEN
- parameter2 := actualParameters.GetExpression(2);
- IF parameter2.type # NIL THEN type2 := parameter2.type.resolved
- ELSE
- Error(parameter2.position,"forbidden type-less argument");
- result := SyntaxTree.invalidExpression
- END
- END;
- IF returnType # NIL THEN
- id := Global.New;
- result := NIL;
- ELSE
- id := builtin.id;
- IF system.operatorDefined[id] THEN (* try to find overloaded operator *)
- result := NewOperatorCall(position,builtin.id,parameter0,parameter1,NIL);
- END;
- END;
- IF result = SyntaxTree.invalidExpression THEN (* error already handled *)
- ELSIF result # NIL THEN type := result.type (* operator *)
- ELSE
- result := SyntaxTree.NewBuiltinCallDesignator(position,id,left,actualParameters);
- result(SyntaxTree.Designator).SetLeft(left);
- IF returnType # NIL THEN
- type := returnType;
- END;
- (* ---- ASSERT ----- *)
- IF (id = Global.Assert) & CheckArity(1,2) THEN
- IF CheckBooleanType(parameter0) THEN
- (* mk: Commented this out because Oberon 07 uses Assert(FALSE, trap) instead of HALT
- fof: commented in again as ASSERT is crucial for compilation tests, Oberon07 obviously needs a HALT statement
- misusing ASSERT does not make the language clearer nor odes it make the compiler simpler!
- *)
- IF IsBooleanValue(parameter0,b) & ~b & ~(currentIsUnreachable) THEN
- Error(position, "assert failed");
- END;
- IF (numberActualParameters > 1) & CheckIntegerValue(parameter1,i1) THEN
- (* modified: any integer parameter value is allowed, it is in the responsibility of the programmer to adhere to
- rules imposed by the architecture / current runtime
- *)
- END;
- END;
- (* ---- COPY ----- *)
- ELSIF (id = Global.Copy) & CheckArity(2,2) THEN
- IF~IsStringType(type0) THEN
- Error(parameter0.position,"no string type");
- END;
- IF ~IsStringType(type1) THEN
- Error(parameter1.position,"no string type");
- ELSIF CheckVariable(parameter1) THEN
- IF (type0 IS SyntaxTree.StringType) THEN
- arrayType := type1(SyntaxTree.ArrayType);
- IF arrayType.form = SyntaxTree.Static THEN
- IF arrayType.staticLength < type0(SyntaxTree.StringType).length THEN
- Error(position, "destination length smaller than source length")
- END;
- END;
- END;
- END;
- (* ---- INC, DEC----- *)
- ELSIF ((id = Global.Dec) OR (id = Global.Inc)) & CheckArity(1,2) THEN
- IF numberActualParameters = 1 THEN
- parameter1 :=Global.NewIntegerValue(system,position,1);
- actualParameters.AddExpression(parameter1);
- END;
- IF CheckVariable(parameter0) & CheckIntegerType(parameter0) & CheckIntegerType(parameter1) THEN
- IF ~CompatibleTo(system,parameter1.type,parameter0.type) THEN
- Error(position, "incompatible increment");
- ELSE
- parameter1 := NewConversion(Basic.invalidPosition,parameter1,parameter0.type,NIL);
- actualParameters.SetExpression(1,parameter1);
- END;
- END;
- (* ---- EXCL, INCL----- *)
- ELSIF ((id = Global.Excl) OR (id = Global.Incl)) & CheckArity(2,2) THEN
- IF CheckVariable(parameter0) & CheckSetType(parameter0) & CheckIntegerType(parameter1) THEN
- IF IsIntegerValue(parameter1,i0) THEN
- IF (i0 < 0) OR (i0>= system.setType.sizeInBits) THEN
- Error(position, "parameter out of SET range")
- END;
- END;
- parameter1 := NewConversion(Basic.invalidPosition,parameter1,system.longintType,NIL);
- actualParameters.SetExpression(1,parameter1);
- END;
- (* ---- HALT, SYSTEM.HALT ----- *)
- ELSIF ((id = Global.Halt) OR (id = Global.systemHalt)) & CheckArity(1,1) THEN
- IF CheckPositiveIntegerValue(parameter0,i0,FALSE) THEN
- (* modified: any integer parameter value is allowed, it is in the responsibility of the programmer to adhere to
- rules imposed by the architecture / current runtime
- *)
- END;
- (* ---- WAIT ----- *)
- ELSIF cooperative & (id = Global.Wait) & CheckArity(1,1) THEN
- IF CheckObjectType(parameter0) THEN
- END;
- (* ---- NEW ----- *)
- ELSIF (id = Global.New) THEN
- IF returnType # NIL THEN
- first := 0; type2 := type1; type1 := type0 ; type0:= returnType.resolved;
- ELSE
- first := 1;
- END;
- IF CheckArity(first,Infinity) THEN
- IF currentIsRealtime THEN
- Error(position, "forbidden new in realtime block");
- END;
- (* check constructor *)
- IF (first =0) OR CheckVariable(parameter0) THEN
- IF type0 IS SyntaxTree.PointerType THEN
- type0 := type0(SyntaxTree.PointerType).pointerBase.resolved;
- ELSIF type0 IS SyntaxTree.CellType THEN
- ELSIF type0 IS SyntaxTree.MathArrayType THEN
- ELSE
- Error(position, "forbidden new on value type");
- END;
- IF type0 IS SyntaxTree.ArrayType THEN
- arrayType := type0(SyntaxTree.ArrayType);
- IF arrayType.form = SyntaxTree.Static THEN
- i := first
- ELSIF arrayType.form = SyntaxTree.Open THEN
- i := Dimension(arrayType,{SyntaxTree.Open})+first;
- ELSE HALT(100)
- END;
- IF CheckArity(i,i) & (numberActualParameters>1) THEN
- i := first;
- REPEAT
- actualParameter := actualParameters.GetExpression(i);
- IF CheckSizeType(actualParameter) THEN
- actualParameter := NewConversion(Basic.invalidPosition,actualParameter,system.longintType,NIL);
- actualParameters.SetExpression(i,actualParameter);
- END;
- INC(i);
- UNTIL ~CheckSizeType(actualParameter) OR (actualParameter.resolved # NIL) & ~CheckPositiveIntegerValue(actualParameter,i0,TRUE) OR (i=numberActualParameters);
- END;
- ELSIF (type0 IS SyntaxTree.RecordType) THEN
- constructor := GetConstructor(type0(SyntaxTree.RecordType));
- IF constructor = NIL THEN
- IF CheckArity(first,first) THEN END;
- ELSIF (constructor.scope.ownerModule # currentScope.ownerModule) & ~(SyntaxTree.PublicRead IN constructor.access) THEN
- Error(position, "new on object with hidden constructor");
- ELSE
- procedureType := constructor.type(SyntaxTree.ProcedureType);
- numberFormalParameters := procedureType.numberParameters;
- IF numberActualParameters-first <= numberFormalParameters THEN
- formalParameter := procedureType.firstParameter;
- FOR i := first TO numberActualParameters-1 DO
- actualParameter := actualParameters.GetExpression(i);
- IF (actualParameter = SyntaxTree.invalidExpression) THEN
- ELSIF ~ParameterCompatible(formalParameter,actualParameter) THEN
- ELSE
- IF formalParameter.type.resolved # actualParameter.type.resolved THEN
- actualParameter := NewConversion(actualParameter.position,actualParameter,formalParameter.type,NIL);
- END;
- actualParameters.SetExpression(i,actualParameter);
- END;
- formalParameter := formalParameter.nextParameter;
- END;
- WHILE (formalParameter # NIL) DO
- IF formalParameter.defaultValue # NIL THEN
- actualParameters.AddExpression(formalParameter.defaultValue);
- formalParameter := formalParameter.nextParameter
- ELSE
- Error(position, "less actual than formal parameters");
- formalParameter := NIL;
- END;
- END;
- ELSE
- Error(position, "more actual than formal parameters")
- END;
- END;
- ELSIF type0 IS SyntaxTree.MathArrayType THEN
- mathArrayType := type0(SyntaxTree.MathArrayType);
- IF mathArrayType.form = SyntaxTree.Static THEN
- Error(position, "new on static array");
- ELSE
- IF mathArrayType.form = SyntaxTree.Tensor THEN
- i0 := first+1; i1 := Infinity;
- ELSIF mathArrayType.form = SyntaxTree.Open THEN
- i0 := Dimension(mathArrayType,{SyntaxTree.Open})+first;
- i1 := i0;
- ELSE HALT(100);
- END;
- IF type1 IS SyntaxTree.MathArrayType THEN (* NEW(a, array) *)
- (* use type checking facilities of procedure calls: artificially build parameters here and call checker *)
- base := ArrayBase(type0,MAX(LONGINT));
- parameterType := SyntaxTree.NewMathArrayType(Basic.invalidPosition,currentScope,SyntaxTree.Tensor);
- parameterType(SyntaxTree.MathArrayType).SetArrayBase(base);
- IF ~CompatibleTo(system,type0,parameterType) THEN
- Error(parameter0.position,"incompatible parameter in new");
- result := SyntaxTree.invalidExpression;
- ELSE
- parameter0 := NewConversion(Basic.invalidPosition,parameter0,parameterType,NIL); actualParameters.SetExpression(0,parameter0);
- END;
- parameterType := SyntaxTree.NewMathArrayType(Basic.invalidPosition,currentScope,SyntaxTree.Open);
- parameterType(SyntaxTree.MathArrayType).SetArrayBase(system.longintType);
- IF ~CompatibleTo(system,type1,parameterType) THEN
- Error(parameter1.position,"parameter incompatible to math array of longint");
- result := SyntaxTree.invalidExpression;
- ELSE
- parameter1 := NewConversion(Basic.invalidPosition,parameter1,parameterType,NIL); actualParameters.SetExpression(1,parameter1);
- END;
- ELSE
- IF CheckArity(i0,i1) & (numberActualParameters >first) THEN
- i := first;
- REPEAT
- actualParameter := actualParameters.GetExpression(i);
- IF CheckSizeType(actualParameter) THEN
- actualParameter := NewConversion(Basic.invalidPosition,actualParameter,system.sizeType,NIL);
- actualParameters.SetExpression(i,actualParameter);
- END;
- INC(i);
- UNTIL ~CheckSizeType(actualParameter) OR (actualParameter.resolved # NIL) & ~CheckPositiveIntegerValue(actualParameter,i0,TRUE) OR (i=numberActualParameters);
- END;
- END;
- END;
- ELSIF type0 IS SyntaxTree.CellType THEN
- IF ~(currentIsCellNet) THEN
- Error(position, "cell allocation outside activeCells ");
- ELSE
- constructor := type0(SyntaxTree.CellType).cellScope.constructor;
- IF (constructor = NIL) & CheckArity(1,1) THEN
- (* ok *)
- ELSE
- procedureType := constructor.type(SyntaxTree.ProcedureType);
- numberFormalParameters := procedureType.numberParameters;
- DEC(numberActualParameters);
- IF numberActualParameters <= numberFormalParameters THEN
- formalParameter := procedureType.firstParameter;
- FOR i := first TO numberActualParameters DO
- actualParameter := actualParameters.GetExpression(i);
- IF (actualParameter = SyntaxTree.invalidExpression) THEN
- ELSIF ~ParameterCompatible(formalParameter,actualParameter) THEN
- ELSE
- IF formalParameter.type.resolved # actualParameter.type.resolved THEN
- actualParameter := NewConversion(actualParameter.position,actualParameter,formalParameter.type,NIL);
- END;
- actualParameters.SetExpression(i,actualParameter);
- END;
- formalParameter := formalParameter.nextParameter;
- END;
- WHILE (formalParameter # NIL) DO
- IF formalParameter.defaultValue # NIL THEN
- actualParameters.AddExpression(formalParameter.defaultValue);
- formalParameter := formalParameter.nextParameter
- ELSE
- Error(position, "less actual than formal parameters");
- formalParameter := NIL;
- END;
- END;
- ELSE
- Error(position, "more actual than formal parameters")
- END;
- END;
- END;
- CheckModifiers(type0(SyntaxTree.CellType), parameter0(SyntaxTree.Designator).modifiers);
- activeCellsStatement := TRUE;
- ELSE
- Error(position, "cannot be allocated");
- END;
- END;
- END;
- (* ---- DISPOSE ----- *)
- ELSIF (id = Global.Dispose) & CheckArity(1,1) THEN
- IF ~IsPointerType(parameter0.type) THEN
- Error(parameter0.position,"is not a pointer")
- ELSIF ~IsDisposable(parameter0.type) THEN
- Error(parameter0.position,"is not disposable")
- ELSIF CheckVariable(parameter0) THEN (* ok *)
- END
- (* ---- GETPROCEDURE ----- *)
- ELSIF (id = Global.GetProcedure) & CheckArity(3,3) THEN
- IF CheckStringType(parameter0) & CheckStringType(parameter1) THEN
- IF CheckVariable(parameter2) THEN
- IF ~GetProcedureAllowed(parameter2.type) THEN
- Error(parameter2.position,"GETPROCEDURE not allowed on this type");
- END;
- END;
- END;
- (* ---- ABS ----- *)
- ELSIF (id = Global.Abs) & CheckArity(1,1) THEN
- (* note: ABS on complex numbers is done using overloading *)
- IF CheckNonComplexNumberSizeType(parameter0) THEN
- type := type0;
- IF IsIntegerValue(parameter0,i0) THEN
- result.SetResolved(SyntaxTree.NewIntegerValue(position,ABS(i0)));
- type := Global.GetIntegerType(system,ABS(i0));
- ELSIF IsRealValue(parameter0,r) THEN
- result.SetResolved(SyntaxTree.NewRealValue(position,ABS(r)));
- END;
- ELSE
- type := SyntaxTree.invalidType;
- END;
- (* ---- ASH, ASR ----- *)
- ELSIF ((id = Global.Ash) OR (id= Global.Asr)) & CheckArity(2,2) THEN
- type := type0;
- IF CheckIntegerType(parameter0) & CheckIntegerType(parameter1) THEN
- (*
- ConvertOperands(parameter0,parameter1); (* same type *)
- *)
- type := parameter0.type;
- IF IsIntegerValue(parameter0,i0) THEN
- IF IsIntegerValue(parameter1,i1) THEN
- IF id = Global.Ash THEN i0 := ASH(i0,i1) ELSE i0 := ASR(i0,i1) END;
- result.SetResolved(SyntaxTree.NewIntegerValue(position,i0));
- result := ResolveExpression(result);
- type := Global.GetIntegerType(system,i0);
- END;
- END;
- IF type.resolved.sizeInBits < 32 THEN
- type := system.longintType;
- END;
- (*!compatibility with release, remove when resolved
- critical in release : SHORT(ASH(..))), ASH(ORD(..))
- *)
- parameter1 := NewConversion(parameter1.position,parameter1,system.longintType,NIL);
- parameter0 := NewConversion(parameter0.position,parameter0,type,NIL);
- actualParameters.SetExpression(0,parameter0);
- actualParameters.SetExpression(1,parameter1);
- END;
- (* ---- CAP ----- *)
- ELSIF (id = Global.Cap) & CheckArity(1,1) THEN
- type := system.characterType;
- IF CheckCharacterType (parameter0) THEN
- parameter0 := NewConversion(parameter0.position,parameter0,type,NIL);
- actualParameters.SetExpression(0,parameter0);
- IF IsCharacterValue(parameter0,c) THEN
- IF (c <= "z") & (c >= "a") THEN
- result.SetResolved(SyntaxTree.NewCharacterValue(position,CAP(c)))
- ELSE
- result.SetResolved(SyntaxTree.NewCharacterValue(position,c))
- END;
- END;
- END;
- (* ---- CHR ----- *)
- ELSIF ((id = Global.Chr) OR (id = Global.Chr32)) & CheckArity(1,1) THEN
- IF id = Global.Chr THEN
- type := system.characterType
- ELSE
- type := system.characterType32
- END;
- IF CheckIntegerType(parameter0) THEN
- IF IsIntegerValue(parameter0,i0) THEN
- result.SetResolved(SyntaxTree.NewCharacterValue(position,CHR(i0)));
- result := ResolveExpression(result);
- ELSE
- (*
- result := NewConversion(parameter0.position,parameter0,type);
- *)
- END;
- END
- (* ---- ENTIER ----- *)
- ELSIF (id = Global.Entier) & CheckArity(1,1) THEN
- type := system.longintType;
- IF CheckRealType(parameter0) THEN
- IF IsRealValue(parameter0,r) THEN
- result.SetResolved(SyntaxTree.NewIntegerValue(position,ENTIER(r)));
- type := Global.GetIntegerType(system,ENTIER(r));
- END
- END;
- (* ---- ENTIERH ----- *)
- ELSIF (id = Global.EntierH) & CheckArity(1,1) THEN
- type := system.hugeintType;
- IF CheckRealType(parameter0) THEN
- IF IsRealValue(parameter0,r) THEN
- result.SetResolved(SyntaxTree.NewIntegerValue(position,ENTIERH(r)));
- END
- END;
- (* ---- LEN ----- *)
- ELSIF (id = Global.Len) & CheckArity(1,2) THEN
- type := system.longintType;
- base := type0;
- IF (base IS SyntaxTree.PointerType) & (parameter0 IS SyntaxTree.Designator) THEN
- IF base(SyntaxTree.PointerType).isUnsafe THEN
- base := base(SyntaxTree.PointerType).pointerBase.resolved;
- IF~(base IS SyntaxTree.ArrayType) OR (base(SyntaxTree.ArrayType).form # SyntaxTree.Static) THEN
- Error(position, "forbidden len on unsafe pointer");
- END;
- type0 := base;
- ELSE
- parameter0 := NewDereferenceDesignator(position,parameter0(SyntaxTree.Designator));
- type0 := parameter0.type.resolved;
- actualParameters.SetExpression(0,parameter0);
- base := type0;
- END;
- END;
- IF (numberActualParameters=1) OR (numberActualParameters =2) & CheckIntegerType(parameter1) THEN
- IF ~(numberActualParameters=2) OR ~IsIntegerValue(parameter1,i1) THEN i1 := 0 END;
- IF i1 < 0 THEN
- Error(position, "invalid dimension");
- base := SyntaxTree.invalidType;
- ELSE
- base := ArrayBase(base,i1);
- IF (base # NIL) & Indexable(base) THEN
- ELSE
- Error(position, "len on no array");
- IF VerboseErrorMessage THEN
- Printout.Info("base",base);
- END;
- base := SyntaxTree.invalidType;
- END;
- END;
- IF numberActualParameters=2 THEN
- parameter1 := NewConversion(parameter1.position,parameter1,system.longintType,NIL);
- actualParameters.SetExpression(1,parameter1);
- ELSIF base IS SyntaxTree.MathArrayType THEN
- Error(position, "missing dimension specification");
- END;
- IF (numberActualParameters=1) OR (numberActualParameters =2) & IsIntegerValue(parameter1,i1) THEN
- IF base IS SyntaxTree.ArrayType THEN
- arrayType := base(SyntaxTree.ArrayType);
- IF (arrayType.length # NIL) & (arrayType.length.resolved # NIL) & IsIntegerValue(arrayType.length,i) THEN
- (* do not use length directly such as in result := length as this mide have side-effects when result types get converted *)
- result := Global.NewIntegerValue(system,position,i);
- type := result.type;(* arrayType.length.type;*)
- ASSERT(type # NIL);
- END;
- ELSIF base IS SyntaxTree.MathArrayType THEN
- mathArrayType := base(SyntaxTree.MathArrayType);
- IF (mathArrayType.length # NIL) & (mathArrayType.length.resolved # NIL) & IsIntegerValue(mathArrayType.length,i) THEN
- result := Global.NewIntegerValue(system,position,i);
- type := result.type;
- (*
- type := mathArrayType.length.type;
- *)
- ASSERT(type # NIL);
- END;
- END;
- END;
- ELSE
- type := system.longintType;
- END;
- (* ---- FIRST ---- *)
- ELSIF (id = Global.First) & CheckArity(1,1) THEN
- type := system.longintType;
- IF CheckRangeType(parameter0) THEN END;
- result.SetAssignable(parameter0.assignable)
- (* ---- LAST ---- *)
- ELSIF (id = Global.Last) & CheckArity(1,1) THEN
- type := system.longintType;
- IF CheckRangeType(parameter0) THEN END;
- result.SetAssignable(parameter0.assignable)
- (* ---- STEP ---- *)
- ELSIF (id = Global.Step) & CheckArity(1,1) THEN
- type := system.longintType;
- IF CheckRangeType(parameter0) THEN END;
- result.SetAssignable(parameter0.assignable)
- (* ---- RE ---- *)
- ELSIF (id = Global.Re) & CheckArity(1,1) THEN
- IF CheckNumberType(parameter0) THEN
- IF parameter0.type.resolved IS SyntaxTree.ComplexType THEN
- type := parameter0.type.resolved(SyntaxTree.ComplexType).componentType;
- IF IsComplexValue(parameter0, r, im) THEN result.SetResolved(SyntaxTree.NewRealValue(parameter0.position, r)) END
- ELSIF parameter0.type.resolved IS SyntaxTree.FloatType THEN
- type := parameter0.type
- ELSE
- type := system.realType
- END
- END;
- result.SetAssignable(parameter0.assignable)
- (* ---- IM ---- *)
- ELSIF (id = Global.Im) & CheckArity(1,1) THEN
- IF CheckNumberType(parameter0) THEN
- IF parameter0.type.resolved IS SyntaxTree.ComplexType THEN
- type := parameter0.type.resolved(SyntaxTree.ComplexType).componentType;
- IF IsComplexValue(parameter0, r, im) THEN result.SetResolved(SyntaxTree.NewRealValue(parameter0.position, im)) END
- ELSE
- type := system.realType;
- result.SetResolved(SyntaxTree.NewRealValue(parameter0.position, 0))
- END
- END;
- result.SetAssignable(parameter0.assignable)
- (* ---- MAX ----- *)
- ELSIF (id = Global.Max) & CheckArity(1,2) THEN
- IF numberActualParameters = 1 THEN
- IF parameter0.type = SyntaxTree.typeDeclarationType THEN
- type := parameter0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType.resolved;
- IF type IS SyntaxTree.CharacterType THEN result.SetResolved(SyntaxTree.NewCharacterValue(position,MAX(CHAR)));
- (*!! ELSIF type = Global.Char16 THEN result.SetResolved(SyntaxTree.NewIntegerValue(position,0FFFFH));
- ELSIF type = Global.Char32 THEN result.SetResolved(SyntaxTree.NewIntegerValue(position,0FFFFFFFFH));
- *)
- ELSIF type IS SyntaxTree.IntegerType THEN result.SetResolved(SyntaxTree.NewIntegerValue(position,Global.MaxInteger(system,type(SyntaxTree.IntegerType))));
- ELSIF type IS SyntaxTree.FloatType THEN result.SetResolved(SyntaxTree.NewRealValue(position,Global.MaxFloat(system,type(SyntaxTree.FloatType))));
- ELSIF type IS SyntaxTree.SetType THEN result.SetResolved(SyntaxTree.NewIntegerValue(position,system.SizeOf(type)-1)); type := system.shortintType;
- ELSIF type IS SyntaxTree.SizeType THEN result.SetResolved(SyntaxTree.NewIntegerValue(position,Global.MaxInteger(system,type(SyntaxTree.BasicType))));
- ELSE Error(parameter0.position, "builtin function not applicable to this type");
- END;
- ELSE
- Error(parameter0.position,"is not a type symbol");
- END
- ELSIF CheckNonComplexNumberSizeType(parameter0) & CheckNonComplexNumberSizeType(parameter1) THEN
- ConvertOperands(parameter0,parameter1);
- actualParameters.SetExpression(0,parameter0);
- actualParameters.SetExpression(1,parameter1);
- IF IsRealValue(parameter0,r0) & IsRealValue(parameter1,r1) THEN
- IF r0 > r1 THEN result.SetResolved(parameter0(SyntaxTree.Value))
- ELSE result.SetResolved(parameter0(SyntaxTree.Value))
- END;
- ELSIF IsIntegerValue(parameter0,i0) & IsIntegerValue(parameter1,i1) THEN
- IF i0 > i1 THEN result.SetResolved(parameter0(SyntaxTree.Value))
- ELSE result.SetResolved(parameter1(SyntaxTree.Value))
- END;
- END;
- type := parameter0.type;
- ELSE type := SyntaxTree.invalidType;
- END;
- (* ---- MIN ----- *)
- ELSIF (id = Global.Min) & CheckArity(1,2) THEN
- IF numberActualParameters = 1 THEN
- IF parameter0.type = SyntaxTree.typeDeclarationType THEN
- type := parameter0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType.resolved;
- IF type IS SyntaxTree.CharacterType THEN result.SetResolved(SyntaxTree.NewCharacterValue(position,MIN(CHAR)));
- ELSIF type IS SyntaxTree.IntegerType THEN result.SetResolved(SyntaxTree.NewIntegerValue(position,Global.MinInteger(system,type(SyntaxTree.IntegerType))));
- ELSIF type IS SyntaxTree.FloatType THEN result.SetResolved(SyntaxTree.NewRealValue(position,Global.MinFloat(system,type(SyntaxTree.FloatType))));
- ELSIF type IS SyntaxTree.SetType THEN result.SetResolved(SyntaxTree.NewIntegerValue(position,0)); type := system.shortintType;
- ELSIF type IS SyntaxTree.SizeType THEN result.SetResolved(SyntaxTree.NewIntegerValue(position, Global.MinInteger(system,type(SyntaxTree.BasicType))));
- ELSE Error(parameter0.position,"builtin function not applicable to this type");
- END;
- ELSE
- Error(parameter0.position,"is not a type symbol");
- END
- ELSIF CheckNonComplexNumberSizeType(parameter0) & CheckNonComplexNumberSizeType(parameter1) THEN
- ConvertOperands(parameter0,parameter1);
- actualParameters.SetExpression(0,parameter0);
- actualParameters.SetExpression(1,parameter1);
- IF IsRealValue(parameter0,r0) & IsRealValue(parameter1,r1) THEN
- IF r0 < r1 THEN result.SetResolved(parameter0.resolved)
- ELSE result.SetResolved(parameter1.resolved)
- END;
- ELSIF IsIntegerValue(parameter0,i0) & IsIntegerValue(parameter1,i1) THEN
- IF i0 < i1 THEN result.SetResolved(parameter0.resolved)
- ELSE result.SetResolved(parameter1.resolved)
- END;
- END;
- type := parameter0.type;
- ELSE type := SyntaxTree.invalidType;
- END;
- (* ---- ODD ----- *)
- ELSIF (id = Global.Odd) & CheckArity(1,1) THEN
- type := system.booleanType;
- IF CheckIntegerType(parameter0) THEN
- IF IsIntegerValue(parameter0,i0) THEN
- result.SetResolved(SyntaxTree.NewBooleanValue(position,ODD(i0)));
- type := system.booleanType;
- END;
- END;
- (* ---- ORD ----- *)
- ELSIF ((id = Global.Ord) OR (id = Global.Ord32)) & CheckArity(1,1) THEN
- IF id = Global.Ord THEN
- type := system.integerType;
- ELSE
- type := system.longintType;
- END;
- IF CompatibleTo(system, parameter0.type, system.characterType) THEN
- parameter0 := NewConversion(parameter0.position, parameter0, system.characterType,NIL);
- actualParameters.SetExpression(0,parameter0);
- (* IF CheckCharacterType(parameter0) THEN*)
- IF IsCharacterValue(parameter0,c)THEN
- result.SetResolved(Global.NewIntegerValue(system,position,ORD(c)));
- type := Global.GetSignedIntegerType(system,ORD(c));
- END;
- ELSE Error(parameter0.position, "incompatible parameter");
- END;
- (* ---- SHORT ----- *)
- ELSIF (id = Global.Short) & CheckArity(1,1) THEN
- type := type0;
- IF IsSignedIntegerType(type) THEN
- IF (type.sizeInBits = 8) OR (type = system.shortintType) THEN Error(parameter0.position,"short not applicable")
- ELSIF type = system.integerType THEN type := system.shortintType
- ELSIF type = system.longintType THEN type := system.integerType
- ELSIF type = system.hugeintType THEN type:= system.longintType
- ELSE
- CASE type.sizeInBits OF
- 16: type := Global.Integer8
- |32: type := Global.Integer16
- |64: type := Global.Integer32
- END;
- END;
- ELSIF type IS SyntaxTree.FloatType THEN
- IF (type.sizeInBits = 32) OR (type = system.realType) THEN Error(parameter0.position,"short not applicable")
- ELSIF type = system.longrealType THEN type := system.realType
- ELSIF type.sizeInBits = 64 THEN type := Global.Float32
- END;
- ELSIF type IS SyntaxTree.ComplexType THEN
- IF (type.sizeInBits = 64) OR (type = system.complexType) THEN Error(parameter0.position,"short not applicable")
- ELSIF (type = system.longcomplexType) THEN type := system.complexType
- ELSIF type.sizeInBits = 128 THEN type := Global.Complex64
- END;
- ELSE
- Error(parameter0.position,"short not applicable")
- END;
- IF (parameter0.resolved # NIL) THEN
- parameter0 := ConvertValue(parameter0.position,parameter0.resolved,type);
- IF parameter0 IS SyntaxTree.Value THEN
- result.SetResolved(parameter0(SyntaxTree.Value));
- END;
- END;
- (* ---- LONG ----- *)
- ELSIF (id = Global.Long) & CheckArity(1,1) THEN
- type := type0;
- IF IsSignedIntegerType(type) THEN
- IF (type.sizeInBits = 64) OR (type = system.hugeintType) THEN Error(parameter0.position,"long not applicable")
- ELSIF type = system.longintType THEN type := system.hugeintType
- ELSIF type = system.integerType THEN type := system.longintType
- ELSIF type = system.shortintType THEN type := system.integerType
- ELSE
- CASE type.sizeInBits OF
- 8: type := Global.Integer16
- |16: type := Global.Integer32
- |32: type := Global.Integer64
- END;
- END;
- ELSIF type IS SyntaxTree.FloatType THEN
- IF (type.sizeInBits = 64) OR (type = system.longrealType) THEN Error(parameter0.position,"long not applicable")
- ELSIF type= system.realType THEN type := system.longrealType
- ELSIF type.sizeInBits = 32 THEN type := Global.Float64
- END;
- ELSIF type IS SyntaxTree.ComplexType THEN
- IF (type.sizeInBits = 128) OR (type = system.longcomplexType) THEN Error(parameter0.position,"long not applicable")
- ELSIF type = system.complexType THEN type := system.longcomplexType
- ELSIF type.sizeInBits = 64 THEN type := Global.Complex128
- END;
- ELSE
- Error(parameter0.position,"long not applicable")
- END;
- IF (parameter0.resolved # NIL) THEN
- parameter0 := ConvertValue(parameter0.position,parameter0.resolved,type);
- IF parameter0 IS SyntaxTree.Value THEN
- result.SetResolved(parameter0(SyntaxTree.Value));
- END;
- END;
- (* ---- SIZE OF ----- *)
- ELSIF (id = Global.systemSize) & CheckArity(1,1) THEN
- IF (parameter0.type = SyntaxTree.typeDeclarationType) THEN
- type := parameter0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType;
- result.SetResolved(SyntaxTree.NewIntegerValue(position,system.SizeOf(type.resolved) DIV 8 (* in bytes *) ));
- type := system.integerType;
- (* was Int16 in paco but should be systemSize (conflict with current release) *)
- ELSE
- (* for variables, system sizeof could represent the physically occupied size
- determined via the type descriptor, implement that ? *)
- Error(parameter0.position,"is not a type symbol");
- END
- (* ---- SYSTEM.TRACE -----*)
- ELSIF (id = Global.systemTrace) & CheckArity(1,MAX(LONGINT)) THEN
- FOR i := 0 TO numberActualParameters-1 DO
- parameter0 := actualParameters.GetExpression(i);
- IF ~IsBasicType(parameter0.type) & ~IsStringType(parameter0.type) THEN
- Error(parameter0.position,"incompatible parameter");
- END;
- END;
- (* remaining issues can only be tested in backend *)
- (* ---- ADDRESSOF----- *)
- ELSIF (id = Global.systemAdr) & CheckArity(1,1) THEN
- IF HasAddress(parameter0) THEN
- type := system.addressType;
- ELSE
- type := SyntaxTree.invalidType;
- Error(parameter0.position,"has no address");
- END;
- (* ---- BIT ----- *)
- ELSIF (id = Global.systemBit) & CheckArity(2,2) THEN
- IF CheckAddressType(parameter0) & CheckSizeType(parameter1) THEN
- parameter0 := NewConversion(parameter0.position,parameter0,system.addressType,NIL);
- actualParameters.SetExpression(0,parameter0);
- parameter1 := NewConversion(parameter1.position,parameter1,system.addressType,NIL);
- actualParameters.SetExpression(1,parameter1);
- END;
- type := system.booleanType;
- (* ----- MSK ---- *)
- ELSIF (id = Global.systemMsk) & CheckArity(2,2) THEN
- IF CheckIntegerType(parameter0) & CheckIntegerType(parameter1) THEN
- ConvertOperands(parameter0,parameter1);
- actualParameters.SetExpression(0,parameter0);
- actualParameters.SetExpression(1,parameter1);
- END;
- type := parameter0.type;
- (* ---- SYSTEM.GET64 ----- *)
- ELSIF (id = Global.systemGet64) & CheckArity(1,1) THEN
- IF CheckAddressType(parameter0) THEN
- parameter0 := NewConversion(Basic.invalidPosition,parameter0,system.addressType,NIL);
- actualParameters.SetExpression(0,parameter0);
- END;
- type := system.hugeintType;
- (* ---- SYSTEM.GET32 ----- *)
- ELSIF (id = Global.systemGet32) & CheckArity(1,1) THEN
- IF CheckAddressType(parameter0) THEN
- parameter0 := NewConversion(Basic.invalidPosition,parameter0,system.addressType,NIL);
- actualParameters.SetExpression(0,parameter0);
- END;
- type := system.longintType;
- (* ---- SYSTEM.GET16 ----- *)
- ELSIF (id = Global.systemGet16) & CheckArity(1,1) THEN
- IF CheckAddressType(parameter0) THEN
- parameter0 := NewConversion(Basic.invalidPosition,parameter0,system.addressType,NIL);
- actualParameters.SetExpression(0,parameter0);
- END;
- type := system.integerType;
- (* ---- SYSTEM.GET8 ----- *)
- ELSIF (id = Global.systemGet8) & CheckArity(1,1) THEN
- IF CheckAddressType(parameter0) THEN
- parameter0 := NewConversion(Basic.invalidPosition,parameter0,system.addressType,NIL);
- actualParameters.SetExpression(0,parameter0);
- END;
- type := system.shortintType;
- (* ---- SYSTEM.GetStackPointer ----- *)
- ELSIF (id = Global.systemGetStackPointer) & CheckArity(0,0) THEN
- type := system.addressType;
- (* ---- SYSTEM.GetFramePointer ----- *)
- ELSIF (id = Global.systemGetFramePointer) & CheckArity(0,0) THEN
- type := system.addressType;
- (* ---- SYSTEM.GetActivity ----- *)
- ELSIF cooperative & (id = Global.systemGetActivity) & CheckArity(0,0) THEN
- type := system.objectType;
- (* ---- SYSTEM.SetStackPointer ----- *)
- ELSIF (id = Global.systemSetStackPointer) & CheckArity(1,1) THEN
- IF CheckAddressType(parameter0) THEN
- parameter0 := NewConversion(Basic.invalidPosition,parameter0,system.addressType,NIL);
- actualParameters.SetExpression(0,parameter0);
- END;
- (* ---- SYSTEM.SetFramePointer ----- *)
- ELSIF (id = Global.systemSetFramePointer) & CheckArity(1,1) THEN
- IF CheckAddressType(parameter0) THEN
- parameter0 := NewConversion(Basic.invalidPosition,parameter0,system.addressType,NIL);
- actualParameters.SetExpression(0,parameter0);
- END;
- (* ---- SYSTEM.SetActivity ----- *)
- ELSIF cooperative & (id = Global.systemSetActivity) & CheckArity(1,1) THEN
- IF CheckObjectType(parameter0) THEN
- parameter0 := NewConversion(Basic.invalidPosition,parameter0,system.addressType,NIL);
- actualParameters.SetExpression(0,parameter0);
- END;
- (* ---- LSH, LSL, ROT, ROR ----- *)
- ELSIF ((id = Global.Lsh) OR (id = Global.Rot) OR (id= Global.Ror)) & CheckArity(2,2) THEN
- type := type0;
- parameter1 := NewConversion(parameter1.position,parameter1,system.longintType,NIL);
- actualParameters.SetExpression(1, parameter1);
- IF IsIntegerValue(parameter0,i0) & IsIntegerValue(parameter1,i1) THEN
- IF id = Global.Lsh THEN
- result.SetResolved(SyntaxTree.NewIntegerValue(position,LSH(i0,i1)));
- ELSIF id = Global.Rot THEN
- result.SetResolved(SyntaxTree.NewIntegerValue(position,ROT(i0,i1)));
- ELSIF id = Global.Ror THEN
- result.SetResolved(SyntaxTree.NewIntegerValue(position,ROR(i0,i1)));
- END;
- END;
- (* ---- SYSTEM.VAL ----- *)
- ELSIF (id = Global.systemVal) & CheckArity(2,2) THEN
- IF CheckTypeDeclarationType(parameter0) THEN
- type := parameter0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType;
- IF (type.resolved IS SyntaxTree.ArrayType) & (type.resolved(SyntaxTree.ArrayType).form # SyntaxTree.Static) THEN
- result := SyntaxTree.invalidExpression;
- Error(parameter0.position,"is no basic type");
- ELSE
- IF (parameter1.resolved # NIL) THEN
- parameter0 := ConvertValue(parameter1.position,parameter1.resolved,type);
- IF parameter0 IS SyntaxTree.Value THEN
- result.SetResolved(parameter0(SyntaxTree.Value));
- END;
- END;
- result.SetAssignable(parameter1.assignable);
- END;
- END;
- (* ---- SYSTEM.GET ----- *)
- ELSIF (id = Global.systemGet) & CheckArity(2,2) THEN
- IF CheckAddressType(parameter0) & CheckBasicType(parameter1) & CheckVariable(parameter1) THEN
- parameter0 := NewConversion(Basic.invalidPosition,parameter0,system.addressType,NIL);
- actualParameters.SetExpression(0,parameter0);
- END;
- (* ---- SYSTEM.PUT ----- *)
- ELSIF (id = Global.systemPut) & CheckArity(2,2) THEN
- IF CheckAddressType(parameter0) & CheckBasicType(parameter1) THEN
- parameter0 := NewConversion(Basic.invalidPosition,parameter0,system.addressType,NIL);
- actualParameters.SetExpression(0,parameter0);
- END;
- (* ---- SYSTEM.PUT64 ----- *)
- ELSIF (id = Global.systemPut64) & CheckArity(2,2) THEN
- IF CheckAddressType(parameter0) & CheckBasicType(parameter1) THEN
- parameter0 := NewConversion(parameter0.position,parameter0,system.addressType,NIL);
- parameter1 := NewConversion(parameter1.position,parameter1,system.hugeintType,NIL);
- actualParameters.SetExpression(0,parameter0);
- actualParameters.SetExpression(1,parameter1);
- END;
- (* ---- SYSTEM.PUT32 ----- *)
- ELSIF (id = Global.systemPut32) & CheckArity(2,2) THEN
- IF CheckAddressType(parameter0) & CheckBasicType(parameter1) THEN
- parameter0 := NewConversion(parameter0.position,parameter0,system.addressType,NIL);
- parameter1 := NewConversion(parameter1.position,parameter1,system.longintType,NIL);
- actualParameters.SetExpression(0,parameter0);
- actualParameters.SetExpression(1,parameter1);
- END;
- (* ---- SYSTEM.PUT16 ----- *)
- ELSIF (id = Global.systemPut16) & CheckArity(2,2) THEN
- IF CheckAddressType(parameter0) & CheckBasicType(parameter1) THEN
- parameter0 := NewConversion(parameter0.position,parameter0,system.addressType,NIL);
- parameter1 := NewConversion(parameter1.position,parameter1,system.integerType,NIL);
- actualParameters.SetExpression(0,parameter0);
- actualParameters.SetExpression(1,parameter1);
- END;
- (* ---- SYSTEM.PUT8 ----- *)
- ELSIF (id = Global.systemPut8) & CheckArity(2,2) THEN
- IF CheckAddressType(parameter0) & CheckBasicType(parameter1) THEN
- parameter0 := NewConversion(parameter0.position,parameter0,system.addressType,NIL);
- parameter1 := NewConversion(parameter1.position,parameter1,system.shortintType,NIL);
- actualParameters.SetExpression(0,parameter0);
- actualParameters.SetExpression(1,parameter1);
- END;
- (* ---- SYSTEM.MOVE ----- *)
- ELSIF (id = Global.systemMove) & CheckArity(3,3) THEN
- IF CheckAddressType(parameter0) & CheckAddressType(parameter1) & CheckAddressType(parameter2) THEN
- parameter0 := NewConversion(Basic.invalidPosition,parameter0,system.addressType,NIL);
- parameter1 := NewConversion(Basic.invalidPosition,parameter1,system.addressType,NIL);
- parameter2 := NewConversion(Basic.invalidPosition,parameter2,system.addressType,NIL);
- actualParameters.SetExpression(0,parameter0);
- actualParameters.SetExpression(1,parameter1);
- actualParameters.SetExpression(2,parameter2);
- END;
- (* ---- SYSTEM.NEW ----- *)
- ELSIF (id = Global.systemNew) & CheckArity(2,2) THEN
- IF ~IsPointerType(parameter0.type) THEN
- Error(parameter0.position,"is not a pointer")
- ELSIF CheckSizeType(parameter1) THEN
- parameter1 := NewConversion(Basic.invalidPosition, parameter1, system.sizeType,NIL);
- actualParameters.SetExpression(1,parameter1);
- END;
- (* ----SYSTEM.REF ---- *)
- ELSIF (id = Global.systemRef) & CheckArity(1,1) & CheckStringType(parameter0) THEN
- type := system.addressType
- (* ---- INCR ----- *)
- ELSIF (id = Global.Incr) & CheckArity(1,2) THEN
- type := system.sizeType;
- base := type0;
- IF (numberActualParameters =2) & CheckSizeType(parameter1) THEN
- IF ~IsIntegerValue(parameter1,i1) THEN i1 := 0 END;
- IF i1 < 0 THEN
- Error(position, "invalid dimension");
- base := SyntaxTree.invalidType;
- ELSE
- base := ArrayBase(base,i1);
- IF (base # NIL) & Indexable(base) THEN
- ELSE
- Error(position, "len on no array");
- IF VerboseErrorMessage THEN
- Printout.Info("base",base);
- END;
- base := SyntaxTree.invalidType;
- END;
- END;
- parameter1 := NewConversion(parameter1.position,parameter1,system.longintType,NIL);
- actualParameters.SetExpression(1,parameter1);
- IF (numberActualParameters =2) & (parameter1 IS SyntaxTree.IntegerValue) THEN
- mathArrayType := base(SyntaxTree.MathArrayType);
- IF (mathArrayType.form = SyntaxTree.Static) THEN
- result := SyntaxTree.NewIntegerValue(position,ToMemoryUnits(system,mathArrayType.staticIncrementInBits));
- type := system.longintType;
- END;
- END;
- ELSE
- type := system.longintType;
- END;
- (* ---- SUM ----- *)
- ELSIF (id = Global.Sum) & CheckArity(1,2) THEN (* can only be found by overloading *)
- Error(position, "sum operator not applicable");
- (* ---- ALL ----- *)
- ELSIF (id = Global.All) & CheckArity(2,4) THEN (* can only be found by overloading *)
- Error(position, "all operator not applicable");
- (* ---- DIM ----- *)
- ELSIF (id = Global.Dim) & CheckArity(1,1) THEN
- type := system.sizeType;
- IF type0 IS SyntaxTree.MathArrayType THEN
- IF type0(SyntaxTree.MathArrayType).form # SyntaxTree.Tensor THEN
- i := Dimension(type0,{SyntaxTree.Open,SyntaxTree.Static});
- result.SetResolved(SyntaxTree.NewIntegerValue(position,i));
- END;
- ELSE
- Error(position, "dimension on non math array type");
- END;
- (* ---- CAS ----- *)
- ELSIF (id = Global.Cas) & CheckArity(3,3) THEN
- IF type0.IsComposite () THEN
- Error(position, "first parameter of composite type");
- result := SyntaxTree.invalidExpression;
- ELSIF ~IsVariable (parameter0) THEN
- Error(position, "first parameter not assignable");
- result := SyntaxTree.invalidExpression;
- ELSIF ~CompatibleTo(system,type1,type0) THEN
- Error(position, "second parameter incompatible");
- result := SyntaxTree.invalidExpression;
- ELSIF ~CompatibleTo(system,type2,type0) THEN
- Error(position, "third parameter incompatible");
- result := SyntaxTree.invalidExpression;
- ELSE
- parameter1 := NewConversion(Basic.invalidPosition,parameter1,type0,NIL); actualParameters.SetExpression(1,parameter1);
- parameter2 := NewConversion(Basic.invalidPosition,parameter2,type0,NIL); actualParameters.SetExpression(2,parameter2);
- type := type0;
- END;
- (* ---- RESHAPE ----- *)
- ELSIF (id = Global.Reshape) & CheckArity(2,2) THEN
- IF type0 IS SyntaxTree.MathArrayType THEN
- (* use type checking facilities of procedure calls: artificially build parameters here and call checker *)
- base := ArrayBase(type0,MAX(LONGINT));
- type := SyntaxTree.NewMathArrayType(Basic.invalidPosition,currentScope,SyntaxTree.Tensor);
- type(SyntaxTree.MathArrayType).SetArrayBase(base);
- parameterType := SyntaxTree.NewMathArrayType(Basic.invalidPosition,currentScope,SyntaxTree.Tensor);
- parameterType(SyntaxTree.MathArrayType).SetArrayBase(base);
- IF ~CompatibleTo(system,type0,parameterType) THEN
- Error(parameter0.position,"incompatible parameter in reshape");
- result := SyntaxTree.invalidExpression;
- ELSE
- parameter0 := NewConversion(Basic.invalidPosition,parameter0,parameterType,NIL); actualParameters.SetExpression(0,parameter0);
- END;
- parameterType := SyntaxTree.NewMathArrayType(Basic.invalidPosition,currentScope,SyntaxTree.Open);
- parameterType(SyntaxTree.MathArrayType).SetArrayBase(system.longintType);
- IF ~CompatibleTo(system,type1,parameterType) THEN
- Error(parameter1.position,"parameter incompatible to math array of longint");
- result := SyntaxTree.invalidExpression;
- ELSE
- parameter1 := NewConversion(Basic.invalidPosition,parameter1,parameterType,NIL); actualParameters.SetExpression(1,parameter1);
- END;
- ELSE
- Error(position,"reshape on non math array type");
- result := SyntaxTree.invalidExpression;
- END;
- (* ---- SYSTEM.TYPECODE ----- *)
- ELSIF (id = Global.systemTypeCode) & CheckArity(1,1) THEN
- IF (parameter0.type = SyntaxTree.typeDeclarationType) THEN
- type := parameter0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType;
- type := type.resolved;
- IF type IS SyntaxTree.PointerType THEN
- type := type(SyntaxTree.PointerType).pointerBase.resolved;
- END;
- IF ~(type IS SyntaxTree.RecordType) THEN
- Error(parameter0.position,"must be type with type descriptor");
- END;
- ELSE
- Error(parameter0.position,"is not a type symbol");
- END;
- type := system.addressType;
- (* -------- FLT --------- *)
- ELSIF (id = Global.Flt) & CheckArity(1,1) THEN
- type := system.realType;
- IF IsRealValue(parameter0, r) THEN
- result.SetResolved(SyntaxTree.NewRealValue(position, r));
- ELSIF CheckIntegerType(parameter0) & IsIntegerValue(parameter0, i) THEN
- i0 := i; i := ABS(i);
- IF i # 0 THEN
- i1 := 23;
- IF i >= 2*800000H THEN
- REPEAT i := i DIV 2; INC(i1) UNTIL i < 2*800000H;
- ELSIF i < 800000H THEN
- REPEAT i := 2 * i; DEC(i1) UNTIL i >= 800000H;
- END;
- i := (i1 + 127)*800000H - 800000H + i;
- IF i0 < 0 THEN i := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, i) + {31}); END;
- END;
- result.SetResolved(SyntaxTree.NewRealValue(position, SYSTEM.VAL(REAL, i)));
- END;
- (* ------- CONNECT -------*)
- ELSIF (id = Global.Connect) & (CheckArity(2,3)) THEN
- (*IF ~(currentIsCellNet) THEN
- Error(position, "connection outside activeCells body block");
- END;*)
- IF CheckPortType(parameter0, outPort) & CheckPortType(parameter1, inPort) THEN
- IF (outPort.direction # SyntaxTree.OutPort) THEN Error(parameter0.position,"not an out-port") END;
- IF (inPort.direction # SyntaxTree.InPort) THEN Error(parameter1.position,"not an in-port") END;
- END;
- IF numberActualParameters = 3 THEN
- (*IF ~cellsAreObjects & ~IsIntegerValue(parameter2,i0) & (i0>=0) THEN
- Error(position, "incompatible channel size parameter");
- END;
- *)
- parameter2 := NewConversion(Basic.invalidPosition,parameter2,system.longintType,NIL);
- actualParameters.SetExpression(2,parameter2);
- END;
- activeCellsStatement := TRUE;
- (* ---------- DELEGATE --------*)
- ELSIF (id = Global.Delegate) & (CheckArity(2,2)) THEN
- (*
- IF ~(currentIsCellNet) THEN
- Error(position, "connection delegation outside activeCells body block");
- END;
- *)
- IF ~CheckPortType(parameter1, inPort) THEN
- Error(parameter0.position,"not a port")
- ELSIF ~CheckPortType(parameter0, outPort) THEN
- Error(parameter1.position,"not a port")
- ELSIF (outPort.direction # inPort.direction) THEN
- Error(parameter0.position,"invalid port direction");
- ELSIF outPort.sizeInBits # inPort.sizeInBits THEN
- Error(position, "incompatible port sizes");
- END;
- activeCellsStatement := TRUE;
- (* --------- RECEIVE ---------*)
- ELSIF (id = Global.Receive) & CheckArity(2,3) THEN
- IF ~cellsAreObjects THEN ImportModule(Global.NameChannelModule,position) END;
- IF CheckPortType(parameter0,inPort) & CheckVariable(parameter1) THEN
- IF inPort.direction # SyntaxTree.InPort THEN
- Error(parameter0.position,"not an in-port")
- ELSIF inPort.sizeInBits # system.SizeOf(parameter1.type) THEN
- Error(parameter1.position,"incompatible to port type");
- END;
- IF (numberActualParameters=3) & CheckVariable(parameter2) THEN
- IF ~SameType(parameter2.type, system.integerType) THEN
- Error(parameter2.position,"incompatible to integer type");
- END;
- END;
- END;
- (* --------- SEND ---------*)
- ELSIF (id = Global.Send) & CheckArity(2,2) THEN
- IF ~cellsAreObjects THEN ImportModule(Global.NameChannelModule,position) END;
- IF CheckPortType(parameter0,outPort) THEN
- IF outPort.direction # SyntaxTree.OutPort THEN
- Error(parameter1.position,"not an out-port")
- ELSIF outPort.sizeInBits # system.SizeOf(parameter1.type) THEN
- Error(parameter1.position,"incompatible to port type");
- ELSE
- parameter1 := NewConversion(position,parameter1,parameter0.type.resolved,NIL);
- actualParameters.SetExpression(1,parameter1);
- END;
- END;
- (* ------- custom builtins ----- *)
- ELSIF id = Global.systemSpecial THEN
- customBuiltin := builtin(SyntaxTree.CustomBuiltin);
- ASSERT(customBuiltin.type IS SyntaxTree.ProcedureType);
- procedureType := customBuiltin.type(SyntaxTree.ProcedureType);
- type := procedureType.returnType;
- IF CheckArity(procedureType.numberParameters, procedureType.numberParameters) THEN (* check parameter count *)
- (* go through all formal parameters *)
- formalParameter := procedureType.firstParameter;
- FOR i := 0 TO actualParameters.Length() - 1 DO
- actualParameter := actualParameters.GetExpression(i);
- IF actualParameter = SyntaxTree.invalidExpression THEN
- ELSIF ~ParameterCompatible(formalParameter,actualParameter) THEN
- Error(position, "incompatible parameter")
- ELSE
- actualParameter := NewConversion(actualParameter.position, actualParameter, formalParameter.type, NIL)
- END;
- actualParameters.SetExpression(i, actualParameter);
- formalParameter := formalParameter.nextParameter
- END
- END
- ELSE
- Error(position, "builtin not implemented");
- result := SyntaxTree.invalidExpression;
- END;
- END;
- IF result # SyntaxTree.invalidExpression THEN
- type := ResolveType(type);
- IF result.resolved # NIL THEN result.resolved.SetType(type) END;
- result.SetType(type);
- END;
- RETURN result
- END NewBuiltinCallDesignator;
- (** return type guard designator left(type)
- - check if type can be extended (i.e. is no static record)
- - check if type is a type extension of left.type
- - returns new type guard designator
- returns invalidDesignator = invalidExpression if error
- **)
- PROCEDURE NewTypeGuardDesignator(position: Position; left: SyntaxTree.Designator; type: SyntaxTree.Type; typeExpression: SyntaxTree.Expression): SyntaxTree.Designator;
- VAR result: SyntaxTree.Designator;
- BEGIN
- result := SyntaxTree.invalidDesignator;
- IF ~IsTypeExtension(left.type.resolved,type.resolved) THEN
- Error(position, "no type extension of type");
- IF VerboseErrorMessage THEN
- Printout.Info("left",left);
- Printout.Info("type",type);
- END;
- ELSIF ~(left.type.resolved = type.resolved) & ~IsExtensibleDesignator(left) THEN (* left is not extensible *)
- Error(position, "variable cannot be extended");
- ELSIF IsUnsafePointer(left.type) THEN
- Error(position, "forbidden type guard on unsafe pointer");
- ELSE
- result := SyntaxTree.NewTypeGuardDesignator(position,left,type);
- result.SetType(type);
- result.SetAssignable(left.assignable);
- result(SyntaxTree.TypeGuardDesignator).SetTypeExpression(typeExpression);
- END;
- RETURN result
- END NewTypeGuardDesignator;
- (** check and resolve parameter designator left(expression list)
- - check expression list
- - if one parameter and left is extensible type and parameter contains type declaration then return TypeGuardDesignator
- - elsif left is a procedure type then
- - if left is a built-in procedure then return NewBuiltinCallDesignator
- - else return is a procedure call then return ProcedureCallDesignator
- returns invalidDesignator = invalidExpression if error
- **)
- PROCEDURE VisitParameterDesignator(designator: SyntaxTree.ParameterDesignator);
- VAR
- parameters: SyntaxTree.ExpressionList;
- left: SyntaxTree.Designator;
- result,expression: SyntaxTree.Expression;
- typeDeclaration: SyntaxTree.TypeDeclaration;
- type, expressionType: SyntaxTree.Type;
- PROCEDURE BaseType(type: SyntaxTree.Type): SyntaxTree.Type;
- BEGIN
- type := type.resolved;
- WHILE (type # NIL) & (type IS SyntaxTree.MathArrayType) DO
- type := Resolved(type(SyntaxTree.MathArrayType).arrayBase);
- END;
- RETURN type
- END BaseType;
- BEGIN
- IF Trace THEN D.Str("VisitParameterDesignator"); D.Ln; END;
- result := SyntaxTree.invalidDesignator;
- left := ResolveDesignator(designator.left);
- IF left # SyntaxTree.invalidDesignator THEN
- parameters := designator.parameters;
- IF ExpressionList(parameters) THEN
- IF (left.type = NIL) THEN
- Error(left.position,"object is not a procedure or cannot be extended");
- ELSIF IsExtensibleDesignator(left) & (parameters.Length()=1) & IsTypeDesignator(parameters.GetExpression(0),typeDeclaration) THEN
- result := NewTypeGuardDesignator(designator.position,left,typeDeclaration.declaredType, parameters.GetExpression(0))
- ELSIF IsUnextensibleRecord(left) & (parameters.Length()=1) & IsTypeDesignator(parameters.GetExpression(0),typeDeclaration) & (typeDeclaration.declaredType.resolved = left.type.resolved) THEN
- result := NewTypeGuardDesignator(designator.position,left,typeDeclaration.declaredType, parameters.GetExpression(0))
- ELSIF (left.type.resolved IS SyntaxTree.ProcedureType) THEN
- IF (left IS SyntaxTree.SymbolDesignator) & (left(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Builtin) THEN
- result := NewBuiltinCallDesignator(designator.position,left(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Builtin),parameters,left,NIL);
- ELSE
- result := NewProcedureCallDesignator(designator.position,left,parameters)
- END
- ELSIF IsTypeDesignator(left,typeDeclaration) & (parameters.Length()=1) THEN
- expression := parameters.GetExpression(0);
- type := typeDeclaration.declaredType.resolved;
- expressionType := BaseType(expression.type); (* type or base type of math array, if applicable *)
- IF ((type IS SyntaxTree.NumberType) OR (type IS SyntaxTree.AddressType) OR (type IS SyntaxTree.SizeType)) &
- ((expressionType IS SyntaxTree.NumberType) OR (expressionType IS SyntaxTree.AddressType) OR (expressionType IS SyntaxTree.SizeType)
- OR (expressionType IS SyntaxTree.EnumerationType)
- ) THEN
- result := NewConversion(designator.position,expression,typeDeclaration.declaredType,left)
- ELSE
- Error(left.position,"invalid type in explicit conversion");
- END;
- ELSE
- Error(left.position,"called object is not a procedure or cannot be extended");
- IF VerboseErrorMessage THEN Printout.Info("designator",designator); Printout.Info("left",left) END;
- result := SyntaxTree.invalidDesignator;
- END;
- ELSE
- result := SyntaxTree.invalidDesignator
- END;
- END;
- resolvedExpression := result;
- END VisitParameterDesignator;
- (** check dereference designator left^
- - check if left is pointer type or left is object type
- - return new dereference designator with type = left.baseType.type (if appropriate)
- with error handling
- returns invalidDesignator = invalidExpression if error
- **)
- PROCEDURE NewDereferenceDesignator(position: Position; left: SyntaxTree.Designator): SyntaxTree.Designator;
- VAR type: SyntaxTree.Type; result: SyntaxTree.Designator;
- BEGIN
- result := SyntaxTree.invalidDesignator;
- type := left.type;
- IF (type # NIL) & ((type.resolved IS SyntaxTree.PointerType)) THEN
- type := type.resolved(SyntaxTree.PointerType).pointerBase;
- result := SyntaxTree.NewDereferenceDesignator(position,left);
- result.SetAssignable(TRUE);
- result.SetType(type);
- result.SetHidden(left.isHidden);
- ELSIF (type # NIL) & (type.resolved IS SyntaxTree.ArrayType) & (type.resolved(SyntaxTree.ArrayType).form = SyntaxTree.SemiDynamic) THEN
- type := type.resolved;
- result := SyntaxTree.NewDereferenceDesignator(position,left);
- result.SetAssignable(TRUE);
- result.SetType(type);
- result.SetHidden(left.isHidden);
- ELSIF (type # NIL) & (type.resolved IS SyntaxTree.CellType) THEN
- result := SyntaxTree.NewDereferenceDesignator(position,left);
- result.SetAssignable(TRUE);
- result.SetType(type);
- result.SetHidden(left.isHidden);
- ELSE
- Error(position, "dereference on no pointer");
- IF VerboseErrorMessage THEN
- Printout.Info("pointer", type);
- Printout.Info("scope", currentScope);
- END;
- END;
- RETURN result
- END NewDereferenceDesignator;
- (** check supercall designator left^
- - if left is symbol designator with procedure symbol containing non-nil supermethod then
- - return new supercall designator with type = left.type
- with error handling
- **)
- PROCEDURE NewSupercallDesignator(position: Position; left: SyntaxTree.Designator): SyntaxTree.Designator;
- VAR result: SyntaxTree.Designator; symbol: SyntaxTree.Symbol; procedure: SyntaxTree.Procedure;
- objectScope: SyntaxTree.Scope;
- BEGIN
- result := SyntaxTree.invalidDesignator;
- IF left = SyntaxTree.invalidDesignator THEN
- (* error already handled *)
- ELSIF left IS SyntaxTree.SymbolDesignator THEN
- symbol := left(SyntaxTree.SymbolDesignator).symbol;
- ASSERT(symbol # SyntaxTree.invalidSymbol);
- IF symbol IS SyntaxTree.Procedure THEN
- procedure := symbol(SyntaxTree.Procedure);
- objectScope := currentScope;
- WHILE (objectScope # NIL) & ~(objectScope IS SyntaxTree.RecordScope) DO
- objectScope := objectScope.outerScope;
- END;
- IF (left.left = NIL) OR ~
- (
- (left.left IS SyntaxTree.SelfDesignator) OR
- (left.left IS SyntaxTree.DereferenceDesignator)
- & (left.left(SyntaxTree.Designator).left # NIL)
- & (left.left(SyntaxTree.Designator).left IS SyntaxTree.SelfDesignator)) OR (procedure.scope # objectScope) THEN
- Error(position, "procedure not in immediate object scope");
- IF VerboseErrorMessage THEN
- Printout.Info("left.left",left.left);
- END;
- ELSIF procedure.super # NIL THEN
- result := SyntaxTree.NewSupercallDesignator(position,left);
- result.SetType(left.type.resolved)
- ELSE
- Error(position, "no supermethod for this procedure");
- END;
- ELSE
- Error(position, "symbol is not a procedure");
- END;
- ELSE
- Error(position, "is no symbol designator");
- END;
- RETURN result
- END NewSupercallDesignator;
- (** check and semantically resolve arrow designator left^
- - if left is procedure type -> result := SupercallDesignator
- - else result := DereferenceDesignator
- returns result via global variable resolvedExpression
- error handling deferred to procedures SupercallDesignator and DereferenceDesignator
- **)
- PROCEDURE VisitArrowDesignator(arrowDesignator: SyntaxTree.ArrowDesignator);
- VAR left: SyntaxTree.Designator;
- BEGIN
- IF Trace THEN D.Str("VisitArrowDesignator"); D.Ln; END;
- left := ResolveDesignator(arrowDesignator.left);
- IF left # NIL THEN
- IF (left.type = NIL) THEN
- Error(arrowDesignator.position,"Invalid arrow designator");
- ELSIF (left.type.resolved # NIL) & (left.type.resolved IS SyntaxTree.ProcedureType) THEN
- resolvedExpression := NewSupercallDesignator(arrowDesignator.position,left);
- ELSE
- IF IsPointerToObject(left.type) THEN
- (* Warning(arrowDesignator.position, "forbidden dereference on object"); *)
- END;
- resolvedExpression := NewDereferenceDesignator(arrowDesignator.position,left)
- END
- END
- END VisitArrowDesignator;
- (** check and return expression
- - if expression has no type then resolve expression
- - resulting expression is exchanged via global variable "resolvedExpression" which makes this mechanism thread-unsafe
- - return result
- **)
- PROCEDURE ResolveExpression(expression: SyntaxTree.Expression): SyntaxTree.Expression;
- VAR result,prev: SyntaxTree.Expression;
- BEGIN
- IF expression = NIL THEN result := NIL
- ELSIF (expression.type = NIL) THEN
- prev := resolvedExpression;
- resolvedExpression := SyntaxTree.invalidExpression;
- IF ~(expression IS SyntaxTree.BuiltinCallDesignator) THEN
- expression.SetType(SyntaxTree.invalidType);
- END;
- expression.Accept(SELF);
- result := resolvedExpression;
- IF currentIsRealtime THEN
- IF (result.type # NIL) & ~result.type.resolved.isRealtime THEN
- Error(expression.position,"forbidden non-realtime expression in realtime procedure");
- END;
- END;
- (* designator modifiers for backends if they support it ...*)
- IF (expression IS SyntaxTree.Designator) & (expression(SyntaxTree.Designator).modifiers # NIL) & (result IS SyntaxTree.Designator) THEN
- result(SyntaxTree.Designator).SetModifiers(expression(SyntaxTree.Designator).modifiers);
- CheckModifiers(result(SyntaxTree.Designator).modifiers, FALSE);
- END;
- resolvedExpression := prev
- ELSE
- result := expression
- END;
- RETURN result
- END ResolveExpression;
- (**
- check expression to be constant expression
- - resolve expression
- - if valid then check that of value type
- report error and return invalidExpression if anything fails
- **)
- PROCEDURE ConstantExpression(expression: SyntaxTree.Expression): SyntaxTree.Expression;
- VAR position: Position;
- BEGIN
- position := expression.position;
- expression := ResolveExpression(expression);
- IF expression = SyntaxTree.invalidExpression THEN (* error already reported *)
- ELSIF (expression.resolved = NIL) THEN
- Error(position, "expression is not constant");
- IF VerboseErrorMessage THEN Printout.Info("expression",expression); END;
- expression := SyntaxTree.invalidExpression;
- END;
- RETURN expression
- END ConstantExpression;
- (** check expression to be constant integer
- - resolve expresssion
- - if valid then check that of integer value type
- report error and return invalidExpression if anything fails
- **)
- PROCEDURE ConstantInteger(expression: SyntaxTree.Expression): SyntaxTree.Expression;
- VAR position: Position;
- BEGIN
- position := expression.position;
- expression := ResolveExpression(expression);
- IF expression = SyntaxTree.invalidExpression THEN (* error already reported *)
- ELSIF (expression.resolved = NIL) OR ~(expression.resolved IS SyntaxTree.IntegerValue) THEN
- expression := SyntaxTree.invalidExpression;
- Error(position, "expression is not a constant integer");
- END;
- RETURN expression
- END ConstantInteger;
- (** check expression as positive (>=0) constant integer
- - resolve expression
- - if valid then check that integer value
- - if integer value then check that value >= 0
- report error and return invalidExpression if anything fails
- **)
- PROCEDURE ConstantIntegerGeq0(expression: SyntaxTree.Expression): SyntaxTree.Expression;
- VAR position: Position;
- BEGIN
- position := expression.position;
- expression := ConstantExpression(expression);
- IF expression = SyntaxTree.invalidExpression THEN
- (* error already reported *)
- ELSIF (expression.resolved = NIL) OR ~(expression.resolved IS SyntaxTree.IntegerValue) THEN
- Error(position, "expression is not integer valued");
- expression := SyntaxTree.invalidExpression
- ELSIF (expression.resolved(SyntaxTree.IntegerValue).hvalue <0) THEN
- Error(position, "integer is not greater or equal zero");
- END;
- RETURN expression
- END ConstantIntegerGeq0;
- (** check expression as condition
- - resolve expression
- - if valid expression then check that result type is boolean
- report error and return invalidExpression if anything fails
- **)
- PROCEDURE ResolveCondition(expression: SyntaxTree.Expression): SyntaxTree.Expression;
- VAR position: Position;
- BEGIN
- position := expression.position;
- expression := ResolveExpression(expression);
- IF expression = SyntaxTree.invalidExpression THEN (* error already reported *)
- ELSIF (expression.type = NIL) OR ~(expression.type.resolved IS SyntaxTree.BooleanType) THEN
- expression := SyntaxTree.invalidExpression;
- Error(position, "expression is not boolean");
- END;
- RETURN expression
- END ResolveCondition;
- (*** symbols ***)
- PROCEDURE ResolveSymbol(x: SyntaxTree.Symbol);
- BEGIN
- x.Accept(SELF);
- END ResolveSymbol;
- (** check a symbol
- - check visibility flags (symbols within procedure scope (direct or indirect) cannot be exported)
- **)
- PROCEDURE CheckSymbolVisibility(symbol: SyntaxTree.Symbol);
- VAR scope: SyntaxTree.Scope;
- BEGIN
- (* visibility *)
- scope := symbol.scope;
- WHILE (scope # NIL) & ~(scope IS SyntaxTree.ProcedureScope) DO
- scope := scope.outerScope;
- END;
- IF (scope # NIL) THEN (* symbol (directly or indirectly) in procedure scope *)
- IF (symbol.access * SyntaxTree.Public # {}) & (~(symbol IS SyntaxTree.Procedure) OR ~symbol(SyntaxTree.Procedure).isBodyProcedure & ~symbol(SyntaxTree.Procedure).isConstructor & ~symbol(SyntaxTree.Procedure).isFinalizer) THEN
- Error(symbol.position,"cannot be exported");
- IF VerboseErrorMessage THEN
- Printout.Info("symbol",symbol);
- END;
- END;
- END;
- END CheckSymbolVisibility;
- (** Check if a node has already been resolved. If not then mark as currently being resolved.
- If node is currently being resolved then emit a cyclic definition error.
- Return TRUE only if node is fully resolved.
- **)
- PROCEDURE SymbolNeedsResolution(x: SyntaxTree.Symbol): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- IF SyntaxTree.Resolved IN x.state THEN
- result := FALSE
- ELSIF SyntaxTree.BeingResolved IN x.state THEN
- Error(x.position,"cyclic definition");
- result := FALSE;
- ELSE
- result := TRUE;
- x.SetState(SyntaxTree.BeingResolved)
- END;
- RETURN result
- END SymbolNeedsResolution;
- (** check and resolve a type declaration symbol = Type
- - set type to declaration type
- -> the type of a type declaration is NOT the declared type but the "declaration" type.
- This is so because the type declaration itself does not have a type but it only stands for a type.
- In the implementation of the compiler this made a lot much easier.
- - resolve and set declared type
- - check symbol
- **)
- PROCEDURE VisitTypeDeclaration(typeDeclaration: SyntaxTree.TypeDeclaration);
- VAR prevScope: SyntaxTree.Scope;
- BEGIN
- IF Trace THEN D.Str("VisitTypeDeclaration "); D.Str0(typeDeclaration.name); D.Ln; END;
- IF SymbolNeedsResolution(typeDeclaration) THEN
- typeDeclaration.SetState(SyntaxTree.Resolved);
- prevScope := currentScope;
- currentScope := typeDeclaration.scope;
- typeDeclaration.SetType(SyntaxTree.typeDeclarationType);
- typeDeclaration.SetDeclaredType(ResolveType(typeDeclaration.declaredType));
- CheckSymbolVisibility(typeDeclaration);
- typeDeclaration.SetState(SyntaxTree.Resolved);
- currentScope := prevScope;
- END;
- END VisitTypeDeclaration;
- (** check and resolve a constant declaration symbol = (constant) expression
- - check expression
- - set type and value
- - check symbol
- **)
- PROCEDURE VisitConstant(constant: SyntaxTree.Constant);
- VAR
- expression: SyntaxTree.Expression;
- type: SyntaxTree.Type;
- name: Basic.SegmentedName;
- replacement: Replacement;
- BEGIN
- IF Trace THEN D.Str("VisitConstant "); D.Str0(constant.name); D.Ln; END;
- IF SymbolNeedsResolution(constant) THEN
- expression := constant.value;
- IF replacements # NIL THEN
- Global.GetSymbolSegmentedName(constant, name);
- replacement := replacements;
- WHILE (replacement # NIL) & (replacement.name # name) DO
- replacement := replacement.next;
- END;
- IF replacement # NIL THEN
- InfoSS(constant.position, "replacing constant", constant.name);
- (*
- NEW(stringReader, Strings.Length(replacement.string^));
- stringReader.Set(replacement.string^);
- NEW(scanner, replacement.string^, stringReader,0, diagnostics);
- NEW(parser, scanner, diagnostics);
- expression := parser.Expression();
- *)
- expression := replacement.expression;
- replacement.used := TRUE;
- END;
- END;
- constant.SetType(SyntaxTree.invalidType);
- expression := ConstantExpression(expression);
- ASSERT(expression.type # NIL);
- type := expression.type.resolved;
- constant.SetType(type);
- constant.SetValue(expression);
- CheckSymbolVisibility(constant);
- constant.SetState(SyntaxTree.Resolved);
- END;
- END VisitConstant;
- PROCEDURE AdaptStackAlignment(procedure: SyntaxTree.Procedure; alignment: LONGINT);
- VAR procedureAlignment: LONGINT;
- PROCEDURE LCM(a0,b0: LONGINT): LONGINT;
- (* least common multiple *)
- VAR a,b: LONGINT;
- BEGIN
- a := a0; b := b0;
- WHILE (a # b) DO
- IF a < b THEN a := a+a0
- ELSE b := b + b0
- END;
- END;
- RETURN a
- END LCM;
- BEGIN
- IF alignment > 1 THEN
- procedureAlignment := procedure.type(SyntaxTree.ProcedureType).stackAlignment;
- IF (procedureAlignment > 1) THEN
- alignment := LCM(alignment, procedureAlignment);
- END;
- procedure.type(SyntaxTree.ProcedureType).SetStackAlignment(alignment);
- END;
- END AdaptStackAlignment;
- (** check and resolve a variable / field
- - check and set type
- - negative check on open array type
- - check symbol
- **)
- PROCEDURE VisitVariable(variable: SyntaxTree.Variable);
- VAR modifiers: SyntaxTree.Modifier; value: LONGINT; position: Position; pointerType: SyntaxTree.PointerType;
- BEGIN
- IF Trace THEN D.Str("VisitVariable "); D.Str0(variable.name); D.Ln; END;
- IF SymbolNeedsResolution(variable) THEN
- modifiers := variable.modifiers;
- (*
- flags := Flags(variable.modifiers,{SyntaxTree.UntracedFlag, SyntaxTree.AlignedFlag, SyntaxTree.FixedFlag});
- variable.AddFlags(flags);
- *)
- variable.SetType(ResolveType(variable.type));
- IF variable.type.resolved IS SyntaxTree.ArrayType THEN
- IF variable.type.resolved(SyntaxTree.ArrayType).length = NIL THEN
- Error(variable.position,"forbidden open array variable");
- END;
- END;
- CheckSymbolVisibility(variable);
- IF HasFlag(modifiers, Global.NameUntraced,position) THEN
- variable.SetUntraced(TRUE);
- IF ~ContainsPointer(variable.type) THEN
- IF VerboseErrorMessage THEN Printout.Info("variable",variable); Printout.Info("variable.type",variable.type.resolved); END;
- Error(position, "untraced flag on non-pointer variable");
- END;
- END;
- IF HasValue(modifiers, Global.NameAligned,position, value) THEN
- IF (variable.scope IS SyntaxTree.ProcedureScope) THEN
- IF ~PowerOf2(value) THEN
- Error(position, "forbidden alignment - must be power of two");
- ELSE
- AdaptStackAlignment(variable.scope(SyntaxTree.ProcedureScope).ownerProcedure, value);
- END;
- END;
- variable.SetAlignment(FALSE,value);
- ELSIF HasValue(modifiers, Global.NameFixed,position, value) THEN
- IF (variable.scope IS SyntaxTree.ProcedureScope) THEN
- Error(position, "fixed position not possible in procedure");
- END;
- variable.SetAlignment(TRUE, value);
- ELSIF HasValue(modifiers, Global.NameFictive, position, value) THEN
- IF (variable.scope IS SyntaxTree.ProcedureScope) THEN
- Error(position,"fictive offset not possible in procedure");
- END;
- variable.SetFictive(value);
- variable.SetOffset(value*system.dataUnit);
- IF ContainsPointer(variable.type) THEN variable.SetUntraced(TRUE) END;
- END;
- IF HasFlag(modifiers, Global.NameRegister, position) THEN variable.SetUseRegister(TRUE) END;
- IF variable.type.resolved IS SyntaxTree.CellType THEN
- IF HasValue(modifiers, Global.NameCodeMemorySize, position, value) THEN END;
- IF HasValue(modifiers, Global.NameDataMemorySize, position, value) THEN END;
- END;
- CheckModifiers(modifiers, ~InCellNetScope(variable.scope) & ~(variable.type.resolved IS SyntaxTree.CellType) & ~(variable.type.resolved IS SyntaxTree.PortType));
- IF variable.initializer # NIL THEN
- variable.SetInitializer (CompatibleConversion (variable.initializer.position, ConstantExpression(variable.initializer), variable.type));
- END;
-
- IF (variable.type.resolved IS SyntaxTree.CellType) (*& (cellsAreObjects)*) THEN
- pointerType := SyntaxTree.NewPointerType(variable.position, variable.scope);
- pointerType.SetPointerBase(variable.type);
- pointerType.SetHidden(TRUE);
- variable.SetType(ResolveType(pointerType));
- END;
-
- variable.SetState(SyntaxTree.Resolved);
- END;
- END VisitVariable;
- PROCEDURE VisitProperty(property: SyntaxTree.Property);
- BEGIN
- VisitVariable(property)
- END VisitProperty;
-
- (** check and resolve a (procedure) parameter
- - check and set type
- - check symbol
- - check parameter kind and set read-only flags if appropriate
- **)
- PROCEDURE VisitParameter(parameter: SyntaxTree.Parameter);
- VAR modifiers: SyntaxTree.Modifier; expression: SyntaxTree.Expression; position: Position;
- BEGIN
- IF Trace THEN D.Str("VisitParameter "); D.Str0(parameter.name); D.Ln; END;
- IF SymbolNeedsResolution(parameter) THEN
- modifiers := parameter.modifiers;
- parameter.SetType(ResolveType(parameter.type));
- ASSERT(parameter.type.resolved # NIL);
- CheckSymbolVisibility(parameter);
- IF parameter.defaultValue # NIL THEN
- IF parameter.kind # SyntaxTree.ValueParameter THEN
- Error(parameter.position,"forbidden default value on non-value parameter");
- ELSE
- expression := ConstantExpression(parameter.defaultValue);
- IF CompatibleTo(system,expression.type, parameter.type) THEN
- expression := NewConversion(expression.position, expression, parameter.type, NIL);
- parameter.SetDefaultValue(expression);
- END;
- END;
- END;
- IF HasFlag(modifiers, Global.NameUntraced,position) THEN
- parameter.SetUntraced(TRUE);
- IF ~ContainsPointer(parameter.type) THEN
- IF VerboseErrorMessage THEN Printout.Info("parameter",parameter); Printout.Info("parameter.type",parameter.type.resolved); END;
- Error(position, "untraced flag on non-pointer variable");
- END;
- END;
- IF HasFlag(modifiers, Global.NameMovable,position) THEN
- parameter.SetMoveable(TRUE);
- IF ~(parameter.type.resolved IS SyntaxTree.AddressType) THEN
- IF VerboseErrorMessage THEN Printout.Info("parameter",parameter); Printout.Info("parameter.type",parameter.type.resolved); END;
- Error(position, "illegal movable flag on non-address variable");
- ELSIF parameter.kind = SyntaxTree.VarParameter THEN
- IF VerboseErrorMessage THEN Printout.Info("parameter",parameter); Printout.Info("parameter.type",parameter.type.resolved); END;
- Error(position, "unnecessary movable flag on variable variable");
- END;
- END;
- CheckModifiers(modifiers, ~InCellNetScope(parameter.scope) & ~(parameter.type.resolved IS SyntaxTree.CellType) & ~(parameter.type.resolved IS SyntaxTree.PortType));
- parameter.SetState(SyntaxTree.Resolved);
- END;
- END VisitParameter;
- (** check and resolve a procedure (with declaration and implementation scope)
- - check the procedure type
- - check if method (i.e. in record scope), if so then
- - check if (unique) constructor
- - check if (unique) finalizer
- - check if super method available, if so then check signature
- - of not in record scope then negative check on constructor flag
- - of not in record scope then negative check on finalizer flag
- - check declarations (including a delayed implementation check, cf procedure Declarations)
- - check procedure symbol
- **)
- PROCEDURE VisitProcedure(procedure: SyntaxTree.Procedure);
- VAR super,proc: SyntaxTree.Procedure; record: SyntaxTree.RecordType;
- procedureType: SyntaxTree.ProcedureType;
- type: SyntaxTree.Type;
- selfParameter: SyntaxTree.Parameter; qualifiedIdentifier: SyntaxTree.QualifiedIdentifier;
- qualifiedType: SyntaxTree.QualifiedType;
- value: LONGINT;
- modifiers: SyntaxTree.Modifier; recentIsRealtime, recentIsBodyProcedure: BOOLEAN;
- position: Position;
- fp: SyntaxTree.FingerPrint;
- BEGIN
- IF Trace THEN D.Str("VisitProcedure "); D.Str0(procedure.name); D.Ln; END;
- IF IsOberonInline(procedure) THEN
- IF SyntaxTree.Public * procedure.access # {} THEN
- Warning(procedure.position, "Export of Oberon Inline Not Yet Tested")
- END;
- procedure.SetInline(FALSE);
- procedure.SetOberonInline(TRUE);
- END;
- IF SymbolNeedsResolution(procedure) THEN
- recentIsRealtime := currentIsRealtime;
- recentIsBodyProcedure := currentIsBodyProcedure;
- IF Trace THEN D.Str("undefined"); D.Ln; END;
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- modifiers := procedureType.modifiers;
- IF HasFlag(modifiers, Global.NameWinAPI,position) THEN procedureType.SetCallingConvention(SyntaxTree.WinAPICallingConvention)
- ELSIF HasFlag(modifiers, Global.NameC,position) THEN
- IF useDarwinCCalls THEN (*fld*)
- procedureType.SetCallingConvention(SyntaxTree.DarwinCCallingConvention)
- ELSE
- procedureType.SetCallingConvention(SyntaxTree.CCallingConvention)
- END
- END;
- IF HasFlag(modifiers, Global.NameInterrupt, position) THEN
- procedureType.SetInterrupt(TRUE);
- procedureType.SetCallingConvention(SyntaxTree.InterruptCallingConvention)
- END;
- IF HasFlag(modifiers, Global.NameNoReturn, position) THEN
- procedureType.SetNoReturn(TRUE);
- END;
- IF HasValue(modifiers, Global.NamePcOffset, position, value) THEN procedureType.SetPcOffset(value) END;
- IF HasFlag(modifiers,Global.NameNoPAF,position) THEN procedureType.SetNoPAF(TRUE) END;
- IF HasFlag(modifiers, Global.NameEntry,position) THEN procedure.SetEntry(TRUE)
- ELSIF (procedure.scope IS SyntaxTree.ModuleScope) & HasFlag(modifiers, Global.NameExit, position) THEN procedure.SetExit(TRUE)
- END;
- IF HasValue(modifiers,Global.NameAligned,position,value) THEN procedure.SetAlignment(FALSE,value)
- ELSIF HasValue(modifiers,Global.NameFixed,position,value) THEN procedure.SetAlignment(TRUE,value)
- END;
- IF HasValue(modifiers,Global.NameStackAligned, position, value) THEN
- IF ~PowerOf2(value) THEN
- Error(position, "forbidden stack alignment - must be power of two");
- ELSE
- procedureType.SetStackAlignment(value)
- END;
- END;
- IF HasFlag(modifiers,Global.NameRealtime,position) THEN procedureType.SetRealtime(TRUE) END;
- IF HasFlag(modifiers,Global.NameFinal,position) THEN procedure.SetFinal(TRUE)
- ELSIF HasFlag(modifiers,Global.NameAbstract,position) THEN procedure.SetAbstract(TRUE)
- END;
- IF HasValue(modifiers, Global.NameFingerprint, position, value) THEN
- SyntaxTree.InitFingerPrint(fp);
- fp.shallow := value;
- fp.shallowAvailable := TRUE;
- procedure.SetFingerPrint(fp);
- END;
- CheckModifiers(modifiers, TRUE);
-
- modifiers := procedureType.returnTypeModifiers;
- procedureType.SetUntracedReturn(HasFlag(modifiers, Global.NameUntraced, position));
- CheckModifiers(modifiers, TRUE);
-
- procedure.SetState(SyntaxTree.Resolved);
-
- FixProcedureType(procedureType);
- currentIsRealtime := procedureType.isRealtime;
- currentIsBodyProcedure := procedure.isBodyProcedure;
- IF ~system.GenerateParameterOffsets(procedure,FALSE) (* assume that this is no nested procedure, is fixed later otherwise *)
- THEN
- Error(procedure.position,"problems during parameter offset computation");
- END;
- CheckSymbolVisibility(procedure);
- IF procedure.scope IS SyntaxTree.ProcedureScope THEN
- procedure.SetLevel(procedure.scope(SyntaxTree.ProcedureScope).ownerProcedure.level+1);
- IF ~system.GenerateParameterOffsets(procedure,TRUE) THEN
- Error(procedure.position,"problem during parameter offset generation");
- END;
- END;
- IF procedure.scope IS SyntaxTree.RecordScope THEN
- record := procedure.scope(SyntaxTree.RecordScope).ownerRecord;
- procedureType.SetDelegate(TRUE);
- IF (record.pointerType # NIL) & (procedureType.selfParameter = NIL) THEN
- (* add auto-self *)
- selfParameter := SyntaxTree.NewParameter(procedure.position,procedureType,Global.SelfParameterName,SyntaxTree.ValueParameter);
- IF (record.pointerType.typeDeclaration = NIL) THEN
- selfParameter.SetType(record.pointerType);
- ELSE
- qualifiedIdentifier := SyntaxTree.NewQualifiedIdentifier(procedure.position,SyntaxTree.invalidIdentifier,record.pointerType.typeDeclaration.name);
- qualifiedType := SyntaxTree.NewQualifiedType(procedure.position,procedure.scope,qualifiedIdentifier);
- qualifiedType.SetResolved(record.pointerType);
- selfParameter.SetType(qualifiedType);
- END;
- selfParameter.SetAccess(SyntaxTree.Hidden);
- END;
- (*! constructor information is redundant, we can remove "isConstructor" and repplace by constructor procedure reference *)
- IF procedure.isConstructor THEN
- (*! constructor is always visible, compatibility to paco
- procedure.SetAccess(SyntaxTree.Public+SyntaxTree.Protected+SyntaxTree.Internal);
- *)
- procedure.MarkUsed;
- IF procedureType.returnType # NIL THEN
- Error(procedure.position,"constructor with forbidden return type");
- END;
- proc := procedure.scope.firstProcedure;
- WHILE (proc # NIL) & ((proc = procedure) OR ~(proc.isConstructor)) DO
- proc := proc.nextProcedure;
- END;
- IF proc # NIL THEN
- Error(procedure.position,"duplicate constructor")
- ELSE
- procedure.scope(SyntaxTree.RecordScope).SetConstructor(procedure);
- END;
- END;
- IF procedure.isFinalizer THEN
- procedure.MarkUsed;
- IF procedureType.returnType # NIL THEN
- Error(procedure.position,"finalizer with forbidden return type");
- END;
- IF procedureType.numberParameters # 0 THEN
- Error(procedure.position,"finalizer with formal parameters");
- END;
- proc := procedure.scope.firstProcedure;
- WHILE (proc # NIL) & ((proc = procedure) OR ~(proc.isFinalizer)) DO
- proc := proc.nextProcedure;
- END;
- IF proc # NIL THEN
- Error(procedure.position,"duplicate finalizer")
- ELSE
- procedure.scope(SyntaxTree.RecordScope).SetFinalizer(procedure);
- END;
- END;
- super := FindSuperProcedure(record.recordScope, procedure);
- IF (super # NIL) & SignatureCompatible(procedure.position,procedureType,super.type.resolved(SyntaxTree.ProcedureType)) THEN
- IF (super.isConstructor) & ~(procedure.isConstructor) THEN
- Error(procedure.position,"incompatible signature: non-constructor extends constructor");
- END;
- IF (super.isFinalizer) & ~(procedure.isFinalizer) THEN
- Error(procedure.position,"incompatible signature: non-finalizer extends finalizer");
- END;
- IF super.isFinal THEN
- Error(procedure.position,"forbidden method extending final method");
- END;
- procedure.SetSuper(super);
- super.SetOverwritten(TRUE);
- procedure.SetAccess(procedure.access+super.access);
- procedure.MarkUsed;
- END;
- IF ~system.GenerateParameterOffsets(procedure,FALSE) (* assume that this is no nested procedure, is fixed later otherwise *)
- THEN
- Error(procedure.position,"problems during parameter offset computation");
- END;
- ELSIF procedure.scope IS SyntaxTree.CellScope THEN (* allowed to be constructor *)
- IF cellsAreObjects THEN
- procedureType.SetDelegate(TRUE);
- END;
- IF procedure.isConstructor THEN
- procedure.scope(SyntaxTree.CellScope).SetConstructor(procedure);
- END;
- ELSIF procedure.isConstructor THEN
- Error(procedure.position,"procedure illegaly marked as initializer - not in object scope");
- END;
- Declarations(procedure.procedureScope, FALSE, TRUE,TRUE);
- (* body resolution part done as late fix of the procedure type *)
- procedure.SetState(SyntaxTree.Resolved);
- currentIsRealtime := recentIsRealtime;
- currentIsBodyProcedure := recentIsBodyProcedure;
- END;
- END VisitProcedure;
- (**
- a builtin procedure is a global item that may not be modified locally
- instead the resolving of builtin procedure calls are done in the esignator
- **)
- PROCEDURE VisitBuiltin(builtinProcedure: SyntaxTree.Builtin);
- VAR type: SyntaxTree.Type;
- BEGIN
- type := ResolveType(builtinProcedure.type);
- END VisitBuiltin;
- (* nopov *)
- (** check and resolve operator
- - operators are first checked as procedures
- - then additional operator-specific checks are done
- - note that only module-scope operators are checked here
- (operators in a record scope are only allowed in the context of
- array-structured object types and checked in 'ResolveArrayStructure')
- - also note that inter-operator conformity is not checked here
- **)
- PROCEDURE VisitOperator(operator: SyntaxTree.Operator);
- VAR
- procedureType: SyntaxTree.ProcedureType;
- leftType, rightType: SyntaxTree.Type;
- identifierNumber: LONGINT; position: Position;
- hasReturnType, mustBeUnary, mustBeBinary, mustReturnBoolean, mustReturnInteger, mustHaveEquitypedOperands: BOOLEAN;
- modifiers: SyntaxTree.Modifier;
- (** whether a type is locally defined in the current module scope
- for arrays, the base type must be locally defined **)
- PROCEDURE IsLocallyDefined(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN
- RETURN FALSE
- ELSIF (type.typeDeclaration # NIL) & (type.typeDeclaration.scope.ownerModule = currentScope.ownerModule) THEN
- RETURN TRUE
- ELSIF (type.resolved IS SyntaxTree.ArrayType) THEN
- RETURN IsLocallyDefined(type.resolved(SyntaxTree.ArrayType).arrayBase)
- ELSIF (type.resolved IS SyntaxTree.MathArrayType) THEN
- RETURN IsLocallyDefined(type.resolved(SyntaxTree.MathArrayType).arrayBase)
- ELSE
- RETURN FALSE
- END
- END IsLocallyDefined;
- BEGIN
- ASSERT(operator.type IS SyntaxTree.ProcedureType);
- procedureType := operator.type(SyntaxTree.ProcedureType);
- modifiers := procedureType.modifiers;
- IF HasFlag(modifiers, Global.NameDynamic, position) THEN operator.SetDynamic(TRUE) END;
- CheckModifiers(modifiers, TRUE);
- VisitProcedure(operator);
- IF operator.scope IS SyntaxTree.RecordScope THEN
- ELSIF operator.scope IS SyntaxTree.ModuleScope THEN
- identifierNumber := Global.GetSymbol(operator.scope.ownerModule.case, operator.name);
- IF identifierNumber = -1 THEN
- Error(operator.position, "operator with unknown identifier")
- ELSIF ~system.operatorDefined[identifierNumber] THEN
- Error(operator.position, "identifier may not be used for operator")
- ELSE
- IF procedureType.numberParameters < 1 THEN
- Error(operator.position, "operator without operand");
- ELSIF procedureType.numberParameters > 2 THEN
- Error(operator.position, "operator with more than two operands");
- ELSE
- (* determine operand types *)
- leftType := procedureType.firstParameter.type;
- IF procedureType.numberParameters > 1 THEN
- rightType := procedureType.firstParameter.nextParameter.type
- ELSE
- rightType := NIL
- END;
- (* check whether at least one of the operand types is declared in the current module (this check is skipped for the module FoxArrayBase) *)
- IF currentScope.ownerModule.name # Global.ArrayBaseName THEN
- IF ~(IsLocallyDefined(leftType) OR IsLocallyDefined(rightType)) THEN
- Error(operator.position, "none of the operands is declared in the same module")
- END
- END;
- (* TODO: refine the checks, think about how restrictive the checks should be
- requiring operators such as "&", "OR", "~" to return Booleans, makes overloading for them almost pointless.
- They might be used for intersection, union, complement of custom object types *)
- (* defaults *)
- hasReturnType := TRUE;
- mustBeUnary := FALSE;
- mustBeBinary := FALSE;
- mustReturnBoolean := FALSE;
- mustReturnInteger := FALSE;
- mustHaveEquitypedOperands := FALSE;
- (* operator-specific exceptions *)
- CASE identifierNumber OF
- | Scanner.Equal, Scanner.Unequal, Scanner.Less, Scanner.LessEqual, Scanner.Greater, Scanner.GreaterEqual:
- mustBeBinary := TRUE; mustReturnBoolean := TRUE;
- | Scanner.DotEqual, Scanner.DotUnequal, Scanner.DotLess, Scanner.DotLessEqual, Scanner.DotGreater, Scanner.DotGreaterEqual:
- mustBeBinary := TRUE
- | Scanner.In: mustBeBinary := TRUE; mustReturnBoolean := TRUE
- | Scanner.Is: mustBeBinary := TRUE; mustReturnBoolean := TRUE
- | Scanner.Times: mustBeBinary := TRUE
- | Scanner.TimesTimes: mustBeBinary := TRUE
- | Scanner.DotTimes: mustBeBinary := TRUE
- | Scanner.PlusTimes: mustBeBinary := TRUE
- | Scanner.Slash: mustBeBinary := TRUE
- | Scanner.Backslash: mustBeBinary := TRUE
- | Scanner.DotSlash: mustBeBinary := TRUE
- | Scanner.Div, Scanner.Mod: mustBeBinary := TRUE;
- | Scanner.And, Scanner.Or: mustBeBinary := TRUE;
- | Scanner.Not: mustBeUnary := TRUE
- | Scanner.Plus, Scanner.Minus: (* unary and binary *)
- | Scanner.Becomes: mustBeBinary := TRUE; hasReturnType := FALSE;
- | Scanner.Transpose: mustBeUnary := TRUE;
- | Global.Conversion: mustBeUnary := TRUE; (* TODO: get rid of return type? *)
- | Global.DotTimesPlus: mustBeBinary := TRUE;
- | Global.AtMulDec, Global.AtMulInc: mustBeBinary := TRUE;
- | Global.DecMul, Global.IncMul: mustBeBinary := TRUE;
- | Global.Dec, Global.Inc: hasReturnType := FALSE; (* unary and binary *)
- | Global.Excl, Global.Incl:hasReturnType := FALSE;
- | Global.Abs: mustBeUnary := TRUE;
- | Global.Ash: (* TODO: arity? *)
- | Global.Cap: (* TODO: arity? *)
- | Global.Chr: mustBeUnary := TRUE;
- | Global.Entier: (* TODO: arity? *)
- | Global.EntierH: (* TODO: arity? *)
- | Global.Len: (* unary and binary *)
- | Global.Short, Global.Long: mustBeUnary := TRUE;
- | Global.Max, Global.Min: (* unary and binary *)
- | Global.Odd: (* TODO: arity? *)
- | Global.Sum: (* TODO: arity? *)
- | Global.All: (* TODO: arity? *)
- | Global.Dim: mustBeUnary := TRUE; mustReturnInteger := TRUE;
- | Scanner.Alias:
- | Scanner.GreaterGreater, Scanner.LessLess:
- mustBeBinary := TRUE; hasReturnType := FALSE;
- | Scanner.GreaterGreaterQ, Scanner.LessLessQ:
- mustBeBinary := TRUE; mustReturnBoolean := TRUE;
- END;
- (* check parameter count *)
- IF mustBeUnary & (procedureType.numberParameters # 1) THEN
- Error(operator.position,"operator is not unary")
- ELSIF mustBeBinary & (procedureType.numberParameters # 2) THEN
- Error(operator.position,"operator is not binary")
- END;
- (* check parameter types *)
- (* TODO: is this used at all? *)
- IF mustHaveEquitypedOperands & (procedureType.numberParameters = 2) THEN
- leftType := procedureType.firstParameter.type;
- rightType := procedureType.firstParameter.nextParameter.type;
- IF ~leftType.resolved.SameType(rightType.resolved) THEN
- Error(operator.position, "the two operands are not of the same type")
- END
- END;
- (* check return type *)
- IF hasReturnType THEN
- IF procedureType.returnType = NIL THEN
- Error(operator.position, "return type required")
- ELSIF mustReturnBoolean THEN
- IF ~(procedureType.returnType.resolved IS SyntaxTree.BooleanType) THEN
- Error(operator.position,"return type is not Boolean")
- END
- ELSIF mustReturnInteger THEN
- IF ~(procedureType.returnType.resolved IS SyntaxTree.IntegerType) THEN
- Error(operator.position,"return type is not integer")
- END
- END
- ELSIF procedureType.returnType # NIL THEN
- Error(operator.position, "return type not allowed")
- END
- END
- END
- END
- END VisitOperator;
- PROCEDURE AddImport*(module: SyntaxTree.Module; x: SyntaxTree.Import): BOOLEAN;
- VAR prevScope: SyntaxTree.Scope; prevDiagnostics: Diagnostics.Diagnostics;
- BEGIN
- IF error THEN RETURN FALSE END;
- prevScope := currentScope;
- prevDiagnostics := diagnostics;
- diagnostics := NIL; (* suppress error output *)
- currentScope := module.moduleScope;
- VisitImport(x);
- IF ~error THEN
- module.moduleScope.AddImport(x);
- x.SetScope(module.moduleScope);
- END;
- currentScope := prevScope;
- diagnostics := prevDiagnostics;
- IF error THEN error := FALSE; RETURN FALSE ELSE RETURN TRUE END;
- END AddImport;
- (** check and resolve import
- - check for name = SYSTEM
- - check for forbidden self import
- - search through global import cache: already imported?
- - check if already imported indirectly
- - import if necessary -> set module and enter into import cache
- - enter re-imports into list of imported modules as non-direct import (if not in direct import list)
- - after this import this direct import and all indirect imports are stored in the current module's import list
- **)
- PROCEDURE VisitImport(x: SyntaxTree.Import);
- VAR
- module: SyntaxTree.Module;
- moduleScope: SyntaxTree.ModuleScope;
- import,reimport: SyntaxTree.Import;
- filename: FileName;
- prevScope: SyntaxTree.Scope;
- BEGIN
- IF SymbolNeedsResolution(x) THEN
- prevScope := currentScope;
- x.SetType(SyntaxTree.importType);
- moduleScope := currentScope.ownerModule.moduleScope;
- IF (x.moduleName=Global.SystemName) THEN x.SetModule(system.systemModule[Scanner.Uppercase])
- ELSIF (x.moduleName=Global.systemName) THEN x.SetModule(system.systemModule[Scanner.Lowercase])
- ELSIF (x.moduleName=currentScope.ownerModule.name) & (x.context=currentScope.ownerModule.context) THEN
- Error(x.position,"forbidden self import");
- ELSE
- (* search through global import list: already imported ? *)
- IF (x.module = NIL) & (importCache # NIL) THEN
- import := importCache.ImportByModuleName(x.moduleName,x.context);
- ELSE import := NIL
- END;
- IF x.module # NIL THEN (* already imported indirectly *)
- module := x.module;
- ELSIF import # NIL THEN (* already in module list *)
- module := import.module;
- ASSERT(module # NIL);
- x.SetModule(module);
- ELSE (* must be imported *)
- Global.ModuleFileName(x.moduleName,x.context,filename);
- IF symbolFileFormat # NIL THEN
- module := symbolFileFormat.Import(filename,importCache); (* includes module parsing *)
- IF module = NIL THEN
- ErrorSS(x.position,"could not import",filename);
- IF VerboseErrorMessage THEN
- Printout.Info("import",x)
- END
- ELSE
- (*
- IF ~(SyntaxTree.Resolved IN module.state) THEN
- (*! should rather be done by importer *)
- checker := NewChecker(diagnostics,VerboseErrorMessage,system,symbolFileFormat,importCache);
- checker.importCache := importCache;
- checker.arrayBaseImported := arrayBaseImported;
- checker.global := global;
- checker.Module(module); (* semantic check *)
- error := error OR checker.error;
- END;
- *)
- (*
- ASSERT(SyntaxTree.Resolved IN module.state);
- *)
- x.SetModule(module);
- IF importCache # NIL THEN
- import := SyntaxTree.NewImport(Basic.invalidPosition,x.moduleName,x.moduleName,FALSE);
- import.SetContext(x.context);
- import.SetModule(module);
- importCache.AddImport(import);
- END;
- END;
- ELSE
- ErrorSS(x.position,"no symbol file specified: cannot import",filename);
- END;
- END;
- IF module # NIL THEN (* enter reimports into list of imported modules *)
- IF SELF.module = NIL THEN (* happens in recursive imports *)
- END;
- import := module.moduleScope.firstImport;
- WHILE(import # NIL) DO
- ASSERT(import.moduleName # SyntaxTree.invalidIdentifier);
- ASSERT(currentScope # NIL);
- ASSERT(currentScope.ownerModule # NIL);
- ASSERT(import.context # SyntaxTree.invalidIdentifier);
- IF (import.moduleName=currentScope.ownerModule.name) & (import.context=currentScope.ownerModule.context) THEN
- Error(x.position,"recursive import");
- ELSE
- IF import.context = SyntaxTree.invalidIdentifier THEN import.SetContext(x.context) END;
- reimport := moduleScope.ImportByModuleName(import.moduleName,import.context);
- IF reimport = NIL THEN (* indirect import *)
- reimport := SyntaxTree.NewImport(Basic.invalidPosition,import.moduleName,import.moduleName,FALSE);
- reimport.SetContext(import.context);
- reimport.SetModule(import.module);
- moduleScope.AddImport(reimport);
- reimport.SetScope(moduleScope);
- ELSE
- ASSERT(import.module # NIL);
- reimport.SetModule(import.module); (* direct or indirect import *)
- END;
- END;
- import := import.nextImport;
- END;
- END;
- END;
- currentScope := prevScope;
- (* ELSE nothing to be done *)
- x.SetState(SyntaxTree.Resolved);
- END;
- END VisitImport;
- (*** statements ***)
- PROCEDURE ResolveStatement(x: SyntaxTree.Statement): SyntaxTree.Statement;
- VAR prev,resolved: SyntaxTree.Statement;
- BEGIN
- prev := resolvedStatement;
- resolvedStatement := x;
- IF currentIsUnreachable THEN x.SetUnreachable(TRUE) END;
- activeCellsStatement := FALSE;
- x.Accept(SELF);
- (* removed this, implementation restriction should be resolved by backend
- IF (inCellNetBody) & (activeCellsStatement = FALSE) THEN
- Error(x.position, "non-activeCells statement in activeCells block - not yet implemented");
- END;
- *)
- resolved := resolvedStatement;
- resolvedStatement := prev;
- RETURN resolved
- END ResolveStatement;
- (** check and resolve statement sequence
- - check all statements, replace if necessary
- **)
- PROCEDURE StatementSequence(statementSequence: SyntaxTree.StatementSequence);
- VAR i: LONGINT; statement,resolved: SyntaxTree.Statement;
- BEGIN
- IF statementSequence # NIL THEN (* else empty *)
- FOR i := 0 TO statementSequence.Length()-1 DO
- statement := statementSequence.GetStatement(i);
- resolved := ResolveStatement(statement);
- IF (resolved # statement) THEN
- statementSequence.SetStatement(i,resolved);
- END;
- END;
- END;
- END StatementSequence;
- (** check and resolve procedure call statement procedureCall() or procedureCall;
- - check if call is a procedure call designator, if not (procedure type symbol) try to make one out of it
- - check if procedure is callable
- - check return type = NIL (otherwise must be assignment statement)
- **)
- PROCEDURE VisitProcedureCallStatement(procedureCall: SyntaxTree.ProcedureCallStatement);
- VAR call: SyntaxTree.Designator;
- BEGIN
- IF Trace THEN D.Str("VisitProcedureCallStatement"); D.Ln; END;
- call := procedureCall.call;
- IF (call # NIL) & ~(call IS SyntaxTree.ParameterDesignator) & ~(call IS SyntaxTree.ProcedureCallDesignator) & ~(call IS SyntaxTree.BuiltinCallDesignator) THEN
- call := SyntaxTree.NewParameterDesignator(call.position,call,SyntaxTree.NewExpressionList());
- END;
- call := ResolveDesignator(call);
- IF call = SyntaxTree.invalidDesignator THEN
- (* error already handled *)
- ELSIF call IS SyntaxTree.StatementDesignator THEN
- (* inline call in a statement *)
- ELSIF ~IsCallable(call) THEN
- Error(procedureCall.position,"called object is not a procedure");
- ELSIF (call.type # NIL) & (call.left # NIL) & (call.left.type.resolved(SyntaxTree.ProcedureType).callingConvention # SyntaxTree.WinAPICallingConvention) THEN
- Error(procedureCall.position,"calling procedure with non-void return type");
- IF VerboseErrorMessage THEN Printout.Info("call ",call) END;
- END;
- procedureCall.SetCall(call);
- (*
- IF call = SyntaxTree.invalidDesignator THEN
- ELSIF (call.left IS SyntaxTree.SymbolDesignator) & (call.left(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Procedure) THEN
- procedure := call.left(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Procedure);
- IF IsOberonInline(procedure) THEN
- Warning(procedure.position,"call to inline proc");
- block := SyntaxTree.NewStatementBlock(call.position, NIL (*! todo *));
- block.SetStatementSequence(SyntaxTree.CloneStatementSequence(procedure.procedureScope.body.statements));
- ReplaceParameters(block, procedure.type(SyntaxTree.ProcedureType).firstParameter, call(SyntaxTree.ProcedureCallDesignator).parameters);
- resolvedStatement := block;
- RETURN;
- END;
- END;
- *)
- END VisitProcedureCallStatement;
- (** check and resolve assignment LHS := RHS
- - resolve LHS and RHS
- - check if assignment operator is found. if yes, return operator call instead of assignment instruction
- - check if assignment is compatible
- - check if LHS is variable (i.e. assignable)
- - convert RHS if necessary
- - for the following two cases, return index write operator call on ASOT instead of assignment instruction:
- - assignment between different ASOTs
- asot := asot2; -> asot^."[]"( *, *, ..., *, asot2);
- - assignment to ASOT elements:
- asot[indexList] := rhs; -> asot^."[]"(indexList, rhs);
- **)
- PROCEDURE VisitAssignment(assignment: SyntaxTree.Assignment);
- VAR
- left: SyntaxTree.Designator;
- right, expression: SyntaxTree.Expression;
- designator: SyntaxTree.Designator;
- procedureCallDesignator: SyntaxTree.ProcedureCallDesignator;
- mathArrayType: SyntaxTree.MathArrayType;
- BEGIN
- right := ResolveExpression(assignment.right);
- assignment.left.SetRelatedRhs(right); (* store a reference to the RHS in the assignement's LHS*)
- left := ResolveDesignator(assignment.left);
- IF (left = SyntaxTree.invalidDesignator) OR (right = SyntaxTree.invalidExpression) THEN
- (* error already handled *)
- ELSIF (left IS SyntaxTree.ProcedureCallDesignator) & (left.type = NIL) & (left.relatedAsot # NIL) THEN
- (* LHS is index write operator call on ASOT *)
- procedureCallDesignator := left(SyntaxTree.ProcedureCallDesignator);
- (* necessary ?
- procedureType := procedureCallDesignator.left(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Procedure).type(SyntaxTree.ProcedureType);
- type := procedureType.firstParameter.type;
- expression := procedureCallDesignator.parameters.GetExpression(0);
- procedureCallDesignator.parameters.SetExpression(0,NewConversion(0,expression,type,NIL));
- *)
- resolvedStatement := SyntaxTree.NewProcedureCallStatement(assignment.position, procedureCallDesignator, assignment.outer);
- ELSIF CheckVariable(left) THEN
- expression := NewOperatorCall(assignment.position, Scanner.Becomes, left, right, NIL);
- IF (expression # NIL) & (expression IS SyntaxTree.ProcedureCallDesignator) THEN
- procedureCallDesignator := expression(SyntaxTree.ProcedureCallDesignator);
- (* conversion done by procedure call
- (* try to convert to left argument *)
- IF (left.type.resolved IS SyntaxTree.MathArrayType) & (right.type.resolved IS SyntaxTree.MathArrayType) & AssignmentCompatible(left, right) THEN
- right := NewConversion(right.position, right, left.type.resolved, NIL);
- procedureCallDesignator.parameters.SetExpression(1, right);
- END;
- *)
- resolvedStatement := SyntaxTree.NewProcedureCallStatement(assignment.position, procedureCallDesignator, assignment.outer);
- ELSIF (expression # NIL) & (expression IS SyntaxTree.StatementDesignator) THEN
- resolvedStatement := expression(SyntaxTree.StatementDesignator).statement;
- ELSIF AssignmentCompatible(left, right) THEN
- IF IsArrayStructuredObjectType(left.type) & (left.type.resolved # right.type.resolved) THEN
- mathArrayType := MathArrayStructureOfType(left.type);
- right := NewConversion(right.position, right, mathArrayType, NIL);
- designator := NewIndexOperatorCall(Basic.invalidPosition, left, ListOfOpenRanges(mathArrayType.Dimensionality()), right);
- resolvedStatement := SyntaxTree.NewProcedureCallStatement(assignment.position, designator, assignment.outer)
- ELSE
- right := NewConversion(right.position, right, left.type.resolved, NIL);
- assignment.SetLeft(left);
- assignment.SetRight(right);
- resolvedStatement := assignment
- END
- END
- END
- END VisitAssignment;
- (** check and resolve assignment LHS := RHS
- - resolve LHS and RHS
- - check if assignment operator is found. if yes, return operator call instead of assignment instruction
- - check if assignment is compatible
- - check if LHS is variable (i.e. assignable)
- - convert RHS if necessary
- - for the following two cases, return index write operator call on ASOT instead of assignment instruction:
- - assignment between different ASOTs
- asot := asot2; -> asot^."[]"( *, *, ..., *, asot2);
- - assignment to ASOT elements:
- asot[indexList] := rhs; -> asot^."[]"(indexList, rhs);
- **)
- PROCEDURE VisitCommunicationStatement(communication: SyntaxTree.CommunicationStatement);
- VAR
- left: SyntaxTree.Designator;
- right: SyntaxTree.Expression;
- inPort, outPort: SyntaxTree.PortType;
- expression: SyntaxTree.Expression;
- procedureCallDesignator: SyntaxTree.ProcedureCallDesignator;
- BEGIN
- right := ResolveExpression(communication.right);
- left := ResolveDesignator(communication.left);
- communication.SetLeft(left);
- communication.SetRight(right);
-
- expression := NewOperatorCall(communication.position, communication.op, left, right, NIL);
- IF (expression # NIL) & (expression IS SyntaxTree.ProcedureCallDesignator) THEN
- procedureCallDesignator := expression(SyntaxTree.ProcedureCallDesignator);
- (* conversion done by procedure call
- (* try to convert to left argument *)
- IF (left.type.resolved IS SyntaxTree.MathArrayType) & (right.type.resolved IS SyntaxTree.MathArrayType) & AssignmentCompatible(left, right) THEN
- right := NewConversion(right.position, right, left.type.resolved, NIL);
- procedureCallDesignator.parameters.SetExpression(1, right);
- END;
- *)
- resolvedStatement := SyntaxTree.NewProcedureCallStatement(communication.position, procedureCallDesignator, communication.outer);
- ELSE
- IF ~cellsAreObjects THEN ImportModule(Global.NameChannelModule,communication.position) END;
- IF (left = SyntaxTree.invalidDesignator) OR (right = SyntaxTree.invalidExpression) THEN
- (* error already handled *)
- ELSIF communication.op = Scanner.LessLess THEN (* left is dest *)
- IF (left.type.resolved IS SyntaxTree.PortType) & CheckPortType(left, outPort) THEN (* send *)
- IF outPort.direction # SyntaxTree.OutPort THEN
- Error(left.position,"not an out-port")
- ELSIF outPort.sizeInBits < system.SizeOf(right.type) THEN
- Error(left.position,"incompatible to port type");
- ELSE
- right := NewConversion(communication.position,right,left.type.resolved,NIL);
- communication.SetRight(right)
- END;
- ELSIF (right.type.resolved IS SyntaxTree.PortType) & CheckPortType(right, inPort) THEN (* receive *)
- IF CheckVariable(left) THEN
- IF inPort.direction # SyntaxTree.InPort THEN
- Error(left.position,"not an in-port")
- ELSIF inPort.sizeInBits # system.SizeOf(left.type) THEN
- Error(right.position,"incompatible to port type");
- END;
- END;
- ELSE
- Error(communication.position,"unsupported stream operation");
- END;
- ELSIF (communication.op = Scanner.ExclamationMark) & CheckPortType(left,outPort) THEN
- IF outPort.direction # SyntaxTree.OutPort THEN
- Error(left.position,"not an out-port")
- ELSIF outPort.sizeInBits < system.SizeOf(right.type) THEN
- Error(left.position,"incompatible to port type");
- ELSE
- right := NewConversion(communication.position,right,left.type.resolved,NIL);
- communication.SetRight(right)
- END;
- ELSIF (communication.op = Scanner.Questionmark) & CheckPortType(left,inPort) THEN
- IF CheckVariable(right) THEN
- IF inPort.direction # SyntaxTree.InPort THEN
- Error(left.position,"not an in-port")
- ELSIF inPort.sizeInBits # system.SizeOf(right.type) THEN
- Error(right.position,"incompatible to port type");
- END;
- END;
- ELSE
- Error(communication.position, "unsupported operation");
- END;
- END;
- END VisitCommunicationStatement;
- (** check and resolve if/eslif part
- - check condition
- - check statement sequence
- **)
- PROCEDURE IfPart(ifPart: SyntaxTree.IfPart; VAR true: BOOLEAN);
- VAR prevUnreachable, b: BOOLEAN;
- BEGIN
- prevUnreachable := currentIsUnreachable;
- ifPart.SetCondition(ResolveCondition(ifPart.condition));
- IF IsBooleanValue(ifPart.condition,b) THEN
- IF b=FALSE THEN
- currentIsUnreachable := TRUE
- ELSIF b=TRUE THEN
- true := TRUE
- END;
- END;
- StatementSequence(ifPart.statements);
- currentIsUnreachable := prevUnreachable;
- END IfPart;
- (** check and resolve if statement
- - check if parts and else part statement sequence
- **)
- PROCEDURE VisitIfStatement(ifStatement: SyntaxTree.IfStatement);
- VAR elsif: SyntaxTree.IfPart; i: LONGINT; ifPartTrue, prevUnreachable: BOOLEAN;
- BEGIN
- prevUnreachable := currentIsUnreachable;
- ifPartTrue := FALSE;
- IfPart(ifStatement.ifPart,ifPartTrue);
- FOR i := 0 TO ifStatement.ElsifParts()-1 DO
- elsif := ifStatement.GetElsifPart(i);
- IfPart(elsif,ifPartTrue);
- END;
- IF ifStatement.elsePart # NIL THEN
- IF ifPartTrue THEN
- currentIsUnreachable := TRUE
- END;
- StatementSequence(ifStatement.elsePart)
- END;
- currentIsUnreachable := prevUnreachable;
- END VisitIfStatement;
- PROCEDURE WithPart(withPart: SyntaxTree.WithPart; VAR symbol: SyntaxTree.Symbol);
- VAR variable: SyntaxTree.Designator;
- type,variableType: SyntaxTree.Type;
- withEntry: WithEntry;
- BEGIN
- variable := ResolveDesignator(withPart.variable);
- variableType := variable.type.resolved;
- withPart.SetVariable(variable);
- type := ResolveType(withPart.type);
- withPart.SetType(type);
- WHILE variable IS SyntaxTree.TypeGuardDesignator DO
- variable := variable(SyntaxTree.TypeGuardDesignator).left(SyntaxTree.Designator);
- END;
- IF (type.resolved = SyntaxTree.invalidType) OR (variableType = SyntaxTree.invalidType) THEN (* error already reported *)
- ELSIF ~(type.resolved = variableType) & ~IsExtensibleDesignator(variable) THEN
- Error(variable.position,"is not extensible designator");
- ELSIF ~(variable IS SyntaxTree.SymbolDesignator) (* OR (variable(SyntaxTree.SymbolDesignator).left # NIL) needed ?? *) THEN
- Error(variable.position,"is no local variable ");
- IF VerboseErrorMessage THEN
- Printout.Info("variable",variable)
- END;
- ELSIF ~IsTypeExtension(variableType, type.resolved) THEN
- Error(variable.position,"withguarded symbol is no type extension of ");
- IF VerboseErrorMessage THEN
- Printout.Info("variable",variable);
- Printout.Info("type",type);
- END;
- ELSIF ~(variable(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Variable)
- & ~(variable(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Parameter) THEN
- Error(variable.position,"withguarded symbol is no variable ");
- IF VerboseErrorMessage THEN
- Printout.Info("variable",variable);
- Printout.Info("type",type);
- END;
- ELSIF (symbol # NIL) & (symbol # variable(SyntaxTree.SymbolDesignator).symbol) THEN
- Error(variable.position,"invalid change of withguarded symbol");
- ELSE
- symbol := variable(SyntaxTree.SymbolDesignator).symbol;
- NEW(withEntry);
- withEntry.previous := withEntries;
- withEntry.symbol := variable(SyntaxTree.SymbolDesignator).symbol;
- withEntry.type := type;
- withEntries := withEntry;
- StatementSequence(withPart.statements);
- withEntries := withEntries.previous;
- END;
- END WithPart;
- (** check and resolve with statement WITH variable: type DO ... END;
- - check type and variable
- - check that variable type is type extension of type
- - check that variable is a variable
- - enter new with scope and enter guardedVariable with same name and reference to variable
- - create if statement:
- WITH variable: type DO ... END; --> IF ~(variable IS type) THEN HALT(withTrap) ELSE ... END;
- **)
- PROCEDURE VisitWithStatement(withStatement: SyntaxTree.WithStatement);
- VAR i: LONGINT; prevScope: SyntaxTree.Scope; symbol: SyntaxTree.Symbol;
- BEGIN
- prevScope := currentScope; symbol := NIL;
- FOR i := 0 TO withStatement.WithParts()-1 DO
- WithPart(withStatement.GetWithPart(i),symbol);
- END;
- IF withStatement.elsePart # NIL THEN
- StatementSequence(withStatement.elsePart)
- END;
- currentScope := prevScope;
- END VisitWithStatement;
- (** check and resolve case part <<a, b, c..d: StatementSequence>>
- - check expression to be constant or case range expression <<first .. last>> with constants 'first' and 'last' and compatible to type
- - check 'first' < 'last' and no overlaps between different case labels
- - check statement sequence
- **)
- PROCEDURE CasePart(casePart: SyntaxTree.CasePart; type: SyntaxTree.Type; VAR allcases: SyntaxTree.CaseConstant; VAR min,max: LONGINT);
- VAR
- i: LONGINT;
- position: Position;
- expression, left, right: SyntaxTree.Expression;
- expressionType: SyntaxTree.Type;
- l, r: LONGINT;
- cl, cr: CHAR;
- thiscases: SyntaxTree.CaseConstant;
- BEGIN
- thiscases := NIL;
- FOR i := 0 TO casePart.elements.Length() - 1 DO
- expression := casePart.elements.GetExpression(i);
- position := expression.position;
- (* set context of range *)
- IF expression IS SyntaxTree.RangeExpression THEN
- expression(SyntaxTree.RangeExpression).SetContext(SyntaxTree.CaseGuard)
- END;
- expression := ResolveExpression(expression);
- IF expression = SyntaxTree.invalidExpression THEN
- (* error already reported *)
- expressionType := SyntaxTree.invalidType;
- ELSIF (expression IS SyntaxTree.RangeExpression) THEN
- (* read out 'first' and 'last' *)
- left := expression(SyntaxTree.RangeExpression).first;
- right := expression(SyntaxTree.RangeExpression).last;
- (* guaranteed by VisitRangeExpression: *)
- ASSERT((left # NIL) & (right # NIL));
- ASSERT(left.type.resolved = right.type.resolved);
- left := CompatibleConversion(left.position, left, type);
- right := CompatibleConversion(right.position, right, type);
- expression(SyntaxTree.RangeExpression).SetFirst(left);
- expression(SyntaxTree.RangeExpression).SetLast(right);
- expressionType := RegularType(position,left.type);
- ELSE
- expression := ConstantExpression(expression);
- expression := CompatibleConversion(expression.position, expression, type);
- (*
- IF IsStringType(expression.type) (*& IsCharacterValue(expression,cl) *) THEN
- left := Global.NewCharacterValue(system,expression.position,cl);
- expression := casePart.elements.GetExpression(i);
- expression.SetResolved(left(SyntaxTree.CharacterValue));
- expression := left
- END;
- *)
- casePart.elements.SetExpression(i,expression);
- left := expression; right := expression;
- expressionType := RegularType(position,expression.type)
- END;
- IF (expressionType = SyntaxTree.invalidType) THEN
- ELSIF ~CompatibleTo(system,expressionType,type) THEN
- Error(position, "inadmissible case label");
- expression := SyntaxTree.invalidExpression;
- ELSE
- l := 0; r := 0;
- IF IsIntegerValue(left,l) & CheckIntegerValue(right,r) THEN
- ELSIF IsCharacterValue(left,cl) & CheckCharacterValue(right,cr) THEN
- l := ORD(cl); r := ORD(cr);
- ELSIF IsEnumerationValue(left,l) & CheckEnumerationValue(right,r) THEN
- ELSE
- expression := SyntaxTree.invalidExpression
- END;
- IF expression # SyntaxTree.invalidExpression THEN
- IF l>r THEN
- Error(position, "empty case label")
- ELSIF ~EnterCase(thiscases,l,r) OR ~EnterCase(allcases,l,r) THEN
- Error(position, "duplicate case label");
- ELSE
- IF l < min THEN min := l END;
- IF r > max THEN max := r END;
- END;
- END;
- END;
- casePart.elements.SetExpression(i,expression);
- END;
- (*! Coalesce(caseConstants); sort and find succeeeding numbers !!! *)
- casePart.SetConstants(thiscases);
- StatementSequence(casePart.statements);
- END CasePart;
- (** check and resolve case statement CASE variable OF ... END;
- - check variable
- - check case parts
- **)
- PROCEDURE VisitCaseStatement(caseStatement: SyntaxTree.CaseStatement);
- VAR expression: SyntaxTree.Expression; i: LONGINT; type: SyntaxTree.Type; caseList: SyntaxTree.CaseConstant;
- ch: CHAR; l: LONGINT; min,max: LONGINT; msg: ARRAY 64 OF CHAR;
- BEGIN
- expression := ResolveExpression(caseStatement.variable);
- type := RegularType(expression.position,expression.type);
- IF type = SyntaxTree.invalidType THEN
- expression := SyntaxTree.invalidExpression;
- ELSIF IsIntegerType(type) THEN
- ELSIF IsStringType(expression.type) (* & IsCharacterValue(expression,ch) *) THEN
- expression := NewConversion(expression.position, expression, system.characterType,NIL);
- (*
- expression := Global.NewCharacterValue(system,expression.position,ch);
- *)
- type := expression.type;
- ELSIF IsCharacterType(type) THEN
- ELSIF IsEnumerationType(type) THEN
- ELSE
- Error(caseStatement.variable.position,"variable must be integer or character type");
- expression := SyntaxTree.invalidExpression;
- END;
- caseStatement.SetVariable(expression);
- caseList := NIL;
- min := MAX(LONGINT); max := MIN(LONGINT);
- FOR i := 0 TO caseStatement.CaseParts()-1 DO
- CasePart(caseStatement.GetCasePart(i),type,caseList,min,max);
- END;
- IF (max - min > 1024) & (100* caseStatement.CaseParts() DIV (max-min) < 10) (* less than ten percent used in a huge case table *) THEN
- msg := "huge sparse case table ";
- Strings.AppendInt(msg, max-min);
- Strings.Append(msg,"/");
- Strings.AppendInt(msg, caseStatement.CaseParts());
- Warning(caseStatement.position,msg);
- END;
- caseStatement.SetMinMax(min,max);
- StatementSequence(caseStatement.elsePart);
- IF expression.resolved # NIL THEN
- IF IsCharacterValue(expression,ch) THEN
- l := ORD(ch)
- ELSIF IsIntegerValue(expression,l) THEN
- END;
- IF EnterCase(caseList,l,l) & (caseStatement.elsePart = NIL) THEN Error(caseStatement.position,"no matching case label") END;
- END;
- END VisitCaseStatement;
- (** check and resolve while statement
- - check condition
- - check statement sequence
- **)
- PROCEDURE VisitWhileStatement(whileStatement: SyntaxTree.WhileStatement);
- VAR prevIsUnreachable,b: BOOLEAN;
- BEGIN
- prevIsUnreachable := currentIsUnreachable;
- whileStatement.SetCondition(ResolveCondition(whileStatement.condition));
- IF IsBooleanValue(whileStatement.condition,b) THEN
- IF b=FALSE THEN
- currentIsUnreachable := TRUE
- END;
- END;
- StatementSequence(whileStatement.statements);
- currentIsUnreachable := prevIsUnreachable
- END VisitWhileStatement;
- (** check and resolve repeat statement
- - check condition
- - check statement sequence
- **)
- PROCEDURE VisitRepeatStatement(repeatStatement: SyntaxTree.RepeatStatement);
- BEGIN
- repeatStatement.SetCondition(ResolveCondition(repeatStatement.condition));
- StatementSequence(repeatStatement.statements);
- END VisitRepeatStatement;
- PROCEDURE GetGuard(symbol: SyntaxTree.Symbol; VAR type: SyntaxTree.Type): BOOLEAN;
- VAR withEntry: WithEntry;
- BEGIN
- withEntry := withEntries;
- WHILE (withEntry # NIL) & (withEntry.symbol # symbol) DO
- withEntry := withEntry.previous
- END;
- IF withEntry = NIL THEN RETURN FALSE
- ELSE
- type := withEntry.type;
- RETURN TRUE
- END;
- END GetGuard;
- (** check and resolve for statement FOR variable := from TO to BY by DO StatementSequence END;
- - check that variable is an integer variable
- - check that from is integer typed with compatible type
- - check that to has compatible type
- - check that by is constant integer with compatible type
- **)
- PROCEDURE VisitForStatement(forStatement: SyntaxTree.ForStatement);
- VAR expression: SyntaxTree.Expression; designator: SyntaxTree.Designator; type: SyntaxTree.Type;
- BEGIN
- designator := ResolveDesignator(forStatement.variable);
- type := SyntaxTree.invalidType;
- IF designator.type = SyntaxTree.invalidType THEN (* error already handled *)
- designator := SyntaxTree.invalidDesignator;
- ELSIF ~IsIntegerType(designator.type.resolved) THEN
- Error(designator.position,"control variable of non-integer type");
- designator := SyntaxTree.invalidDesignator;
- ELSIF CheckVariable(designator) THEN
- type := designator.type;
- END;
- forStatement.SetVariable(designator);
- expression := ResolveExpression(forStatement.from);
- IF expression = SyntaxTree.invalidExpression THEN
- ELSIF ~CompatibleTo(system,expression.type.resolved,designator.type.resolved) THEN
- Error(expression.position,"start value of incompatible type");
- expression := SyntaxTree.invalidExpression;
- ELSIF type # SyntaxTree.invalidType THEN
- expression := NewConversion(expression.position,expression,type,NIL)
- END;
- forStatement.SetFrom(expression);
- expression := ResolveExpression(forStatement.to);
- IF expression = SyntaxTree.invalidExpression THEN
- ELSIF ~CompatibleTo(system,expression.type.resolved,designator.type.resolved) THEN
- Error(expression.position,"end value of incompatible type");
- expression := SyntaxTree.invalidExpression;
- ELSIF type # SyntaxTree.invalidType THEN
- expression := NewConversion(expression.position,expression,type,NIL)
- END;
- forStatement.SetTo(expression);
- IF forStatement.by # NIL THEN
- expression := ConstantInteger(forStatement.by);
- ELSE
- expression := Global.NewIntegerValue(system,Basic.invalidPosition,1);
- END;
- IF expression = SyntaxTree.invalidExpression THEN
- ELSIF ~CompatibleTo(system,expression.type.resolved,designator.type.resolved) THEN
- Error(expression.position,"step value of incompatible type");
- ELSIF (expression.resolved(SyntaxTree.IntegerValue).hvalue = 0) THEN
- Error(expression.position,"invalid step value");
- ELSIF type # SyntaxTree.invalidType THEN
- expression := NewConversion(expression.position,expression,type,NIL)
- END;
- forStatement.SetBy(expression);
- StatementSequence(forStatement.statements);
- END VisitForStatement;
- (** check and resolve loop statement LOOP StatementSequence END
- - check statement sequence
- **)
- PROCEDURE VisitLoopStatement(loopStatement: SyntaxTree.LoopStatement);
- BEGIN
- StatementSequence(loopStatement.statements)
- END VisitLoopStatement;
- PROCEDURE VisitExitableBlock(exitableBlock: SyntaxTree.ExitableBlock);
- BEGIN
- StatementSequence(exitableBlock.statements);
- END VisitExitableBlock;
- (** check and resolve exit statement EXIT
- - check that exit is within LOOP statement block
- **)
- PROCEDURE VisitExitStatement(exitStatement: SyntaxTree.ExitStatement);
- VAR outer: SyntaxTree.Statement;
- BEGIN
- outer := exitStatement.outer;
- WHILE(outer # NIL) & ~(outer IS SyntaxTree.ExitableBlock) DO
- outer := outer.outer;
- END;
- IF outer = NIL THEN
- Error(exitStatement.position,"exit statement not within loop statement");
- END;
- END VisitExitStatement;
- (** check and resolve return statement RETURN [expression]
- - check expression (if any)
- - check if in procedure scope
- - if in procedure scope then check expression compatibility
- - if not in procecdure scope then check on return without expression
- **)
- PROCEDURE VisitReturnStatement(returnStatement: SyntaxTree.ReturnStatement);
- VAR expression: SyntaxTree.Expression; position: Position; procedure: SyntaxTree.Procedure;
- returnType: SyntaxTree.Type; outer: SyntaxTree.Statement; scope: SyntaxTree.Scope;
- BEGIN
- position := returnStatement.position;
- expression := returnStatement.returnValue;
- IF expression # NIL THEN
- expression := ResolveExpression(expression);
- returnStatement.SetReturnValue(expression);
- END;
- outer := returnStatement.outer;
- WHILE(outer # NIL) & ~(outer IS SyntaxTree.Body) DO
- outer := outer.outer
- END;
- IF (outer # NIL) THEN
- scope := outer(SyntaxTree.Body).inScope;
- IF ~(scope IS SyntaxTree.ProcedureScope) THEN
- IF (expression # NIL) THEN
- Error(position, "return statement with parameter not in procedure scope");
- END;
- ELSE
- procedure := scope(SyntaxTree.ProcedureScope).ownerProcedure;
- IF procedure.type(SyntaxTree.ProcedureType).noReturn THEN
- Error(position, "return statement in procedure that does not return");
- END;
- returnType := procedure.type(SyntaxTree.ProcedureType).returnType;
- IF returnType # NIL THEN
- returnType := returnType.resolved;
- IF expression = NIL THEN
- Error(position, "empty return type in procedure providing a return type")
- ELSIF expression.type = NIL THEN
- Error(position,"returned type incompatible: expression has no type");
- ELSIF ~CompatibleTo(system,expression.type.resolved,returnType) THEN
- Error(position, "return type not compatible");
- IF VerboseErrorMessage THEN
- Printout.Info("returnType",returnType);
- Printout.Info("expression",expression);
- END;
- ELSE
- expression := NewConversion(expression.position,expression,returnType,NIL);
- returnStatement.SetReturnValue(expression);
- END;
- ELSIF expression # NIL THEN
- Error(position, "non-empty return type in procedure providing no return type");
- END;
- END;
- END;
- END VisitReturnStatement;
- (** check and resolve await statement AWAIT(condition: Expression)
- - check await condition
- **)
- PROCEDURE VisitAwaitStatement(awaitStatement: SyntaxTree.AwaitStatement);
- VAR condition: SyntaxTree.Expression;
- BEGIN
- condition := ResolveCondition(awaitStatement.condition);
- IF currentIsRealtime THEN
- Error(awaitStatement.position,"forbidden await statement in realtime block");
- END;
- IF (condition.resolved # NIL) & (condition.resolved IS SyntaxTree.BooleanValue) THEN
- Error(awaitStatement.position,"senseless await statement with constant condition");
- END;
- awaitStatement.SetCondition(condition);
- END VisitAwaitStatement;
- PROCEDURE CheckSystemImport(position: Position);
- VAR import: SyntaxTree.Import;
- BEGIN
- import := currentScope.ownerModule.moduleScope.firstImport;
- WHILE(import # NIL) DO
- IF (import.module.name = Global.SystemName) OR (import.module.name = Global.systemName) THEN
- RETURN;
- END;
- import := import.nextImport;
- END;
- Error(position, "forbidden code without system import");
- END CheckSystemImport;
- (** check and resolve code statement: do nothing, must be done by assembler
- **)
- PROCEDURE VisitCode(code: SyntaxTree.Code);
- VAR i: LONGINT; statement: SyntaxTree.Statement;
- BEGIN
- CheckSystemImport(code.position);
- FOR i := 0 TO code.inRules.Length()-1 DO
- statement := code.inRules.GetStatement(i);
- IF statement IS SyntaxTree.Assignment THEN
- WITH statement: SyntaxTree.Assignment DO
- statement.SetRight(ResolveExpression(statement.right));
- END;
- ELSE
- Error(statement.position, "can only be assignment")
- END;
- END;
- FOR i := 0 TO code.outRules.Length()-1 DO
- statement := code.outRules.GetStatement(i);
- IF statement IS SyntaxTree.Assignment THEN
- WITH statement: SyntaxTree.Assignment DO
- statement.SetLeft(ResolveDesignator(statement.left));
- END;
- ELSIF statement IS SyntaxTree.ReturnStatement THEN
- (* must be a reference to some register *)
- ELSIF statement IS SyntaxTree.StatementBlock THEN
- ELSE
- Printout.Info("out statement ", statement);
- Error(statement.position, "(out) can only be assignment")
- END;
- END;
- END VisitCode;
- (** check and set flags of a statement block
- - check for multiply occurence of a flag
- - check and set priority only in bodies
- - check for valid names
- **)
- PROCEDURE BlockFlags(block: SyntaxTree.StatementBlock);
- VAR blockModifier: SyntaxTree.Modifier; expression: SyntaxTree.Expression; name: SyntaxTree.Identifier; flags: SET; position: Position;
- flag: LONGINT; recordBody: SyntaxTree.Body;
- PROCEDURE SetProtectedRecord;
- VAR scope: SyntaxTree.Scope;
- BEGIN
- scope := currentScope;
- WHILE (scope # NIL) & ~(scope IS SyntaxTree.RecordScope) DO
- scope := scope.outerScope
- END;
- IF scope # NIL THEN
- scope(SyntaxTree.RecordScope).ownerRecord.SetProtected(TRUE);
- END;
- END SetProtectedRecord;
- BEGIN
- flags := {};
- IF (block IS SyntaxTree.Body) & (currentIsBodyProcedure) & ((currentScope.outerScope = NIL) OR ~(currentScope.outerScope IS SyntaxTree.ModuleScope)) THEN
- recordBody := block(SyntaxTree.Body)
- ELSE
- recordBody := NIL
- END;
- blockModifier := block.blockModifiers;
- WHILE(blockModifier # NIL) DO
- name := blockModifier.identifier;
- expression := blockModifier.expression;
- position := blockModifier.position;
- flag := -1;
- IF name=Global.NamePriority THEN
- IF expression = NIL THEN
- Error(position, "missing priority expression");
- ELSIF recordBody = NIL THEN
- Error(position, "priority not on record body");
- ELSIF recordBody.priority # NIL THEN
- Error(position, "duplicate priority expression");
- ELSE
- recordBody.SetPriority(expression);
- END;
- ELSIF expression # NIL THEN
- Error(expression.position,"expression not in connection with priority")
- ELSIF name=Global.NameExclusive THEN
- IF block.isExclusive THEN
- Error(position, "duplicate exclusive flag")
- END;
- block.SetExclusive(TRUE); SetProtectedRecord;
- ELSIF name=Global.NameActive THEN
- IF recordBody = NIL THEN
- Error(position, "active not in record body");
- ELSIF recordBody.isActive THEN
- Error(position, "duplicate active flag")
- ELSE
- recordBody.SetActive(TRUE); SetProtectedRecord;
- END;
- ELSIF name=Global.NameSafe THEN
- IF recordBody = NIL THEN
- Error(position, "safe not in record body");
- ELSIF recordBody.isSafe THEN
- Error(position, "duplicate safe flag")
- ELSE
- recordBody.SetSafe(TRUE);
- SetProtectedRecord;
- END;
- ELSIF name=Global.NameRealtime THEN
- IF recordBody = NIL THEN
- Error(position, "realtime not in record body");
- ELSIF recordBody.isRealtime THEN
- Error(position, "duplicate realtime flag")
- ELSE
- recordBody.SetRealtime(TRUE);
- block.SetRealtime(TRUE);
- END;
- ELSIF name=Global.NameUnchecked THEN
- IF block.isUnchecked THEN
- Error(position, "duplicate unchecked flag")
- ELSE
- block.SetUnchecked(TRUE);
- END;
- ELSIF (name=Global.NameUncooperative) THEN
- IF block.isUncooperative THEN
- Error(position, "duplicate uncooperative flag")
- ELSE
- block.SetUncooperative(TRUE);
- END;
- ELSE
- Error(position, "unknown block modifier");
- END;
- blockModifier := blockModifier.nextModifier;
- END;
- END BlockFlags;
- (** check and resolve statement block
- - check flags (exclusive)
- - check statement sequence
- **)
- PROCEDURE VisitStatementBlock(statementBlock: SyntaxTree.StatementBlock);
- VAR recentExclusive, recentUnreachable, recentRealtime: BOOLEAN;
- BEGIN
- BlockFlags(statementBlock);
- IF statementBlock.isExclusive THEN
- (* check that not in exclusive block *)
- IF currentIsExclusive THEN
- Error (statementBlock.position,"forbidden recursive exclusive")
- ELSIF currentIsRealtime THEN
- Error( statementBlock.position,"forbidden exculsive in realtime block");
- END;
- END;
- recentExclusive := currentIsExclusive;
- recentUnreachable := currentIsUnreachable;
- recentRealtime := currentIsRealtime;
- IF statementBlock.isExclusive THEN currentIsExclusive := TRUE END;
- IF statementBlock.isUnreachable THEN currentIsUnreachable := TRUE END;
- IF statementBlock.isRealtime THEN currentIsRealtime := TRUE END;
- StatementSequence(statementBlock.statements);
- currentIsRealtime := recentRealtime;
- currentIsExclusive := recentExclusive;
- currentIsUnreachable := recentUnreachable;
- END VisitStatementBlock;
- (** check and resolve body
- - check flags (active, priority, safe)
- - check body and finally part
- **)
- PROCEDURE Body(body: SyntaxTree.Body);
- BEGIN
- VisitStatementBlock(body);
- IF body.isActive THEN
- IF ~currentIsBodyProcedure THEN
- Error(body.position,"active flag not in object body");
- ELSIF body.priority # NIL THEN
- body.SetPriority(ConstantInteger(body.priority));
- END;
- ELSIF body.isSafe THEN
- Error(body.position,"safe flag not in active body");
- ELSIF body.priority # NIL THEN
- Error(body.position,"priority flag not in active body");
- END;
- IF body.code # NIL THEN
- CheckSystemImport(body.position);
- END;
- StatementSequence(body.finally)
- END Body;
- (*** scopes ***)
- (** Register a symbol in a scope. Check for duplicate symbols and collision with globally defined symbols. **)
- PROCEDURE Register(symbol: SyntaxTree.Symbol; scope: SyntaxTree.Scope; allowDuplicate: BOOLEAN);
- VAR duplicateSymbol: BOOLEAN;
- BEGIN
- ASSERT(symbol.name # SyntaxTree.invalidIdentifier);
- IF ~allowDuplicate & (global.FindSymbol(symbol.name)#NIL) THEN
- Error(symbol.position,"globally defined keyword")
- END;
- scope.EnterSymbol(symbol,duplicateSymbol);
- IF ~allowDuplicate & duplicateSymbol THEN
- Error(symbol.position,"Multiply defined identifier.");
- IF VerboseErrorMessage THEN
- Printout.Info("multiply defined identifier",symbol);
- Printout.Info("in scope",scope);
- END;
- END;
- END Register;
- (**
- implementation: check and resolve an implementation part
- **)
- (*! can in principle be done in parallel on different checkers: implementations do only depend on declarations)
- move implementation checker to a separate object ? *)
- PROCEDURE Implementation(scope: SyntaxTree.Scope);
- VAR prevScope: SyntaxTree.Scope; procedure: SyntaxTree.Procedure; prevIsRealtime, prevIsBodyProcedure, prevIsCellNet: BOOLEAN;
- BEGIN
- prevIsRealtime := currentIsRealtime;
- prevIsBodyProcedure := currentIsBodyProcedure;
- prevIsCellNet := currentIsCellNet;
- prevScope := currentScope;
- currentScope := scope;
- IF (scope IS SyntaxTree.ProcedureScope) THEN
- procedure := scope(SyntaxTree.ProcedureScope).ownerProcedure;
- currentIsBodyProcedure := currentIsBodyProcedure OR procedure.isBodyProcedure;
- currentIsRealtime := currentIsRealtime OR procedure.type.isRealtime;
- currentIsCellNet := InCellNetScope(procedure.scope) OR cellsAreObjects;
- (*
- IF procedure.isInline & ((scope(SyntaxTree.ProcedureScope).body = NIL) OR (scope(SyntaxTree.ProcedureScope).body # NIL) & (scope(SyntaxTree.ProcedureScope).body.code = NIL)) THEN
- Warning(procedure.position,"unsupported inline procedure - must be assembler code")
- END;
- *)
- END;
- IF (scope IS SyntaxTree.ProcedureScope) & (scope(SyntaxTree.ProcedureScope).body # NIL) (* & ~(scope IS SyntaxTree.RecordScope) *) THEN
- (* module body, record bodies are wrapped into an artifical procedure *)
- IF (phase = InlinePhase) & (IsOberonInline(procedure)) THEN
- Body(scope(SyntaxTree.ProcedureScope).body)
- ELSIF (phase = ImplementationPhase) & ~IsOberonInline(procedure) THEN
- Body(scope(SyntaxTree.ProcedureScope).body)
- END;
-
- END;
- currentScope := prevScope;
- currentIsRealtime := prevIsRealtime;
- currentIsBodyProcedure := prevIsBodyProcedure;
- currentIsCellNet := prevIsCellNet;
- END Implementation;
- (** implementation phase:
- check and resolve all scopes (implementation phase) that have been entered into a list during the declaration phase
- **)
- PROCEDURE Implementations(x: SyntaxTree.Module);
- VAR scope: SyntaxTree.Scope; prevPhase: LONGINT;
- BEGIN
- prevPhase := phase;
- phase := InlinePhase;
- scope := x.firstScope;
- WHILE(scope # NIL) DO
- Implementation(scope);
- scope := scope.nextScope;
- END;
- phase := ImplementationPhase;
- scope := x.firstScope;
- WHILE(scope # NIL) DO
- Implementation(scope);
- scope := scope.nextScope;
- END;
- phase := prevPhase;
- END Implementations;
- (** declaration phase:
- check and resolve all declarations of a scope (module scope, procedure scope, record scope):
- - import lists (for module scopes)
- - parameter list (for procedure scopes)
- - constant declarations
- - type declarations
- - variable declarations
- - procedure declarations
- preformed in two stages:
- - first all symbols are entered into the symbol table (with uniqueness check),
- - then all symbols are resolved
- after declaration check, bodies are entered into the global list of implementations that remain to be resolved after all declarations.
- Declarations depend on other declarations, this procedure is neither thread safe not would it be wise to try concurrency here
- **)
- PROCEDURE Declarations(scope: SyntaxTree.Scope; skipImplementation: BOOLEAN; procedures, nonProcedures: BOOLEAN);
- VAR
- constant: SyntaxTree.Constant;
- typeDeclaration: SyntaxTree.TypeDeclaration;
- variable: SyntaxTree.Variable;
- procedure: SyntaxTree.Procedure;
- procedureType : SyntaxTree.ProcedureType;
- prevScope: SyntaxTree.Scope;
- parameter: SyntaxTree.Parameter;
- import: SyntaxTree.Import;
- symbol: SyntaxTree.Symbol;
- prevPhase: LONGINT;
- prevError : BOOLEAN;
- i: LONGINT;
-
- PROCEDURE DeclareCell(type: SyntaxTree.CellType);
- VAR baseType: SyntaxTree.Type; property, prop: SyntaxTree.Property; variable: SyntaxTree.Variable;
- BEGIN
- IF type.baseType # NIL THEN
- baseType := type.baseType.resolved;
- IF baseType IS SyntaxTree.PointerType THEN
- baseType := baseType(SyntaxTree.PointerType).pointerBase.resolved;
- END;
- (*
- IF baseType IS SyntaxTree.CellType THEN
- DeclareCell(baseType(SyntaxTree.CellType));
- END;
- *)
- END;
- parameter := type.firstParameter;
- WHILE(parameter # NIL) DO (* duplicates forbidden *)
- (*
- variable := SyntaxTree.NewVariable(parameter.position, parameter.name);
- variable.SetType(parameter.type);
- variable.SetAccess(SyntaxTree.Hidden);
- variable.SetModifiers(parameter.modifiers);
- currentScope.PushVariable(variable);
- *)
- Register(parameter,scope, FALSE);
- parameter := parameter.nextParameter;
- END;
-
- property := type.firstProperty;
- WHILE (property # NIL) DO (* duplicates allowed : overwrite *)
- (*
- variable := currentScope.FindVariable(property.name);
- IF (variable # NIL) & (variable IS SyntaxTree.Property) THEN (* overwrite *)
- prop := variable(SyntaxTree.Property);
- ELSE (* add, duplicate symbols detection later *)
- prop := SyntaxTree.NewProperty(property.position, property.name);
- currentScope.PushVariable(prop);
- END;
- prop.SetType(property.type);
- prop.SetValue(property.value);
- prop.SetAccess(SyntaxTree.Hidden);
- *)
- Register(property, scope, FALSE);
- property := property.nextProperty;
- END;
- END DeclareCell;
-
-
- BEGIN
- prevError := error;
- prevPhase := phase;
- phase := DeclarationPhase;
- prevScope := currentScope;
- currentScope := scope;
- error := FALSE;
-
- IF nonProcedures THEN
- (* first enter all symbols in scope *)
- IF scope IS SyntaxTree.ModuleScope THEN
- (* treat imports first for a module scope, , set default context if necessary *)
- import := scope(SyntaxTree.ModuleScope).firstImport;
- WHILE(import # NIL) DO
- IF import.context = SyntaxTree.invalidIdentifier THEN import.SetContext(scope.ownerModule.context) END;
- Register(import, currentScope, FALSE);
- import := import.nextImport;
- END;
- import := scope(SyntaxTree.ModuleScope).firstImport;
- WHILE(import # NIL) DO (* 2nd stage to avoid duplicate symbol *)
- ResolveSymbol(import);
- import := import.nextImport;
- END;
- ELSIF scope IS SyntaxTree.ProcedureScope THEN
- (* enter parameters for a procedure scope *)
- procedureType := scope(SyntaxTree.ProcedureScope).ownerProcedure.type.resolved(SyntaxTree.ProcedureType);
- parameter := procedureType.firstParameter;
- WHILE(parameter # NIL) DO
- Register(parameter,currentScope, FALSE); parameter := parameter.nextParameter;
- END;
- parameter := procedureType.returnParameter;
- IF parameter # NIL THEN Register(parameter, currentScope, FALSE); END;
- parameter := procedureType.selfParameter;
- IF parameter # NIL THEN
- Register(parameter, currentScope, FALSE);
- parameter.SetState(SyntaxTree.Resolved); (* would lead to cycles, otherwise *)
- END;
- ELSIF scope IS SyntaxTree.CellScope THEN
- DeclareCell(scope(SyntaxTree.CellScope).ownerCell);
- IF~skipImplementation THEN
- import := scope(SyntaxTree.CellScope).firstImport;
- WHILE(import # NIL) DO
- IF import.context = SyntaxTree.invalidIdentifier THEN import.SetContext(scope.ownerModule.context) END;
- Register(import, currentScope, FALSE);
- import := import.nextImport;
- END;
- import := scope(SyntaxTree.CellScope).firstImport;
- WHILE(import # NIL) DO (* 2nd stage to avoid duplicate symbol *)
- ResolveSymbol(import);
- import := import.nextImport;
- END;
- END;
- END;
- IF error THEN RETURN END;
- IF skipImplementation THEN
- scope.Clear;
- END;
-
- (* constants *)
- constant := scope.firstConstant;
- WHILE (constant # NIL) DO
- Register(constant, currentScope, FALSE); constant := constant.nextConstant;
- END;
- (* type declarations *)
- typeDeclaration := scope.firstTypeDeclaration;
- WHILE (typeDeclaration # NIL) DO
- Register(typeDeclaration, currentScope, FALSE); typeDeclaration := typeDeclaration.nextTypeDeclaration;
- END;
- (* variables *)
- variable := scope.firstVariable;
- WHILE (variable # NIL) DO
- Register(variable, currentScope, FALSE); variable := variable.nextVariable;
- END;
- (* procedures *)
- IF scope.procedures # NIL THEN
- FOR i := 0 TO scope.procedures.Length()-1 DO
- procedure := scope.procedures.GetProcedure(i);
- procedureType := procedure.type.resolved(SyntaxTree.ProcedureType);
- IF procedureType.selfParameter = NIL THEN
- scope.AddProcedure(procedure);
- Register(procedure, currentScope, procedure IS SyntaxTree.Operator);
- ELSE
- typeDeclaration := currentScope.FindTypeDeclaration(procedureType.selfParameter.type(SyntaxTree.QualifiedType).qualifiedIdentifier.suffix);
- IF typeDeclaration = NIL THEN
- Error(procedureType.selfParameter.position, "No such type declaration");
- ELSE
- procedureType.selfParameter.type(SyntaxTree.QualifiedType).SetResolved(typeDeclaration.declaredType.resolved);
- procedureType.selfParameter.SetState(SyntaxTree.Resolved);
- typeDeclaration.declaredType(SyntaxTree.RecordType).recordScope.AddProcedure(procedure);
- Register(procedure, typeDeclaration.declaredType(SyntaxTree.RecordType).recordScope, procedure IS SyntaxTree.Operator);
- END;
- END;
- END;
- END;
- END;
- (*
- procedure := scope.firstProcedure;
- WHILE (procedure # NIL) DO
- procedureType := procedure.type.resolved(SyntaxTree.ProcedureType);
- IF procedureType.selfParameter = NIL THEN
- Register(procedure, currentScope, procedure IS SyntaxTree.Operator);
- END;
- procedure := procedure.nextProcedure;
- END;
- *)
- (* type bound procedures *)
- (*
- procedure := scope.firstProcedure;
- WHILE (procedure # NIL) DO
- procedureType := procedure.type.resolved(SyntaxTree.ProcedureType);
- IF procedureType.selfParameter # NIL THEN
- typeDeclaration := currentScope.FindTypeDeclaration(procedureType.selfParameter.type(SyntaxTree.QualifiedType).qualifiedIdentifier.suffix);
- IF typeDeclaration = NIL THEN
- Error(procedureType.selfParameter.position, "No such type declaration");
- ELSE
- procedureType.selfParameter.type(SyntaxTree.QualifiedType).SetResolved(typeDeclaration.declaredType.resolved);
- procedureType.selfParameter.SetState(SyntaxTree.Resolved);
- END;
- Register(procedure, typeDeclaration.declaredType(SyntaxTree.RecordType).recordScope, procedure IS SyntaxTree.Operator);
- END;
- procedure := procedure.nextProcedure;
- END;
- *)
- (* now process all symbols without any presumption on the order *)
- symbol := scope.firstSymbol;
- WHILE(symbol # NIL) DO
- IF ~(symbol IS SyntaxTree.Parameter) OR (symbol(SyntaxTree.Parameter).ownerType IS SyntaxTree.CellType) THEN
- IF (symbol IS SyntaxTree.Procedure) THEN
- IF procedures THEN
- ResolveSymbol(symbol);
- END;
- ELSE
- IF nonProcedures THEN
- ResolveSymbol(symbol);
- END;
- END;
- END;
- symbol := symbol.nextSymbol;
- END;
-
-
- IF (scope IS SyntaxTree.ProcedureScope) & scope(SyntaxTree.ProcedureScope).ownerProcedure.type.isRealtime THEN
- symbol := scope.firstSymbol;
- WHILE symbol # NIL DO
- IF (symbol IS SyntaxTree.Variable) OR (symbol IS SyntaxTree.Parameter) THEN
- IF (symbol.type IS SyntaxTree.PointerType) OR (symbol.type IS SyntaxTree.QualifiedType) THEN
- pointerFixes.Add(symbol, currentScope);
- END;
- IF ~symbol.type.resolved.isRealtime THEN
- Error(symbol.position,"symbol has no realtime type");
- END;
- END;
- symbol := symbol.nextSymbol
- END;
- END;
- IF ~error & procedures & ~system.GenerateVariableOffsets(scope) THEN
- Error(Basic.invalidPosition,"problems during offset computation in module");
- END;
- IF (scope.ownerModule # NIL) & procedures THEN
- (* add scope to global list of all scopes, very handy for code generation and for checking implementations *)
- scope.ownerModule.AddScope(scope);
- END;
- phase := prevPhase;
- currentScope := prevScope;
- error := error OR prevError;
- END Declarations;
- (* nopov *)
- (** check if all operators from one module are compatible to the ones in the other module
- - check if there are not multiple operators with the same signature
- (apart from the conversion operator "@Convert": it is the only operator that may be defined multiple times with the same signature)
- - check for all operators whose signatures are compatible, whether the return types are compatible
- note that:
- - the return type is not considered to be part of the signature
- - two signatures are considered compatible, if all of the operands are compatible
- **)
- PROCEDURE CheckInterOperatorConformity(thisModuleScope, thatModuleScope: SyntaxTree.ModuleScope);
- VAR
- thisOperator, thatOperator: SyntaxTree.Operator;
- thisProcedureType, thatProcedureType: SyntaxTree.ProcedureType;
- thisParameter, thatParameter: SyntaxTree.Parameter;
- operandsAreEqual, operandsAreCompatible, hasError: BOOLEAN;
- i: LONGINT;
- BEGIN
- currentScope := thisModuleScope;
- hasError := FALSE;
- (* go through all operators in the other module *)
- thatOperator := thatModuleScope.firstOperator;
- WHILE (thatOperator # NIL) & ~hasError DO
- IF (thisModuleScope = thatModuleScope) OR (SyntaxTree.PublicRead IN thatOperator.access) THEN
- (* the other operator is accessible *)
- IF thatOperator.name # Global.GetIdentifier(Global.Conversion, thatModuleScope.ownerModule.case) THEN
- (* the other operator is not the conversion operator *)
- (* go through all operators in this module *)
- thisOperator := thisModuleScope.firstOperator;
- WHILE (thisOperator # NIL) & ~hasError DO
- IF thisOperator # thatOperator THEN
- (* the operators are not the same *)
- IF thisOperator.name = thatOperator.name THEN
- (* the operators share the same identifier *)
- ASSERT(thisOperator.type IS SyntaxTree.ProcedureType);
- ASSERT(thatOperator.type IS SyntaxTree.ProcedureType);
- thisProcedureType := thisOperator.type(SyntaxTree.ProcedureType);
- thatProcedureType := thatOperator.type(SyntaxTree.ProcedureType);
- IF thisProcedureType.numberParameters = thatProcedureType.numberParameters THEN
- (* both operators have the same paramter count *)
- thisParameter := thisProcedureType.firstParameter;
- thatParameter := thatProcedureType.firstParameter;
- operandsAreEqual := TRUE;
- operandsAreCompatible := TRUE;
- (* go through all parameters *)
- FOR i := 1 TO thisProcedureType.numberParameters DO
- ASSERT(thatParameter # NIL);
- IF ~SameType(thisParameter.type, thatParameter.type) THEN
- operandsAreEqual := FALSE;
- IF ~CompatibleTo(system, thisParameter.type, thatParameter.type) THEN
- operandsAreCompatible := FALSE
- END
- END;
- thisParameter := thisParameter.nextParameter;
- thatParameter := thatParameter.nextParameter
- END;
- IF operandsAreEqual THEN
- Error(thisOperator.position, "operator has the same identifier and operand types as other one");
- hasError := TRUE
- ELSIF operandsAreCompatible THEN
- IF ~CompatibleTo(system, thisProcedureType.returnType, thatProcedureType.returnType) THEN
- Error(thisOperator.position, "operator's return type is not compatible to the one of a more generic operator");
- hasError := TRUE
- ELSIF ~thisOperator.isDynamic & thatOperator.isDynamic THEN
- Error(thisOperator.position, "operator must be dynamic because it is signature-compatible to a dynamic one");
- hasError := TRUE
- END
- END
- END
- END
- END;
- thisOperator := thisOperator.nextOperator
- END
- END
- END;
- thatOperator := thatOperator.nextOperator
- END
- END CheckInterOperatorConformity;
- (** check module:
- - check module declaration
- - add context, if necessary
- - remove module from import cache, if necessary
- - check declarations
- - resolve all type fixes
- - check implementation (bodies)
- **)
- PROCEDURE Module*(x: SyntaxTree.Module);
- VAR (* nopov *)
- import: SyntaxTree.Import; modifier: SyntaxTree.Modifier; value: LONGINT; position: Position; prevIsCellNet: BOOLEAN; prevScope: SyntaxTree.Scope;
- BEGIN
- prevScope := currentScope;
- prevIsCellNet := currentIsCellNet;
- module := x;
- ASSERT(x # NIL);
- global := system.globalScope[x.case];
- x.moduleScope.SetGlobalScope(global);
- currentScope := global;
- IF (x.name = Global.SystemName) OR (x.name = Global.systemName) THEN Error(x.position,"name reserved") END;
- IF x.context = SyntaxTree.invalidIdentifier THEN x.SetContext(Global.A2Name) END;
- RemoveModuleFromCache(importCache,x);
- Declarations(x.moduleScope, FALSE, TRUE, TRUE);
- FixTypes();
- IF module.isCellNet THEN
- currentIsCellNet := TRUE;
- modifier := x.modifiers;
- IF HasValue(modifier,Global.NameFrequencyDivider,position,value) THEN END;
- CheckModifiers(modifier, FALSE);
- END;
- (* nopov *)
- IF ~error THEN
- (* check if operators conform to each other within this module *)
- CheckInterOperatorConformity(x.moduleScope, x.moduleScope);
- (* go through all imports *)
- import := x.moduleScope.firstImport;
- WHILE import # NIL DO
- IF (import.module # NIL) & ~Global.IsSystemModule(import.module) THEN (* ignore SYSTEM-module *)
- (* check if all operators in this module conform to the ones of the imported module *)
- CheckInterOperatorConformity(x.moduleScope, import.module.moduleScope)
- END;
- import := import.nextImport
- END;
- END;
- Implementations(x);
- module := NIL;
- currentIsCellNet := prevIsCellNet;
- currentScope := prevScope;
- END Module;
- END Checker;
- Warnings*=OBJECT (SyntaxTree.Visitor)
- VAR diagnostics: Diagnostics.Diagnostics; module: SyntaxTree.Module;
- PROCEDURE &InitWarnings*(diagnostics: Diagnostics.Diagnostics);
- BEGIN
- SELF.diagnostics := diagnostics
- END InitWarnings;
- PROCEDURE VisitPortType(x: SyntaxTree.PortType);
- BEGIN END VisitPortType;
- (** types *)
- PROCEDURE Type(x: SyntaxTree.Type);
- BEGIN x.Accept(SELF)
- END Type;
- PROCEDURE VisitType*(x: SyntaxTree.Type);
- BEGIN END VisitType;
- PROCEDURE VisitBasicType*(x: SyntaxTree.BasicType);
- BEGIN END VisitBasicType;
- PROCEDURE VisitCharacterType*(x: SyntaxTree.CharacterType);
- BEGIN END VisitCharacterType;
- PROCEDURE VisitIntegerType*(x: SyntaxTree.IntegerType);
- BEGIN END VisitIntegerType;
- PROCEDURE VisitFloatType*(x: SyntaxTree.FloatType);
- BEGIN END VisitFloatType;
- PROCEDURE VisitQualifiedType*(x: SyntaxTree.QualifiedType);
- BEGIN END VisitQualifiedType;
- PROCEDURE VisitStringType*(x: SyntaxTree.StringType);
- BEGIN END VisitStringType;
- PROCEDURE VisitEnumerationType*(x: SyntaxTree.EnumerationType);
- BEGIN END VisitEnumerationType;
- PROCEDURE VisitRangeType*(x: SyntaxTree.RangeType);
- BEGIN END VisitRangeType;
- PROCEDURE VisitArrayType*(x: SyntaxTree.ArrayType);
- BEGIN
- IF ~(SyntaxTree.Warned IN x.state) THEN
- x.SetState(SyntaxTree.Warned);
- Type(x.arrayBase);
- END;
- END VisitArrayType;
- PROCEDURE VisitMathArrayType*(x: SyntaxTree.MathArrayType);
- BEGIN
- IF ~(SyntaxTree.Warned IN x.state) THEN
- x.SetState(SyntaxTree.Warned);
- Type(x.arrayBase);
- END;
- END VisitMathArrayType;
- PROCEDURE VisitPointerType*(x: SyntaxTree.PointerType);
- BEGIN
- IF ~(SyntaxTree.Warned IN x.state) THEN
- x.SetState(SyntaxTree.Warned);
- Type(x.pointerBase);
- END;
- END VisitPointerType;
- PROCEDURE VisitRecordType*(x: SyntaxTree.RecordType);
- BEGIN Scope(x.recordScope) END VisitRecordType;
- PROCEDURE VisitCellType*(x: SyntaxTree.CellType);
- BEGIN Scope(x.cellScope) END VisitCellType;
- PROCEDURE VisitProcedureType*(x: SyntaxTree.ProcedureType);
- BEGIN END VisitProcedureType;
- PROCEDURE Warning(x: SyntaxTree.Symbol; CONST text: ARRAY OF CHAR);
- VAR msg: ARRAY 256 OF CHAR;
- BEGIN
- Global.GetSymbolName(x,msg);
- Strings.Append(msg," ");
- Strings.Append(msg,text);
- Basic.Warning(diagnostics, module.sourceName,x.position, msg);
- END Warning;
- (** symbols *)
- PROCEDURE Symbol(x: SyntaxTree.Symbol);
- BEGIN
- IF ~x.used & (x.access * SyntaxTree.Public = {}) & (x.access # SyntaxTree.Hidden) THEN
- IF ~(x IS SyntaxTree.Parameter) THEN
- Warning(x,"never used");
- END;
- END;
- x.Accept(SELF);
- END Symbol;
- PROCEDURE VisitSymbol*(x: SyntaxTree.Symbol);
- BEGIN END VisitSymbol;
- PROCEDURE VisitTypeDeclaration*(x: SyntaxTree.TypeDeclaration);
- BEGIN Type(x.declaredType) END VisitTypeDeclaration;
- PROCEDURE VisitConstant*(x: SyntaxTree.Constant);
- BEGIN END VisitConstant;
- PROCEDURE VisitVariable*(x: SyntaxTree.Variable);
- BEGIN END VisitVariable;
- PROCEDURE VisitProperty*(x: SyntaxTree.Property);
- BEGIN END VisitProperty;
- PROCEDURE VisitParameter*(x: SyntaxTree.Parameter);
- BEGIN END VisitParameter;
- PROCEDURE VisitProcedure*(x: SyntaxTree.Procedure);
- BEGIN
- Scope(x.procedureScope)
- END VisitProcedure;
- PROCEDURE VisitOperator*(x: SyntaxTree.Operator);
- BEGIN END VisitOperator;
- PROCEDURE VisitImport*(x: SyntaxTree.Import);
- BEGIN END VisitImport;
- PROCEDURE Scope(scope: SyntaxTree.Scope);
- VAR
- symbol: SyntaxTree.Symbol;
- BEGIN
- symbol := scope.firstSymbol;
- WHILE(symbol # NIL) DO
- Symbol(symbol);
- symbol := symbol.nextSymbol;
- END;
- END Scope;
- PROCEDURE Module*(x: SyntaxTree.Module);
- BEGIN
- SELF.module := x;
- Scope(x.moduleScope);
- END Module;
- END Warnings;
- PROCEDURE IsOberonInline(procedure: SyntaxTree.Procedure): BOOLEAN;
- BEGIN
- RETURN procedure.isInline & ((procedure.procedureScope.body = NIL) OR (procedure.procedureScope.body # NIL) & (procedure.procedureScope.body.code = NIL))
- END IsOberonInline;
- PROCEDURE Resolved(x: SyntaxTree.Type): SyntaxTree.Type;
- BEGIN
- IF x = NIL THEN RETURN NIL ELSE RETURN x.resolved END;
- END Resolved;
- PROCEDURE PowerOf2(x: LONGINT): BOOLEAN;
- VAR i: LONGINT;
- BEGIN
- i := 1;
- WHILE i < x DO
- i := i *2
- END;
- RETURN i=x
- END PowerOf2;
- PROCEDURE IsCellNetScope(scope: SyntaxTree.Scope): BOOLEAN;
- BEGIN
- RETURN
- (scope # NIL) &
- (scope IS SyntaxTree.ModuleScope)
- & (scope(SyntaxTree.ModuleScope).ownerModule.isCellNet)
- OR
- (scope # NIL) & (scope IS SyntaxTree.CellScope)
- & (scope(SyntaxTree.CellScope).ownerCell.isCellNet)
- END IsCellNetScope;
- PROCEDURE IsCellScope(scope: SyntaxTree.Scope): BOOLEAN;
- BEGIN
- RETURN (scope # NIL) & (scope IS SyntaxTree.CellScope) & ~(scope(SyntaxTree.CellScope).ownerCell.isCellNet)
- END IsCellScope;
- PROCEDURE InCellNetScope(scope: SyntaxTree.Scope): BOOLEAN;
- BEGIN
- WHILE (scope # NIL) & ~IsCellScope(scope) & ~IsCellNetScope(scope) DO scope := scope.outerScope END;
- RETURN (scope # NIL) & IsCellNetScope(scope)
- END InCellNetScope;
- PROCEDURE ToMemoryUnits(system: Global.System; size: LONGINT): LONGINT;
- BEGIN
- ASSERT(size MOD system.dataUnit = 0);
- RETURN size DIV system.dataUnit
- END ToMemoryUnits;
- (* Returns TRUE if the built-in function GETPROCEDURE can be used with this procedure type *)
- PROCEDURE GetProcedureAllowed*(type: SyntaxTree.Type) : BOOLEAN;
- VAR procedureType: SyntaxTree.ProcedureType; numberParameters: LONGINT;
- PROCEDURE TypeAllowed(t : SyntaxTree.Type) : BOOLEAN;
- BEGIN
- IF t = NIL THEN
- RETURN TRUE
- ELSE
- t := t.resolved;
- RETURN (t IS SyntaxTree.RecordType) OR IsPointerToRecord(t) OR (t IS SyntaxTree.AnyType);
- END;
- END TypeAllowed;
- BEGIN
- type := type.resolved;
- IF ~(type IS SyntaxTree.ProcedureType) THEN
- RETURN FALSE
- ELSE
- procedureType := type(SyntaxTree.ProcedureType);
- numberParameters := procedureType.numberParameters;
- RETURN
- (numberParameters = 0) & TypeAllowed(procedureType.returnType) OR
- (numberParameters = 1) & TypeAllowed(procedureType.firstParameter.type) & TypeAllowed(procedureType.returnType) OR
- (numberParameters = 1) & (procedureType.firstParameter.ownerType.resolved IS SyntaxTree.AnyType) & (procedureType.returnType.resolved IS SyntaxTree.AnyType)
- END;
- END GetProcedureAllowed;
- (** check import cache: if module x is in current import cache then remove x and all modules importing x from the cache **)
- PROCEDURE RemoveModuleFromCache*(importCache: SyntaxTree.ModuleScope; x: SyntaxTree.Module);
- VAR import: SyntaxTree.Import;
- BEGIN
- import := importCache.ImportByModuleName(x.name,x.context);
- IF import # NIL THEN
- importCache.RemoveImporters(x.name,x.context);
- END;
- END RemoveModuleFromCache;
- PROCEDURE CompatibleTo(system: Global.System; this,to: SyntaxTree.Type): BOOLEAN;
- (* to <- this assignment compatibility *)
- VAR result: BOOLEAN;
- BEGIN
- IF this= NIL THEN result := (to=NIL)
- ELSIF to=NIL THEN result := FALSE
- ELSE
- (*! will be replaced by this:
- ELSE result := this.CompatibleTo(to.resolved);
- *)
- this := this.resolved; to := to.resolved;
- IF to=SyntaxTree.invalidType THEN result := FALSE
- ELSIF to=SyntaxTree.typeDeclarationType THEN result := FALSE;
- ELSIF to = this THEN
- result := ~(to IS SyntaxTree.ArrayType) OR (to(SyntaxTree.ArrayType).form # SyntaxTree.Open);
- ELSIF to IS SyntaxTree.BasicType THEN
- IF (to IS SyntaxTree.NumberType) & (this IS SyntaxTree.NumberType) THEN
- IF (to IS SyntaxTree.ComplexType) OR (this IS SyntaxTree.ComplexType) THEN
- result := this.CompatibleTo(to.resolved)
- ELSE
- result := Global.BasicTypeDistance(system,this(SyntaxTree.BasicType),to(SyntaxTree.BasicType)) < Infinity;
- END
- ELSIF (to IS SyntaxTree.SetType) & (this IS SyntaxTree.SetType) THEN
- result := to.sizeInBits = this.sizeInBits;
- ELSIF (to IS SyntaxTree.IntegerType) & (this IS SyntaxTree.AddressType) THEN
- result := to.sizeInBits >= this.sizeInBits; (* weak compatibility: (unsigned) address may be assigned to signed integer of same (or greater) size *)
- ELSIF (to IS SyntaxTree.IntegerType) & (this IS SyntaxTree.SizeType) THEN
- result := to.sizeInBits >= this.sizeInBits; (* compatibility: (signed) size may be assigned to signed integer of greater or equal size *)
- ELSIF (to IS SyntaxTree.FloatType) & (this IS SyntaxTree.AddressType) OR (this IS SyntaxTree.SizeType) THEN
- result := TRUE;
- ELSIF to IS SyntaxTree.AnyType THEN
- result := (this IS SyntaxTree.RecordType) & this(SyntaxTree.RecordType).isObject OR (this IS SyntaxTree.PointerType) OR (this IS SyntaxTree.ProcedureType) OR (this IS SyntaxTree.NilType) OR (this IS SyntaxTree.AnyType) OR (this IS SyntaxTree.ObjectType);
- ELSIF to IS SyntaxTree.ObjectType THEN
- result := IsPointerToRecord(this) OR (this IS SyntaxTree.NilType) OR (this IS SyntaxTree.ObjectType) OR (this IS SyntaxTree.AnyType) (*! remove when symbol file can distinguish OBJECT from ANY *) ;
- ELSIF to IS SyntaxTree.ByteType THEN
- result := (this IS SyntaxTree.IntegerType) & (to.sizeInBits = 8) OR IsCharacterType(this)
- ELSIF to IS SyntaxTree.CharacterType THEN
- result := IsCharacterType(this)
- ELSIF (to IS SyntaxTree.SizeType) & ((this IS SyntaxTree.SizeType) OR (this IS SyntaxTree.IntegerType) OR (this IS SyntaxTree.AddressType)) THEN
- result := to.sizeInBits >= this.sizeInBits (*! weak compatibility: signed size type may be assigned with unsigned address type of same size *)
- ELSIF (to IS SyntaxTree.AddressType) & ((this IS SyntaxTree.AddressType) OR (this IS SyntaxTree.IntegerType) OR (this IS SyntaxTree.SizeType) OR IsPointerType(this) OR (this IS SyntaxTree.ProcedureType)) THEN
- result := to.sizeInBits >= this.sizeInBits; (*! weak compatibility: addresses may be assigned with signed integer *)
- ELSIF (to IS SyntaxTree.RangeType) & (this IS SyntaxTree.RangeType) THEN
- result := TRUE;
- ELSIF (to IS SyntaxTree.BooleanType) & (this IS SyntaxTree.BooleanType) THEN
- result := TRUE;
- ELSE
- result := FALSE
- END;
- ELSIF to IS SyntaxTree.PointerType THEN
- result := (this IS SyntaxTree.NilType) OR ((this IS SyntaxTree.AddressType) OR (this IS SyntaxTree.IntegerType)) & to(SyntaxTree.PointerType).isUnsafe OR
- IsPointerType(this) & (IsTypeExtension(to,this) OR to(SyntaxTree.PointerType).isUnsafe OR ((to(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.ArrayType) & SameType(to,this)))
- & (~to.isRealtime OR this.isRealtime);
- ELSIF to IS SyntaxTree.ProcedureType THEN
- result := (this IS SyntaxTree.NilType) OR (this IS SyntaxTree.ProcedureType) & SameType(to(SyntaxTree.ProcedureType),this(SyntaxTree.ProcedureType))
- & (~(this(SyntaxTree.ProcedureType).isDelegate) OR (to(SyntaxTree.ProcedureType).isDelegate))
- & (~to.isRealtime OR this.isRealtime)
- & ((this(SyntaxTree.ProcedureType).stackAlignment <=1) OR (this(SyntaxTree.ProcedureType).stackAlignment <= to(SyntaxTree.ProcedureType).stackAlignment));
- ELSIF (to IS SyntaxTree.RecordType) & to(SyntaxTree.RecordType).isObject THEN
- result := (this IS SyntaxTree.NilType) OR IsTypeExtension(to,this);
- ELSIF to IS SyntaxTree.RecordType THEN
- result := (this IS SyntaxTree.RecordType) & IsTypeExtension(to,this);
- ELSIF to IS SyntaxTree.ArrayType THEN
- IF IsStringType(to) & (this IS SyntaxTree.StringType) THEN
- result := (to(SyntaxTree.ArrayType).form = SyntaxTree.Open) OR (to(SyntaxTree.ArrayType).staticLength >= this(SyntaxTree.StringType).length)
- ELSIF StaticArrayCompatible(to, this) THEN
- result := TRUE
- ELSE
- result := (to(SyntaxTree.ArrayType).staticLength # 0) & SameType(to,this)
- END;
- ELSIF to IS SyntaxTree.MathArrayType THEN
- IF this IS SyntaxTree.MathArrayType THEN
- IF to(SyntaxTree.MathArrayType).arrayBase= NIL THEN
- IF to(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
- result := TRUE;
- ELSIF this(SyntaxTree.MathArrayType).arrayBase = NIL THEN
- result := TRUE;
- ELSE
- result := ~(this(SyntaxTree.MathArrayType).arrayBase.resolved IS SyntaxTree.MathArrayType);
- END;
- (* special case: ARRAY [...] OF SYSTEM.ALL *)
- ELSIF (to(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) OR (this(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) THEN
- (* ARRAY [?] OF <- ARRAY [x,...,x] OF *)
- result := CompatibleTo(system,ArrayBase(this,Infinity),ArrayBase(to,Infinity));
- ELSIF (to(SyntaxTree.MathArrayType).form = SyntaxTree.Open) OR (this(SyntaxTree.MathArrayType).form = SyntaxTree.Open)
- OR (to(SyntaxTree.MathArrayType).staticLength = this(SyntaxTree.MathArrayType).staticLength) THEN
- (* ARRAY [x] OF <- ARRAY [x] OF *)
- result := CompatibleTo(system,this(SyntaxTree.MathArrayType).arrayBase,to(SyntaxTree.MathArrayType).arrayBase);
- ELSE
- result := FALSE
- END;
- (* an array-structured object type is compatible to the type of its array structure *)
- ELSIF IsArrayStructuredObjectType(this) THEN
- result := CompatibleTo(system, to, MathArrayStructureOfType(this))
- ELSE
- result := FALSE;
- END;
- ELSIF to IS SyntaxTree.StringType THEN
- result := FALSE;
- ELSIF to IS SyntaxTree.EnumerationType THEN
- result := IsEnumerationExtension(this,to);
- ELSIF to IS SyntaxTree.PortType THEN
- result := SameType(to, this)
- ELSE
- Printout.Info("CompatibleTo",to);
- HALT(100); (* implement missing type check *)
- END;
- END;
- RETURN result
- END CompatibleTo;
- PROCEDURE StaticArrayCompatible(formal: SyntaxTree.Type; actual: SyntaxTree.Type): BOOLEAN;
- VAR actualBase, formalBase: SyntaxTree.Type;
- BEGIN
- IF SameType(formal,actual) THEN
- RETURN TRUE
- ELSIF (formal IS SyntaxTree.MathArrayType) & (actual IS SyntaxTree.ArrayType) THEN
- actualBase := actual(SyntaxTree.ArrayType).arrayBase.resolved;
- formalBase := formal(SyntaxTree.MathArrayType).arrayBase.resolved;
- RETURN
- (formal(SyntaxTree.MathArrayType).form = SyntaxTree.Static)
- & (actual(SyntaxTree.ArrayType).form = SyntaxTree.Static)
- & (actual(SyntaxTree.ArrayType).staticLength = formal(SyntaxTree.MathArrayType).staticLength)
- & StaticArrayCompatible(formalBase,actualBase)
- ELSIF (formal IS SyntaxTree.ArrayType) & (actual IS SyntaxTree.MathArrayType) THEN
- actualBase := actual(SyntaxTree.MathArrayType).arrayBase.resolved;
- formalBase := formal(SyntaxTree.ArrayType).arrayBase.resolved;
- RETURN
- (formal(SyntaxTree.ArrayType).form = SyntaxTree.Static)
- & (actual(SyntaxTree.MathArrayType).form = SyntaxTree.Static)
- & (actual(SyntaxTree.MathArrayType).staticLength = formal(SyntaxTree.ArrayType).staticLength)
- & StaticArrayCompatible(formalBase,actualBase)
- ELSE RETURN FALSE
- END;
- END StaticArrayCompatible;
- PROCEDURE OpenArrayCompatible(formalType: SyntaxTree.ArrayType; actualType: SyntaxTree.Type): BOOLEAN;
- VAR arrayBase: SyntaxTree.Type; result: BOOLEAN;
- PROCEDURE TC(formal,actual: SyntaxTree.Type): BOOLEAN;
- VAR actualBase,formalBase: SyntaxTree.Type; result: BOOLEAN;
- BEGIN
- result := SameType(formal,actual);
- IF ~result & (formal IS SyntaxTree.ArrayType) & (actual IS SyntaxTree.ArrayType) THEN
- actualBase := actual(SyntaxTree.ArrayType).arrayBase.resolved;
- formalBase := formal(SyntaxTree.ArrayType).arrayBase.resolved;
- result := (formal(SyntaxTree.ArrayType).form = SyntaxTree.Open) & TC(formalBase,actualBase)
- ELSIF ~result & (formal IS SyntaxTree.ArrayType) & (actual IS SyntaxTree.MathArrayType) THEN
- actualBase := actual(SyntaxTree.MathArrayType).arrayBase.resolved;
- formalBase := formal(SyntaxTree.ArrayType).arrayBase.resolved;
- result := (formal(SyntaxTree.ArrayType).form = SyntaxTree.Open) & (actual(SyntaxTree.MathArrayType).form = SyntaxTree.Static)
- & TC(formalBase, actualBase);
- END;
- RETURN result
- END TC;
- BEGIN
- IF formalType.form # SyntaxTree.Open THEN result := FALSE
- ELSE
- arrayBase := formalType.arrayBase.resolved;
- IF (actualType IS SyntaxTree.StringType) THEN
- result := arrayBase IS SyntaxTree.CharacterType
- ELSIF actualType IS SyntaxTree.ArrayType THEN
- result := (arrayBase IS SyntaxTree.ByteType) OR TC(formalType,actualType)
- ELSIF actualType IS SyntaxTree.MathArrayType THEN
- result := TC(formalType, actualType);
- ELSE
- result := (arrayBase IS SyntaxTree.ByteType)
- END;
- END;
- RETURN result
- END OpenArrayCompatible;
- PROCEDURE MathArrayCompatible(formalType: SyntaxTree.MathArrayType; actualType: SyntaxTree.Type): BOOLEAN;
- (* special compatibility rule for parameters of the form VAR A: ARRAY [x] OF , VAR A: ARRAY [*] OF and VAR A: ARRAY [?] OF *)
- VAR formalBase,actualBase: SyntaxTree.Type; result: BOOLEAN; actualArray: SyntaxTree.MathArrayType;
- BEGIN
- IF actualType IS SyntaxTree.MathArrayType THEN
- actualArray := actualType(SyntaxTree.MathArrayType);
- IF (formalType.form = SyntaxTree.Tensor) OR (actualArray.form = SyntaxTree.Tensor) THEN
- (*
- ARRAY [?] OF -> ARRAY [?|*|k] OF
- ARRAY [?|*|k] OF -> ARRAY [?] OF
- *)
- actualBase := ArrayBase(actualType,Infinity);
- formalBase := ArrayBase(formalType,Infinity);
- result := (formalBase = NIL) OR SameType(formalBase,actualBase);
- ELSE
- (*
- ARRAY [*|k] OF -> ARRAY [*|n] OF
- *)
- formalBase := Resolved(formalType.arrayBase);
- actualBase := Resolved(actualArray.arrayBase);
- IF (formalType.form = SyntaxTree.Static) & (actualArray.form = SyntaxTree.Static) THEN
- (*
- ARRAY [k] -> ARRAY [n]
- *)
- result := (formalType.staticLength = actualArray.staticLength)
- ELSE
- result := TRUE
- END;
- IF ~result THEN
- ELSIF formalBase = NIL THEN result := (actualBase = NIL) OR ~(actualBase IS SyntaxTree.MathArrayType);
- ELSIF actualBase = NIL THEN result := FALSE
- ELSIF formalBase IS SyntaxTree.MathArrayType THEN
- result := MathArrayCompatible(formalBase(SyntaxTree.MathArrayType),actualBase)
- ELSE
- result := SameType(formalBase,actualBase)
- END;
- END;
- ELSE
- result := FALSE
- END;
- RETURN result
- END MathArrayCompatible;
- (**
- Math Array Type distance for assignments / parameter passings of the form
- from -> to
- variants:
- ARRAY [num] | ARRAY [*] | ARRAY [?] -> ARRAY [num] | ARRAY[*] | ARRAY [?]
- allowed:
- static -> static (& size match)
- static -> open
- static -> tensor
- open -> open
- open -> tensor
- open -> static
- tensor -> tensor
- tensor -> open
- tensor -> static
- **)
- (*! think about the metric here: is form matching more important than element type matching? *)
- PROCEDURE MathArrayTypeDistance(system: Global.System; from,to: SyntaxTree.MathArrayType; varpar:BOOLEAN): LONGINT;
- VAR i: LONGINT; fromBase, toBase: SyntaxTree.Type;
- BEGIN
- fromBase := Resolved(from.arrayBase);
- toBase := Resolved(to.arrayBase);
- i := Infinity;
- IF from = to THEN
- i := 0;
- ELSIF (from.form = to.form) THEN
- (* static -> static, open -> open, tensor -> tensor *)
- IF (from.form # SyntaxTree.Static) OR (from.staticLength = to.staticLength) THEN
- IF fromBase = toBase THEN i := 0
- ELSIF toBase = NIL THEN i := 1
- ELSIF (fromBase IS SyntaxTree.MathArrayType) & (toBase IS SyntaxTree.MathArrayType) THEN
- i := MathArrayTypeDistance(system,fromBase(SyntaxTree.MathArrayType),toBase(SyntaxTree.MathArrayType),varpar);
- ELSE
- i := TypeDistance(system,fromBase, toBase, varpar);
- END;
- END;
- ELSIF (to.form = SyntaxTree.Static) THEN
- (* forbidden *)
- ELSIF (from.form = SyntaxTree.Tensor) OR (to.form = SyntaxTree.Tensor) THEN
- (* static -> tensor, open -> tensor, tensor -> open *)
- IF toBase=fromBase THEN i := 0;
- ELSIF toBase = NIL THEN i := 1;
- ELSIF (toBase IS SyntaxTree.MathArrayType) THEN
- toBase := ArrayBase(toBase,Infinity);
- IF (fromBase=toBase) THEN i := 0
- ELSIF (toBase = NIL) THEN i:= 1
- ELSIF (fromBase = NIL) THEN i := Infinity;
- ELSE i := TypeDistance(system,fromBase,toBase,varpar);
- END;
- ELSIF (fromBase IS SyntaxTree.MathArrayType) THEN
- fromBase := ArrayBase(fromBase,Infinity);
- IF (fromBase=toBase) THEN i := 0
- ELSIF (toBase = NIL) THEN i := 1
- ELSIF (fromBase = NIL) THEN i := Infinity;
- ELSE i := TypeDistance(system,fromBase,toBase,varpar);
- END;
- ELSE i := TypeDistance(system, fromBase, toBase, varpar);
- END;
- IF i # Infinity THEN INC(i,2) END;
- ELSIF (from.form = SyntaxTree.Static) THEN
- (* static -> open *)
- IF toBase=fromBase THEN i := 0
- ELSIF toBase = NIL THEN i := 1
- ELSIF fromBase = NIL THEN i := Infinity
- ELSIF (toBase IS SyntaxTree.MathArrayType) & (fromBase IS SyntaxTree.MathArrayType) THEN
- i := MathArrayTypeDistance(system,fromBase(SyntaxTree.MathArrayType),toBase(SyntaxTree.MathArrayType),varpar);
- ELSE i := TypeDistance(system,fromBase, toBase, varpar);
- END;
- IF i # Infinity THEN INC(i,1) END;
- ELSE HALT(100); (* unknown case *)
- END;
- RETURN i;
- END MathArrayTypeDistance;
- (** compute and return the distance of two array types
- - return the distance of the base types
- **)
- PROCEDURE ArrayTypeDistance(system: Global.System; from, to: SyntaxTree.ArrayType): LONGINT;
- VAR i: LONGINT;
- BEGIN
- i := Infinity;
- IF from = to THEN
- i := 0
- ELSE
- i := TypeDistance(system,from.arrayBase.resolved, to.arrayBase.resolved,FALSE);
- (*
- ELSIF (from.mode = static) & (to.mode IN {open}) THEN
- i := TypeDistance(from.base, to.base);
- IF i >= 0 THEN INC(i) END
- ELSIF (from.mode = open) & (to.mode = open) THEN
- i := TypeDistance(from.base, to.base);
- *)
- END;
- RETURN i
- END ArrayTypeDistance;
- (** compute the signature distance of a procedure and an actual parameter list
- - if any of the parameters are not compatible, the result is infinite
- - add up and return the distance over all parameters
- **)
- PROCEDURE Distance(system: Global.System; procedureType: SyntaxTree.ProcedureType; actualParameters: SyntaxTree.ExpressionList): LONGINT;
- VAR result: LONGINT; formalParameter: SyntaxTree.Parameter; actualParameter: SyntaxTree.Expression;
- distance: LONGINT; baseFormal,baseActual, to: SyntaxTree.Type; i: LONGINT;
- BEGIN
- IF actualParameters.Length() # (procedureType.numberParameters) THEN
- result := Infinity
- ELSE
- formalParameter := procedureType.firstParameter;
- i := 0;
- result := 0;
- (*! taken from paco, seems to not be 100% correct, check (in particular array part -> length of arrays??) *)
- WHILE (formalParameter # NIL) & (result # Infinity) DO
- actualParameter := actualParameters.GetExpression(i);
-
-
- ASSERT(formalParameter.type # NIL);
- IF (actualParameter.type = NIL) THEN distance := Infinity
- ELSE
- distance := TypeDistance(system,actualParameter.type.resolved,formalParameter.type.resolved,formalParameter.kind = SyntaxTree.VarParameter);
- END;
- IF distance = Infinity THEN
- result := Infinity;
- ELSE
- to := formalParameter.type.resolved;
- IF (formalParameter.kind = SyntaxTree.VarParameter) & (distance # 0) THEN
- IF (to IS SyntaxTree.MathArrayType) & (actualParameter.type.resolved IS SyntaxTree.MathArrayType) THEN
- (* already handled varpar *)
- (*
- baseActual := actualParameter.type.resolved(SyntaxTree.MathArrayType).arrayBase.resolved;
- baseFormal := to(SyntaxTree.MathArrayType).arrayBase.resolved;
- WHILE(baseActual IS SyntaxTree.MathArrayType) & (baseFormal IS SyntaxTree.MathArrayType) DO
- baseActual := baseActual(SyntaxTree.MathArrayType).arrayBase.resolved;
- baseFormal := baseFormal(SyntaxTree.MathArrayType).arrayBase.resolved;
- END;
- IF TypeDistance(system,baseActual,baseFormal,FALSE) # 0 THEN
- result := Infinity
- END;
- *)
- INC(result, distance);
- ELSIF (to IS SyntaxTree.ArrayType) & (to(SyntaxTree.ArrayType).length = NIL) & (to(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.ByteType) THEN
- INC(result, distance);
- ELSIF (to IS SyntaxTree.ArrayType) & (actualParameter.type.resolved IS SyntaxTree.ArrayType) THEN
- baseActual := actualParameter.type.resolved(SyntaxTree.ArrayType).arrayBase.resolved;
- baseFormal := to(SyntaxTree.ArrayType).arrayBase.resolved;
- WHILE(baseActual IS SyntaxTree.ArrayType) & (baseFormal IS SyntaxTree.ArrayType) DO
- baseActual := baseActual(SyntaxTree.ArrayType).arrayBase.resolved;
- baseFormal := baseFormal(SyntaxTree.ArrayType).arrayBase.resolved;
- END;
- IF TypeDistance(system,baseActual,baseFormal,FALSE) # 0 THEN
- result := Infinity
- END;
- ELSE
- result := Infinity
- END;
- ELSE
- INC(result,distance);
- END;
- END;
- (*
- Printout.Info("actual=", actualParameter);
- Printout.Info("formal=", formalParameter);
- TRACE(result);
- *)
- formalParameter := formalParameter.nextParameter; INC(i);
- END;
- END;
- ASSERT(result >= 0);
- RETURN result
- END Distance;
-
- PROCEDURE ProcedureTypeDistance(system: Global.System; procedureType: SyntaxTree.ProcedureType; right: SyntaxTree.ProcedureType): LONGINT;
- VAR result: LONGINT; formalParameter, rightParameter: SyntaxTree.Parameter; distance: LONGINT; i: LONGINT;
- BEGIN
- IF right.numberParameters # (procedureType.numberParameters) THEN
- result := Infinity
- ELSE
- formalParameter := procedureType.firstParameter;
- rightParameter := right.firstParameter;
- i := 0;
- result := 0;
- (*! taken from paco, seems to not be 100% correct, check (in particular array part -> length of arrays??) *)
- WHILE (formalParameter # NIL) & (result # Infinity) DO
- distance := TypeDistance(system,rightParameter.type.resolved,formalParameter.type.resolved,formalParameter.kind = SyntaxTree.VarParameter);
- IF distance = Infinity THEN
- result := Infinity;
- ELSE
- INC(result,distance);
- END;
- formalParameter := formalParameter.nextParameter;
- rightParameter := rightParameter.nextParameter;
- END;
- END;
- ASSERT(result >= 0);
- RETURN result
- END ProcedureTypeDistance;
- (** compute and return the distance between two types, used for computation of signature distance
- from -> to
- **)
- PROCEDURE TypeDistance(system: Global.System; from, to: SyntaxTree.Type; varpar: BOOLEAN): LONGINT;
- VAR i: LONGINT; ptr: SyntaxTree.PointerType;
- BEGIN
- IF IsArrayStructuredObjectType(from) & (to IS SyntaxTree.MathArrayType) THEN
- RETURN TypeDistance(system, MathArrayStructureOfType(from), to, varpar) + 0; (* TODO: find better value?*)
- END;
- i := Infinity;
- IF from = to THEN
- i := 0
- ELSIF (to = NIL) OR (from=NIL) THEN HALT(100); (* was: SYSTEM.ALL type, removed *)
- ELSIF (from IS SyntaxTree.NilType) OR (to IS SyntaxTree.NilType) THEN
- i := Infinity;
- ELSIF (to IS SyntaxTree.ArrayType) & (to(SyntaxTree.ArrayType).length = NIL) & (to(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.ByteType) THEN
- i := 10;
- ELSIF (from IS SyntaxTree.StringType) THEN
- IF (to IS SyntaxTree.ArrayType) & (to(SyntaxTree.ArrayType).length = NIL) & (to(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.CharacterType) THEN i := 1 END
- ELSIF (from IS SyntaxTree.CharacterType) THEN
- IF (to IS SyntaxTree.CharacterType) & (to.sizeInBits = from.sizeInBits) THEN i := 0
- ELSIF (to IS SyntaxTree.ArrayType) & (to(SyntaxTree.ArrayType).length = NIL) & (to(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.CharacterType) THEN i := 1
- ELSIF to IS SyntaxTree.ByteType THEN i := 1 END
- ELSIF (from IS SyntaxTree.IntegerType) & (to IS SyntaxTree.ByteType) & (to.sizeInBits = from.sizeInBits) THEN
- i := 1
- ELSIF (from IS SyntaxTree.NilType) THEN
- IF (to IS SyntaxTree.AnyType) OR (to IS SyntaxTree.ObjectType) OR (to IS SyntaxTree.PointerType) OR (to IS SyntaxTree.ProcedureType) THEN i := 1 END
- (*
- ELSIF (from = NoType) THEN
- IF (to IS Delegate) THEN i := 1 END (*special case: procedure -> proctype, not resolved yet*)
- *)
- ELSIF (from IS SyntaxTree.BasicType) THEN
- IF to IS SyntaxTree.BasicType THEN i := Global.BasicTypeDistance(system,from(SyntaxTree.BasicType), to(SyntaxTree.BasicType)) END;
- IF varpar & (i # 0) THEN i := Infinity END;
- ELSIF (from IS SyntaxTree.ArrayType) THEN
- IF to IS SyntaxTree.ArrayType THEN i := ArrayTypeDistance(system,from(SyntaxTree.ArrayType), to(SyntaxTree.ArrayType)) END
- ELSIF (from IS SyntaxTree.RecordType) THEN
- IF to IS SyntaxTree.RecordType THEN i := RecordTypeDistance(from(SyntaxTree.RecordType), to (SyntaxTree.RecordType)) END
- ELSIF (from IS SyntaxTree.MathArrayType) THEN
- IF to IS SyntaxTree.MathArrayType THEN
- (*
- IF varpar & (from(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) & (to(SyntaxTree.MathArrayType).form # SyntaxTree.Tensor) THEN
- i := Infinity;
- ELSE
- *)
- i := MathArrayTypeDistance(system,from(SyntaxTree.MathArrayType), to(SyntaxTree.MathArrayType),varpar)
- (*
- END;
- *)
- END
- ELSIF (from IS SyntaxTree.PointerType) THEN
- ptr := from(SyntaxTree.PointerType);
- IF (to IS SyntaxTree.AnyType) THEN i := 1
- ELSIF to IS SyntaxTree.PointerType THEN i := PointerTypeDistance(ptr, to(SyntaxTree.PointerType))
- (* ELSE i := TypeDistance(ptr.base, to); *)
- END
- ELSIF (from IS SyntaxTree.ProcedureType) THEN
- IF (to IS SyntaxTree.ProcedureType) THEN
- i := ProcedureTypeDistance(system, from(SyntaxTree.ProcedureType), to(SyntaxTree.ProcedureType));
- END;
- ELSIF (from IS SyntaxTree.PortType) THEN
- IF (to IS SyntaxTree.PortType) THEN
- IF (to.sizeInBits = from.sizeInBits) & (to(SyntaxTree.PortType).direction = from(SyntaxTree.PortType).direction) THEN
- i := 0;
- END;
- END;
- (*no procedure test, procedure must be the same*)
- END;
- RETURN i
- END TypeDistance;
- PROCEDURE IsIntegerType*(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- RETURN (type # NIL) & ((type IS SyntaxTree.IntegerType) OR (type IS SyntaxTree.AddressType) OR (type IS SyntaxTree.SizeType))
- END IsIntegerType;
- PROCEDURE IsAddressType*(type: SyntaxTree.Type; addressWidth: LONGINT): BOOLEAN;
- BEGIN
- RETURN (type # NIL) & ((type IS SyntaxTree.IntegerType) & (type(SyntaxTree.IntegerType).sizeInBits <= addressWidth) OR (type IS SyntaxTree.AddressType) OR (type IS SyntaxTree.SizeType))
- END IsAddressType;
- PROCEDURE IsSizeType(type: SyntaxTree.Type; addressWidth: LONGINT): BOOLEAN;
- BEGIN
- RETURN (type # NIL) & ((type IS SyntaxTree.IntegerType) & (type(SyntaxTree.IntegerType).sizeInBits <= addressWidth) OR (type IS SyntaxTree.SizeType))
- END IsSizeType;
- PROCEDURE IsSignedIntegerType*(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- RETURN (type # NIL) & (type IS SyntaxTree.IntegerType) & type(SyntaxTree.IntegerType).signed
- END IsSignedIntegerType;
- PROCEDURE IsUnsignedIntegerType*(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- RETURN (type # NIL) & (type IS SyntaxTree.IntegerType) & ~type(SyntaxTree.IntegerType).signed
- END IsUnsignedIntegerType;
- PROCEDURE IsIntegerValue(x: SyntaxTree.Expression; VAR value: LONGINT): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.IntegerValue) THEN
- value := x.resolved(SyntaxTree.IntegerValue).value;
- result := TRUE
- ELSE
- result := FALSE
- END;
- RETURN result
- END IsIntegerValue;
- PROCEDURE IsEnumerationValue(x: SyntaxTree.Expression; VAR value: LONGINT): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.EnumerationValue) THEN
- value := x.resolved(SyntaxTree.EnumerationValue).value;
- result := TRUE
- ELSE
- result := FALSE
- END;
- RETURN result
- END IsEnumerationValue;
- PROCEDURE IsRealValue(x: SyntaxTree.Expression; VAR value: LONGREAL): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.RealValue) THEN
- value := x.resolved(SyntaxTree.RealValue).value;
- result := TRUE
- ELSE
- result := FALSE
- END;
- RETURN result
- END IsRealValue;
- PROCEDURE IsComplexValue(x: SyntaxTree.Expression; VAR realValue, imagValue: LONGREAL): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.ComplexValue) THEN
- realValue := x.resolved(SyntaxTree.ComplexValue).realValue;
- imagValue := x.resolved(SyntaxTree.ComplexValue).imagValue;
- result := TRUE
- ELSE
- result := FALSE
- END;
- RETURN result
- END IsComplexValue;
- PROCEDURE IsCharacterValue(x: SyntaxTree.Expression; VAR value: CHAR): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.CharacterValue) THEN
- value := x.resolved(SyntaxTree.CharacterValue).value;
- result := TRUE
- ELSE
- result := FALSE
- END;
- RETURN result
- END IsCharacterValue;
- PROCEDURE IsBooleanValue*(x: SyntaxTree.Expression; VAR value: BOOLEAN): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.BooleanValue) THEN
- value := x.resolved(SyntaxTree.BooleanValue).value;
- result := TRUE
- ELSE
- result := FALSE
- END;
- RETURN result
- END IsBooleanValue;
- PROCEDURE IsSetValue(x: SyntaxTree.Expression; VAR value: SET): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.SetValue) THEN
- value := x.resolved(SyntaxTree.SetValue).value;
- result := TRUE
- ELSE
- result := FALSE
- END;
- RETURN result
- END IsSetValue;
- PROCEDURE IsStringValue(x: SyntaxTree.Expression; VAR value: Scanner.StringType): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.StringValue) THEN
- value := x.resolved(SyntaxTree.StringValue).value;
- result := TRUE
- ELSE
- result := FALSE
- END;
- RETURN result
- END IsStringValue;
- PROCEDURE Indexable(x: SyntaxTree.Type): BOOLEAN;
- BEGIN
- x := x.resolved;
- RETURN (x IS SyntaxTree.ArrayType) OR (x IS SyntaxTree.MathArrayType);
- END Indexable;
- PROCEDURE SameType(t1,t2: SyntaxTree.Type): BOOLEAN;
- BEGIN
- RETURN t1.SameType(t2.resolved);
- END SameType;
- PROCEDURE ArrayBase*(t: SyntaxTree.Type; max: LONGINT): SyntaxTree.Type;
- BEGIN
- IF t IS SyntaxTree.MathArrayType THEN
- WHILE (t # NIL) & (t IS SyntaxTree.MathArrayType) & ((t(SyntaxTree.MathArrayType).form # SyntaxTree.Tensor) OR (max = Infinity)) & (max > 0) DO
- t := Resolved(t(SyntaxTree.MathArrayType).arrayBase);
- IF (t # NIL) & (t IS SyntaxTree.PointerType) & (t(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.MathArrayType) THEN t := t(SyntaxTree.PointerType).pointerBase.resolved END;
- DEC(max);
- END;
- ELSIF t IS SyntaxTree.ArrayType THEN
- WHILE (t IS SyntaxTree.ArrayType) & (max > 0) DO
- t := t(SyntaxTree.ArrayType).arrayBase.resolved; DEC(max);
- IF (t IS SyntaxTree.PointerType) & (t(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.ArrayType) THEN t := t(SyntaxTree.PointerType).pointerBase.resolved END;
- END;
- END;
- RETURN t;
- END ArrayBase;
- PROCEDURE IsOpenArray*(type: SyntaxTree.Type; VAR base: SyntaxTree.Type): BOOLEAN;
- BEGIN
- type := type.resolved;
- IF (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.Open) THEN
- base := type(SyntaxTree.ArrayType).arrayBase;
- RETURN TRUE;
- END;
- RETURN FALSE;
- END IsOpenArray;
-
- PROCEDURE IsStaticArray*(type: SyntaxTree.Type; VAR base: SyntaxTree.Type; VAR dim :LONGINT): BOOLEAN;
- BEGIN
- type := type.resolved;
- IF (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.Static) THEN
- base := type(SyntaxTree.ArrayType).arrayBase;
- dim := type(SyntaxTree.ArrayType).staticLength;
- RETURN TRUE
- ELSE
- RETURN FALSE
- END;
- END IsStaticArray;
- PROCEDURE IsDynamicArray*(type: SyntaxTree.Type; VAR base: SyntaxTree.Type): BOOLEAN;
- BEGIN
- type := type.resolved;
- IF (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.SemiDynamic) THEN
- base := type(SyntaxTree.ArrayType).arrayBase;
- RETURN TRUE
- ELSE
- RETURN FALSE
- END;
- END IsDynamicArray;
- PROCEDURE Dimension*(t: SyntaxTree.Type; form: SET): LONGINT;
- VAR i: LONGINT;
- BEGIN
- i := 0;
- t := t.resolved;
- IF t IS SyntaxTree.MathArrayType THEN
- WHILE (t # NIL) & (t IS SyntaxTree.MathArrayType) & (t(SyntaxTree.MathArrayType).form IN form) DO
- t := Resolved(t(SyntaxTree.MathArrayType).arrayBase); INC(i);
- END;
- ELSIF t IS SyntaxTree.ArrayType THEN
- WHILE(t IS SyntaxTree.ArrayType) & (t(SyntaxTree.ArrayType).form IN form) DO
- t := t(SyntaxTree.ArrayType).arrayBase.resolved; INC(i);
- END;
- END;
- RETURN i
- END Dimension;
- PROCEDURE IsVariable(expression: SyntaxTree.Expression): BOOLEAN;
- BEGIN
- RETURN expression.assignable;
- END IsVariable;
- PROCEDURE IsVariableParameter*(symbol: SyntaxTree.Symbol): BOOLEAN;
- BEGIN
- IF (symbol IS SyntaxTree.Parameter) THEN
- WITH symbol: SyntaxTree.Parameter DO
- RETURN (symbol.kind = SyntaxTree.VarParameter) OR (symbol.kind = SyntaxTree.ConstParameter) & ((symbol.type.resolved IS SyntaxTree.RecordType) OR (symbol.type.resolved IS SyntaxTree.ArrayType));
- END;
- ELSE
- RETURN FALSE
- END;
- END IsVariableParameter;
- PROCEDURE IsPointerType*(type: SyntaxTree.Type): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- IF type = NIL THEN result := FALSE
- ELSE
- type := type.resolved;
- result := (type IS SyntaxTree.AnyType) OR (type IS SyntaxTree.PointerType) OR (type IS SyntaxTree.NilType) OR (type IS SyntaxTree.ObjectType)
- END;
- RETURN result
- END IsPointerType;
- PROCEDURE IsUnsafePointer*(type: SyntaxTree.Type): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- IF type = NIL THEN result := FALSE
- ELSE
- type := type.resolved;
- result := (type IS SyntaxTree.PointerType) & type(SyntaxTree.PointerType).isUnsafe;
- END;
- RETURN result
- END IsUnsafePointer;
-
- PROCEDURE IsDisposable*(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- RETURN (type # NIL) & (type.resolved IS SyntaxTree.PointerType) & (type.resolved(SyntaxTree.PointerType).isDisposable)
- END IsDisposable;
- PROCEDURE IsPointerToRecord(type: SyntaxTree.Type): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- IF type = NIL THEN result := FALSE
- ELSE
- type := type.resolved;
- result := (type IS SyntaxTree.PointerType) & (type(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType);
- result := result OR (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).pointerType # NIL);
- result := result OR (type IS SyntaxTree.ObjectType);
- END;
- RETURN result
- END IsPointerToRecord;
- PROCEDURE IsPointerToObject(type: SyntaxTree.Type): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- IF type = NIL THEN result := FALSE
- ELSE
- type := type.resolved;
- result := (type IS SyntaxTree.PointerType) & (type(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType)
- & (type(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType).isObject)
- ;
- result := result OR (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).pointerType # NIL);
- result := result OR (type IS SyntaxTree.ObjectType);
- END;
- RETURN result
- END IsPointerToObject;
- PROCEDURE ContainsPointer*(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type # NIL THEN
- RETURN type.resolved.hasPointers
- ELSE
- RETURN FALSE
- END;
- END ContainsPointer;
- PROCEDURE IsStringType*(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE END;
- type := type.resolved;
- RETURN (type IS SyntaxTree.StringType) OR (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.CharacterType);
- END IsStringType;
- PROCEDURE IsCharacterType*(type: SyntaxTree.Type):BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE END;
- type := type.resolved;
- RETURN (type IS SyntaxTree.CharacterType) OR (type IS SyntaxTree.ByteType) OR (type IS SyntaxTree.StringType) & (type(SyntaxTree.StringType).length = 2)
- END IsCharacterType;
- PROCEDURE IsEnumerationType*(type: SyntaxTree.Type):BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE END;
- type := type.resolved;
- RETURN (type IS SyntaxTree.EnumerationType)
- END IsEnumerationType;
- (** cf. section "Type extension (base type)" in the language report **)
- PROCEDURE IsTypeExtension(base,extension: SyntaxTree.Type): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- ASSERT(base # NIL); ASSERT(extension # NIL);
- base := base.resolved; extension := extension.resolved;
- IF ( (base IS SyntaxTree.ObjectType) OR (base IS SyntaxTree.AnyType)) & IsPointerToRecord(extension) THEN
- result := TRUE;
- ELSE
- IF (base IS SyntaxTree.PointerType) & (extension IS SyntaxTree.PointerType) THEN
- base := base(SyntaxTree.PointerType).pointerBase.resolved;
- extension := extension(SyntaxTree.PointerType).pointerBase.resolved;
- END;
- WHILE (extension # NIL) & (extension # base) DO
- IF extension IS SyntaxTree.RecordType THEN
- extension := extension(SyntaxTree.RecordType).baseType;
- IF (extension # NIL) THEN extension := extension.resolved END;
- IF (extension # NIL) & (extension IS SyntaxTree.PointerType) THEN
- extension := extension(SyntaxTree.PointerType).pointerBase.resolved;
- END;
- ELSE extension := NIL;
- END;
- END;
- result := (extension = base) & (extension IS SyntaxTree.RecordType);
- END;
- RETURN result
- END IsTypeExtension;
- (** check if base is the base enumeration type of extension **)
- PROCEDURE IsEnumerationExtension(base,extension: SyntaxTree.Type): BOOLEAN;
- BEGIN
- base := base.resolved; extension := extension.resolved;
- WHILE (extension # NIL) & (extension # base) DO
- IF extension IS SyntaxTree.EnumerationType THEN
- extension := extension(SyntaxTree.EnumerationType).enumerationBase;
- IF extension # NIL THEN extension := extension.resolved END;
- ELSE
- extension := NIL
- END;
- END;
- RETURN (extension = base) & (base IS SyntaxTree.EnumerationType);
- END IsEnumerationExtension;
- PROCEDURE IsCallable(expression: SyntaxTree.Expression): BOOLEAN;
- BEGIN
- IF expression IS SyntaxTree.ProcedureCallDesignator THEN
- RETURN TRUE
- ELSIF expression IS SyntaxTree.BuiltinCallDesignator THEN
- RETURN TRUE
- ELSIF (expression.type # NIL) & (expression.type.resolved IS SyntaxTree.ProcedureType) THEN
- RETURN TRUE
- ELSE
- RETURN FALSE
- END
- END IsCallable;
- (** compute and return the distance of two record types
- returns the number of extension levels of from to to, returns infinite if to is not an extension of from
- **)
- PROCEDURE RecordTypeDistance(from, to: SyntaxTree.RecordType): LONGINT;
- VAR i: LONGINT; baseType: SyntaxTree.Type;
- BEGIN
- i := 0;
- WHILE (from # NIL) & (from # to) DO
- baseType := from.baseType;
- IF (baseType # NIL) THEN
- baseType := baseType.resolved;
- IF baseType IS SyntaxTree.PointerType THEN
- baseType := baseType(SyntaxTree.PointerType).pointerBase.resolved;
- END;
- IF baseType IS SyntaxTree.RecordType THEN
- from := baseType(SyntaxTree.RecordType);
- ELSE
- from := NIL;
- END;
- ELSE
- from := NIL
- END;
- INC(i)
- END;
- IF from = NIL THEN i := Infinity END;
- RETURN i
- END RecordTypeDistance;
- (** compute and return the distance of two pointer types **)
- PROCEDURE PointerTypeDistance(from, to: SyntaxTree.PointerType): LONGINT;
- BEGIN
- IF ~((to.pointerBase.resolved IS SyntaxTree.RecordType) & (from.pointerBase.resolved IS SyntaxTree.RecordType)) THEN
- RETURN Infinity;
- ELSE
- RETURN RecordTypeDistance(from.pointerBase.resolved(SyntaxTree.RecordType), to.pointerBase.resolved(SyntaxTree.RecordType));
- END;
- END PointerTypeDistance;
- (** check if expression contains a symbol designator pointing to a type declaration.
- - if so then enter type declaration into typeDeclaration and return true else return false
- **)
- PROCEDURE IsTypeDesignator(expression: SyntaxTree.Expression; VAR typeDeclaration: SyntaxTree.TypeDeclaration): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- result := FALSE;
- IF (expression # NIL) & (expression.type.resolved = SyntaxTree.typeDeclarationType) THEN
- result := TRUE;
- typeDeclaration := expression(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration)
- END;
- RETURN result
- END IsTypeDesignator;
- (** returns true if type is an extensible type (pointer to record, record, object or any), returns false otherwise **)
- PROCEDURE IsExtensibleType( type: SyntaxTree.Type): BOOLEAN;
- VAR result: BOOLEAN;
- BEGIN
- type := type.resolved;
- IF type IS SyntaxTree.PointerType THEN
- result := IsExtensibleType(type(SyntaxTree.PointerType).pointerBase.resolved);
- ELSIF (type IS SyntaxTree.AnyType) OR (type IS SyntaxTree.ObjectType) THEN
- result := TRUE
- ELSE
- result := type IS SyntaxTree.RecordType
- END;
- RETURN result
- END IsExtensibleType;
- PROCEDURE IsUnextensibleRecord(d: SyntaxTree.Expression): BOOLEAN;
- BEGIN
- RETURN (d.type.resolved IS SyntaxTree.RecordType) &
- (d IS SyntaxTree.SymbolDesignator) &
- ( (d(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Variable)
- OR
- (d(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Parameter) & (d(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Parameter).kind = SyntaxTree.ValueParameter));
- END IsUnextensibleRecord;
- PROCEDURE IsExtensibleDesignator(d: SyntaxTree.Expression): BOOLEAN;
- BEGIN
- IF IsUnextensibleRecord(d) THEN
- RETURN FALSE
- ELSE RETURN IsExtensibleType(d.type.resolved)
- END;
- END IsExtensibleDesignator;
- PROCEDURE IsBasicType(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- type := type.resolved;
- IF (type IS SyntaxTree.PointerType) THEN
- RETURN TRUE
- ELSIF (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).pointerType # NIL) (* object *) THEN
- RETURN TRUE
- ELSIF (type IS SyntaxTree.ProcedureType) THEN
- RETURN TRUE
- ELSIF (type IS SyntaxTree.BasicType) THEN
- RETURN TRUE
- END;
- RETURN FALSE
- END IsBasicType;
- PROCEDURE RecordBase*(record: SyntaxTree.RecordType): SyntaxTree.RecordType;
- VAR baseType: SyntaxTree.Type; recordType: SyntaxTree.RecordType;
- BEGIN
- baseType := record.baseType;
- IF (baseType # NIL) THEN
- baseType := baseType.resolved;
- IF (baseType IS SyntaxTree.PointerType) THEN
- baseType := baseType(SyntaxTree.PointerType).pointerBase.resolved;
- END;
- END;
- IF (baseType # NIL) & (baseType IS SyntaxTree.RecordType) THEN
- recordType := baseType(SyntaxTree.RecordType);
- ELSE
- recordType := NIL;
- END;
- RETURN recordType
- END RecordBase;
- PROCEDURE FindSuperProcedure*(scope: SyntaxTree.RecordScope; procedure: SyntaxTree.Procedure): SyntaxTree.Procedure;
- VAR super: SyntaxTree.Procedure; operator: SyntaxTree.Operator; procedureType: SyntaxTree.Type; baseRecord: SyntaxTree.RecordType;
- BEGIN
- baseRecord := RecordBase(scope.ownerRecord);
- IF baseRecord = NIL THEN RETURN NIL END;
- scope := baseRecord.recordScope;
- procedureType := procedure.type.resolved;
- IF procedure IS SyntaxTree.Operator THEN
- operator := scope.firstOperator;
- WHILE (operator # NIL) & ((operator.name # procedure.name) OR ~SameType(procedureType, operator.type)) DO
- (*
- Printout.Info("not same ",procedureType);
- Printout.Info("with ",operator.type);
- *)
- operator := operator.nextOperator;
- END;
- super := operator;
- ELSE
- super := scope.firstProcedure;
- WHILE (super # NIL) & (super.name # procedure.name) DO
- super := super.nextProcedure;
- END;
- END;
- IF (super # NIL) & ((super.scope.ownerModule = procedure.scope.ownerModule) OR (SyntaxTree.Public * super.access # {})) THEN
- RETURN super
- ELSIF (super # NIL) & (FindSuperProcedure(scope,procedure)#NIL) THEN (* check if there is an exported supermethod, in which case return (non-exported) supermethod *)
- RETURN super
- ELSE
- RETURN FindSuperProcedure(scope,procedure);
- END;
- END FindSuperProcedure;
- PROCEDURE GetConstructor(record: SyntaxTree.RecordType): SyntaxTree.Procedure;
- VAR procedure: SyntaxTree.Procedure;
- BEGIN
- procedure := record.recordScope.constructor;
- IF procedure = NIL THEN
- record := RecordBase(record);
- IF record # NIL THEN
- procedure := GetConstructor(record)
- END;
- END;
- RETURN procedure;
- END GetConstructor;
- (* enter a case into a list of cases in a sorted way and check for collision *)
- PROCEDURE EnterCase(VAR root: SyntaxTree.CaseConstant; min,max: LONGINT): BOOLEAN;
- VAR prev,this,new: SyntaxTree.CaseConstant;
- BEGIN
- this := root;
- prev := NIL;
- WHILE (this # NIL) & (min > this.max) DO prev := this; this := this.next END;
- IF (this # NIL) & (max >= this.min) THEN (* collision since min <= this.max and max >= this.min *)
- RETURN FALSE
- ELSE
- IF (this # NIL) & (this.min = max+1) THEN
- this.min := min
- ELSIF (prev # NIL) & (min+1 = prev.max) THEN
- prev.max := min
- ELSE
- NEW(new); new.min := min; new.max := max;
- new.next := this;
- IF prev = NIL THEN
- root := new;
- ELSE
- prev.next := new
- END
- END;
- RETURN TRUE
- END;
- END EnterCase;
- (** generate and return a new checker object, errors are entered into diagnostics **)
- PROCEDURE NewChecker*(diagnostics: Diagnostics.Diagnostics; verboseErrorMessage,useDarwinCCalls,cooperative: BOOLEAN; system: Global.System; symbolFileFormat: Formats.SymbolFileFormat; VAR importCache: SyntaxTree.ModuleScope; CONST backend: ARRAY OF CHAR): Checker;
- VAR checker: Checker;
- BEGIN
- NEW(checker, diagnostics,verboseErrorMessage,useDarwinCCalls,cooperative,system,symbolFileFormat,importCache,backend);
- RETURN checker
- END NewChecker;
- PROCEDURE NewWarnings*(diagnostics: Diagnostics.Diagnostics): Warnings;
- VAR warnings: Warnings;
- BEGIN
- NEW(warnings, diagnostics); RETURN warnings;
- END NewWarnings;
- PROCEDURE IsRangeType(type: SyntaxTree.Type): BOOLEAN;
- BEGIN RETURN (type # NIL) & (type.resolved IS SyntaxTree.RangeType);
- END IsRangeType;
- PROCEDURE IsMathArrayType(type: SyntaxTree.Type): BOOLEAN;
- BEGIN RETURN (type # NIL) & (type.resolved IS SyntaxTree.MathArrayType);
- END IsMathArrayType;
- PROCEDURE IsArrayType(type: SyntaxTree.Type): BOOLEAN;
- BEGIN RETURN (type # NIL) & (type.resolved IS SyntaxTree.ArrayType);
- END IsArrayType;
- PROCEDURE IsComplexType(type: SyntaxTree.Type): BOOLEAN;
- BEGIN RETURN (type # NIL) & (type.resolved IS SyntaxTree.ComplexType);
- END IsComplexType;
- (** if a type is an array-structured object type *)
- PROCEDURE IsArrayStructuredObjectType*(type: SyntaxTree.Type): BOOLEAN;
- VAR recordType: SyntaxTree.RecordType;
- BEGIN
- IF type = NIL THEN
- RETURN FALSE
- ELSE
- type := type.resolved;
- IF type IS SyntaxTree.PointerType THEN
- type := type(SyntaxTree.PointerType).pointerBase.resolved;
- IF type IS SyntaxTree.RecordType THEN
- recordType := type(SyntaxTree.RecordType);
- RETURN recordType.isObject & recordType.HasArrayStructure()
- ELSE
- RETURN FALSE
- END
- ELSE
- RETURN FALSE
- END
- END
- END IsArrayStructuredObjectType;
- (** the math array structure of a type
- - for math arrays: the array itself
- - for pointers: the math array structure of the pointer base
- - for array-structured object types: the underlying structure
- - for non-math arrays and all other types: NIL
- **)
- PROCEDURE MathArrayStructureOfType(type: SyntaxTree.Type): SyntaxTree.MathArrayType;
- VAR
- result: SyntaxTree.MathArrayType;
- BEGIN
- IF type = NIL THEN
- result := NIL
- ELSE
- type := type.resolved;
- IF type IS SyntaxTree.PointerType THEN
- type := type(SyntaxTree.PointerType).pointerBase.resolved;
- END;
- IF type IS SyntaxTree.MathArrayType THEN
- result := type(SyntaxTree.MathArrayType)
- ELSIF type IS SyntaxTree.RecordType THEN
- result := type(SyntaxTree.RecordType).arrayStructure
- ELSE
- result := NIL
- END
- END;
- RETURN result
- END MathArrayStructureOfType;
- PROCEDURE IsStaticRange(x: SyntaxTree.Expression; VAR firstValue, lastValue, stepValue: LONGINT): BOOLEAN;
- VAR
- result: BOOLEAN;
- rangeExpression: SyntaxTree.RangeExpression;
- BEGIN
- IF x IS SyntaxTree.RangeExpression THEN
- rangeExpression := x(SyntaxTree.RangeExpression);
- result := TRUE;
- IF ~IsIntegerValue(rangeExpression.first, firstValue) THEN result := FALSE END;
- IF ~IsIntegerValue(rangeExpression.last, lastValue) THEN result := FALSE END;
- IF ~IsIntegerValue(rangeExpression.step, stepValue) THEN result := FALSE END
- ELSE
- result := FALSE
- END;
- RETURN result
- END IsStaticRange;
- (** whether a type is a math array of tensor form **)
- PROCEDURE IsTensor(type: SyntaxTree.Type): BOOLEAN;
- BEGIN RETURN (type.resolved IS SyntaxTree.MathArrayType) & (type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor)
- END IsTensor;
- PROCEDURE IsStaticMathArray*(type: SyntaxTree.Type; VAR length: LONGINT; VAR baseType: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF (type IS SyntaxTree.MathArrayType) & (type(SyntaxTree.MathArrayType).form = SyntaxTree.Static) THEN
- length := type(SyntaxTree.MathArrayType).staticLength;
- baseType := type(SyntaxTree.MathArrayType).arrayBase.resolved;
- RETURN TRUE
- ELSE
- RETURN FALSE
- END;
- END IsStaticMathArray;
- PROCEDURE SymbolHasAddress*(symbol: SyntaxTree.Symbol): BOOLEAN;
- BEGIN
- RETURN (symbol IS SyntaxTree.Variable) OR (symbol IS SyntaxTree.Parameter) OR (symbol IS SyntaxTree.Procedure)
- END SymbolHasAddress;
- PROCEDURE HasAddress*(expression: SyntaxTree.Expression): BOOLEAN;
- BEGIN
- RETURN
- (expression # NIL) & (expression IS SyntaxTree.SymbolDesignator) & SymbolHasAddress(expression(SyntaxTree.SymbolDesignator).symbol) OR (expression IS SyntaxTree.ResultDesignator)
- OR (expression IS SyntaxTree.IndexDesignator) OR (expression IS SyntaxTree.DereferenceDesignator)
- OR (expression IS SyntaxTree.TypeGuardDesignator) OR (expression IS SyntaxTree.StringValue)
- OR (expression IS SyntaxTree.StatementDesignator) & HasAddress(expression(SyntaxTree.StatementDesignator).result)
- OR (expression IS SyntaxTree.BuiltinCallDesignator) & (expression(SyntaxTree.BuiltinCallDesignator).id = Global.systemVal) & HasAddress(expression(SyntaxTree.BuiltinCallDesignator).parameters.GetExpression(1))
- ;
- END HasAddress;
-
- PROCEDURE IsLocalVariable*(e: SyntaxTree.Expression): BOOLEAN;
- VAR d: SyntaxTree.Designator; symbol: SyntaxTree.Symbol;
- BEGIN
- IF (e IS SyntaxTree.Designator) THEN
- d := e(SyntaxTree.Designator);
- WHILE (d # NIL) & ~(d IS SyntaxTree.SymbolDesignator) DO
- IF d IS SyntaxTree.DereferenceDesignator THEN (* on heap *) RETURN FALSE END;
- e := d.left;
- IF (e # NIL) & (e IS SyntaxTree.Designator) THEN d := e(SyntaxTree.Designator) ELSE d := NIL END;
- END;
- IF d # NIL THEN
- symbol := d(SyntaxTree.SymbolDesignator).symbol;
- RETURN (symbol.scope IS SyntaxTree.ProcedureScope) & (symbol.externalName = NIL);
- END;
- END;
- RETURN FALSE;
- END IsLocalVariable;
- PROCEDURE IsStaticProcedure*(procedure: SyntaxTree.Procedure): BOOLEAN;
- BEGIN
- IF procedure.scope IS SyntaxTree.RecordScope THEN
- RETURN (procedure.super = NIL) & ((procedure.isFinal) OR (procedure.access * SyntaxTree.Public = {}) & ~procedure.isOverwritten)
- ELSE
- RETURN TRUE
- END;
- END IsStaticProcedure;
- PROCEDURE InMethodTable*(procedure: SyntaxTree.Procedure): BOOLEAN;
- CONST OptimizeMethodTable = FALSE;
- BEGIN
- RETURN ~OptimizeMethodTable OR IsStaticProcedure(procedure)
- END InMethodTable;
-
- PROCEDURE ReturnedAsParameter*(type: SyntaxTree.Type): BOOLEAN;
- BEGIN
- IF type = NIL THEN RETURN FALSE
- ELSE
- type := type.resolved;
- RETURN (type IS SyntaxTree.RecordType) OR (type IS SyntaxTree.RangeType) OR (type IS SyntaxTree.ComplexType) OR (type IS SyntaxTree.ProcedureType) OR IsPointerType(type)
- OR (type IS SyntaxTree.ArrayType) OR (type IS SyntaxTree.MathArrayType);
- END
- END ReturnedAsParameter;
- PROCEDURE StructuredReturnType*(procedureType: SyntaxTree.ProcedureType): BOOLEAN;
- BEGIN
- RETURN (procedureType # NIL) & (procedureType.callingConvention=SyntaxTree.OberonCallingConvention) & ReturnedAsParameter(procedureType.returnType);
- END StructuredReturnType;
- END FoxSemanticChecker.
- SystemTools.FreeDownTo FoxSemanticChecker ~
|