FoxArrayBase.Mod 338 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695469646974698469947004701470247034704470547064707470847094710471147124713471447154716471747184719472047214722472347244725472647274728472947304731473247334734473547364737473847394740474147424743474447454746474747484749475047514752475347544755475647574758475947604761476247634764476547664767476847694770477147724773477447754776477747784779478047814782478347844785478647874788478947904791479247934794479547964797479847994800480148024803480448054806480748084809481048114812481348144815481648174818481948204821482248234824482548264827482848294830483148324833483448354836483748384839484048414842484348444845484648474848484948504851485248534854485548564857485848594860486148624863486448654866486748684869487048714872487348744875487648774878487948804881488248834884488548864887488848894890489148924893489448954896489748984899490049014902490349044905490649074908490949104911491249134914491549164917491849194920492149224923492449254926492749284929493049314932493349344935493649374938493949404941494249434944494549464947494849494950495149524953495449554956495749584959496049614962496349644965496649674968496949704971497249734974497549764977497849794980498149824983498449854986498749884989499049914992499349944995499649974998499950005001500250035004500550065007500850095010501150125013501450155016501750185019502050215022502350245025502650275028502950305031503250335034503550365037503850395040504150425043504450455046504750485049505050515052505350545055505650575058505950605061506250635064506550665067506850695070507150725073507450755076507750785079508050815082508350845085508650875088508950905091509250935094509550965097509850995100510151025103510451055106510751085109511051115112511351145115511651175118511951205121512251235124512551265127512851295130513151325133513451355136513751385139514051415142514351445145514651475148514951505151515251535154515551565157515851595160516151625163516451655166516751685169517051715172517351745175517651775178517951805181518251835184518551865187518851895190519151925193519451955196519751985199520052015202520352045205520652075208520952105211521252135214521552165217521852195220522152225223522452255226522752285229523052315232523352345235523652375238523952405241524252435244524552465247524852495250525152525253525452555256525752585259526052615262526352645265526652675268526952705271527252735274527552765277527852795280528152825283528452855286528752885289529052915292529352945295529652975298529953005301530253035304530553065307530853095310531153125313531453155316531753185319532053215322532353245325532653275328532953305331533253335334533553365337533853395340534153425343534453455346534753485349535053515352535353545355535653575358535953605361536253635364536553665367536853695370537153725373537453755376537753785379538053815382538353845385538653875388538953905391539253935394539553965397539853995400540154025403540454055406540754085409541054115412541354145415541654175418541954205421542254235424542554265427542854295430543154325433543454355436543754385439544054415442544354445445544654475448544954505451545254535454545554565457545854595460546154625463546454655466546754685469547054715472547354745475547654775478547954805481548254835484548554865487548854895490549154925493549454955496549754985499550055015502550355045505550655075508550955105511551255135514551555165517551855195520552155225523552455255526552755285529553055315532553355345535553655375538553955405541554255435544554555465547554855495550555155525553555455555556555755585559556055615562556355645565556655675568556955705571557255735574557555765577557855795580558155825583558455855586558755885589559055915592559355945595559655975598559956005601560256035604560556065607560856095610561156125613561456155616561756185619562056215622562356245625562656275628562956305631563256335634563556365637563856395640564156425643564456455646564756485649565056515652565356545655565656575658565956605661566256635664566556665667566856695670567156725673567456755676567756785679568056815682568356845685568656875688568956905691569256935694569556965697569856995700570157025703570457055706570757085709571057115712571357145715571657175718571957205721572257235724572557265727572857295730573157325733573457355736573757385739574057415742574357445745574657475748574957505751575257535754575557565757575857595760576157625763576457655766576757685769577057715772577357745775577657775778577957805781578257835784578557865787578857895790579157925793579457955796579757985799580058015802580358045805580658075808580958105811581258135814581558165817581858195820582158225823582458255826582758285829583058315832583358345835583658375838583958405841584258435844584558465847584858495850585158525853585458555856585758585859586058615862586358645865586658675868586958705871587258735874587558765877587858795880588158825883588458855886588758885889589058915892589358945895589658975898589959005901590259035904590559065907590859095910591159125913591459155916591759185919592059215922592359245925592659275928592959305931593259335934593559365937593859395940594159425943594459455946594759485949595059515952595359545955595659575958595959605961596259635964596559665967596859695970597159725973597459755976597759785979598059815982598359845985598659875988598959905991599259935994599559965997599859996000600160026003600460056006600760086009601060116012601360146015601660176018601960206021602260236024602560266027602860296030603160326033603460356036603760386039604060416042604360446045604660476048604960506051605260536054605560566057605860596060606160626063606460656066606760686069607060716072607360746075607660776078607960806081608260836084608560866087608860896090609160926093609460956096609760986099610061016102610361046105610661076108610961106111611261136114611561166117611861196120612161226123612461256126612761286129613061316132613361346135613661376138613961406141614261436144614561466147614861496150615161526153615461556156615761586159616061616162616361646165616661676168616961706171617261736174617561766177617861796180618161826183618461856186618761886189619061916192619361946195619661976198619962006201620262036204620562066207620862096210621162126213621462156216621762186219622062216222622362246225622662276228622962306231623262336234623562366237623862396240624162426243624462456246624762486249625062516252625362546255625662576258625962606261626262636264626562666267626862696270627162726273627462756276627762786279628062816282628362846285628662876288628962906291629262936294629562966297629862996300630163026303630463056306630763086309631063116312631363146315631663176318631963206321632263236324632563266327632863296330633163326333633463356336633763386339634063416342634363446345634663476348634963506351635263536354635563566357635863596360636163626363636463656366636763686369637063716372637363746375637663776378637963806381638263836384638563866387638863896390639163926393639463956396639763986399640064016402640364046405640664076408640964106411641264136414641564166417641864196420642164226423642464256426642764286429643064316432643364346435643664376438643964406441644264436444644564466447644864496450645164526453645464556456645764586459646064616462646364646465646664676468646964706471647264736474647564766477647864796480648164826483648464856486648764886489649064916492649364946495649664976498649965006501650265036504650565066507650865096510651165126513651465156516651765186519652065216522652365246525652665276528652965306531653265336534653565366537653865396540654165426543654465456546654765486549655065516552655365546555655665576558655965606561656265636564656565666567656865696570657165726573657465756576657765786579658065816582658365846585658665876588658965906591659265936594659565966597659865996600660166026603660466056606660766086609661066116612661366146615661666176618661966206621662266236624662566266627662866296630663166326633663466356636663766386639664066416642664366446645664666476648664966506651665266536654665566566657665866596660666166626663666466656666666766686669667066716672667366746675667666776678667966806681668266836684668566866687668866896690669166926693669466956696669766986699670067016702670367046705670667076708670967106711671267136714671567166717671867196720672167226723672467256726672767286729673067316732673367346735673667376738673967406741674267436744674567466747674867496750675167526753675467556756675767586759676067616762676367646765676667676768676967706771677267736774677567766777677867796780678167826783678467856786678767886789679067916792679367946795679667976798679968006801680268036804680568066807680868096810681168126813681468156816681768186819682068216822682368246825682668276828682968306831683268336834683568366837683868396840684168426843684468456846684768486849685068516852685368546855685668576858685968606861686268636864686568666867686868696870687168726873687468756876687768786879688068816882688368846885688668876888688968906891689268936894689568966897689868996900690169026903690469056906690769086909691069116912691369146915691669176918691969206921692269236924692569266927692869296930693169326933693469356936693769386939694069416942694369446945694669476948694969506951695269536954695569566957695869596960696169626963696469656966696769686969697069716972697369746975697669776978697969806981698269836984698569866987698869896990699169926993699469956996699769986999700070017002700370047005700670077008700970107011701270137014701570167017701870197020702170227023702470257026702770287029703070317032703370347035703670377038703970407041704270437044704570467047704870497050705170527053705470557056705770587059706070617062706370647065706670677068706970707071707270737074707570767077707870797080708170827083708470857086708770887089709070917092709370947095709670977098709971007101710271037104710571067107710871097110711171127113711471157116711771187119712071217122712371247125712671277128712971307131713271337134713571367137713871397140714171427143714471457146714771487149715071517152715371547155715671577158715971607161716271637164716571667167716871697170717171727173717471757176717771787179718071817182718371847185718671877188718971907191719271937194719571967197719871997200720172027203720472057206720772087209721072117212721372147215721672177218721972207221722272237224722572267227722872297230723172327233723472357236723772387239724072417242724372447245724672477248724972507251725272537254725572567257725872597260726172627263726472657266726772687269727072717272727372747275727672777278727972807281728272837284728572867287728872897290729172927293729472957296729772987299730073017302730373047305730673077308730973107311731273137314731573167317731873197320732173227323732473257326732773287329733073317332733373347335733673377338733973407341734273437344734573467347734873497350735173527353735473557356735773587359736073617362736373647365736673677368736973707371737273737374737573767377737873797380738173827383738473857386738773887389739073917392739373947395739673977398739974007401740274037404740574067407740874097410741174127413741474157416741774187419742074217422742374247425742674277428742974307431743274337434743574367437743874397440744174427443744474457446744774487449745074517452745374547455745674577458745974607461746274637464746574667467746874697470747174727473747474757476747774787479748074817482748374847485748674877488748974907491749274937494749574967497749874997500750175027503750475057506750775087509751075117512751375147515751675177518751975207521752275237524752575267527752875297530753175327533753475357536753775387539754075417542754375447545754675477548754975507551755275537554755575567557755875597560756175627563756475657566756775687569757075717572757375747575757675777578757975807581758275837584758575867587758875897590759175927593759475957596759775987599760076017602760376047605760676077608760976107611761276137614761576167617761876197620762176227623762476257626762776287629763076317632763376347635763676377638763976407641764276437644764576467647764876497650765176527653765476557656765776587659766076617662766376647665766676677668766976707671767276737674767576767677767876797680768176827683768476857686768776887689769076917692769376947695769676977698769977007701770277037704770577067707770877097710771177127713771477157716771777187719772077217722772377247725772677277728772977307731773277337734773577367737773877397740774177427743774477457746774777487749775077517752775377547755775677577758775977607761776277637764776577667767776877697770777177727773777477757776777777787779778077817782778377847785778677877788778977907791779277937794779577967797779877997800780178027803780478057806780778087809781078117812781378147815781678177818781978207821782278237824782578267827782878297830783178327833783478357836783778387839784078417842784378447845784678477848784978507851785278537854785578567857785878597860786178627863786478657866786778687869787078717872787378747875787678777878787978807881788278837884788578867887788878897890789178927893789478957896789778987899790079017902790379047905790679077908790979107911791279137914791579167917791879197920792179227923792479257926792779287929793079317932793379347935793679377938793979407941794279437944794579467947794879497950795179527953795479557956795779587959796079617962796379647965796679677968796979707971797279737974797579767977797879797980798179827983798479857986798779887989799079917992799379947995799679977998799980008001800280038004800580068007800880098010801180128013801480158016801780188019802080218022802380248025802680278028802980308031803280338034803580368037803880398040804180428043804480458046804780488049805080518052805380548055805680578058805980608061806280638064806580668067806880698070807180728073807480758076807780788079808080818082808380848085808680878088808980908091809280938094809580968097809880998100810181028103810481058106810781088109811081118112811381148115811681178118811981208121812281238124812581268127812881298130813181328133813481358136813781388139814081418142814381448145814681478148814981508151815281538154815581568157815881598160816181628163816481658166816781688169817081718172817381748175817681778178817981808181818281838184818581868187818881898190819181928193819481958196819781988199820082018202820382048205820682078208820982108211821282138214821582168217821882198220822182228223822482258226822782288229823082318232823382348235823682378238823982408241824282438244824582468247824882498250825182528253825482558256825782588259826082618262826382648265826682678268826982708271827282738274827582768277827882798280828182828283828482858286828782888289829082918292829382948295829682978298829983008301830283038304830583068307830883098310831183128313831483158316831783188319832083218322832383248325832683278328832983308331833283338334833583368337833883398340834183428343834483458346834783488349835083518352835383548355835683578358835983608361836283638364836583668367836883698370837183728373837483758376837783788379838083818382838383848385838683878388838983908391839283938394839583968397839883998400840184028403840484058406840784088409841084118412841384148415841684178418841984208421842284238424842584268427842884298430843184328433843484358436843784388439844084418442844384448445844684478448844984508451845284538454845584568457845884598460846184628463846484658466846784688469847084718472847384748475847684778478847984808481848284838484848584868487848884898490849184928493849484958496849784988499850085018502850385048505850685078508850985108511851285138514851585168517851885198520852185228523852485258526852785288529853085318532853385348535853685378538853985408541854285438544854585468547854885498550855185528553855485558556855785588559856085618562856385648565856685678568856985708571857285738574857585768577857885798580858185828583858485858586858785888589859085918592859385948595859685978598859986008601860286038604860586068607860886098610861186128613861486158616861786188619862086218622862386248625862686278628862986308631863286338634863586368637863886398640864186428643864486458646864786488649865086518652865386548655865686578658865986608661866286638664866586668667866886698670867186728673867486758676867786788679868086818682868386848685868686878688868986908691869286938694869586968697869886998700870187028703870487058706870787088709871087118712871387148715871687178718871987208721872287238724872587268727872887298730873187328733873487358736873787388739874087418742874387448745874687478748874987508751875287538754875587568757875887598760876187628763876487658766876787688769877087718772877387748775877687778778877987808781878287838784878587868787878887898790879187928793879487958796879787988799880088018802880388048805880688078808880988108811881288138814881588168817881888198820882188228823882488258826882788288829883088318832883388348835883688378838883988408841884288438844884588468847884888498850885188528853885488558856885788588859886088618862886388648865886688678868886988708871887288738874887588768877887888798880888188828883888488858886888788888889889088918892889388948895889688978898889989008901890289038904890589068907890889098910891189128913891489158916891789188919892089218922892389248925892689278928892989308931893289338934893589368937893889398940894189428943894489458946894789488949895089518952895389548955895689578958895989608961896289638964896589668967896889698970897189728973897489758976897789788979898089818982898389848985898689878988898989908991899289938994899589968997899889999000900190029003900490059006900790089009901090119012901390149015901690179018901990209021902290239024902590269027902890299030903190329033903490359036903790389039904090419042904390449045904690479048904990509051905290539054905590569057905890599060906190629063906490659066906790689069907090719072907390749075907690779078907990809081908290839084908590869087908890899090909190929093909490959096909790989099910091019102910391049105910691079108910991109111911291139114911591169117911891199120912191229123912491259126912791289129913091319132913391349135913691379138913991409141914291439144914591469147914891499150915191529153915491559156915791589159916091619162916391649165916691679168916991709171917291739174917591769177917891799180918191829183918491859186918791889189919091919192919391949195919691979198919992009201920292039204920592069207920892099210921192129213921492159216921792189219922092219222922392249225922692279228922992309231923292339234923592369237923892399240924192429243924492459246924792489249925092519252925392549255925692579258925992609261926292639264926592669267926892699270927192729273927492759276927792789279928092819282928392849285928692879288928992909291929292939294929592969297929892999300930193029303930493059306930793089309931093119312931393149315931693179318931993209321932293239324932593269327932893299330933193329333933493359336933793389339934093419342934393449345934693479348934993509351935293539354935593569357935893599360936193629363936493659366936793689369937093719372937393749375937693779378937993809381938293839384938593869387938893899390939193929393939493959396939793989399940094019402940394049405940694079408940994109411941294139414941594169417941894199420942194229423942494259426942794289429943094319432943394349435943694379438943994409441944294439444944594469447944894499450945194529453945494559456945794589459946094619462946394649465946694679468946994709471947294739474947594769477947894799480948194829483948494859486948794889489949094919492949394949495949694979498949995009501950295039504950595069507950895099510951195129513951495159516951795189519952095219522952395249525952695279528952995309531953295339534953595369537953895399540954195429543954495459546954795489549955095519552955395549555955695579558955995609561956295639564956595669567956895699570957195729573957495759576957795789579958095819582958395849585958695879588958995909591959295939594959595969597959895999600960196029603960496059606960796089609961096119612961396149615961696179618961996209621962296239624962596269627962896299630963196329633963496359636963796389639964096419642964396449645964696479648964996509651965296539654965596569657965896599660966196629663966496659666966796689669967096719672967396749675967696779678967996809681968296839684968596869687968896899690969196929693969496959696969796989699970097019702970397049705970697079708970997109711971297139714971597169717971897199720972197229723972497259726972797289729973097319732973397349735973697379738973997409741974297439744974597469747974897499750975197529753975497559756975797589759976097619762976397649765976697679768976997709771977297739774977597769777977897799780978197829783978497859786978797889789979097919792979397949795979697979798979998009801980298039804980598069807980898099810981198129813981498159816981798189819982098219822982398249825982698279828982998309831983298339834983598369837983898399840984198429843984498459846984798489849985098519852985398549855985698579858985998609861986298639864986598669867986898699870987198729873987498759876987798789879988098819882988398849885988698879888988998909891989298939894989598969897989898999900990199029903990499059906990799089909991099119912991399149915991699179918991999209921992299239924992599269927992899299930993199329933993499359936993799389939994099419942994399449945994699479948994999509951995299539954995599569957995899599960996199629963996499659966996799689969997099719972997399749975997699779978997999809981998299839984998599869987998899899990999199929993999499959996999799989999100001000110002100031000410005100061000710008100091001010011100121001310014100151001610017100181001910020100211002210023100241002510026100271002810029100301003110032100331003410035100361003710038100391004010041100421004310044100451004610047100481004910050100511005210053100541005510056100571005810059100601006110062100631006410065100661006710068100691007010071100721007310074100751007610077100781007910080100811008210083100841008510086100871008810089100901009110092100931009410095100961009710098100991010010101101021010310104101051010610107101081010910110101111011210113101141011510116101171011810119101201012110122101231012410125101261012710128101291013010131101321013310134101351013610137101381013910140101411014210143101441014510146101471014810149101501015110152101531015410155101561015710158101591016010161101621016310164101651016610167
  1. MODULE FoxArrayBase; (* stubs for array base runtime - can only be compiled by oc compiler *)
  2. (* (c) fof, fn, ETH Zürich, 2008 *)
  3. (*! do do: MAX(array,scalar) and MAX(array,array) for all datatypes*)
  4. IMPORT SYSTEM, KernelLog, Heaps, Math, MathL;
  5. TYPE
  6. GenericUnaryAALoopS = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: SHORTINT): SHORTINT );
  7. GenericUnaryAALoopI = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: INTEGER): INTEGER );
  8. GenericUnaryAALoopL = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: LONGINT): LONGINT );
  9. GenericUnaryAALoopH = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: HUGEINT): HUGEINT );
  10. GenericUnaryAALoopR = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: REAL): REAL );
  11. GenericUnaryAALoopX = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: LONGREAL): LONGREAL );
  12. GenericUnaryAALoopZ = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: COMPLEX): COMPLEX );
  13. GenericUnaryAALoopLZ = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: LONGCOMPLEX): LONGCOMPLEX );
  14. UnaryAALoop = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  15. UnaryASLoop = PROCEDURE ( ladr, dadr: ADDRESS; linc, len: SIZE );
  16. UnarySALoop = PROCEDURE ( ladr, dadr: ADDRESS; dinc, len: SIZE );
  17. BinaryAAALoop = PROCEDURE ( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  18. BinaryASALoop = PROCEDURE ( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  19. BinaryAASLoop = PROCEDURE ( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  20. BinaryAABLoop = PROCEDURE ( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  21. BinaryASBLoop = PROCEDURE ( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  22. CONST
  23. debug = FALSE; (* warning: debug=true -> a lot of output is generated -> traps are not displayed in Oberon (Kernel overflow) *)
  24. statistics= FALSE;
  25. conservative=TRUE;
  26. ArrDataArrayOffset=ADDRESS(16); (* offset of data in array with pointers *)
  27. AddressSize=SIZEOF(ADDRESS);
  28. MathPtrOffset=0*AddressSize;
  29. MathAdrOffset=1*AddressSize;
  30. MathFlagsOffset=2*AddressSize;
  31. MathDimOffset=3*AddressSize;
  32. MathElementSizeOffset=4*AddressSize;
  33. MathLenOffset=5*AddressSize;
  34. MathIncrOffset=6*AddressSize;
  35. GeometryMismatch = 400;
  36. DimensionMismatch=401;
  37. AllocationForbidden=402;
  38. TensorFlag = 0; RangeFlag = 1; TemporaryFlag = 2;
  39. down = 0; up = 1; (* memory copy modes *)
  40. (* flags for optimizations with small matricies and vectors (Alexey Morozov) *)
  41. SmallMatrixFlag = 3; (* flag for identification of a small matrix *)
  42. SmallVectorFlag = 3; (* flag for identification of a small vector *)
  43. Size2Flag = 4; (* size = 2 *)
  44. Size3Flag = 5; (* size = 3 *)
  45. Size4Flag = 6; (* size = 4 *)
  46. Size5Flag = 7; (* size = 5 *)
  47. Size6Flag = 8; (* size = 6 *)
  48. Size7Flag = 9; (* size = 7 *)
  49. Size8Flag = 10; (* size = 8 *)
  50. Mat2x2 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,Size2Flag});
  51. Mat3x3 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,Size3Flag});
  52. Mat4x4 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,Size4Flag});
  53. Mat5x5 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,Size5Flag});
  54. Mat6x6 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,Size6Flag});
  55. Mat7x7 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,Size7Flag});
  56. Mat8x8 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,Size8Flag});
  57. Vec2 = SYSTEM.VAL(LONGINT,{SmallVectorFlag,Size2Flag});
  58. Vec3 = SYSTEM.VAL(LONGINT,{SmallVectorFlag,Size3Flag});
  59. Vec4 = SYSTEM.VAL(LONGINT,{SmallVectorFlag,Size4Flag});
  60. Vec5 = SYSTEM.VAL(LONGINT,{SmallVectorFlag,Size5Flag});
  61. Vec6 = SYSTEM.VAL(LONGINT,{SmallVectorFlag,Size6Flag});
  62. Vec7 = SYSTEM.VAL(LONGINT,{SmallVectorFlag,Size7Flag});
  63. Vec8 = SYSTEM.VAL(LONGINT,{SmallVectorFlag,Size8Flag});
  64. MatVec2x2 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,SmallVectorFlag,Size2Flag});
  65. MatVec3x3 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,SmallVectorFlag,Size3Flag});
  66. MatVec4x4 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,SmallVectorFlag,Size4Flag});
  67. MatVec5x5 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,SmallVectorFlag,Size5Flag});
  68. MatVec6x6 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,SmallVectorFlag,Size6Flag});
  69. MatVec7x7 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,SmallVectorFlag,Size7Flag});
  70. MatVec8x8 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,SmallVectorFlag,Size8Flag});
  71. SmallArrayMask = {SmallMatrixFlag,SmallVectorFlag,Size2Flag,Size3Flag,Size4Flag,Size5Flag,Size6Flag,Size7Flag,Size8Flag};
  72. TYPE
  73. FastMatMul* = PROCEDURE ( matrixA, matrixB, matrixC, IncA, StrideA, IncB, StrideB, IncC, StrideC, RowsA, ColsA, RowsB, ColsB: LONGINT ): BOOLEAN;
  74. TransposeP* = PROCEDURE ( ladr, dadr, lstride, linc, dstride, dinc, rows, cols: LONGINT );
  75. LenInc = RECORD
  76. len: SIZE;
  77. inc: SIZE
  78. END;
  79. ArrayDescriptor*= RECORD
  80. ptr*: ANY;
  81. adr*: ADDRESS;
  82. flags*: SET;
  83. dim*: SIZE;
  84. elementSize*: SIZE;
  85. END;
  86. Tensor = POINTER TO ArrayDescriptor;
  87. UnsafeArray*= POINTER {UNSAFE} TO RECORD(ArrayDescriptor)
  88. lens*: ARRAY 8 OF LenInc;
  89. END;
  90. A0 = RECORD(ArrayDescriptor) END;
  91. A1 = RECORD(ArrayDescriptor) lens : ARRAY 1 OF LenInc; END;
  92. A2 = RECORD(ArrayDescriptor) lens : ARRAY 2 OF LenInc; END;
  93. A3 = RECORD(ArrayDescriptor) lens : ARRAY 3 OF LenInc; END;
  94. A4 = RECORD(ArrayDescriptor) lens : ARRAY 4 OF LenInc; END;
  95. A5 = RECORD(ArrayDescriptor) lens : ARRAY 5 OF LenInc; END;
  96. A6 = RECORD(ArrayDescriptor) lens : ARRAY 6 OF LenInc; END;
  97. A7 = RECORD(ArrayDescriptor) lens : ARRAY 7 OF LenInc; END;
  98. A8 = RECORD(ArrayDescriptor) lens : ARRAY 8 OF LenInc; END;
  99. T0 = POINTER TO A0;
  100. T1 = POINTER TO A1;
  101. T2 = POINTER TO A2;
  102. T3 = POINTER TO A3;
  103. T4 = POINTER TO A4;
  104. T5 = POINTER TO A5;
  105. T6 = POINTER TO A6;
  106. T7 = POINTER TO A7;
  107. T8 = POINTER TO A8;
  108. (* used for optimizations of MatMul with small sizes (Alexey Morozov) *)
  109. SmallMatMul* = PROCEDURE(dadr, ladr, radr: LONGINT);
  110. VAR
  111. alloc*: LONGINT; (* statistics *)
  112. allocTemp*: LONGINT; (* statistics *)
  113. (* procedures that might be replaced by ASM methods *)
  114. loopSPAXAX*, loopSPARAR*: BinaryAASLoop;
  115. loopSPAZAZ, loopSPALZALZ: BinaryAASLoop;
  116. loopAddAXAX*, loopAddARAR*, loopAddAZAZ*, loopAddALZALZ*: BinaryAAALoop;
  117. loopMatMulAXAX*, loopMatMulARAR*: BinaryAASLoop;
  118. loopMatMulIncAXAX*, loopMatMulIncARAR*: BinaryAASLoop;
  119. loopMulAXSX*, loopMulARSR*, loopMulAZSZ*, loopMulALZSLZ*: BinaryASALoop;
  120. loopIncMulAXSX*, loopIncMulARSR*: BinaryASALoop;
  121. matMulX*, matMulR*: FastMatMul; matMulIncX*, matMulIncR*: FastMatMul;
  122. transpose4*: TransposeP; transpose8*: TransposeP;
  123. (* optimizations for small arrays (Alexey Morozov) *)
  124. matMulR2x2*: SmallMatMul;
  125. matMulR3x3*: SmallMatMul;
  126. matMulR4x4*: SmallMatMul;
  127. matVecMulR2x2*: SmallMatMul;
  128. matVecMulR3x3*: SmallMatMul;
  129. matVecMulR4x4*: SmallMatMul;
  130. matMulLR2x2*: SmallMatMul;
  131. matMulLR3x3*: SmallMatMul;
  132. matMulLR4x4*: SmallMatMul;
  133. matVecMulLR2x2*: SmallMatMul;
  134. matVecMulLR3x3*: SmallMatMul;
  135. matVecMulLR4x4*: SmallMatMul;
  136. (*
  137. TensorTypePool: ARRAY 32 OF TensorType;
  138. *)
  139. PROCEDURE SetDefaults*; (* set standard procedures *)
  140. BEGIN
  141. KernelLog.String( "ArrayBase XXXXXXX: setting runtime library (semi-optimized) default methods." ); KernelLog.Ln; loopSPAXAX := SPAXAXLoop;
  142. loopSPARAR := SPARARLoop; loopAddAXAX := AddAXAXLoop;
  143. loopSPAZAZ := SPAZAZLoop; loopSPALZALZ := SPALZALZLoop;
  144. loopAddARAR := AddARARLoop; loopMatMulAXAX := MatMulAXAXLoop;
  145. loopAddAZAZ := AddAZAZLoop; loopAddALZALZ := AddALZALZLoop;
  146. loopMatMulIncAXAX := MatMulIncAXAXLoop;
  147. loopMatMulARAR := MatMulARARLoop; loopMulAXSX := MulAXSXLoop;
  148. loopIncMulAXSX := IncMulAXSXLoop;
  149. loopMatMulIncARAR := MatMulIncARARLoop;
  150. loopMulARSR := MulARSRLoop; loopIncMulARSR := IncMulARSRLoop;
  151. matMulX := NIL; matMulR := NIL; matMulIncX := NIL; matMulIncR := NIL;
  152. loopMulAZSZ := MulAZSZLoop;
  153. loopMulALZSLZ := MulALZSLZLoop;
  154. END SetDefaults;
  155. PROCEDURE Err(CONST s: ARRAY OF CHAR );
  156. BEGIN
  157. KernelLog.String( "Runtime Error: " ); KernelLog.String( s ); KernelLog.Ln; HALT( 100 );
  158. END Err;
  159. (* get increment of dimension dim *)
  160. PROCEDURE GetIncr(base: UnsafeArray; dim: SIZE): SIZE;
  161. BEGIN{UNCHECKED}
  162. RETURN base.lens[dim].inc
  163. END GetIncr;
  164. (* set increment of dimension dim *)
  165. PROCEDURE PutInc(base: UnsafeArray; dim,val: SIZE);
  166. BEGIN{UNCHECKED}
  167. base.lens[dim].inc := val
  168. END PutInc;
  169. (* get length of dimension dim *)
  170. PROCEDURE GetLen(base: UnsafeArray; dim: SIZE): LONGINT;
  171. BEGIN{UNCHECKED}
  172. RETURN base.lens[dim].len
  173. END GetLen;
  174. (* set length of dimension dim *)
  175. PROCEDURE PutLen(base: UnsafeArray; dim,val: SIZE);
  176. BEGIN{UNCHECKED}
  177. base.lens[dim].len := val
  178. END PutLen;
  179. (* get data address *)
  180. PROCEDURE GetAdr(base: UnsafeArray): ADDRESS;
  181. BEGIN
  182. RETURN base.adr;
  183. END GetAdr;
  184. (* set data address *)
  185. PROCEDURE PutAdr(base: UnsafeArray; value: ADDRESS);
  186. BEGIN
  187. base.adr := value
  188. END PutAdr;
  189. (* get data base pointer (GC protection) *)
  190. PROCEDURE GetPtr(base: UnsafeArray): ANY;
  191. BEGIN
  192. RETURN base.ptr;
  193. END GetPtr;
  194. (* set data base pointer (GC protection) *)
  195. PROCEDURE PutPtr(base: UnsafeArray; value: ANY);
  196. BEGIN
  197. base.ptr := value
  198. END PutPtr;
  199. PROCEDURE GetSize( base: UnsafeArray ): LONGINT;
  200. BEGIN
  201. IF base = NIL THEN RETURN 0 ELSE RETURN base.elementSize END
  202. END GetSize;
  203. PROCEDURE PutSize( base: UnsafeArray; val: SIZE );
  204. BEGIN
  205. base.elementSize := val
  206. END PutSize;
  207. PROCEDURE GetDim( base: UnsafeArray ): SIZE;
  208. VAR dim: LONGINT;
  209. BEGIN
  210. IF base = 0 THEN RETURN 0 ELSE RETURN base.dim END;
  211. END GetDim;
  212. PROCEDURE GetFlags( base: UnsafeArray ): SET;
  213. BEGIN
  214. IF base = 0 THEN RETURN {} ELSE RETURN base.flags END;
  215. END GetFlags;
  216. PROCEDURE PutDim( base: UnsafeArray; dim: SIZE );
  217. BEGIN
  218. base.dim := dim
  219. END PutDim;
  220. PROCEDURE PutFlags( base: UnsafeArray; flags: SET );
  221. BEGIN
  222. base.flags := flags
  223. END PutFlags;
  224. (* report geometry of array passed via address s *)
  225. PROCEDURE Report(CONST name: ARRAY OF CHAR; s: ADDRESS );
  226. VAR i: LONGINT; dim: LONGINT;
  227. PROCEDURE Set( s: SET );
  228. VAR i: LONGINT; first: BOOLEAN;
  229. BEGIN
  230. KernelLog.String( "{" ); first := TRUE;
  231. FOR i := 31 TO 0 BY -1 DO
  232. IF i IN s THEN
  233. IF ~first THEN KernelLog.String( "," ); ELSE first := FALSE END;
  234. KernelLog.Int( i, 1 );
  235. END;
  236. END;
  237. KernelLog.String( "}" );
  238. END Set;
  239. BEGIN
  240. KernelLog.String( name );
  241. IF s = 0 THEN KernelLog.String( " : NIL " ); KernelLog.Ln;
  242. ELSE
  243. KernelLog.String( " at adr " ); KernelLog.Int( s, 1 ); KernelLog.String( "; ptr= " );
  244. KernelLog.Address( GetPtr( s )); KernelLog.String( "; adr= " );
  245. KernelLog.Address( GetAdr( s )); KernelLog.String( "; dim=" );
  246. KernelLog.Int( GetDim( s ), 1 ); KernelLog.String( "; flags=" ); Set( GetFlags( s ) );
  247. KernelLog.Ln; dim := GetDim( s );
  248. IF dim > 32 THEN dim := 0 END;
  249. FOR i := 0 TO dim - 1 DO
  250. KernelLog.String( "dim (rev)=" ); KernelLog.Int( i, 1 ); KernelLog.String( ", len=" );
  251. KernelLog.Int( GetLen( s, i ), 1 ); KernelLog.String( ", inc=" );
  252. KernelLog.Int( GetIncr( s, i ), 1 ); KernelLog.Ln;
  253. END;
  254. (*
  255. FindPattern1( s, dim, ldim, len, inc ); KernelLog.String( "increment: " );
  256. KernelLog.Int( inc, 10 ); KernelLog.Ln; KernelLog.String( "longest dim:" ); KernelLog.Int( ldim, 10 );
  257. KernelLog.Ln; KernelLog.String( "len:" ); KernelLog.Int( len, 10 ); KernelLog.Ln;
  258. *)
  259. END;
  260. END Report;
  261. PROCEDURE GetArrayDesc( dim: LONGINT ): Tensor;
  262. VAR (* t: TensorType; *) ptr: Tensor;
  263. p0: T0;
  264. p1: T1; p2: T2; p3: T3; p4: T4; p5: T5; p6: T6; p7: T7; p8: T8;
  265. BEGIN
  266. (*
  267. IF dim < LEN( TensorTypePool ) THEN t := TensorTypePool[dim]
  268. ELSE NewTensorType( dim, t );
  269. END;
  270. Heaps.NewRec( ptr, t.tag );
  271. *)
  272. CASE dim OF
  273. |0: NEW(p0); ptr := p0;
  274. |1:NEW(p1); ptr := p1;
  275. |2:NEW(p2); ptr := p2;
  276. |3:NEW(p3); ptr := p3;
  277. |4:NEW(p4); ptr := p4;
  278. |5:NEW(p5); ptr := p5;
  279. |6:NEW(p6); ptr := p6;
  280. |7:NEW(p7); ptr := p7;
  281. |8:NEW(p8); ptr := p8;
  282. ELSE
  283. HALT(200)
  284. END;
  285. ptr.dim := dim;
  286. ptr.flags := {TensorFlag};
  287. RETURN ptr;
  288. END GetArrayDesc;
  289. PROCEDURE EnsureArrayDesc*(dim: SIZE; VAR d: Tensor);
  290. BEGIN
  291. IF d = NIL THEN
  292. d := GetArrayDesc(dim);
  293. ELSIF d.dim # dim THEN
  294. IF ~(TensorFlag IN d.flags) &
  295. ~(TemporaryFlag IN d.flags) THEN (* no, not allowed*)
  296. HALT( 100 );
  297. END;
  298. d := GetArrayDesc(dim)
  299. (* ELSE keep as is *)
  300. END;
  301. END EnsureArrayDesc;
  302. PROCEDURE Halt( code: LONGINT; left, right, dest: LONGINT );
  303. VAR reason: ARRAY 64 OF CHAR;
  304. BEGIN
  305. IF left # 0 THEN Report( "Source operand ", left ) END;
  306. IF right # 0 THEN Report( "Source operand 2 ", right ) END;
  307. IF dest # 0 THEN Report( "Dest operand ", dest ) END;
  308. IF code = GeometryMismatch THEN reason := "Geometry mismatch";
  309. ELSIF code = DimensionMismatch THEN reason := "Dimension mismatch";
  310. ELSIF code = AllocationForbidden THEN reason := "Allocation forbidden for dest";
  311. ELSE reason := "unknown";
  312. END;
  313. KernelLog.String( "ArrayBase Halt. Reason= " ); KernelLog.String( reason ); KernelLog.Ln;
  314. HALT( 400 );
  315. END Halt;
  316. (** patterns ********************************************************************)
  317. (* find the largest block with a regular pattern of the form offset+{i*li: 0<=i<len}. d is dimension applying to the resulting loop *)
  318. PROCEDURE FindPattern1( left, dim: ADDRESS; VAR d, len, linc: LONGINT );
  319. BEGIN
  320. d := dim - 1; len := GetLen( left, d );
  321. WHILE (len = 1) & (d > 0) DO DEC( d ); len := GetLen( left, d );
  322. END; (* skip lower dimensions with len=1, in most cases d=0 *)
  323. linc := GetIncr( left, d ); DEC( d );
  324. WHILE (d >= 0) & (GetIncr( left, d ) = len * linc) DO
  325. len := len * GetLen( left, d ); DEC( d );
  326. END; (* find dimension where pattern does not work any more *)
  327. INC( d );
  328. IF debug THEN
  329. KernelLog.String( "FindPattern1: " ); KernelLog.Int( len, 10 ); KernelLog.Int( linc, 10 );
  330. KernelLog.Ln;
  331. END;
  332. END FindPattern1;
  333. (* find the largest block with a regular pattern of the form offset+{i*linc: 0<=i<len} for two arrays simultaneously. d is dimension applying to the resulting loop *)
  334. PROCEDURE FindPattern2( left, right: ADDRESS; dim: LONGINT;
  335. VAR d, len, linc, ri: LONGINT );
  336. (* geometric precondition: lengths must coincide *)
  337. BEGIN
  338. d := dim - 1; len := GetLen( left, d ); ASSERT( len = GetLen( right, d ) );
  339. WHILE (len = 1) & (d > 0) DO DEC( d ); len := GetLen( left, d ); END;
  340. linc := GetIncr( left, d ); ri := GetIncr( right, d ); DEC( d );
  341. WHILE (d >= 0) & (GetIncr( left, d ) = len * linc) & (GetIncr( right, d ) = len * ri) DO
  342. len := len * GetLen( left, d ); DEC( d );
  343. END;
  344. INC( d );
  345. IF debug THEN
  346. KernelLog.String( "FindPattern2: " ); KernelLog.Int( d, 10 ); KernelLog.Int( len, 10 );
  347. KernelLog.Int( linc, 10 ); KernelLog.Int( ri, 10 ); KernelLog.Ln;
  348. END;
  349. END FindPattern2;
  350. (* find the largest block with a regular pattern of the form offset+{i*linc: 0<=i<len} for three arrays simultaneously. d is dimension applying to the resulting loop *)
  351. PROCEDURE FindPattern3( left, right, dest: ADDRESS; dim: LONGINT;
  352. VAR d, len, linc, ri, di: LONGINT );
  353. (* geometric precondition: lengths must coincide *)
  354. BEGIN
  355. d := dim - 1; len := GetLen( left, d );
  356. WHILE (len = 1) & (d > 0) DO DEC( d ); len := GetLen( left, d );
  357. END;
  358. linc := GetIncr( left, d ); ri := GetIncr( right, d ); di := GetIncr( dest, d );
  359. DEC( d );
  360. WHILE (d >= 0) & (GetIncr( left, d ) = len * linc) &
  361. (GetIncr( right, d ) = len * ri) & (GetIncr( dest, d ) = len * di) DO
  362. len := len * GetLen( left, d ); DEC( d );
  363. END;
  364. INC( d );
  365. IF debug THEN
  366. KernelLog.String( "FindPattern3: " ); KernelLog.Int( len, 10 ); KernelLog.Int( linc, 10 );
  367. KernelLog.Int( ri, 10 ); KernelLog.Int( di, 10 ); KernelLog.Ln;
  368. END;
  369. END FindPattern3;
  370. PROCEDURE Reverse( src: ADDRESS; dim: LONGINT );
  371. VAR d, sl, sr: LONGINT;
  372. BEGIN
  373. d := 0; sl := GetAdr( src );
  374. WHILE (d < dim) DO
  375. INC( sr, GetIncr( src, d ) * (GetLen( src, d ) - 1) );
  376. PutInc( src, d, -GetIncr( src, d ) ); INC( d );
  377. END;
  378. PutAdr( src, sl + sr );
  379. END Reverse;
  380. (* check if forward copy may be performed *)
  381. PROCEDURE CopyUpCompatible( dest, src: ADDRESS; VAR modes: SET );
  382. VAR d, sl, sr, dl, dr: LONGINT; dim: LONGINT;
  383. (* precondition: len(src,i)=len(dest,i) *)
  384. (* for forward src -> dest copy compatibility src must not be overwritten before src is copied.
  385. Sufficient (but not necessary) conditions:
  386. 1.) no overlap: src right < dest left or src left > dest right or
  387. 2.) same geometry and src left >= dest left
  388. same geometry if ginc(s)=ginc(d) with
  389. ginc(s)=inc(s,0)*len(s,0)+inc(s,1)*len(s,1)+...
  390. ginc(d)=inc(d,0)*len(d,0)+inc(d,1)*len(d,1)+...
  391. *)
  392. BEGIN
  393. d := 0; sl := GetAdr( src ); sr := sl; dl := GetAdr( dest ); dr := dl;
  394. dim := GetDim( src );
  395. WHILE (d < dim) DO
  396. INC( sr, GetIncr( src, d ) * (GetLen( src, d ) - 1) );
  397. INC( dr, GetIncr( dest, d ) * (GetLen( dest, d ) - 1) ); INC( d );
  398. END;
  399. IF (sr < dl) OR (sl > dr) THEN (* no overlap, both directions possible *)
  400. ELSIF ((sr - sl) = (dr - dl)) THEN
  401. IF (sl = dl) THEN (* same memory region, both directions possible *)
  402. ELSIF (sl > dl) THEN
  403. EXCL( modes, down ) (* only copy up possible *)
  404. ELSE (*sl < dl*)
  405. EXCL( modes, up ) (* only copy down possible *)
  406. END;
  407. ELSE
  408. modes := modes - {down, up}; (* neither nor *)
  409. END;
  410. END CopyUpCompatible;
  411. PROCEDURE AllocateTemp( VAR dest: ADDRESS; src: ADDRESS;
  412. Size: LONGINT ): ANY;
  413. (* allocate a temporary block containing both descriptor and data *)
  414. VAR d, len, i: LONGINT; p: ANY; dim: LONGINT;
  415. BEGIN
  416. HALT(100);
  417. (*
  418. IF statistics THEN INC( allocTemp ) END;
  419. d := 0; len := Size; dim := GetDim( src );
  420. WHILE (d < dim) DO len := len * GetLen( src, d ); INC( d ); END;
  421. INC( len, 2 * dim * SIZEOF( LONGINT ) + MathLenOffset ); SYSTEM.NEW( p, len );
  422. dest := SYSTEM.VAL( LONGINT, p );
  423. PutAdr( dest, dest + dim * 2 * SIZEOF( LONGINT ) + MathLenOffset );
  424. PutPtr( dest, dest ); PutDim( dest, dim ); len := Size;
  425. FOR i := 0 TO dim - 1 DO
  426. PutInc( dest, i, len ); PutLen( dest, i, GetLen( src, i ) );
  427. len := len * GetLen( src, i );
  428. END;
  429. (* Report("allocdest",dest,dim); *)
  430. RETURN p;
  431. *)
  432. END AllocateTemp;
  433. (*** procedures to traverse arrays and apply operators *)
  434. (** apply unary operator to array: array SHORTINT -> array SHORTINT *)
  435. PROCEDURE ApplyGenericUnaryAAOpS( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopS; op: PROCEDURE(x: SHORTINT): SHORTINT );
  436. VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT;
  437. origdest: LONGINT; modes: SET;
  438. dest, left: ADDRESS; dim: SIZE;
  439. PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS );
  440. VAR len: LONGINT; linc, dinc: LONGINT;
  441. BEGIN
  442. IF dim = loopd THEN
  443. Loop( ladr, dadr, loopli, loopdi, looplen, op );
  444. IF conservative THEN INC( glen, looplen ) END;
  445. ELSE
  446. len := GetLen( left, dim ); linc := GetIncr( left, dim );
  447. dinc := GetIncr( dest, dim ); INC( dim );
  448. WHILE (len > 0) DO
  449. Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  450. END;
  451. END;
  452. END Traverse;
  453. BEGIN
  454. SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left );
  455. origdest := 0; modes := {up, down};
  456. (* allocate destination, if necessary *)
  457. p := AllocateSame( dest, left, elementSize );
  458. IF p = NIL THEN
  459. CopyUpCompatible( dest, left, modes );
  460. IF up IN modes THEN (* nothing to be done *)
  461. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  462. ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize );
  463. END;
  464. END;
  465. (* allocate destination, if necessary *)
  466. (*IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize )
  467. ELSIF CheckGeometry( left, dest, dim )
  468. END; *)
  469. IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END;
  470. (* check pattern: longest piece that can be done with a loop *)
  471. FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi );
  472. Traverse( 0, GetAdr( left ), GetAdr( dest ) );
  473. IF up IN modes THEN (* nothing to be done *)
  474. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  475. ELSE CopyContent( origdest, dest, elementSize );
  476. END;
  477. SYSTEM.PUT( d, dest );
  478. END ApplyGenericUnaryAAOpS;
  479. (** apply unary operator to array: array INTEGER -> array INTEGER *)
  480. PROCEDURE ApplyGenericUnaryAAOpI( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopI; op: PROCEDURE(x: INTEGER): INTEGER );
  481. VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT;
  482. origdest: LONGINT; modes: SET;
  483. dest, left: ADDRESS; dim: SIZE;
  484. PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS );
  485. VAR len: LONGINT; linc, dinc: LONGINT;
  486. BEGIN
  487. IF dim = loopd THEN
  488. Loop( ladr, dadr, loopli, loopdi, looplen, op );
  489. IF conservative THEN INC( glen, looplen ) END;
  490. ELSE
  491. len := GetLen( left, dim ); linc := GetIncr( left, dim );
  492. dinc := GetIncr( dest, dim ); INC( dim );
  493. WHILE (len > 0) DO
  494. Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  495. END;
  496. END;
  497. END Traverse;
  498. BEGIN
  499. SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left );
  500. origdest := 0; modes := {up, down};
  501. (* allocate destination, if necessary *)
  502. p := AllocateSame( dest, left, elementSize );
  503. IF p = NIL THEN
  504. CopyUpCompatible( dest, left, modes );
  505. IF up IN modes THEN (* nothing to be done *)
  506. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  507. ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize );
  508. END;
  509. END;
  510. (* allocate destination, if necessary *)
  511. (*IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize )
  512. ELSIF CheckGeometry( left, dest, dim )
  513. END; *)
  514. IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END;
  515. (* check pattern: longest piece that can be done with a loop *)
  516. FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi );
  517. Traverse( 0, GetAdr( left ), GetAdr( dest ) );
  518. IF up IN modes THEN (* nothing to be done *)
  519. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  520. ELSE CopyContent( origdest, dest, elementSize );
  521. END;
  522. SYSTEM.PUT( d, dest );
  523. END ApplyGenericUnaryAAOpI;
  524. (** apply unary operator to array: array LONGINT -> array LONGINT *)
  525. PROCEDURE ApplyGenericUnaryAAOpL( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopL; op: PROCEDURE(x: LONGINT): LONGINT );
  526. VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT;
  527. origdest: LONGINT; modes: SET;
  528. dest, left: ADDRESS; dim: SIZE;
  529. PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS );
  530. VAR len: LONGINT; linc, dinc: LONGINT;
  531. BEGIN
  532. IF dim = loopd THEN
  533. Loop( ladr, dadr, loopli, loopdi, looplen, op );
  534. IF conservative THEN INC( glen, looplen ) END;
  535. ELSE
  536. len := GetLen( left, dim ); linc := GetIncr( left, dim );
  537. dinc := GetIncr( dest, dim ); INC( dim );
  538. WHILE (len > 0) DO
  539. Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  540. END;
  541. END;
  542. END Traverse;
  543. BEGIN
  544. SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left );
  545. origdest := 0; modes := {up, down};
  546. (* allocate destination, if necessary *)
  547. p := AllocateSame( dest, left, elementSize );
  548. IF p = NIL THEN
  549. CopyUpCompatible( dest, left, modes );
  550. IF up IN modes THEN (* nothing to be done *)
  551. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  552. ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize );
  553. END;
  554. END;
  555. (* allocate destination, if necessary *)
  556. (*IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize )
  557. ELSIF CheckGeometry( left, dest, dim )
  558. END; *)
  559. IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END;
  560. (* check pattern: longest piece that can be done with a loop *)
  561. FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi );
  562. Traverse( 0, GetAdr( left ), GetAdr( dest ) );
  563. IF up IN modes THEN (* nothing to be done *)
  564. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  565. ELSE CopyContent( origdest, dest, elementSize );
  566. END;
  567. SYSTEM.PUT( d, dest );
  568. END ApplyGenericUnaryAAOpL;
  569. (** apply unary operator to array: array HUGEINT -> array HUGEINT *)
  570. PROCEDURE ApplyGenericUnaryAAOpH( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopH; op: PROCEDURE(x: HUGEINT): HUGEINT );
  571. VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT;
  572. origdest: LONGINT; modes: SET;
  573. VAR dest, left: ADDRESS; dim: SIZE;
  574. PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS );
  575. VAR len: LONGINT; linc, dinc: LONGINT;
  576. BEGIN
  577. IF dim = loopd THEN
  578. Loop( ladr, dadr, loopli, loopdi, looplen, op );
  579. IF conservative THEN INC( glen, looplen ) END;
  580. ELSE
  581. len := GetLen( left, dim ); linc := GetIncr( left, dim );
  582. dinc := GetIncr( dest, dim ); INC( dim );
  583. WHILE (len > 0) DO
  584. Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc );
  585. DEC( len );
  586. END;
  587. END;
  588. END Traverse;
  589. BEGIN
  590. SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left );
  591. origdest := 0; modes := {up, down};
  592. (* allocate destination, if necessary *)
  593. p := AllocateSame( dest, left, elementSize );
  594. IF p = NIL THEN
  595. CopyUpCompatible( dest, left, modes );
  596. IF up IN modes THEN (* nothing to be done *)
  597. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  598. ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize );
  599. END;
  600. END;
  601. (*
  602. (* allocate destination, if necessary *)
  603. IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize )
  604. ELSIF CheckGeometry( left, dest, dim )
  605. END;
  606. *)
  607. IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END;
  608. (* check pattern: longest piece that can be done with a loop *)
  609. FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi );
  610. Traverse( 0, GetAdr( left ), GetAdr( dest ) );
  611. IF up IN modes THEN (* nothing to be done *)
  612. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  613. ELSE CopyContent( origdest, dest, elementSize );
  614. END;
  615. SYSTEM.PUT( d, dest );
  616. END ApplyGenericUnaryAAOpH;
  617. (** apply unary operator to array: array REAL -> array REAL *)
  618. PROCEDURE ApplyGenericUnaryAAOpR( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopR; op: PROCEDURE(x: REAL): REAL );
  619. VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT;
  620. origdest: LONGINT; modes: SET;
  621. dest, left: ADDRESS; dim: SIZE;
  622. PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS );
  623. VAR len: LONGINT; linc, dinc: LONGINT;
  624. BEGIN
  625. IF dim = loopd THEN
  626. Loop( ladr, dadr, loopli, loopdi, looplen, op );
  627. IF conservative THEN INC( glen, looplen ) END;
  628. ELSE
  629. len := GetLen( left, dim ); linc := GetIncr( left, dim );
  630. dinc := GetIncr( dest, dim ); INC( dim );
  631. WHILE (len > 0) DO
  632. Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  633. END;
  634. END;
  635. END Traverse;
  636. BEGIN
  637. SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left );
  638. origdest := 0; modes := {up, down};
  639. (* allocate destination, if necessary *)
  640. p := AllocateSame( dest, left, elementSize );
  641. IF p = NIL THEN
  642. CopyUpCompatible( dest, left, modes );
  643. IF up IN modes THEN (* nothing to be done *)
  644. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  645. ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize );
  646. END;
  647. END;
  648. (* allocate destination, if necessary *)
  649. (*IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize )
  650. ELSIF CheckGeometry( left, dest, dim )
  651. END; *)
  652. IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END;
  653. (* check pattern: longest piece that can be done with a loop *)
  654. FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi );
  655. Traverse( 0, GetAdr( left ), GetAdr( dest ) );
  656. IF up IN modes THEN (* nothing to be done *)
  657. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  658. ELSE CopyContent( origdest, dest, elementSize );
  659. END;
  660. SYSTEM.PUT( d, dest );
  661. END ApplyGenericUnaryAAOpR;
  662. (** apply unary operator to array: array LONGREAL -> array LONGREAL *)
  663. PROCEDURE ApplyGenericUnaryAAOpX( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopX; op: PROCEDURE(x: LONGREAL): LONGREAL );
  664. VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT;
  665. origdest: LONGINT; modes: SET;
  666. dest, left: ADDRESS; dim: SIZE;
  667. PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS );
  668. VAR len: LONGINT; linc, dinc: LONGINT;
  669. BEGIN
  670. IF dim = loopd THEN
  671. Loop( ladr, dadr, loopli, loopdi, looplen, op );
  672. IF conservative THEN INC( glen, looplen ) END;
  673. ELSE
  674. len := GetLen( left, dim ); linc := GetIncr( left, dim );
  675. dinc := GetIncr( dest, dim ); INC( dim );
  676. WHILE (len > 0) DO
  677. Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc );
  678. DEC( len );
  679. END;
  680. END;
  681. END Traverse;
  682. BEGIN
  683. SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left );
  684. origdest := 0; modes := {up, down};
  685. (* allocate destination, if necessary *)
  686. p := AllocateSame( dest, left, elementSize );
  687. IF p = NIL THEN
  688. CopyUpCompatible( dest, left, modes );
  689. IF up IN modes THEN (* nothing to be done *)
  690. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  691. ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize );
  692. END;
  693. END;
  694. (*
  695. (* allocate destination, if necessary *)
  696. IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize )
  697. ELSIF CheckGeometry( left, dest, dim )
  698. END;
  699. *)
  700. IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END;
  701. (* check pattern: longest piece that can be done with a loop *)
  702. FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi );
  703. Traverse( 0, GetAdr( left ), GetAdr( dest ) );
  704. IF up IN modes THEN (* nothing to be done *)
  705. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  706. ELSE CopyContent( origdest, dest, elementSize );
  707. END;
  708. SYSTEM.PUT( d, dest );
  709. END ApplyGenericUnaryAAOpX;
  710. (** apply unary operator to array: array COMPLEX -> array COMPLEX *)
  711. PROCEDURE ApplyGenericUnaryAAOpZ( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopZ; op: PROCEDURE(x: COMPLEX): COMPLEX );
  712. VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT;
  713. origdest: LONGINT; modes: SET;
  714. dest, left: ADDRESS; dim: SIZE;
  715. PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS );
  716. VAR len: LONGINT; linc, dinc: LONGINT;
  717. BEGIN
  718. IF dim = loopd THEN
  719. Loop( ladr, dadr, loopli, loopdi, looplen, op );
  720. IF conservative THEN INC( glen, looplen ) END;
  721. ELSE
  722. len := GetLen( left, dim ); linc := GetIncr( left, dim );
  723. dinc := GetIncr( dest, dim ); INC( dim );
  724. WHILE (len > 0) DO
  725. Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc );
  726. DEC( len );
  727. END;
  728. END;
  729. END Traverse;
  730. BEGIN
  731. SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left );
  732. origdest := 0; modes := {up, down};
  733. (* allocate destination, if necessary *)
  734. p := AllocateSame( dest, left, elementSize );
  735. IF p = NIL THEN
  736. CopyUpCompatible( dest, left, modes );
  737. IF up IN modes THEN (* nothing to be done *)
  738. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  739. ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize );
  740. END;
  741. END;
  742. (*
  743. (* allocate destination, if necessary *)
  744. IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize )
  745. ELSIF CheckGeometry( left, dest, dim )
  746. END;
  747. *)
  748. IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END;
  749. (* check pattern: longest piece that can be done with a loop *)
  750. FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi );
  751. Traverse( 0, GetAdr( left ), GetAdr( dest ) );
  752. IF up IN modes THEN (* nothing to be done *)
  753. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  754. ELSE CopyContent( origdest, dest, elementSize );
  755. END;
  756. SYSTEM.PUT( d, dest );
  757. END ApplyGenericUnaryAAOpZ;
  758. (** apply unary operator to array: array LONGCOMPLEX -> array LONGCOMPLEX *)
  759. PROCEDURE ApplyGenericUnaryAAOpLZ( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopLZ; op: PROCEDURE(x: LONGCOMPLEX): LONGCOMPLEX );
  760. VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT;
  761. origdest: LONGINT; modes: SET;
  762. dest, left: ADDRESS; dim: SIZE;
  763. PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS );
  764. VAR len: LONGINT; linc, dinc: LONGINT;
  765. BEGIN
  766. IF dim = loopd THEN
  767. Loop( ladr, dadr, loopli, loopdi, looplen, op );
  768. IF conservative THEN INC( glen, looplen ) END;
  769. ELSE
  770. len := GetLen( left, dim ); linc := GetIncr( left, dim );
  771. dinc := GetIncr( dest, dim ); INC( dim );
  772. WHILE (len > 0) DO
  773. Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc );
  774. DEC( len );
  775. END;
  776. END;
  777. END Traverse;
  778. BEGIN
  779. SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left );
  780. origdest := 0; modes := {up, down};
  781. (* allocate destination, if necessary *)
  782. p := AllocateSame( dest, left, elementSize );
  783. IF p = NIL THEN
  784. CopyUpCompatible( dest, left, modes );
  785. IF up IN modes THEN (* nothing to be done *)
  786. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  787. ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize );
  788. END;
  789. END;
  790. (*
  791. (* allocate destination, if necessary *)
  792. IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize )
  793. ELSIF CheckGeometry( left, dest, dim )
  794. END;
  795. *)
  796. IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END;
  797. (* check pattern: longest piece that can be done with a loop *)
  798. FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi );
  799. Traverse( 0, GetAdr( left ), GetAdr( dest ) );
  800. IF up IN modes THEN (* nothing to be done *)
  801. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  802. ELSE CopyContent( origdest, dest, elementSize );
  803. END;
  804. SYSTEM.PUT( d, dest );
  805. END ApplyGenericUnaryAAOpLZ;
  806. (** apply unary operator to array: array -> array *)
  807. PROCEDURE ApplyUnaryAAOp( d, l: ADDRESS; elementSize: LONGINT;
  808. Loop: UnaryAALoop );
  809. VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT;
  810. origdest: LONGINT; modes: SET;
  811. dest, left: ADDRESS; dim: SIZE;
  812. PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS );
  813. VAR len: LONGINT; linc, dinc: LONGINT;
  814. BEGIN
  815. IF dim = loopd THEN
  816. Loop( ladr, dadr, loopli, loopdi, looplen );
  817. IF conservative THEN INC( glen, looplen ) END;
  818. ELSE
  819. len := GetLen( left, dim ); linc := GetIncr( left, dim );
  820. dinc := GetIncr( dest, dim ); INC( dim );
  821. WHILE (len > 0) DO
  822. Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc );
  823. DEC( len );
  824. END;
  825. END;
  826. END Traverse;
  827. BEGIN
  828. SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left );
  829. origdest := 0; modes := {up, down};
  830. (* allocate destination, if necessary *)
  831. p := AllocateSame( dest, left, elementSize );
  832. IF p = NIL THEN
  833. CopyUpCompatible( dest, left, modes );
  834. IF up IN modes THEN (* nothing to be done *)
  835. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  836. ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize );
  837. END;
  838. END;
  839. (*
  840. (* allocate destination, if necessary *)
  841. IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize )
  842. ELSIF CheckGeometry( left, dest, dim )
  843. END;
  844. *)
  845. IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END;
  846. (* check pattern: longest piece that can be done with a loop *)
  847. FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi );
  848. Traverse( 0, GetAdr( left ), GetAdr( dest ) );
  849. IF up IN modes THEN (* nothing to be done *)
  850. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  851. ELSE CopyContent( origdest, dest, elementSize );
  852. END;
  853. SYSTEM.PUT( d, dest );
  854. END ApplyUnaryAAOp;
  855. (** apply unary operator to array: array -> scalar *)
  856. PROCEDURE ApplyUnaryASOp( dest, l: ADDRESS; Loop: UnaryASLoop );
  857. VAR loopd, looplen, loopli: LONGINT; glen: LONGINT;
  858. VAR left, dim: LONGINT;
  859. PROCEDURE Traverse( dim: LONGINT; ladr: ADDRESS );
  860. VAR len: LONGINT; linc: LONGINT;
  861. BEGIN
  862. IF dim = loopd THEN
  863. Loop( ladr, dest, loopli, looplen );
  864. IF conservative THEN INC( glen, looplen ) END;
  865. ELSE
  866. len := GetLen( left, dim ); linc := GetIncr( left, dim ); INC( dim );
  867. WHILE (len > 0) DO Traverse( dim, ladr ); INC( ladr, linc ); DEC( len ); END;
  868. END;
  869. END Traverse;
  870. BEGIN
  871. SYSTEM.GET( l, left ); dim := GetDim( left );
  872. IF debug THEN Report( "AS: left", left ); END;
  873. (* check pattern: longest piece that can be done with a loop *)
  874. IF conservative THEN glen := 0 END;
  875. FindPattern1( left, dim, loopd, looplen, loopli ); Traverse( 0, GetAdr( left ) );
  876. IF conservative THEN
  877. looplen := 1;
  878. WHILE (dim > 0) DO
  879. looplen := looplen * GetLen( left, dim - 1 ); DEC( dim );
  880. END;
  881. ASSERT( looplen = glen );
  882. END;
  883. END ApplyUnaryASOp;
  884. (** apply unary operator to array: scalar -> array *)
  885. PROCEDURE ApplyUnarySAOp( d, right: ADDRESS; Loop: UnarySALoop );
  886. VAR loopd, looplen, loopdi: LONGINT; glen: LONGINT;
  887. VAR dest, dim: LONGINT;
  888. PROCEDURE Traverse( dim: LONGINT; dadr: ADDRESS );
  889. VAR len: LONGINT; dinc: LONGINT;
  890. BEGIN
  891. IF dim = loopd THEN
  892. Loop( right, dadr, loopdi, looplen );
  893. IF conservative THEN INC( glen, looplen ) END;
  894. ELSE
  895. len := GetLen( dest, dim ); dinc := GetIncr( dest, dim ); INC( dim );
  896. WHILE (len > 0) DO Traverse( dim, dadr ); INC( dadr, dinc ); DEC( len ); END;
  897. END;
  898. END Traverse;
  899. BEGIN
  900. SYSTEM.GET( d, dest ); dim := GetDim( dest );
  901. IF debug THEN Report( "AS: dest", dest ); END;
  902. (* check pattern: longest piece that can be done with a loop *)
  903. IF conservative THEN glen := 0 END;
  904. FindPattern1( dest, dim, loopd, looplen, loopdi ); Traverse( 0, GetAdr( dest ) );
  905. IF conservative THEN
  906. looplen := 1;
  907. WHILE (dim > 0) DO
  908. looplen := looplen * GetLen( dest, dim - 1 ); DEC( dim );
  909. END;
  910. ASSERT( looplen = glen );
  911. END;
  912. END ApplyUnarySAOp;
  913. (** apply binary operator : array x array -> array *)
  914. PROCEDURE ApplyBinaryAAAOp( d, l, r: ADDRESS; elementSize: LONGINT;
  915. Loop: BinaryAAALoop );
  916. VAR loopd, looplen, loopli, loopri, loopdi: LONGINT; p: ANY; glen: LONGINT;
  917. origdest: LONGINT; modes: SET; left, right, dest: ADDRESS; dim: LONGINT;
  918. PROCEDURE Traverse( dim: LONGINT; ladr, radr, dadr: ADDRESS );
  919. VAR len: LONGINT; linc, rinc, dinc: LONGINT;
  920. BEGIN
  921. IF dim = loopd THEN
  922. Loop( ladr, radr, dadr, loopli, loopri, loopdi, looplen );
  923. IF conservative THEN INC( glen, looplen ) END;
  924. ELSE
  925. len := GetLen( left, dim ); linc := GetIncr( left, dim );
  926. rinc := GetIncr( right, dim ); dinc := GetIncr( dest, dim ); INC( dim );
  927. WHILE (len > 0) DO
  928. Traverse( dim, ladr, radr, dadr ); INC( ladr, linc ); INC( radr, rinc );
  929. INC( dadr, dinc ); DEC( len );
  930. END;
  931. END;
  932. END Traverse;
  933. BEGIN
  934. SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); SYSTEM.GET( r, right ); dim := GetDim( left );
  935. (* allocate destination, if necessary *)
  936. IF ~SameShape( left, right ) THEN
  937. Halt( GeometryMismatch, left, right, 0 )
  938. END;
  939. origdest := 0; modes := {up, down};
  940. p := AllocateSame( dest, left, elementSize );
  941. IF p = NIL THEN
  942. CopyUpCompatible( dest, left, modes );
  943. CopyUpCompatible( dest, right, modes );
  944. IF up IN modes THEN (* nothing to be done *)
  945. ELSIF down IN modes THEN
  946. Reverse( left, dim ); Reverse( dest, dim ); Reverse( right, dim );
  947. ELSE
  948. origdest := dest; p := AllocateTemp( dest, origdest, elementSize ); (* 1d field ? *)
  949. END;
  950. END;
  951. (* debugging *)
  952. IF debug THEN Report( "AAA:left", left ); Report( "AAA:right", right ); Report( "AAA:dest", dest ); END;
  953. (* check pattern: longest piece that can be done with a loop *)
  954. FindPattern3( left, right, dest, dim, loopd, looplen, loopli, loopri, loopdi );
  955. (* run through dimensions *)
  956. Traverse( 0, GetAdr( left ), GetAdr( right ), GetAdr( dest ) );
  957. IF up IN modes THEN (* nothing to be done *)
  958. ELSIF down IN modes THEN
  959. Reverse( left, dim ); Reverse( dest, dim ); Reverse( right, dim );
  960. ELSE CopyContent( origdest, dest, elementSize );
  961. END;
  962. SYSTEM.PUT( d, dest );
  963. END ApplyBinaryAAAOp;
  964. (** apply binary operator: array x scalar -> array *)
  965. PROCEDURE ApplyBinaryASAOp( d, l, right: ADDRESS;
  966. elementSize: LONGINT;
  967. Loop: BinaryASALoop );
  968. VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT;
  969. origdest: LONGINT; modes: SET; dest, left: ADDRESS; dim: SIZE;
  970. PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS );
  971. VAR len: LONGINT; linc, dinc: LONGINT;
  972. BEGIN
  973. IF dim = loopd THEN
  974. Loop( ladr, right, dadr, loopli, loopdi, looplen );
  975. IF conservative THEN INC( glen, looplen ) END;
  976. ELSE
  977. len := GetLen( left, dim ); linc := GetIncr( left, dim );
  978. dinc := GetIncr( dest, dim ); INC( dim );
  979. WHILE (len > 0) DO
  980. Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc );
  981. DEC( len );
  982. END;
  983. END;
  984. END Traverse;
  985. BEGIN
  986. SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left );
  987. (* allocate destination, if necessary *)
  988. origdest := 0; modes := {up, down};
  989. p := AllocateSame( dest, left, elementSize );
  990. IF p = NIL THEN
  991. CopyUpCompatible( dest, left, modes );
  992. IF up IN modes THEN (* nothing to be done *)
  993. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  994. ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize );
  995. END;
  996. END;
  997. (* debugging *)
  998. IF debug THEN Report( "ASA:left", left ); Report( "ASA:dest", dest ); END;
  999. (* check pattern: longest piece that can be done with a loop *)
  1000. FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi );
  1001. (* run through dimensions *)
  1002. IF conservative THEN glen := 0 END;
  1003. Traverse( 0, GetAdr( left ), GetAdr( dest ) );
  1004. IF conservative THEN
  1005. looplen := 1;
  1006. WHILE (dim > 0) DO
  1007. looplen := looplen * GetLen( left, dim - 1 ); DEC( dim );
  1008. END;
  1009. ASSERT( looplen = glen );
  1010. END;
  1011. IF up IN modes THEN (* nothing to be done *)
  1012. ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim )
  1013. ELSE CopyContent( origdest, dest, elementSize );
  1014. END;
  1015. SYSTEM.PUT( d, dest );
  1016. END ApplyBinaryASAOp;
  1017. (** apply binary operator: array x array -> scalar *)
  1018. PROCEDURE ApplyBinaryAASOp( dest, l, r: ADDRESS; Loop: BinaryAASLoop );
  1019. VAR loopd, looplen, loopli, loopri: LONGINT; glen: LONGINT;
  1020. left, right, dim: LONGINT;
  1021. PROCEDURE Traverse( dim: LONGINT; ladr, radr: ADDRESS );
  1022. VAR len: LONGINT; linc, rinc: LONGINT;
  1023. BEGIN
  1024. IF dim = loopd THEN
  1025. Loop( ladr, radr, dest, loopli, loopri, looplen );
  1026. IF conservative THEN INC( glen, looplen ) END;
  1027. ELSE
  1028. len := GetLen( left, dim ); linc := GetIncr( left, dim );
  1029. rinc := GetIncr( right, dim ); INC( dim );
  1030. WHILE (len > 0) DO
  1031. Traverse( dim, ladr, radr ); INC( ladr, linc ); INC( radr, rinc );
  1032. DEC( len );
  1033. END;
  1034. END;
  1035. END Traverse;
  1036. BEGIN
  1037. SYSTEM.GET( l, left ); SYSTEM.GET( r, right ); dim := GetDim( left );
  1038. (* check array lengths *)
  1039. IF ~SameShape( left, right ) THEN
  1040. Halt( GeometryMismatch, left, right, 0 )
  1041. END;
  1042. IF debug THEN Report( "AAS:left", left ); Report( "AAS:right", right ); END;
  1043. (* check pattern: longest piece that can be done with a loop *)
  1044. FindPattern2( left, right, dim, loopd, looplen, loopli, loopri );
  1045. (* run through dimensions *)
  1046. IF conservative THEN glen := 0 END;
  1047. Traverse( 0, GetAdr( left ), GetAdr( right ) );
  1048. IF conservative THEN
  1049. looplen := 1;
  1050. WHILE (dim > 0) DO
  1051. looplen := looplen * GetLen( left, dim - 1 ); DEC( dim );
  1052. END;
  1053. ASSERT( looplen = glen );
  1054. END;
  1055. END ApplyBinaryAASOp;
  1056. (** special binary operator: array x array -> boolean *)
  1057. PROCEDURE ApplyBinaryAABOp( l, r: ADDRESS;
  1058. Loop: BinaryAABLoop; geometryMismatchDefault: BOOLEAN ): BOOLEAN;
  1059. VAR loopd, looplen, loopli, loopri: LONGINT; left, right, dim: LONGINT;
  1060. PROCEDURE Traverse( dim: LONGINT; ladr, radr: ADDRESS ): BOOLEAN;
  1061. VAR len: LONGINT; linc, rinc: LONGINT;
  1062. BEGIN
  1063. IF dim = loopd THEN RETURN Loop( ladr, radr, loopli, loopri, looplen );
  1064. ELSE
  1065. len := GetLen( left, dim ); linc := GetIncr( left, dim );
  1066. rinc := GetIncr( right, dim ); INC( dim );
  1067. WHILE (len > 0) DO
  1068. IF ~Traverse( dim, ladr, radr ) THEN RETURN FALSE END;
  1069. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  1070. END;
  1071. RETURN TRUE;
  1072. END;
  1073. END Traverse;
  1074. BEGIN
  1075. SYSTEM.GET( l, left ); SYSTEM.GET( r, right ); dim := GetDim( left );
  1076. (* check array lengths *)
  1077. IF ~SameShape( left, right ) THEN
  1078. RETURN geometryMismatchDefault
  1079. END;
  1080. (* is destination already allocated? (might be a temporary result) *)
  1081. IF debug THEN Report( "AAB:left", left ); Report( "AAB:right", right ); END;
  1082. (* check pattern: longest piece that can be done with a loop *)
  1083. FindPattern2( left, right, dim, loopd, looplen, loopli, loopri );
  1084. (* run through dimensions *)
  1085. RETURN Traverse( 0, GetAdr( left ), GetAdr( right ) );
  1086. END ApplyBinaryAABOp;
  1087. (** special binary operator: array x scalar -> boolean *)
  1088. PROCEDURE ApplyBinaryASBOp( l, right: ADDRESS;
  1089. Loop: BinaryASBLoop ): BOOLEAN;
  1090. VAR loopd, looplen, loopli: LONGINT; left, dim: LONGINT;
  1091. PROCEDURE Traverse( dim: LONGINT; ladr: ADDRESS ): BOOLEAN;
  1092. VAR len: LONGINT; linc: LONGINT;
  1093. BEGIN
  1094. IF dim = loopd THEN RETURN Loop( ladr, right, loopli, looplen );
  1095. ELSE
  1096. len := GetLen( left, dim ); linc := GetIncr( left, dim ); INC( dim );
  1097. WHILE (len > 0) DO
  1098. IF ~Traverse( dim, ladr ) THEN RETURN FALSE END;
  1099. INC( ladr, linc ); DEC( len );
  1100. END;
  1101. RETURN TRUE;
  1102. END;
  1103. END Traverse;
  1104. BEGIN
  1105. SYSTEM.GET( l, left ); dim := GetDim( left );
  1106. IF debug THEN Report( "AAB:left", left ); END;
  1107. (* check pattern: longest piece that can be done with a loop *)
  1108. FindPattern1( left, dim, loopd, looplen, loopli );
  1109. (* run through dimensions *)
  1110. RETURN Traverse( 0, GetAdr( left ) );
  1111. END ApplyBinaryASBOp;
  1112. (**** operators *)
  1113. (*** copy *)
  1114. PROCEDURE Copy4( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1115. CODE {SYSTEM.i386}
  1116. MOV ECX, [EBP+ladr] ; ECX := ladr
  1117. MOV EDX, [EBP+dadr] ; EDX := dadr
  1118. MOV EBX, [EBP+len] ; EBX := len
  1119. start:
  1120. CMP EBX, 0 ;
  1121. JLE end ; WHILE EBX > 0 DO
  1122. MOV EAX, [ECX] ; EAX := SYSTEM.GET32(ECX)
  1123. MOV [EDX], EAX ; SYSTEM.PUT32(EDX, EAX))
  1124. ADD ECX, [EBP+linc] ; INC(ECX, linc)
  1125. ADD EDX, [EBP+dinc] ; INC(EDX, rinc)
  1126. DEC EBX ; DEC(EBX)
  1127. JMP start
  1128. end:
  1129. END Copy4;
  1130. PROCEDURE Copy2( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1131. CODE {SYSTEM.i386}
  1132. MOV ECX, [EBP+ladr] ; ECX := ladr
  1133. MOV EDX, [EBP+dadr] ; EDX := dadr
  1134. MOV EBX, [EBP+len] ; EBX := len
  1135. start:
  1136. CMP EBX, 0 ;
  1137. JLE end ; WHILE EBX > 0 DO
  1138. MOV AX, [ECX] ; EAX := SYSTEM.GET32(ECX)
  1139. MOV [EDX], AX ; SYSTEM.PUT32(EDX, EAX))
  1140. ADD ECX, [EBP+linc] ; INC(ECX, linc)
  1141. ADD EDX, [EBP+dinc] ; INC(EDX, rinc)
  1142. DEC EBX ; DEC(EBX)
  1143. JMP start
  1144. end:
  1145. END Copy2;
  1146. PROCEDURE Copy1( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1147. CODE {SYSTEM.i386}
  1148. MOV ECX, [EBP+ladr] ; ECX := ladr
  1149. MOV EDX, [EBP+dadr] ; EDX := dadr
  1150. MOV EBX, [EBP+len] ; EBX := len
  1151. start:
  1152. CMP EBX, 0 ;
  1153. JLE end ; WHILE EBX > 0 DO
  1154. MOV AL, [ECX] ; EAX := SYSTEM.GET32(ECX)
  1155. MOV [EDX], AL ; SYSTEM.PUT32(EDX, EAX))
  1156. ADD ECX, [EBP+linc] ; INC(ECX, linc)
  1157. ADD EDX, [EBP+dinc] ; INC(EDX, rinc)
  1158. DEC EBX ; DEC(EBX)
  1159. JMP start
  1160. end:
  1161. END Copy1;
  1162. PROCEDURE Copy8( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1163. CODE {SYSTEM.i386}
  1164. MOV ECX, [EBP+ladr] ; ECX := ladr
  1165. MOV EDX, [EBP+dadr] ; EDX := dadr
  1166. MOV EBX, [EBP+len] ; EBX := len
  1167. start:
  1168. CMP EBX, 0 ;
  1169. JLE end ; WHILE EBX > 0 DO
  1170. MOV EAX, [ECX] ; EAX := SYSTEM.GET32(ECX)
  1171. MOV [EDX], EAX ; SYSTEM.PUT32(EDX, EAX))
  1172. MOV EAX, [ECX+4] ; EAX := SYSTEM.GET32(ECX+4)
  1173. MOV [EDX+4], EAX ; SYSTEM.PUT32(EDX+4, EAX))
  1174. ADD ECX, [EBP+linc] ; INC(ECX, linc)
  1175. ADD EDX, [EBP+dinc] ; INC(EDX, rinc)
  1176. DEC EBX ; DEC(EBX)
  1177. JMP start
  1178. end:
  1179. END Copy8;
  1180. PROCEDURE -MoveB*( srcadr, destadr, len: LONGINT );
  1181. (** Correct move if overlap, might be important for some array operations,
  1182. do not use SYSTEM.MOVE. *)
  1183. CODE {SYSTEM.i386}
  1184. MOV ECX, [ESP] ; len
  1185. MOV EDI, [ESP+4] ; destadr
  1186. MOV ESI, [ESP+8] ; srcadr
  1187. CMP ESI, EDI
  1188. JAE moveup ; src adr greater then dest adr, no problem with moving up
  1189. MOV EAX, ESI
  1190. ADD EAX, ECX
  1191. CMP EAX, EDI
  1192. JBE moveup ; no overlap, no problem, move up
  1193. MOV ESI, EAX
  1194. ADD EDI, ECX
  1195. DEC ESI
  1196. DEC EDI
  1197. STD ; move down since overlap occured
  1198. REP
  1199. MOVSB
  1200. JMP done
  1201. moveup:
  1202. CLD
  1203. MOV BL, CL
  1204. SHR ECX, 2
  1205. AND BL, 00000003H ; rest to move after 4 byte move
  1206. REP
  1207. MOVSD ; move 4 bytes each step
  1208. MOV CL, BL
  1209. REP
  1210. MOVSB ; move rest in one byte steps
  1211. done:
  1212. ADD ESP, 12 ; adjust stack pointer(inline procedure!)
  1213. END MoveB;
  1214. PROCEDURE CopyContent( dest, src: ADDRESS; elementSize: SIZE ); (**! optimize *)
  1215. VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT;
  1216. origdest: ADDRESS; modes: SET; dim: LONGINT;
  1217. PROCEDURE Loop( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1218. BEGIN
  1219. IF (dinc = elementSize) & (linc = elementSize) THEN
  1220. MoveB( ladr, dadr, len * elementSize );
  1221. (*
  1222. SYSTEM.MOVE( ladr, dadr, elementSize * len );
  1223. *)
  1224. ELSIF (dinc = -elementSize) & (linc = -elementSize) THEN
  1225. len := len * elementSize;
  1226. MoveB( ladr - len + elementSize, dadr - len + elementSize, len );
  1227. ELSIF elementSize = 1 THEN
  1228. Copy1( ladr, dadr, linc, dinc, len );
  1229. (*
  1230. WHILE (len > 0) DO
  1231. SYSTEM.PUT8( dadr, SYSTEM.GET8( ladr ) ); DEC( len ); INC( ladr, linc ); INC( dadr, dinc );
  1232. END;
  1233. *)
  1234. ELSIF elementSize = 2 THEN
  1235. Copy2( ladr, dadr, linc, dinc, len );
  1236. (*
  1237. WHILE (len > 0) DO
  1238. SYSTEM.PUT16( dadr, SYSTEM.GET16( ladr ) ); DEC( len ); INC( ladr, linc ); INC( dadr, dinc );
  1239. END;
  1240. *)
  1241. ELSIF elementSize = 4 THEN
  1242. Copy4( ladr, dadr, linc, dinc, len );
  1243. (*
  1244. WHILE (len > 0) DO
  1245. SYSTEM.PUT32( dadr, SYSTEM.GET32( ladr ) ); DEC( len ); INC( ladr, linc ); INC( dadr, dinc );
  1246. END;
  1247. *)
  1248. ELSIF elementSize = 8 THEN
  1249. Copy8( ladr, dadr, linc, dinc, len );
  1250. (*
  1251. WHILE (len > 0) DO
  1252. SYSTEM.PUT32( dadr, SYSTEM.GET32( ladr ) );
  1253. SYSTEM.PUT32( dadr + 4, SYSTEM.GET32( ladr + 4 ) ); DEC( len ); INC( ladr, linc );
  1254. INC( dadr, dinc );
  1255. END;
  1256. *)
  1257. ELSE (* SYSTEM.MOVE is expensive ! *)
  1258. WHILE (len > 0) DO
  1259. SYSTEM.MOVE( ladr, dadr, elementSize ); DEC( len ); INC( ladr, linc );
  1260. INC( dadr, dinc );
  1261. END;
  1262. END;
  1263. END Loop;
  1264. PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS );
  1265. VAR len: LONGINT; linc, dinc: LONGINT;
  1266. BEGIN
  1267. IF dim = loopd THEN
  1268. Loop( ladr, dadr, loopli, loopdi, looplen );
  1269. IF conservative THEN INC( glen, looplen ) END;
  1270. ELSE
  1271. len := GetLen( src, dim ); linc := GetIncr( src, dim );
  1272. dinc := GetIncr( dest, dim ); INC( dim );
  1273. WHILE (len > 0) DO
  1274. Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc );
  1275. DEC( len );
  1276. END;
  1277. END;
  1278. END Traverse;
  1279. BEGIN
  1280. dim := GetDim( src );
  1281. origdest := 0; modes := {up, down}; (* copy modes *)
  1282. ASSERT( SameShape( src, dest ) ); (* must be ensured by caller *)
  1283. CopyUpCompatible( dest, src, modes );
  1284. IF up IN modes THEN (* nothing to be done *)
  1285. ELSIF down IN modes THEN (* can only copy from top to bottom *)
  1286. Reverse( src, dim ); Reverse( dest, dim )
  1287. ELSE (* can only copy via double buffer *)
  1288. origdest := dest; p := AllocateTemp( dest, origdest, elementSize );
  1289. END;
  1290. IF debug THEN Report( "AA: src", src ); Report( "AA: dest", dest );
  1291. END;
  1292. (* check pattern: longest piece that can be done with a loop *)
  1293. FindPattern2( src, dest, dim, loopd, looplen, loopli, loopdi );
  1294. Traverse( 0, GetAdr( src ), GetAdr( dest ) );
  1295. IF up IN modes THEN (* nothing to be done *)
  1296. ELSIF down IN modes THEN Reverse( src, dim ); Reverse( dest, dim )
  1297. ELSE CopyContent( origdest, dest, elementSize );
  1298. END;
  1299. END CopyContent;
  1300. PROCEDURE AllocateSame( VAR dest: ADDRESS; src: ADDRESS;
  1301. elementsize: LONGINT ): ANY;
  1302. VAR ptr, data: ANY; Size: LONGINT;
  1303. (* allocate a structure in dest compatible with src, if necessary. returns if allocation has taken place *)
  1304. PROCEDURE UseDescriptor;
  1305. VAR tag: LONGINT;
  1306. BEGIN
  1307. SYSTEM.GET( src - 4, tag );
  1308. Heaps.NewRec( ptr, tag, FALSE );
  1309. dest := ptr;
  1310. END UseDescriptor;
  1311. PROCEDURE NewData;
  1312. VAR dim, len, size: LONGINT;
  1313. BEGIN
  1314. dim := GetDim( src ); size := elementsize;
  1315. PutDim( dest, dim );
  1316. PutSize( dest, elementsize );
  1317. WHILE (dim > 0) DO
  1318. DEC( dim ); len := GetLen( src, dim ); PutLen( dest, dim, len );
  1319. PutInc( dest, dim, size ); size := size * len;
  1320. END;
  1321. SYSTEM.NEW( data, size );
  1322. PutAdr( dest, data);
  1323. PutPtr( dest, data );
  1324. END NewData;
  1325. BEGIN
  1326. IF dest # NIL THEN Size := GetSize( dest ); ASSERT( Size = elementsize ); END;
  1327. IF debug THEN KernelLog.String( "Allocate same " ); Report( "allocation source", src ); Report( "allocation des", dest ); END;
  1328. IF dest = NIL THEN (* NIL pointer, guaranteed to be tensor *)
  1329. IF TensorFlag IN GetFlags( src ) THEN UseDescriptor();
  1330. ELSE ptr := GetArrayDesc( GetDim( src ) ); dest :=ptr;
  1331. END;
  1332. PutFlags(dest, {TensorFlag});
  1333. NewData(); RETURN ptr;
  1334. ELSIF GetDim( dest ) # GetDim( src ) THEN (* different dimension *)
  1335. (* check if re-allocation of descriptor is allowed *)
  1336. IF ~(TensorFlag IN GetFlags( dest )) &
  1337. ~(TemporaryFlag IN GetFlags( dest )) THEN (* no, not allowed*)
  1338. HALT( 100 );
  1339. END;
  1340. UseDescriptor();
  1341. PutFlags(dest, {TensorFlag});
  1342. NewData(); RETURN ptr;
  1343. ELSIF (GetAdr( dest ) = 0) OR ~SameShape( dest, src ) THEN
  1344. (* check if re-allocation of array data is allowed *)
  1345. IF RangeFlag IN GetFlags( dest ) THEN (* no! not allowed *)
  1346. HALT( 100 );
  1347. END;
  1348. NewData();
  1349. RETURN data;
  1350. ELSE (* nothing to do *)
  1351. RETURN NIL;
  1352. END;
  1353. END AllocateSame;
  1354. PROCEDURE TempDescCopy( src: ADDRESS ): ANY;
  1355. VAR p: ANY; adr: ADDRESS;dim: SIZE;
  1356. BEGIN
  1357. dim := GetDim(src);
  1358. p := GetArrayDesc(dim);
  1359. adr := p;
  1360. SYSTEM.MOVE( src, adr, dim * SIZEOF(LenInc) + MathLenOffset );
  1361. PutAdr( src, 0 );
  1362. PutPtr( src, NIL );
  1363. PutFlags( src, {} );
  1364. RETURN p;
  1365. END TempDescCopy;
  1366. (* used when arrays are passed by value *)
  1367. PROCEDURE CopyArraySelf*( dest, src: ADDRESS; elementsize: LONGINT );
  1368. VAR p: ANY;
  1369. BEGIN
  1370. ASSERT( src = dest );
  1371. p := TempDescCopy( dest ); (* copy and prepare dest to be copied over *)
  1372. CopyArray( dest, p, elementsize );
  1373. END CopyArraySelf;
  1374. PROCEDURE CopyArray*( dest: ADDRESS; src: ADDRESS; elementsize: SIZE );
  1375. VAR p: ANY; srcdim, destdim: LONGINT;
  1376. BEGIN
  1377. ASSERT( dest # 0 ); (* impossible unless compiler error *)
  1378. IF GetDim( src ) # GetDim( dest ) THEN (* not allowed but possible (tensor) *)
  1379. srcdim := GetDim(src);
  1380. destdim := GetDim(dest);
  1381. (*
  1382. Debugging.Stack("copy array");
  1383. *)
  1384. Report( "copy array source", src ); Report( "copy array des", dest );
  1385. HALT(100);
  1386. ELSIF src = dest THEN (* self copy *)
  1387. CopyArraySelf( dest, src, elementsize );
  1388. ELSE
  1389. p := AllocateSame( dest, src, elementsize );
  1390. CopyContent( dest, src, elementsize )
  1391. END;
  1392. END CopyArray;
  1393. PROCEDURE CopyTensorSelf*( VAR dest: ADDRESS; src: ADDRESS; elementsize: SIZE );
  1394. BEGIN
  1395. dest := 0; CopyTensor( dest, src, elementsize );
  1396. END CopyTensorSelf;
  1397. PROCEDURE CopyTensor*( VAR dest: ADDRESS; src: ADDRESS;
  1398. elementsize: SIZE );
  1399. VAR p: ANY;
  1400. BEGIN
  1401. (* Report("dest",dest); Report("src",src); *)
  1402. IF (src = NIL) THEN dest := NIL
  1403. ELSIF (dest = 0) OR ~(SameShape( dest, src )) OR (GetAdr( dest ) = 0) THEN
  1404. p := AllocateSame( dest, src, elementsize ); (* includes check if allocation is allowed *)
  1405. CopyContent( dest, src, elementsize );
  1406. ELSIF dest = src THEN CopyTensorSelf( dest, src, elementsize );
  1407. ELSE CopyContent( dest, src, elementsize )
  1408. END;
  1409. END CopyTensor;
  1410. (* copy descriptor of src to that of dest. If not existent then create.*)
  1411. PROCEDURE ShallowCopy*(VAR dest: ADDRESS; src: ADDRESS);
  1412. VAR ptr: ANY; flags: SET;
  1413. PROCEDURE UseTypeDescriptor;
  1414. VAR tag: LONGINT; ptr: ANY;
  1415. BEGIN
  1416. SYSTEM.GET( src + Heaps.TypeDescOffset, tag ); Heaps.NewRec( ptr, tag, FALSE );
  1417. dest := SYSTEM.VAL( LONGINT, ptr );
  1418. END UseTypeDescriptor;
  1419. PROCEDURE CopyDescriptor;
  1420. BEGIN
  1421. SYSTEM.MOVE( src , dest, MathLenOffset + SIZEOF(ADDRESS) * GetDim( src ) *2 );
  1422. END CopyDescriptor;
  1423. BEGIN
  1424. (*
  1425. KernelLog.String("ShallowCopy called with ");
  1426. KernelLog.Int(src,10); KernelLog.Int(dest,10);
  1427. KernelLog.Ln;
  1428. Report( "scopy source", src ); Report( "scopy dest", dest );
  1429. *)
  1430. IF dest = 0 THEN (* NIL pointer, guaranteed to be tensor *)
  1431. IF TensorFlag IN GetFlags( src ) THEN UseTypeDescriptor();
  1432. ELSE
  1433. ptr := GetArrayDesc( GetDim( src ) ); dest := SYSTEM.VAL( LONGINT, ptr ); (* ??? *)
  1434. END;
  1435. CopyDescriptor();
  1436. PutFlags(dest, {TensorFlag});
  1437. ELSIF GetDim( dest ) # GetDim( src ) THEN (* different dimension *)
  1438. flags := GetFlags(dest);
  1439. (* check if re-allocation of descriptor is allowed *)
  1440. IF ~(TensorFlag IN GetFlags( dest )) & ~(TemporaryFlag IN GetFlags( dest )) THEN (* no, not allowed*)
  1441. Halt(DimensionMismatch,src,0,dest);
  1442. END;
  1443. (* create a new descriptor!!! (added by Alexey) *)
  1444. ptr := GetArrayDesc( GetDim( src ) ); dest := SYSTEM.VAL( LONGINT, ptr );
  1445. CopyDescriptor();
  1446. PutFlags(dest, flags);
  1447. ELSE
  1448. flags := GetFlags(dest);
  1449. (* check if re-allocation of array data is allowed *)
  1450. IF RangeFlag IN GetFlags( dest ) THEN (* no! not allowed *)
  1451. Halt(AllocationForbidden,src,0,dest);
  1452. END;
  1453. CopyDescriptor();
  1454. PutFlags(dest, flags);
  1455. END;
  1456. END ShallowCopy;
  1457. PROCEDURE DescriptorCopy( src, dest: LONGINT );
  1458. BEGIN
  1459. IF debug THEN
  1460. KernelLog.String( "DescriptorCopy from " ); KernelLog.Int( src, 1 ); KernelLog.String( " to " );
  1461. KernelLog.Int( dest, 1 ); KernelLog.Ln;
  1462. END;
  1463. SYSTEM.MOVE( src, dest, 2*SIZEOF(ADDRESS) ); (* adr and ptr *)
  1464. SYSTEM.MOVE( src + MathLenOffset, dest + MathLenOffset, SIZEOF(ADDRESS) * GetDim( src ) *2 ); (* lens and increments *)
  1465. END DescriptorCopy;
  1466. PROCEDURE ZeroCopy*(CONST src: ARRAY [?]; VAR dest: ARRAY [?]);
  1467. VAR s,d: ADDRESS;
  1468. BEGIN
  1469. s := SYSTEM.VAL(LONGINT,src); d := SYSTEM.VAL(LONGINT,dest);
  1470. ShallowCopy(d,s);
  1471. SYSTEM.PUT(ADDRESSOF(dest),d);
  1472. END ZeroCopy;
  1473. OPERATOR "ALIAS"*(CONST src: ARRAY [?]): ARRAY[?];
  1474. BEGIN
  1475. ZeroCopy(src, RESULT);
  1476. RETURN RESULT
  1477. END "ALIAS";
  1478. PROCEDURE SameShape( l, r: ADDRESS ): BOOLEAN;
  1479. VAR dim: LONGINT;
  1480. BEGIN
  1481. dim := GetDim( l );
  1482. IF dim # GetDim( r ) THEN RETURN FALSE END;
  1483. WHILE (dim > 0) DO
  1484. DEC( dim );
  1485. IF GetLen( l, dim ) # GetLen( r, dim ) THEN RETURN FALSE END;
  1486. END;
  1487. RETURN TRUE;
  1488. END SameShape;
  1489. (*
  1490. PROCEDURE ZeroCopyArray*( dest: ADDRESS; src: ADDRESS; elementsize: LONGINT );
  1491. (*
  1492. called as ZeroCopy(A,B,Size) with enhanced arrays A,B
  1493. check if deep copy can be avoided and if so then do a shallow copy
  1494. *)
  1495. BEGIN
  1496. ASSERT( dest # 0 ); (* impossible *)
  1497. IF GetDim( src ) # GetDim( dest ) THEN (* not allowed but possible (tensor) *)
  1498. HALT( 100 );
  1499. ELSIF (RangeFlag IN GetFlags( src )) THEN
  1500. (* must copy (and allocate) *)
  1501. CopyArray( dest, src, elementsize );
  1502. ELSIF (RangeFlag IN GetFlags( dest )) THEN (* copy only allowed if shape matches *)
  1503. IF ~SameShape( dest, src ) THEN HALT( 100 );
  1504. ELSE CopyContent( dest, src, elementsize )
  1505. END;
  1506. ELSE DescriptorCopy( src, dest )
  1507. END;
  1508. END ZeroCopyArray;
  1509. PROCEDURE ZeroCopyTensor*( VAR dest: ADDRESS; src: ADDRESS; elementsize: LONGINT );
  1510. (*
  1511. called as ZeroCopy(A,B,Size) with A,B: ARRAY [?] OF ...
  1512. check if deep copy can be avoided and if so then do a shallow copy
  1513. *)
  1514. BEGIN
  1515. IF debug THEN
  1516. KernelLog.String( "ZeroCopy2: " ); KernelLog.String( "ADDRESSOF(dest) " ); KernelLog.Int( ADDRESSOF( dest ), 10 );
  1517. KernelLog.Ln; KernelLog.String( "ADDRESSOF(src) " ); KernelLog.Int( ADDRESSOF( src ), 10 ); KernelLog.Ln;
  1518. KernelLog.String( "dest " ); KernelLog.Int( dest, 10 ); KernelLog.Ln; KernelLog.String( "src " );
  1519. KernelLog.Int( src, 10 ); KernelLog.Ln; KernelLog.String( "elementsize" );
  1520. KernelLog.Int( elementsize, 10 ); KernelLog.Ln;
  1521. END;
  1522. IF (dest = 0) OR (TensorFlag IN GetFlags( dest )) THEN (* descriptor allocation allowed *)
  1523. IF (TensorFlag IN GetFlags( src )) THEN dest := src;
  1524. ELSE
  1525. CopyTensor( dest, src, elementsize ); (* allocate freshly *)
  1526. END;
  1527. ELSIF (RangeFlag IN GetFlags( src )) THEN
  1528. (* must copy (and allocate) *)
  1529. CopyTensor( dest, src, elementsize );
  1530. ELSIF (RangeFlag IN GetFlags( dest )) THEN (* descriptor copy forbidden *)
  1531. IF SameShape( src, dest ) THEN CopyContent( dest, src, elementsize )
  1532. ELSE
  1533. HALT( 100 ); (* copy forbidden *)
  1534. END;
  1535. ELSIF GetDim( src ) = GetDim( dest ) THEN (* descriptor copy allowed *)
  1536. DescriptorCopy( src, dest );
  1537. ELSE
  1538. HALT( 100 ); (* different shapes: not allowed *)
  1539. END;
  1540. END ZeroCopyTensor;
  1541. PROCEDURE ZeroCopy*( left, elementSize, dest, dim: LONGINT ); (**! optimize *)
  1542. VAR i: LONGINT;
  1543. BEGIN
  1544. IF GetPtr( dest ) = -1 THEN (* zero copy forbidden, try data copy *)
  1545. CopyContent( dest, left, elementSize )
  1546. ELSE
  1547. IF debug THEN
  1548. KernelLog.String( "Zero Copy" ); KernelLog.Int( left, 10 ); KernelLog.Int( dest, 10 );
  1549. KernelLog.Ln;
  1550. END;
  1551. PutPtr( dest, GetPtr( left ) ); PutAdr( dest, GetAdr( left ) );
  1552. FOR i := 0 TO dim - 1 DO
  1553. PutInc( dest, i, GetIncr( left, i ) ); PutLen( dest, i, GetLen( left, i ) );
  1554. END;
  1555. END;
  1556. END ZeroCopy;
  1557. *)
  1558. (*** conversions ****)
  1559. (** SHORTINT -> INTEGER *)
  1560. PROCEDURE ConvertASAILoop( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1561. BEGIN
  1562. WHILE (len > 0) DO (* SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); *)
  1563. SYSTEM.PUT16( dadr, SYSTEM.GET8( ladr ) ); INC( ladr, linc ); INC( dadr, dinc );
  1564. DEC( len );
  1565. END;
  1566. END ConvertASAILoop;
  1567. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF SHORTINT ): ARRAY [?] OF INTEGER;
  1568. BEGIN
  1569. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( INTEGER ),ConvertASAILoop );
  1570. RETURN RESULT
  1571. END "@Convert";
  1572. OPERATOR "LONG"*(CONST src: ARRAY [ ? ] OF SHORTINT ): ARRAY [?] OF INTEGER;
  1573. BEGIN
  1574. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( INTEGER ),ConvertASAILoop );
  1575. RETURN RESULT
  1576. END "LONG";
  1577. (** SHORTINT -> LONGINT *)
  1578. PROCEDURE ConvertLoopSL( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1579. BEGIN
  1580. WHILE (len > 0) DO (* SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); *)
  1581. SYSTEM.PUT32( dadr, SYSTEM.GET8( ladr ) ); INC( ladr, linc ); INC( dadr, dinc );
  1582. DEC( len );
  1583. END;
  1584. END ConvertLoopSL;
  1585. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF SHORTINT ): ARRAY [?] OF LONGINT;
  1586. BEGIN
  1587. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ),ConvertLoopSL );
  1588. RETURN RESULT
  1589. END "@Convert";
  1590. (** SHORTINT -> REAL *)
  1591. PROCEDURE ConvertLoopSR( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1592. VAR lval: SHORTINT; dval: REAL;
  1593. BEGIN
  1594. WHILE (len > 0) DO
  1595. SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  1596. INC( dadr, dinc ); DEC( len );
  1597. END;
  1598. END ConvertLoopSR;
  1599. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF SHORTINT ): ARRAY [?] OF REAL;
  1600. BEGIN
  1601. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), ConvertLoopSR );
  1602. RETURN RESULT
  1603. END "@Convert";
  1604. (** SHORTINT -> LONGREAL *)
  1605. PROCEDURE ConvertLoopSX( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1606. VAR lval: SHORTINT; dval: LONGREAL;
  1607. BEGIN
  1608. WHILE (len > 0) DO
  1609. SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  1610. INC( dadr, dinc ); DEC( len );
  1611. END;
  1612. END ConvertLoopSX;
  1613. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF LONGREAL;
  1614. BEGIN
  1615. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), ConvertLoopSX );
  1616. RETURN RESULT
  1617. END "@Convert";
  1618. (** INTEGER -> SHORTINT (SHORT) *)
  1619. PROCEDURE ConvertLoopIS( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1620. VAR lval: INTEGER; dval: SHORTINT;
  1621. BEGIN
  1622. WHILE (len > 0) DO
  1623. SYSTEM.GET( ladr, lval ); dval := SHORT( lval ); SYSTEM.PUT( dadr, dval );
  1624. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  1625. END;
  1626. END ConvertLoopIS;
  1627. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF SHORTINT;
  1628. BEGIN
  1629. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( SHORTINT ), ConvertLoopIS );
  1630. RETURN RESULT
  1631. END "@Convert";
  1632. OPERATOR "SHORT"*(CONST src: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF SHORTINT;
  1633. BEGIN
  1634. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( SHORTINT ), ConvertLoopIS );
  1635. RETURN RESULT
  1636. END "SHORT";
  1637. (** INTEGER -> LONGINT *)
  1638. PROCEDURE ConvertLoopIL( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1639. BEGIN
  1640. WHILE (len > 0) DO (* SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); *)
  1641. SYSTEM.PUT32( dadr, SYSTEM.GET16( ladr ) ); INC( ladr, linc ); INC( dadr, dinc );
  1642. DEC( len );
  1643. END;
  1644. END ConvertLoopIL;
  1645. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF LONGINT;
  1646. BEGIN
  1647. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ), ConvertLoopIL );
  1648. RETURN RESULT
  1649. END "@Convert";
  1650. OPERATOR "LONG"*(CONST src: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF LONGINT;
  1651. BEGIN
  1652. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ), ConvertLoopIL );
  1653. RETURN RESULT
  1654. END "LONG";
  1655. (** INTEGER -> REAL *)
  1656. PROCEDURE ConvertLoopIR( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1657. VAR lval: INTEGER; dval: REAL;
  1658. BEGIN
  1659. WHILE (len > 0) DO
  1660. SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  1661. INC( dadr, dinc ); DEC( len );
  1662. END;
  1663. END ConvertLoopIR;
  1664. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF REAL;
  1665. BEGIN
  1666. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), ConvertLoopIR );
  1667. RETURN RESULT
  1668. END "@Convert";
  1669. (** INTEGER -> LONGREAL *)
  1670. PROCEDURE ConvertLoopIX( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1671. VAR lval: INTEGER; dval: LONGREAL;
  1672. BEGIN
  1673. WHILE (len > 0) DO
  1674. SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  1675. INC( dadr, dinc ); DEC( len );
  1676. END;
  1677. END ConvertLoopIX;
  1678. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF LONGREAL;
  1679. BEGIN
  1680. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), ConvertLoopIX );
  1681. RETURN RESULT
  1682. END "@Convert";
  1683. (** LONGINT -> INTEGER (SHORT) *)
  1684. PROCEDURE ConvertLoopLI( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1685. VAR lval: LONGINT; dval: INTEGER;
  1686. BEGIN
  1687. WHILE (len > 0) DO
  1688. SYSTEM.GET( ladr, lval ); dval := SHORT( lval ); SYSTEM.PUT( dadr, dval );
  1689. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  1690. END;
  1691. END ConvertLoopLI;
  1692. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF INTEGER;
  1693. BEGIN
  1694. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( INTEGER ),ConvertLoopLI );
  1695. RETURN RESULT
  1696. END "@Convert";
  1697. OPERATOR "SHORT"*(CONST src: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF INTEGER;
  1698. BEGIN
  1699. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( INTEGER ),ConvertLoopLI );
  1700. RETURN RESULT
  1701. END "SHORT";
  1702. (** LONGINT -> REAL *)
  1703. PROCEDURE ConvertLoopLR( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1704. VAR lval: LONGINT; dval: REAL;
  1705. BEGIN
  1706. WHILE (len > 0) DO
  1707. SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  1708. INC( dadr, dinc ); DEC( len );
  1709. END;
  1710. END ConvertLoopLR;
  1711. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF REAL;
  1712. BEGIN
  1713. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), ConvertLoopLR );
  1714. RETURN RESULT
  1715. END "@Convert";
  1716. (** LONGINT -> LONGREAL *)
  1717. PROCEDURE ConvertLoopLX( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1718. VAR lval: LONGINT; dval: LONGREAL;
  1719. BEGIN
  1720. WHILE (len > 0) DO
  1721. SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  1722. INC( dadr, dinc ); DEC( len );
  1723. END;
  1724. END ConvertLoopLX;
  1725. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF LONGREAL;
  1726. BEGIN
  1727. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), ConvertLoopLX );
  1728. RETURN RESULT
  1729. END "@Convert";
  1730. (** REAL -> LONGINT (ENTIER) *)
  1731. PROCEDURE ConvertLoopRL( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1732. VAR lval: REAL; dval: LONGINT;
  1733. BEGIN
  1734. WHILE (len > 0) DO
  1735. SYSTEM.GET( ladr, lval ); dval := ENTIER( lval ); SYSTEM.PUT( dadr, dval );
  1736. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  1737. END;
  1738. END ConvertLoopRL;
  1739. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF LONGINT;
  1740. BEGIN
  1741. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ), ConvertLoopRL );
  1742. RETURN RESULT
  1743. END "@Convert";
  1744. OPERATOR "ENTIER"*(CONST src: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF LONGINT;
  1745. BEGIN
  1746. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ), ConvertLoopRL );
  1747. RETURN RESULT
  1748. END "ENTIER";
  1749. (** REAL -> LONGREAL *)
  1750. PROCEDURE ConvertLoopRX( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1751. VAR lval: REAL; dval: LONGREAL;
  1752. BEGIN
  1753. WHILE (len > 0) DO
  1754. SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  1755. INC( dadr, dinc ); DEC( len );
  1756. END;
  1757. END ConvertLoopRX;
  1758. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF LONGREAL;
  1759. BEGIN
  1760. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), ConvertLoopRX );
  1761. RETURN RESULT
  1762. END "@Convert";
  1763. OPERATOR "LONG"*(CONST src: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF LONGREAL;
  1764. BEGIN
  1765. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), ConvertLoopRX );
  1766. RETURN RESULT
  1767. END "LONG";
  1768. (** LONGREAL -> REAL (SHORT) *)
  1769. PROCEDURE ConvertLoopXR( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1770. VAR lval: LONGREAL; dval: REAL;
  1771. BEGIN
  1772. WHILE (len > 0) DO
  1773. SYSTEM.GET( ladr, lval ); dval := SHORT( lval ); SYSTEM.PUT( dadr, dval );
  1774. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  1775. END;
  1776. END ConvertLoopXR;
  1777. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF REAL;
  1778. BEGIN
  1779. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), ConvertLoopXR );
  1780. RETURN RESULT
  1781. END "@Convert";
  1782. OPERATOR "SHORT"*(CONST src: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF REAL;
  1783. BEGIN
  1784. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), ConvertLoopXR );
  1785. RETURN RESULT
  1786. END "SHORT";
  1787. (** LONGREAL -> LONGINT (ENTIER) *)
  1788. PROCEDURE ConvertLoopXL( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1789. VAR lval: LONGREAL; dval: LONGINT;
  1790. BEGIN
  1791. WHILE (len > 0) DO
  1792. SYSTEM.GET( ladr, lval ); dval := ENTIER( lval ); SYSTEM.PUT( dadr, dval );
  1793. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  1794. END;
  1795. END ConvertLoopXL;
  1796. OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF LONGINT;
  1797. BEGIN
  1798. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ),ConvertLoopXL );
  1799. RETURN RESULT
  1800. END "@Convert";
  1801. OPERATOR "ENTIER"*(CONST src: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF LONGINT;
  1802. BEGIN
  1803. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ),ConvertLoopXL );
  1804. RETURN RESULT
  1805. END "ENTIER";
  1806. (*** monadic not A -> ~A ********************************************************************)
  1807. (** BOOLEAN *)
  1808. PROCEDURE NotLoopAB( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1809. VAR lval: BOOLEAN;
  1810. BEGIN
  1811. WHILE (len > 0) DO
  1812. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, ~lval ); INC( ladr, linc ); INC( dadr, dinc );
  1813. DEC( len );
  1814. END;
  1815. END NotLoopAB;
  1816. OPERATOR "~"*(CONST src: ARRAY [ ? ] OF BOOLEAN): ARRAY [ ? ] OF BOOLEAN;
  1817. BEGIN
  1818. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( BOOLEAN ), NotLoopAB );
  1819. RETURN RESULT
  1820. END "~";
  1821. (*** monadic generic (A) -> -A ********************************************************************)
  1822. (** SHORTINT *)
  1823. PROCEDURE GenericLoopS( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: SHORTINT): SHORTINT );
  1824. VAR lval: SHORTINT;
  1825. BEGIN
  1826. WHILE (len > 0) DO
  1827. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, op(lval) ); INC( ladr, linc ); INC( dadr, dinc );
  1828. DEC( len );
  1829. END;
  1830. END GenericLoopS;
  1831. (** INTEGER *)
  1832. PROCEDURE GenericLoopI( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: INTEGER): INTEGER );
  1833. VAR lval: INTEGER;
  1834. BEGIN
  1835. WHILE (len > 0) DO
  1836. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, op(lval) ); INC( ladr, linc ); INC( dadr, dinc );
  1837. DEC( len );
  1838. END;
  1839. END GenericLoopI;
  1840. (** LONGINT *)
  1841. PROCEDURE GenericLoopL( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: LONGINT): LONGINT );
  1842. VAR lval: LONGINT;
  1843. BEGIN
  1844. WHILE (len > 0) DO
  1845. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, op(lval) ); INC( ladr, linc ); INC( dadr, dinc );
  1846. DEC( len );
  1847. END;
  1848. END GenericLoopL;
  1849. (** HUGEINT *)
  1850. PROCEDURE GenericLoopH( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: HUGEINT): HUGEINT );
  1851. VAR lval: HUGEINT;
  1852. BEGIN
  1853. WHILE (len > 0) DO
  1854. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, op(lval) ); INC( ladr, linc ); INC( dadr, dinc );
  1855. DEC( len );
  1856. END;
  1857. END GenericLoopH;
  1858. (** REAL *)
  1859. PROCEDURE GenericLoopR( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: REAL): REAL );
  1860. VAR lval: REAL;
  1861. BEGIN
  1862. WHILE (len > 0) DO
  1863. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, op(lval) ); INC( ladr, linc ); INC( dadr, dinc );
  1864. DEC( len );
  1865. END;
  1866. END GenericLoopR;
  1867. (** LONGREAL *)
  1868. PROCEDURE GenericLoopX( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: LONGREAL): LONGREAL );
  1869. VAR lval: LONGREAL;
  1870. BEGIN
  1871. WHILE (len > 0) DO
  1872. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, op(lval) ); INC( ladr, linc ); INC( dadr, dinc );
  1873. DEC( len );
  1874. END;
  1875. END GenericLoopX;
  1876. (** COMPLEX *)
  1877. PROCEDURE GenericLoopZ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: COMPLEX): COMPLEX );
  1878. VAR lval,dval: POINTER{UNSAFE} TO RECORD val: COMPLEX END;
  1879. BEGIN
  1880. WHILE (len > 0) DO
  1881. lval := ladr;
  1882. dval := dadr;
  1883. dval.val := op(lval.val);
  1884. INC( ladr, linc ); INC( dadr, dinc );
  1885. DEC( len );
  1886. END;
  1887. END GenericLoopZ;
  1888. (** LONGCOMPLEX *)
  1889. PROCEDURE GenericLoopLZ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: LONGCOMPLEX): LONGCOMPLEX );
  1890. VAR lval,dval: POINTER{UNSAFE} TO RECORD val: LONGCOMPLEX END;
  1891. BEGIN
  1892. WHILE (len > 0) DO
  1893. lval := ladr;
  1894. dval := dadr;
  1895. dval.val := op (lval.val);
  1896. INC( ladr, linc ); INC( dadr, dinc );
  1897. DEC( len );
  1898. END;
  1899. END GenericLoopLZ;
  1900. (*** monadic minus A -> -A ********************************************************************)
  1901. (** SHORTINT *)
  1902. PROCEDURE MinusLoopS( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1903. VAR lval: SHORTINT;
  1904. BEGIN
  1905. WHILE (len > 0) DO
  1906. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, -lval ); INC( ladr, linc ); INC( dadr, dinc );
  1907. DEC( len );
  1908. END;
  1909. END MinusLoopS;
  1910. OPERATOR "-"*(CONST src: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT;
  1911. BEGIN
  1912. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( SHORTINT ), MinusLoopS );
  1913. RETURN RESULT
  1914. END "-";
  1915. (** INTEGER *)
  1916. PROCEDURE MinusLoopI( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1917. VAR lval: INTEGER;
  1918. BEGIN
  1919. WHILE (len > 0) DO
  1920. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, -lval ); INC( ladr, linc ); INC( dadr, dinc );
  1921. DEC( len );
  1922. END;
  1923. END MinusLoopI;
  1924. OPERATOR "-"*(CONST src: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER;
  1925. BEGIN
  1926. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( INTEGER ), MinusLoopI );
  1927. RETURN RESULT
  1928. END "-";
  1929. (** LONGINT *)
  1930. PROCEDURE MinusLoopL( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1931. VAR lval: LONGINT;
  1932. BEGIN
  1933. WHILE (len > 0) DO
  1934. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, -lval ); INC( ladr, linc ); INC( dadr, dinc );
  1935. DEC( len );
  1936. END;
  1937. END MinusLoopL;
  1938. OPERATOR "-"*(CONST src: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT;
  1939. BEGIN
  1940. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ), MinusLoopL );
  1941. RETURN RESULT
  1942. END "-";
  1943. (** REAL *)
  1944. PROCEDURE MinusLoopR( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1945. VAR lval: REAL;
  1946. BEGIN
  1947. WHILE (len > 0) DO
  1948. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, -lval ); INC( ladr, linc ); INC( dadr, dinc );
  1949. DEC( len );
  1950. END;
  1951. END MinusLoopR;
  1952. OPERATOR "-"*(CONST src: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL;
  1953. BEGIN
  1954. IF debug THEN KernelLog.String( "MinusAR" ); KernelLog.Ln; END;
  1955. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), MinusLoopR );
  1956. RETURN RESULT
  1957. END "-";
  1958. (** LONGREAL *)
  1959. PROCEDURE MinusLoopX( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  1960. VAR lval: LONGREAL;
  1961. BEGIN
  1962. WHILE (len > 0) DO
  1963. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, -lval ); INC( ladr, linc ); INC( dadr, dinc );
  1964. DEC( len );
  1965. END;
  1966. END MinusLoopX;
  1967. OPERATOR "-"*(CONST src: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL;
  1968. BEGIN
  1969. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ),
  1970. MinusLoopX );
  1971. RETURN RESULT
  1972. END "-";
  1973. (*** add array + array -> array ********************************************************************)
  1974. (** SHORTINT *)
  1975. PROCEDURE AddASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  1976. VAR lval, rval: SHORTINT;
  1977. BEGIN
  1978. WHILE (len > 0) DO
  1979. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval + rval );
  1980. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  1981. END;
  1982. END AddASASLoop;
  1983. OPERATOR "+"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT;
  1984. BEGIN
  1985. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  1986. SIZEOF( SHORTINT ), AddASASLoop );
  1987. RETURN RESULT
  1988. END "+";
  1989. (** INTEGER *)
  1990. PROCEDURE AddAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  1991. VAR lval, rval: INTEGER;
  1992. BEGIN
  1993. WHILE (len > 0) DO
  1994. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval + rval );
  1995. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  1996. END;
  1997. END AddAIAILoop;
  1998. OPERATOR "+"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER;
  1999. BEGIN
  2000. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2001. SIZEOF( INTEGER ), AddAIAILoop );
  2002. RETURN RESULT
  2003. END "+";
  2004. (** LONGINT *)
  2005. PROCEDURE AddALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2006. VAR lval, rval: LONGINT;
  2007. BEGIN
  2008. WHILE (len > 0) DO
  2009. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval + rval );
  2010. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2011. END;
  2012. END AddALALLoop;
  2013. OPERATOR "+"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT;
  2014. BEGIN
  2015. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2016. SIZEOF( LONGINT ), AddALALLoop );
  2017. RETURN RESULT
  2018. END "+";
  2019. (** REAL *)
  2020. PROCEDURE AddARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2021. VAR lval, rval: REAL;
  2022. BEGIN
  2023. WHILE (len > 0) DO
  2024. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval + rval );
  2025. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2026. END;
  2027. END AddARARLoop;
  2028. OPERATOR "+"*(CONST left,right: ARRAY [?] OF REAL): ARRAY [?] OF REAL;
  2029. BEGIN
  2030. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  2031. loopAddARAR );
  2032. RETURN RESULT
  2033. END "+";
  2034. (** LONGREAL *)
  2035. PROCEDURE AddAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2036. VAR lval, rval: LONGREAL;
  2037. BEGIN
  2038. WHILE (len > 0) DO
  2039. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval + rval );
  2040. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2041. END;
  2042. END AddAXAXLoop;
  2043. OPERATOR "+"*(CONST left,right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL;
  2044. BEGIN
  2045. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2046. SIZEOF( LONGREAL ), loopAddAXAX );
  2047. RETURN RESULT
  2048. END "+";
  2049. (** COMPLEX *)
  2050. PROCEDURE AddAZAZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2051. VAR lval, rval: COMPLEX;
  2052. BEGIN
  2053. WHILE (len > 0) DO
  2054. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval + rval );
  2055. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2056. END;
  2057. END AddAZAZLoop;
  2058. OPERATOR "+"*(CONST left,right: ARRAY [?] OF COMPLEX): ARRAY [?] OF COMPLEX;
  2059. BEGIN
  2060. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2061. SIZEOF( COMPLEX ), loopAddAZAZ );
  2062. RETURN RESULT
  2063. END "+";
  2064. (** LONGCOMPLEX *)
  2065. PROCEDURE AddALZALZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2066. VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL;
  2067. BEGIN
  2068. WHILE (len > 0) DO
  2069. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  2070. SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm );
  2071. SYSTEM.PUT( dadr, lvalRe+rvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), lvalIm+rvalIm );
  2072. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  2073. DEC( len );
  2074. END;
  2075. END AddALZALZLoop;
  2076. OPERATOR "+"*(CONST left,right: ARRAY [?] OF LONGCOMPLEX): ARRAY [?] OF LONGCOMPLEX;
  2077. BEGIN
  2078. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2079. SIZEOF( LONGCOMPLEX ), loopAddALZALZ );
  2080. RETURN RESULT
  2081. END "+";
  2082. (*** add array + scalar -> array and scalar + array -> array ********************************************************************)
  2083. (** SHORTINT *)
  2084. PROCEDURE AddASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2085. VAR lval, rval: SHORTINT;
  2086. BEGIN
  2087. SYSTEM.GET( radr, rval );
  2088. WHILE (len > 0) DO
  2089. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc );
  2090. INC( dadr, dinc ); DEC( len );
  2091. END;
  2092. END AddASSSLoop;
  2093. OPERATOR "+"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF SHORTINT;
  2094. BEGIN
  2095. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2096. SIZEOF( SHORTINT ), AddASSSLoop );
  2097. RETURN RESULT
  2098. END "+";
  2099. OPERATOR "+"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT;
  2100. BEGIN
  2101. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2102. SIZEOF( SHORTINT ), AddASSSLoop );
  2103. RETURN RESULT
  2104. END "+";
  2105. (** INTEGER *)
  2106. PROCEDURE AddAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2107. VAR lval, rval: INTEGER;
  2108. BEGIN
  2109. SYSTEM.GET( radr, rval );
  2110. WHILE (len > 0) DO
  2111. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc );
  2112. INC( dadr, dinc ); DEC( len );
  2113. END;
  2114. END AddAISILoop;
  2115. OPERATOR "+"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF INTEGER;
  2116. BEGIN
  2117. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2118. SIZEOF( INTEGER ), AddAISILoop );
  2119. RETURN RESULT
  2120. END "+";
  2121. OPERATOR "+"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER;
  2122. BEGIN
  2123. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2124. SIZEOF( INTEGER ), AddAISILoop );
  2125. RETURN RESULT
  2126. END "+";
  2127. (** LONGINT *)
  2128. PROCEDURE AddALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2129. VAR lval, rval: LONGINT;
  2130. BEGIN
  2131. SYSTEM.GET( radr, rval );
  2132. WHILE (len > 0) DO
  2133. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc );
  2134. INC( dadr, dinc ); DEC( len );
  2135. END;
  2136. END AddALSLLoop;
  2137. OPERATOR "+"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF LONGINT;
  2138. BEGIN
  2139. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2140. SIZEOF( LONGINT ), AddALSLLoop );
  2141. RETURN RESULT
  2142. END "+";
  2143. OPERATOR "+"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT;
  2144. BEGIN
  2145. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2146. SIZEOF( LONGINT ), AddALSLLoop );
  2147. RETURN RESULT
  2148. END "+";
  2149. (** REAL *)
  2150. PROCEDURE AddARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2151. VAR lval, rval: REAL;
  2152. BEGIN
  2153. SYSTEM.GET( radr, rval );
  2154. WHILE (len > 0) DO
  2155. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc );
  2156. INC( dadr, dinc ); DEC( len );
  2157. END;
  2158. END AddARSRLoop;
  2159. OPERATOR "+"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF REAL;
  2160. BEGIN
  2161. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  2162. AddARSRLoop );
  2163. RETURN RESULT
  2164. END "+";
  2165. OPERATOR "+"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL;
  2166. BEGIN
  2167. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ),
  2168. AddARSRLoop );
  2169. RETURN RESULT
  2170. END "+";
  2171. (** LONGREAL *)
  2172. PROCEDURE AddAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2173. VAR lval, rval: LONGREAL;
  2174. BEGIN
  2175. SYSTEM.GET( radr, rval );
  2176. WHILE (len > 0) DO
  2177. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc );
  2178. INC( dadr, dinc ); DEC( len );
  2179. END;
  2180. END AddAXSXLoop;
  2181. OPERATOR "+"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF LONGREAL;
  2182. BEGIN
  2183. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2184. SIZEOF( LONGREAL ), AddAXSXLoop );
  2185. RETURN RESULT
  2186. END "+";
  2187. OPERATOR "+"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL;
  2188. BEGIN
  2189. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2190. SIZEOF( LONGREAL ), AddAXSXLoop );
  2191. RETURN RESULT
  2192. END "+";
  2193. (** COMPLEX *)
  2194. PROCEDURE AddAZSZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2195. VAR lval, rval: COMPLEX;
  2196. BEGIN
  2197. SYSTEM.GET( radr, rval );
  2198. WHILE (len > 0) DO
  2199. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc );
  2200. INC( dadr, dinc ); DEC( len );
  2201. END;
  2202. END AddAZSZLoop;
  2203. OPERATOR "+"*(CONST left: ARRAY [ ? ] OF COMPLEX; right: COMPLEX ): ARRAY [ ? ] OF COMPLEX;
  2204. BEGIN
  2205. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( COMPLEX ),
  2206. AddAZSZLoop );
  2207. RETURN RESULT
  2208. END "+";
  2209. OPERATOR "+"*(left: COMPLEX; CONST right: ARRAY [ ? ] OF COMPLEX): ARRAY [ ? ] OF COMPLEX;
  2210. BEGIN
  2211. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( COMPLEX ),
  2212. AddAZSZLoop );
  2213. RETURN RESULT
  2214. END "+";
  2215. (** LONGCOMPLEX *)
  2216. PROCEDURE AddALZSLZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2217. VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL;
  2218. BEGIN
  2219. SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm );
  2220. WHILE (len > 0) DO
  2221. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  2222. SYSTEM.PUT( dadr, lvalRe + rvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), lvalIm + rvalIm );
  2223. INC( ladr, linc );
  2224. INC( dadr, dinc ); DEC( len );
  2225. END;
  2226. END AddALZSLZLoop;
  2227. OPERATOR "+"*(CONST left: ARRAY [ ? ] OF LONGCOMPLEX; right: LONGCOMPLEX ): ARRAY [ ? ] OF LONGCOMPLEX;
  2228. BEGIN
  2229. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGCOMPLEX ),
  2230. AddALZSLZLoop );
  2231. RETURN RESULT
  2232. END "+";
  2233. OPERATOR "+"*(left: LONGCOMPLEX; CONST right: ARRAY [ ? ] OF LONGCOMPLEX): ARRAY [ ? ] OF LONGCOMPLEX;
  2234. BEGIN
  2235. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGCOMPLEX ),
  2236. AddALZSLZLoop );
  2237. RETURN RESULT
  2238. END "+";
  2239. (*** subtraction array - array -> array ********************************************************************)
  2240. (** SHORTINT *)
  2241. PROCEDURE SubASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2242. VAR lval, rval: SHORTINT;
  2243. BEGIN
  2244. WHILE (len > 0) DO
  2245. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval - rval );
  2246. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2247. END;
  2248. END SubASASLoop;
  2249. OPERATOR "-"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT;
  2250. BEGIN
  2251. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2252. SIZEOF( SHORTINT ), SubASASLoop );
  2253. RETURN RESULT
  2254. END "-";
  2255. (** INTEGER *)
  2256. PROCEDURE SubAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2257. VAR lval, rval: INTEGER;
  2258. BEGIN
  2259. WHILE (len > 0) DO
  2260. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval - rval );
  2261. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2262. END;
  2263. END SubAIAILoop;
  2264. OPERATOR "-"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER;
  2265. BEGIN
  2266. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2267. SIZEOF( INTEGER ), SubAIAILoop );
  2268. RETURN RESULT
  2269. END "-";
  2270. (** LONGINT *)
  2271. PROCEDURE SubALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2272. VAR lval, rval: LONGINT;
  2273. BEGIN
  2274. WHILE (len > 0) DO
  2275. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval - rval );
  2276. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2277. END;
  2278. END SubALALLoop;
  2279. OPERATOR "-"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT;
  2280. BEGIN
  2281. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2282. SIZEOF( LONGINT ), SubALALLoop );
  2283. RETURN RESULT
  2284. END "-";
  2285. (** REAL *)
  2286. PROCEDURE SubARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2287. VAR lval, rval: REAL;
  2288. BEGIN
  2289. WHILE (len > 0) DO
  2290. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval - rval );
  2291. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2292. END;
  2293. END SubARARLoop;
  2294. OPERATOR "-"*(CONST left,right: ARRAY [?] OF REAL): ARRAY [?] OF REAL;
  2295. BEGIN
  2296. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  2297. SubARARLoop );
  2298. RETURN RESULT
  2299. END "-";
  2300. (** LONGREAL *)
  2301. PROCEDURE SubAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2302. VAR lval, rval: LONGREAL;
  2303. BEGIN
  2304. WHILE (len > 0) DO
  2305. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval - rval );
  2306. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2307. END;
  2308. END SubAXAXLoop;
  2309. OPERATOR "-"*(CONST left,right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL;
  2310. BEGIN
  2311. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2312. SIZEOF( LONGREAL ), SubAXAXLoop );
  2313. RETURN RESULT
  2314. END "-";
  2315. (** COMPLEX *)
  2316. PROCEDURE SubAZAZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2317. VAR lval, rval: COMPLEX;
  2318. BEGIN
  2319. WHILE (len > 0) DO
  2320. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval - rval );
  2321. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2322. END;
  2323. END SubAZAZLoop;
  2324. OPERATOR "-"*(CONST left,right: ARRAY [?] OF COMPLEX): ARRAY [?] OF COMPLEX;
  2325. BEGIN
  2326. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2327. SIZEOF( COMPLEX ), SubAZAZLoop );
  2328. RETURN RESULT
  2329. END "-";
  2330. (** LONGCOMPLEX *)
  2331. PROCEDURE SubALZALZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2332. VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL;
  2333. BEGIN
  2334. WHILE (len > 0) DO
  2335. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  2336. SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm );
  2337. SYSTEM.PUT( dadr, lvalRe-rvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), lvalIm-rvalIm );
  2338. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  2339. DEC( len );
  2340. END;
  2341. END SubALZALZLoop;
  2342. OPERATOR "-"*(CONST left,right: ARRAY [?] OF LONGCOMPLEX): ARRAY [?] OF LONGCOMPLEX;
  2343. BEGIN
  2344. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2345. SIZEOF( LONGCOMPLEX ), SubALZALZLoop );
  2346. RETURN RESULT
  2347. END "-";
  2348. (*** subtraction array-scalar -> array ********************************************************************)
  2349. (** SHORTINT *)
  2350. OPERATOR "-"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF SHORTINT; (* a: left, b: right, c: dest *)
  2351. BEGIN
  2352. RESULT := left + (-right);
  2353. RETURN RESULT
  2354. END "-";
  2355. (** INTEGER *)
  2356. OPERATOR "-"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF INTEGER;
  2357. BEGIN
  2358. RESULT := left + (-right);
  2359. RETURN RESULT
  2360. END "-";
  2361. (** LONGINT *)
  2362. OPERATOR "-"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF LONGINT;
  2363. BEGIN
  2364. RESULT := left + (-right);
  2365. RETURN RESULT
  2366. END "-";
  2367. (** REAL *)
  2368. OPERATOR "-"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF REAL;
  2369. BEGIN
  2370. RESULT := left + (-right);
  2371. RETURN RESULT
  2372. END "-";
  2373. (** LONGREAL *)
  2374. OPERATOR "-"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF LONGREAL;
  2375. BEGIN
  2376. RESULT := left + (-right);
  2377. RETURN RESULT
  2378. END "-";
  2379. (** COMPLEX *)
  2380. OPERATOR "-"*(CONST left: ARRAY [ ? ] OF COMPLEX; right: COMPLEX ): ARRAY [ ? ] OF COMPLEX;
  2381. BEGIN
  2382. RESULT := left + (-right);
  2383. RETURN RESULT
  2384. END "-";
  2385. (** LONGCOMPLEX *)
  2386. OPERATOR "-"*(CONST left: ARRAY [ ? ] OF LONGCOMPLEX; right: LONGCOMPLEX ): ARRAY [ ? ] OF LONGCOMPLEX;
  2387. BEGIN
  2388. RESULT := left + (-right);
  2389. RETURN RESULT
  2390. END "-";
  2391. (*** subtraction scalar-array -> array ********************************************************************)
  2392. (** SHORTINT *)
  2393. PROCEDURE SubSSASLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2394. VAR lval, rval, dval: SHORTINT;
  2395. BEGIN
  2396. SYSTEM.GET( radr, rval );
  2397. WHILE (len > 0) DO
  2398. SYSTEM.GET( ladr, lval ); dval := rval - lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  2399. INC( dadr, dinc ); DEC( len );
  2400. END;
  2401. END SubSSASLoop;
  2402. OPERATOR "-"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT;
  2403. BEGIN
  2404. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2405. SIZEOF( SHORTINT ), SubSSASLoop );
  2406. RETURN RESULT
  2407. END "-";
  2408. (** INTEGER *)
  2409. PROCEDURE SubSIAILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2410. VAR lval, rval, dval: INTEGER;
  2411. BEGIN
  2412. SYSTEM.GET( radr, rval );
  2413. WHILE (len > 0) DO
  2414. SYSTEM.GET( ladr, lval ); dval := rval - lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  2415. INC( dadr, dinc ); DEC( len );
  2416. END;
  2417. END SubSIAILoop;
  2418. OPERATOR "-"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER;
  2419. BEGIN
  2420. ApplyBinaryASAOp( ADDRESSOF( RESULT), ADDRESSOF( right ), ADDRESSOF( left ),
  2421. SIZEOF( INTEGER ), SubSIAILoop );
  2422. RETURN RESULT
  2423. END "-";
  2424. (** LONGINT *)
  2425. PROCEDURE SubSLALLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2426. VAR lval, rval, dval: LONGINT;
  2427. BEGIN
  2428. SYSTEM.GET( radr, rval );
  2429. WHILE (len > 0) DO
  2430. SYSTEM.GET( ladr, lval ); dval := rval - lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  2431. INC( dadr, dinc ); DEC( len );
  2432. END;
  2433. END SubSLALLoop;
  2434. OPERATOR "-"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT;
  2435. BEGIN
  2436. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2437. SIZEOF( LONGINT ), SubSLALLoop );
  2438. RETURN RESULT
  2439. END "-";
  2440. (** REAL *)
  2441. PROCEDURE SubSRARLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2442. VAR lval, rval, dval: REAL;
  2443. BEGIN
  2444. SYSTEM.GET( radr, rval );
  2445. WHILE (len > 0) DO
  2446. SYSTEM.GET( ladr, lval ); dval := rval - lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  2447. INC( dadr, dinc ); DEC( len );
  2448. END;
  2449. END SubSRARLoop;
  2450. OPERATOR "-"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL;
  2451. BEGIN
  2452. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ),
  2453. SubSRARLoop );
  2454. RETURN RESULT
  2455. END "-";
  2456. (** LONGREAL *)
  2457. PROCEDURE SubSXAXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2458. VAR lval, rval, dval: LONGREAL;
  2459. BEGIN
  2460. SYSTEM.GET( radr, rval );
  2461. WHILE (len > 0) DO
  2462. SYSTEM.GET( ladr, lval ); dval := rval - lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  2463. INC( dadr, dinc ); DEC( len );
  2464. END;
  2465. END SubSXAXLoop;
  2466. OPERATOR "-"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL;
  2467. BEGIN
  2468. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2469. SIZEOF( LONGREAL ), SubSXAXLoop );
  2470. RETURN RESULT
  2471. END "-";
  2472. (** COMPLEX *)
  2473. PROCEDURE SubSZAZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2474. VAR lval, rval, dval: COMPLEX;
  2475. BEGIN
  2476. SYSTEM.GET( radr, rval );
  2477. WHILE (len > 0) DO
  2478. SYSTEM.GET( ladr, lval ); dval := rval - lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  2479. INC( dadr, dinc ); DEC( len );
  2480. END;
  2481. END SubSZAZLoop;
  2482. OPERATOR "-"*(left: COMPLEX; CONST right: ARRAY [ ? ] OF COMPLEX): ARRAY [ ? ] OF COMPLEX;
  2483. BEGIN
  2484. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2485. SIZEOF( COMPLEX ), SubSZAZLoop );
  2486. RETURN RESULT
  2487. END "-";
  2488. (** LONGCOMPLEX *)
  2489. PROCEDURE SubSLZALZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2490. VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL;
  2491. BEGIN
  2492. SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm );
  2493. WHILE (len > 0) DO
  2494. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  2495. SYSTEM.PUT( dadr, rvalRe-lvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), rvalIm-lvalIm );
  2496. INC( ladr, linc );
  2497. INC( dadr, dinc ); DEC( len );
  2498. END;
  2499. END SubSLZALZLoop;
  2500. OPERATOR "-"*(left: LONGCOMPLEX; CONST right: ARRAY [ ? ] OF LONGCOMPLEX): ARRAY [ ? ] OF LONGCOMPLEX;
  2501. BEGIN
  2502. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2503. SIZEOF( LONGCOMPLEX ), SubSLZALZLoop );
  2504. RETURN RESULT
  2505. END "-";
  2506. (*** element-wise multiply array x array -> array ********************************************************************)
  2507. (** SHORTINT *)
  2508. PROCEDURE EMulASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2509. VAR lval, rval: SHORTINT;
  2510. BEGIN
  2511. WHILE (len > 0) DO
  2512. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval * rval );
  2513. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2514. END;
  2515. END EMulASASLoop;
  2516. OPERATOR ".*"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT;
  2517. BEGIN
  2518. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2519. SIZEOF( SHORTINT ), EMulASASLoop );
  2520. RETURN RESULT
  2521. END ".*";
  2522. (** INTEGER *)
  2523. PROCEDURE EMulAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2524. VAR lval, rval: INTEGER; dval: INTEGER;
  2525. BEGIN
  2526. WHILE (len > 0) DO
  2527. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval * rval;
  2528. SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  2529. DEC( len );
  2530. END;
  2531. END EMulAIAILoop;
  2532. OPERATOR ".*"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER;
  2533. BEGIN
  2534. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2535. SIZEOF( INTEGER ), EMulAIAILoop );
  2536. RETURN RESULT
  2537. END ".*";
  2538. (** LONGINT *)
  2539. PROCEDURE EMulALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2540. VAR lval, rval: LONGINT;
  2541. BEGIN
  2542. WHILE (len > 0) DO
  2543. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval * rval );
  2544. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2545. END;
  2546. END EMulALALLoop;
  2547. OPERATOR ".*"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT;
  2548. BEGIN
  2549. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2550. SIZEOF( LONGINT ), EMulALALLoop );
  2551. RETURN RESULT
  2552. END ".*";
  2553. (** REAL *)
  2554. PROCEDURE EMulARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2555. VAR lval, rval: REAL;
  2556. BEGIN
  2557. WHILE (len > 0) DO
  2558. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval * rval );
  2559. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2560. END;
  2561. END EMulARARLoop;
  2562. OPERATOR ".*"*(CONST left,right: ARRAY [?] OF REAL): ARRAY [?] OF REAL;
  2563. BEGIN
  2564. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  2565. EMulARARLoop );
  2566. RETURN RESULT
  2567. END ".*";
  2568. (** LONGREAL *)
  2569. PROCEDURE EMulAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2570. VAR lval, rval: LONGREAL;
  2571. BEGIN
  2572. WHILE (len > 0) DO
  2573. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval * rval );
  2574. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2575. END;
  2576. END EMulAXAXLoop;
  2577. OPERATOR ".*"*(CONST left,right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL;
  2578. BEGIN
  2579. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2580. SIZEOF( LONGREAL ), EMulAXAXLoop );
  2581. RETURN RESULT
  2582. END ".*";
  2583. (** COMPLEX *)
  2584. PROCEDURE EMulAZAZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2585. VAR lval, rval: COMPLEX;
  2586. BEGIN
  2587. WHILE (len > 0) DO
  2588. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval * rval );
  2589. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2590. END;
  2591. END EMulAZAZLoop;
  2592. OPERATOR ".*"*(CONST left,right: ARRAY [?] OF COMPLEX): ARRAY [?] OF COMPLEX;
  2593. BEGIN
  2594. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2595. SIZEOF( COMPLEX ), EMulAZAZLoop );
  2596. RETURN RESULT
  2597. END ".*";
  2598. (** LONGCOMPLEX *)
  2599. PROCEDURE EMulALZALZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2600. VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL;
  2601. BEGIN
  2602. WHILE (len > 0) DO
  2603. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  2604. SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm );
  2605. SYSTEM.PUT( dadr, lvalRe*rvalRe - lvalIm*rvalIm ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), lvalRe*rvalIm + lvalIm*rvalRe );
  2606. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  2607. DEC( len );
  2608. END;
  2609. END EMulALZALZLoop;
  2610. OPERATOR ".*"*(CONST left,right: ARRAY [?] OF LONGCOMPLEX): ARRAY [?] OF LONGCOMPLEX;
  2611. BEGIN
  2612. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2613. SIZEOF( LONGCOMPLEX ), EMulALZALZLoop );
  2614. RETURN RESULT
  2615. END ".*";
  2616. (*** element-wise multiply and add array x array -> array ********************************************************************)
  2617. (** SHORTINT *)
  2618. PROCEDURE EMulIncASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2619. VAR lval, rval,dval: SHORTINT;
  2620. BEGIN
  2621. WHILE (len > 0) DO
  2622. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.GET(dadr,dval); SYSTEM.PUT( dadr, dval + lval * rval );
  2623. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2624. END;
  2625. END EMulIncASASLoop;
  2626. OPERATOR ".*+"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT;
  2627. BEGIN
  2628. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2629. SIZEOF( SHORTINT ), EMulIncASASLoop );
  2630. END ".*+";
  2631. (** INTEGER *)
  2632. PROCEDURE EMulIncAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2633. VAR lval, rval,dval: INTEGER;
  2634. BEGIN
  2635. WHILE (len > 0) DO
  2636. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );SYSTEM.GET(dadr,dval); dval := dval + lval * rval;
  2637. SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  2638. DEC( len );
  2639. END;
  2640. END EMulIncAIAILoop;
  2641. OPERATOR ".*+"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER;
  2642. BEGIN
  2643. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2644. SIZEOF( INTEGER ), EMulIncAIAILoop );
  2645. END ".*+";
  2646. (** LONGINT *)
  2647. PROCEDURE EMulIncALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2648. VAR lval, rval,dval: LONGINT;
  2649. BEGIN
  2650. WHILE (len > 0) DO
  2651. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.GET(dadr,dval); SYSTEM.PUT( dadr, dval+ lval * rval );
  2652. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2653. END;
  2654. END EMulIncALALLoop;
  2655. OPERATOR ".*+"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT;
  2656. BEGIN
  2657. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2658. SIZEOF( LONGINT ), EMulIncALALLoop );
  2659. END ".*+";
  2660. (** REAL *)
  2661. PROCEDURE EMulIncARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2662. VAR lval, rval,dval: REAL;
  2663. BEGIN
  2664. WHILE (len > 0) DO
  2665. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.GET(dadr,dval); SYSTEM.PUT( dadr, dval+ lval * rval );
  2666. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2667. END;
  2668. END EMulIncARARLoop;
  2669. OPERATOR ".*+"*(CONST left,right: ARRAY [?] OF REAL): ARRAY [?] OF REAL;
  2670. BEGIN
  2671. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  2672. EMulIncARARLoop );
  2673. END ".*+";
  2674. (** LONGREAL *)
  2675. PROCEDURE EMulIncAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  2676. VAR lval, rval,dval: LONGREAL;
  2677. BEGIN
  2678. WHILE (len > 0) DO
  2679. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.GET(dadr,dval); SYSTEM.PUT( dadr,dval+ lval * rval );
  2680. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  2681. END;
  2682. END EMulIncAXAXLoop;
  2683. OPERATOR ".*+"*(CONST left,right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL;
  2684. BEGIN
  2685. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2686. SIZEOF( LONGREAL ), EMulIncAXAXLoop );
  2687. END ".*+";
  2688. (*** multiply array x scalar -> array and scalar + array -> array ********************************************************************)
  2689. (** SHORTINT *)
  2690. PROCEDURE MulASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2691. VAR lval, rval: SHORTINT;
  2692. BEGIN
  2693. SYSTEM.GET( radr, rval );
  2694. WHILE (len > 0) DO
  2695. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc );
  2696. INC( dadr, dinc ); DEC( len );
  2697. END;
  2698. END MulASSSLoop;
  2699. OPERATOR "*"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF SHORTINT;
  2700. BEGIN
  2701. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2702. SIZEOF( SHORTINT ), MulASSSLoop );
  2703. RETURN RESULT
  2704. END "*";
  2705. OPERATOR "*"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT;
  2706. BEGIN
  2707. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2708. SIZEOF( SHORTINT ), MulASSSLoop );
  2709. RETURN RESULT
  2710. END "*";
  2711. (** INTEGER *)
  2712. PROCEDURE MulAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2713. VAR lval, rval: INTEGER;
  2714. BEGIN
  2715. SYSTEM.GET( radr, rval );
  2716. WHILE (len > 0) DO
  2717. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc );
  2718. INC( dadr, dinc ); DEC( len );
  2719. END;
  2720. END MulAISILoop;
  2721. OPERATOR "*"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF INTEGER;
  2722. BEGIN
  2723. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2724. SIZEOF( INTEGER ), MulAISILoop );
  2725. RETURN RESULT
  2726. END "*";
  2727. OPERATOR "*"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER;
  2728. BEGIN
  2729. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2730. SIZEOF( INTEGER ), MulAISILoop );
  2731. RETURN RESULT
  2732. END "*";
  2733. (** LONGINT *)
  2734. PROCEDURE MulALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2735. VAR lval, rval: LONGINT;
  2736. BEGIN
  2737. SYSTEM.GET( radr, rval );
  2738. WHILE (len > 0) DO
  2739. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc );
  2740. INC( dadr, dinc ); DEC( len );
  2741. END;
  2742. END MulALSLLoop;
  2743. OPERATOR "*"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF LONGINT;
  2744. BEGIN
  2745. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2746. SIZEOF( LONGINT ), MulALSLLoop );
  2747. RETURN RESULT
  2748. END "*";
  2749. OPERATOR "*"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT;
  2750. BEGIN
  2751. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2752. SIZEOF( LONGINT ), MulALSLLoop );
  2753. RETURN RESULT
  2754. END "*";
  2755. (** REAL *)
  2756. PROCEDURE MulARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2757. VAR lval, rval: REAL;
  2758. BEGIN
  2759. SYSTEM.GET( radr, rval );
  2760. WHILE (len > 0) DO
  2761. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc );
  2762. INC( dadr, dinc ); DEC( len );
  2763. END;
  2764. END MulARSRLoop;
  2765. OPERATOR "*"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF REAL;
  2766. BEGIN
  2767. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  2768. loopMulARSR );
  2769. RETURN RESULT
  2770. END "*";
  2771. OPERATOR "*"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL;
  2772. BEGIN
  2773. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ),
  2774. loopMulARSR );
  2775. RETURN RESULT
  2776. END "*";
  2777. (** LONGREAL *)
  2778. PROCEDURE MulAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2779. VAR lval, rval: LONGREAL;
  2780. BEGIN
  2781. IF debug THEN
  2782. KernelLog.String( "MulAXSXLoop, ladr,radr,dadr,linc,dinc,len= " ); KernelLog.Int( ladr, 10 ); KernelLog.Int( radr, 10 );
  2783. KernelLog.Int( dadr, 10 ); KernelLog.Int( linc, 10 ); KernelLog.Int( dinc, 10 );
  2784. KernelLog.Int( len, 10 ); KernelLog.Ln;
  2785. END;
  2786. SYSTEM.GET( radr, rval );
  2787. WHILE (len > 0) DO
  2788. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc );
  2789. INC( dadr, dinc ); DEC( len );
  2790. END;
  2791. END MulAXSXLoop;
  2792. OPERATOR "*"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF LONGREAL;
  2793. BEGIN
  2794. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2795. SIZEOF( LONGREAL ), loopMulAXSX );
  2796. RETURN RESULT
  2797. END "*";
  2798. OPERATOR "*"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL;
  2799. BEGIN
  2800. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2801. SIZEOF( LONGREAL ), loopMulAXSX );
  2802. RETURN RESULT
  2803. END "*";
  2804. (** COMPLEX *)
  2805. PROCEDURE MulAZSZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2806. VAR lval, rval: COMPLEX;
  2807. BEGIN
  2808. SYSTEM.GET( radr, rval );
  2809. WHILE (len > 0) DO
  2810. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc );
  2811. INC( dadr, dinc ); DEC( len );
  2812. END;
  2813. END MulAZSZLoop;
  2814. OPERATOR "*"*(CONST left: ARRAY [ ? ] OF COMPLEX; right: COMPLEX ): ARRAY [ ? ] OF COMPLEX;
  2815. BEGIN
  2816. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( COMPLEX ),
  2817. loopMulAZSZ );
  2818. RETURN RESULT
  2819. END "*";
  2820. OPERATOR "*"*(left: COMPLEX; CONST right: ARRAY [ ? ] OF COMPLEX): ARRAY [ ? ] OF COMPLEX;
  2821. BEGIN
  2822. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( COMPLEX ),
  2823. loopMulAZSZ );
  2824. RETURN RESULT
  2825. END "*";
  2826. (** LONGCOMPLEX *)
  2827. PROCEDURE MulALZSLZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2828. VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL;
  2829. BEGIN
  2830. SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm );
  2831. WHILE (len > 0) DO
  2832. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  2833. SYSTEM.PUT( dadr, lvalRe * rvalRe - lvalIm*rvalIm ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), lvalRe * rvalIm + lvalIm*rvalRe );
  2834. INC( ladr, linc );
  2835. INC( dadr, dinc ); DEC( len );
  2836. END;
  2837. END MulALZSLZLoop;
  2838. OPERATOR "*"*(CONST left: ARRAY [ ? ] OF LONGCOMPLEX; right: LONGCOMPLEX ): ARRAY [ ? ] OF LONGCOMPLEX;
  2839. BEGIN
  2840. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGCOMPLEX ),
  2841. loopMulALZSLZ );
  2842. RETURN RESULT
  2843. END "*";
  2844. OPERATOR "*"*(left: LONGCOMPLEX; CONST right: ARRAY [ ? ] OF LONGCOMPLEX): ARRAY [ ? ] OF LONGCOMPLEX;
  2845. BEGIN
  2846. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGCOMPLEX ),
  2847. loopMulALZSLZ );
  2848. RETURN RESULT
  2849. END "*";
  2850. (*** multiply and add array * scalar -> array and scalar * array -> array ********************************************************************)
  2851. (** SHORTINT *)
  2852. PROCEDURE IncMulASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2853. VAR lval, rval, dval: SHORTINT;
  2854. BEGIN
  2855. SYSTEM.GET( radr, rval );
  2856. WHILE (len > 0) DO
  2857. SYSTEM.GET( ladr, lval ); SYSTEM.GET( dadr, dval ); SYSTEM.PUT( dadr, dval + lval * rval );
  2858. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  2859. END;
  2860. END IncMulASSSLoop;
  2861. OPERATOR "INCMUL"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF SHORTINT;
  2862. BEGIN
  2863. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2864. SIZEOF( SHORTINT ), IncMulASSSLoop );
  2865. END "INCMUL";
  2866. OPERATOR "INCMUL"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT;
  2867. BEGIN
  2868. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2869. SIZEOF( SHORTINT ), IncMulASSSLoop );
  2870. RETURN RESULT
  2871. END "INCMUL";
  2872. OPERATOR "DECMUL"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF SHORTINT;
  2873. BEGIN
  2874. RESULT := -RESULT;
  2875. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2876. SIZEOF( SHORTINT ), IncMulASSSLoop );
  2877. RESULT := -RESULT;
  2878. RETURN RESULT
  2879. END "DECMUL";
  2880. OPERATOR "DECMUL"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT;
  2881. BEGIN
  2882. RESULT := -RESULT;
  2883. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2884. SIZEOF( SHORTINT ), IncMulASSSLoop );
  2885. RESULT := -RESULT;
  2886. RETURN RESULT
  2887. END "DECMUL";
  2888. (** INTEGER *)
  2889. PROCEDURE IncMulAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2890. VAR lval, rval, dval: INTEGER;
  2891. BEGIN
  2892. SYSTEM.GET( radr, rval );
  2893. WHILE (len > 0) DO
  2894. SYSTEM.GET( ladr, lval ); SYSTEM.GET( dadr, dval ); SYSTEM.PUT( dadr, dval + lval * rval );
  2895. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  2896. END;
  2897. END IncMulAISILoop;
  2898. OPERATOR "INCMUL"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF INTEGER;
  2899. BEGIN
  2900. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2901. SIZEOF( INTEGER ), IncMulAISILoop );
  2902. RETURN RESULT
  2903. END "INCMUL";
  2904. OPERATOR "INCMUL"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER;
  2905. BEGIN
  2906. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2907. SIZEOF( INTEGER ), IncMulAISILoop );
  2908. RETURN RESULT
  2909. END "INCMUL";
  2910. OPERATOR "DECMUL"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF INTEGER;
  2911. BEGIN
  2912. RESULT := -RESULT;
  2913. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2914. SIZEOF( INTEGER ), IncMulAISILoop );
  2915. RESULT := -RESULT;
  2916. RETURN RESULT
  2917. END "DECMUL";
  2918. OPERATOR "DECMUL"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER;
  2919. BEGIN
  2920. RESULT := -RESULT;
  2921. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2922. SIZEOF( INTEGER ), IncMulAISILoop );
  2923. RESULT := -RESULT;
  2924. RETURN RESULT
  2925. END "DECMUL";
  2926. (** LONGINT *)
  2927. PROCEDURE IncMulALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2928. VAR lval, rval, dval: LONGINT;
  2929. BEGIN
  2930. SYSTEM.GET( radr, rval );
  2931. WHILE (len > 0) DO
  2932. SYSTEM.GET( ladr, lval ); SYSTEM.GET( dadr, dval ); SYSTEM.PUT( dadr, dval + lval * rval );
  2933. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  2934. END;
  2935. END IncMulALSLLoop;
  2936. OPERATOR "INCMUL"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF LONGINT;
  2937. BEGIN
  2938. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2939. SIZEOF( LONGINT ), IncMulALSLLoop );
  2940. RETURN RESULT
  2941. END "INCMUL";
  2942. OPERATOR "INCMUL"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT;
  2943. BEGIN
  2944. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2945. SIZEOF( LONGINT ), IncMulALSLLoop );
  2946. RETURN RESULT
  2947. END "INCMUL";
  2948. OPERATOR "DECMUL"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF LONGINT;
  2949. BEGIN
  2950. RESULT := -RESULT;
  2951. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  2952. SIZEOF( LONGINT ), IncMulALSLLoop );
  2953. RESULT := -RESULT;
  2954. RETURN RESULT
  2955. END "DECMUL";
  2956. OPERATOR "DECMUL"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT;
  2957. BEGIN
  2958. RESULT := -RESULT;
  2959. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  2960. SIZEOF( LONGINT ), IncMulALSLLoop );
  2961. RESULT := -RESULT;
  2962. RETURN RESULT
  2963. END "DECMUL";
  2964. (** REAL *)
  2965. PROCEDURE IncMulARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  2966. VAR lval, rval, dval: REAL;
  2967. BEGIN
  2968. SYSTEM.GET( radr, rval );
  2969. WHILE (len > 0) DO
  2970. SYSTEM.GET( ladr, lval ); SYSTEM.GET( dadr, dval ); SYSTEM.PUT( dadr, dval + lval * rval );
  2971. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  2972. END;
  2973. END IncMulARSRLoop;
  2974. OPERATOR "INCMUL"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF REAL;
  2975. BEGIN
  2976. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  2977. loopIncMulARSR );
  2978. RETURN RESULT
  2979. END "INCMUL";
  2980. OPERATOR "INCMUL"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL;
  2981. BEGIN
  2982. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ),
  2983. loopIncMulARSR );
  2984. RETURN RESULT
  2985. END "INCMUL";
  2986. OPERATOR "DECMUL"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF REAL;
  2987. BEGIN
  2988. RESULT := -RESULT;
  2989. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  2990. loopIncMulARSR );
  2991. RESULT := -RESULT;
  2992. RETURN RESULT
  2993. END "DECMUL";
  2994. OPERATOR "DECMUL"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL;
  2995. BEGIN
  2996. RESULT := -RESULT;
  2997. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ),
  2998. loopIncMulARSR );
  2999. RESULT := -RESULT;
  3000. RETURN RESULT
  3001. END "DECMUL";
  3002. (** LONGREAL *)
  3003. PROCEDURE IncMulAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3004. VAR lval, rval, dval: LONGREAL;
  3005. BEGIN
  3006. IF debug THEN
  3007. KernelLog.String( "IncMulAXSXLoop, ladr,radr,dadr,linc,dinc,len= " ); KernelLog.Int( ladr, 10 ); KernelLog.Int( radr, 10 );
  3008. KernelLog.Int( dadr, 10 ); KernelLog.Int( linc, 10 ); KernelLog.Int( dinc, 10 );
  3009. KernelLog.Int( len, 10 ); KernelLog.Ln;
  3010. END;
  3011. SYSTEM.GET( radr, rval );
  3012. WHILE (len > 0) DO
  3013. SYSTEM.GET( ladr, lval ); SYSTEM.GET( dadr, dval ); SYSTEM.PUT( dadr, dval + lval * rval );
  3014. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  3015. END;
  3016. END IncMulAXSXLoop;
  3017. OPERATOR "INCMUL"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF LONGREAL;
  3018. BEGIN
  3019. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3020. SIZEOF( LONGREAL ), loopIncMulAXSX );
  3021. RETURN RESULT
  3022. END "INCMUL";
  3023. OPERATOR "INCMUL"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL;
  3024. BEGIN
  3025. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  3026. SIZEOF( LONGREAL ), loopIncMulAXSX );
  3027. RETURN RESULT
  3028. END "INCMUL";
  3029. OPERATOR "DECMUL"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF LONGREAL;
  3030. BEGIN
  3031. RESULT := -RESULT;
  3032. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3033. SIZEOF( LONGREAL ), loopIncMulAXSX );
  3034. RESULT := -RESULT;
  3035. RETURN RESULT
  3036. END "DECMUL";
  3037. OPERATOR "DECMUL"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL;
  3038. BEGIN
  3039. RESULT := -RESULT;
  3040. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  3041. SIZEOF( LONGREAL ), loopIncMulAXSX );
  3042. RESULT := -RESULT;
  3043. RETURN RESULT
  3044. END "DECMUL";
  3045. (*** element-wise division array / array -> array ********************************************************************)
  3046. (** SHORTINT *)
  3047. PROCEDURE EDivideASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3048. VAR lval, rval: SHORTINT; dval: REAL;
  3049. BEGIN
  3050. WHILE (len > 0) DO
  3051. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval / rval;
  3052. SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  3053. DEC( len );
  3054. END;
  3055. END EDivideASASLoop;
  3056. OPERATOR "./"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF REAL;
  3057. BEGIN
  3058. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  3059. EDivideASASLoop );
  3060. RETURN RESULT
  3061. END "./";
  3062. (** INTEGER *)
  3063. PROCEDURE EDivideAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3064. VAR lval, rval: INTEGER; dval: REAL;
  3065. BEGIN
  3066. WHILE (len > 0) DO
  3067. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval / rval;
  3068. SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  3069. DEC( len );
  3070. END;
  3071. END EDivideAIAILoop;
  3072. OPERATOR "./"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF REAL;
  3073. BEGIN
  3074. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  3075. EDivideAIAILoop );
  3076. RETURN RESULT
  3077. END "./";
  3078. (** LONGINT *)
  3079. PROCEDURE EDivideALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3080. VAR lval, rval: LONGINT; dval: REAL;
  3081. BEGIN
  3082. WHILE (len > 0) DO
  3083. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval / rval;
  3084. SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  3085. DEC( len );
  3086. END;
  3087. END EDivideALALLoop;
  3088. OPERATOR "./"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF REAL;
  3089. BEGIN
  3090. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  3091. EDivideALALLoop );
  3092. RETURN RESULT
  3093. END "./";
  3094. (** REAL *)
  3095. PROCEDURE EDivideARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3096. VAR lval, rval: REAL; dval: REAL;
  3097. BEGIN
  3098. WHILE (len > 0) DO
  3099. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval / rval;
  3100. SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  3101. DEC( len );
  3102. END;
  3103. END EDivideARARLoop;
  3104. OPERATOR "./"*(CONST left,right: ARRAY [?] OF REAL): ARRAY [?] OF REAL;
  3105. BEGIN
  3106. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  3107. EDivideARARLoop );
  3108. RETURN RESULT
  3109. END "./";
  3110. (** LONGREAL *)
  3111. PROCEDURE EDivideAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3112. VAR lval, rval: LONGREAL; dval: LONGREAL;
  3113. BEGIN
  3114. WHILE (len > 0) DO
  3115. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval / rval;
  3116. SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  3117. DEC( len );
  3118. END;
  3119. END EDivideAXAXLoop;
  3120. OPERATOR "./"*(CONST left,right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL;
  3121. BEGIN
  3122. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3123. SIZEOF( LONGREAL ), EDivideAXAXLoop );
  3124. RETURN RESULT
  3125. END "./";
  3126. (** COMPLEX *)
  3127. PROCEDURE EDivideAZAZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3128. VAR lval, rval: COMPLEX; dval: COMPLEX;
  3129. BEGIN
  3130. WHILE (len > 0) DO
  3131. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval / rval;
  3132. SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  3133. DEC( len );
  3134. END;
  3135. END EDivideAZAZLoop;
  3136. OPERATOR "./"*(CONST left,right: ARRAY [?] OF COMPLEX): ARRAY [?] OF COMPLEX;
  3137. BEGIN
  3138. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3139. SIZEOF( COMPLEX ), EDivideAZAZLoop );
  3140. RETURN RESULT
  3141. END "./";
  3142. (** LONGCOMPLEX *)
  3143. PROCEDURE EDivideALZALZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3144. VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; dvalRe, dvalIm: LONGREAL; v: LONGREAL;
  3145. BEGIN
  3146. WHILE (len > 0) DO
  3147. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  3148. SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm );
  3149. IF rvalIm # 0.0D0 THEN
  3150. v := 1.0D0/(rvalRe*rvalRe + rvalIm*rvalIm);
  3151. dvalRe := v*(lvalRe*rvalRe+lvalIm*rvalIm);
  3152. dvalIm := v*(lvalIm*rvalRe-lvalRe*rvalIm);
  3153. ELSE
  3154. dvalRe := lvalRe/rvalRe;
  3155. dvalIm := lvalIm/rvalRe;
  3156. END;
  3157. SYSTEM.PUT( dadr, dvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), dvalIm );
  3158. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  3159. DEC( len );
  3160. END;
  3161. END EDivideALZALZLoop;
  3162. OPERATOR "./"*(CONST left,right: ARRAY [?] OF LONGCOMPLEX): ARRAY [?] OF LONGCOMPLEX;
  3163. BEGIN
  3164. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3165. SIZEOF( LONGCOMPLEX ), EDivideALZALZLoop );
  3166. RETURN RESULT
  3167. END "./";
  3168. (*** division array / scalar -> array and scalar / array -> array ********************************************************************)
  3169. (** SHORTINT *)
  3170. PROCEDURE DivideASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3171. VAR lval, rval: SHORTINT; dval: REAL;
  3172. BEGIN
  3173. SYSTEM.GET( radr, rval );
  3174. WHILE (len > 0) DO
  3175. SYSTEM.GET( ladr, lval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  3176. INC( dadr, dinc ); DEC( len );
  3177. END;
  3178. END DivideASSSLoop;
  3179. OPERATOR "/"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF REAL;
  3180. BEGIN
  3181. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  3182. DivideASSSLoop );
  3183. RETURN RESULT
  3184. END "/";
  3185. PROCEDURE DivideSSASLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3186. VAR lval, rval: SHORTINT; dval: REAL;
  3187. BEGIN
  3188. SYSTEM.GET( radr, rval );
  3189. WHILE (len > 0) DO
  3190. SYSTEM.GET( ladr, lval ); dval := rval / lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  3191. INC( dadr, dinc ); DEC( len );
  3192. END;
  3193. END DivideSSASLoop;
  3194. OPERATOR "/"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF REAL;
  3195. BEGIN
  3196. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ),
  3197. DivideSSASLoop );
  3198. RETURN RESULT
  3199. END "/";
  3200. (** INTEGER *)
  3201. PROCEDURE DivideAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3202. VAR lval, rval: INTEGER; dval: REAL;
  3203. BEGIN
  3204. SYSTEM.GET( radr, rval );
  3205. WHILE (len > 0) DO
  3206. SYSTEM.GET( ladr, lval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  3207. INC( dadr, dinc ); DEC( len );
  3208. END;
  3209. END DivideAISILoop;
  3210. OPERATOR "/"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF REAL;
  3211. BEGIN
  3212. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  3213. DivideAISILoop );
  3214. RETURN RESULT
  3215. END "/";
  3216. PROCEDURE DivideSIAILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3217. VAR lval, rval: INTEGER; dval: REAL;
  3218. BEGIN
  3219. SYSTEM.GET( radr, rval );
  3220. WHILE (len > 0) DO
  3221. SYSTEM.GET( ladr, lval ); dval := rval / lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  3222. INC( dadr, dinc ); DEC( len );
  3223. END;
  3224. END DivideSIAILoop;
  3225. OPERATOR "/"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF REAL;
  3226. BEGIN
  3227. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ),
  3228. DivideSIAILoop );
  3229. RETURN RESULT
  3230. END "/";
  3231. (** LONGINT *)
  3232. PROCEDURE DivideALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3233. VAR lval, rval: LONGINT; dval: REAL;
  3234. BEGIN
  3235. SYSTEM.GET( radr, rval );
  3236. WHILE (len > 0) DO
  3237. SYSTEM.GET( ladr, lval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  3238. INC( dadr, dinc ); DEC( len );
  3239. END;
  3240. END DivideALSLLoop;
  3241. OPERATOR "/"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF REAL;
  3242. BEGIN
  3243. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  3244. DivideALSLLoop );
  3245. RETURN RESULT
  3246. END "/";
  3247. PROCEDURE DivideSLALLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3248. VAR lval, rval: LONGINT; dval: REAL;
  3249. BEGIN
  3250. SYSTEM.GET( radr, rval );
  3251. WHILE (len > 0) DO
  3252. SYSTEM.GET( ladr, lval ); dval := rval / lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  3253. INC( dadr, dinc ); DEC( len );
  3254. END;
  3255. END DivideSLALLoop;
  3256. OPERATOR "/"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF REAL;
  3257. BEGIN
  3258. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ),
  3259. DivideSLALLoop );
  3260. RETURN RESULT
  3261. END "/";
  3262. (** REAL *)
  3263. PROCEDURE DivideARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3264. VAR lval, rval: REAL; dval: REAL;
  3265. BEGIN
  3266. SYSTEM.GET( radr, rval );
  3267. WHILE (len > 0) DO
  3268. SYSTEM.GET( ladr, lval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  3269. INC( dadr, dinc ); DEC( len );
  3270. END;
  3271. END DivideARSRLoop;
  3272. OPERATOR "/"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF REAL;
  3273. BEGIN
  3274. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  3275. DivideARSRLoop );
  3276. RETURN RESULT
  3277. END "/";
  3278. PROCEDURE DivideSRARLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3279. VAR lval, rval: REAL; dval: REAL;
  3280. BEGIN
  3281. SYSTEM.GET( radr, rval );
  3282. WHILE (len > 0) DO
  3283. SYSTEM.GET( ladr, lval ); dval := rval / lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  3284. INC( dadr, dinc ); DEC( len );
  3285. END;
  3286. END DivideSRARLoop;
  3287. OPERATOR "/"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL;
  3288. BEGIN
  3289. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ),
  3290. DivideSRARLoop );
  3291. RETURN RESULT
  3292. END "/";
  3293. (** LONGREAL *)
  3294. PROCEDURE DivideAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3295. VAR lval, rval: LONGREAL; dval: LONGREAL;
  3296. BEGIN
  3297. SYSTEM.GET( radr, rval );
  3298. WHILE (len > 0) DO
  3299. SYSTEM.GET( ladr, lval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  3300. INC( dadr, dinc ); DEC( len );
  3301. END;
  3302. END DivideAXSXLoop;
  3303. OPERATOR "/"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF LONGREAL;
  3304. BEGIN
  3305. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3306. SIZEOF( LONGREAL ), DivideAXSXLoop );
  3307. RETURN RESULT
  3308. END "/";
  3309. PROCEDURE DivideSXAXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3310. VAR lval, rval: LONGREAL; dval: LONGREAL;
  3311. BEGIN
  3312. SYSTEM.GET( radr, rval );
  3313. WHILE (len > 0) DO
  3314. SYSTEM.GET( ladr, lval ); dval := rval / lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  3315. INC( dadr, dinc ); DEC( len );
  3316. END;
  3317. END DivideSXAXLoop;
  3318. OPERATOR "/"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL;
  3319. BEGIN
  3320. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  3321. SIZEOF( LONGREAL ), DivideSXAXLoop );
  3322. RETURN RESULT
  3323. END "/";
  3324. (** COMPLEX *)
  3325. PROCEDURE DivideAZSZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3326. VAR lval, rval: COMPLEX; dval: COMPLEX;
  3327. BEGIN
  3328. SYSTEM.GET( radr, rval );
  3329. WHILE (len > 0) DO
  3330. SYSTEM.GET( ladr, lval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  3331. INC( dadr, dinc ); DEC( len );
  3332. END;
  3333. END DivideAZSZLoop;
  3334. OPERATOR "/"*(CONST left: ARRAY [ ? ] OF COMPLEX; right: COMPLEX ): ARRAY [ ? ] OF COMPLEX;
  3335. BEGIN
  3336. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3337. SIZEOF( COMPLEX ), DivideAZSZLoop );
  3338. RETURN RESULT
  3339. END "/";
  3340. PROCEDURE DivideSZAZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3341. VAR lval, rval: COMPLEX; dval: COMPLEX;
  3342. BEGIN
  3343. SYSTEM.GET( radr, rval );
  3344. WHILE (len > 0) DO
  3345. SYSTEM.GET( ladr, lval ); dval := rval / lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc );
  3346. INC( dadr, dinc ); DEC( len );
  3347. END;
  3348. END DivideSZAZLoop;
  3349. OPERATOR "/"*(left: COMPLEX; CONST right: ARRAY [ ? ] OF COMPLEX): ARRAY [ ? ] OF COMPLEX;
  3350. BEGIN
  3351. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  3352. SIZEOF( COMPLEX ), DivideSZAZLoop );
  3353. RETURN RESULT
  3354. END "/";
  3355. (** LONGCOMPLEX *)
  3356. PROCEDURE DivideALZSLZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3357. VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; dvalRe, dvalIm: LONGREAL; v: LONGREAL;
  3358. BEGIN
  3359. SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm );
  3360. IF rvalIm # 0.0D0 THEN
  3361. v := 1.0D0/(rvalRe*rvalRe + rvalIm*rvalIm);
  3362. WHILE (len > 0) DO
  3363. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  3364. dvalRe := v*(lvalRe*rvalRe+lvalIm*rvalIm);
  3365. dvalIm := v*(lvalIm*rvalRe-lvalRe*rvalIm);
  3366. SYSTEM.PUT( dadr, dvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), dvalIm );
  3367. INC( ladr, linc );
  3368. INC( dadr, dinc ); DEC( len );
  3369. END;
  3370. ELSE
  3371. WHILE (len > 0) DO
  3372. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  3373. dvalRe := lvalRe / rvalRe; dvalIm := lvalIm / rvalRe;
  3374. SYSTEM.PUT( dadr, dvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), dvalIm );
  3375. INC( ladr, linc );
  3376. INC( dadr, dinc ); DEC( len );
  3377. END;
  3378. END;
  3379. END DivideALZSLZLoop;
  3380. OPERATOR "/"*(CONST left: ARRAY [ ? ] OF LONGCOMPLEX; right: LONGCOMPLEX ): ARRAY [ ? ] OF LONGCOMPLEX;
  3381. BEGIN
  3382. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3383. SIZEOF( LONGCOMPLEX ), DivideALZSLZLoop );
  3384. RETURN RESULT
  3385. END "/";
  3386. PROCEDURE DivideSLZALZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3387. VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; dvalRe, dvalIm: LONGREAL; v: LONGREAL;
  3388. BEGIN
  3389. SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm );
  3390. WHILE (len > 0) DO
  3391. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  3392. v := 1.0D0/(lvalRe*lvalRe + lvalIm*lvalIm);
  3393. dvalRe := v*(rvalRe*lvalRe+rvalIm*lvalIm);
  3394. dvalIm := v*(rvalIm*lvalRe-rvalRe*lvalIm);
  3395. SYSTEM.PUT( dadr, dvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), dvalIm );
  3396. INC( ladr, linc );
  3397. INC( dadr, dinc ); DEC( len );
  3398. END;
  3399. END DivideSLZALZLoop;
  3400. OPERATOR "/"*(left: LONGCOMPLEX; CONST right: ARRAY [ ? ] OF LONGCOMPLEX): ARRAY [ ? ] OF LONGCOMPLEX;
  3401. BEGIN
  3402. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  3403. SIZEOF( LONGCOMPLEX ), DivideSLZALZLoop );
  3404. RETURN RESULT
  3405. END "/";
  3406. (*** element-wise DIV array DIV array -> array ********************************************************************)
  3407. (** SHORTINT *)
  3408. PROCEDURE EDivASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3409. VAR lval, rval: SHORTINT; dval: SHORTINT;
  3410. BEGIN
  3411. WHILE (len > 0) DO
  3412. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval DIV rval;
  3413. SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  3414. DEC( len );
  3415. END;
  3416. END EDivASASLoop;
  3417. OPERATOR "DIV"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT;
  3418. BEGIN
  3419. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3420. SIZEOF( SHORTINT ), EDivASASLoop );
  3421. RETURN RESULT
  3422. END "DIV";
  3423. (** INTEGER *)
  3424. PROCEDURE EDivAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3425. VAR lval, rval: INTEGER; dval: INTEGER;
  3426. BEGIN
  3427. WHILE (len > 0) DO
  3428. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval DIV rval;
  3429. SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  3430. DEC( len );
  3431. END;
  3432. END EDivAIAILoop;
  3433. OPERATOR "DIV"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER;
  3434. BEGIN
  3435. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3436. SIZEOF( INTEGER ), EDivAIAILoop );
  3437. RETURN RESULT
  3438. END "DIV";
  3439. (** LONGINT *)
  3440. PROCEDURE EDivALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3441. VAR lval, rval: LONGINT; dval: LONGINT;
  3442. BEGIN
  3443. WHILE (len > 0) DO
  3444. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval DIV rval;
  3445. SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  3446. DEC( len );
  3447. END;
  3448. END EDivALALLoop;
  3449. OPERATOR "DIV"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT;
  3450. BEGIN
  3451. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3452. SIZEOF( LONGINT ), EDivALALLoop );
  3453. RETURN RESULT
  3454. END "DIV";
  3455. (*** division array DIV scalar -> array and scalar DIV array -> array ********************************************************************)
  3456. (** SHORTINT *)
  3457. PROCEDURE DivASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3458. VAR lval, rval: SHORTINT; dval: SHORTINT;
  3459. BEGIN
  3460. SYSTEM.GET( radr, rval );
  3461. WHILE (len > 0) DO
  3462. SYSTEM.GET( ladr, lval ); dval := lval DIV rval; SYSTEM.PUT( dadr, dval );
  3463. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  3464. END;
  3465. END DivASSSLoop;
  3466. OPERATOR "DIV"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF SHORTINT;
  3467. BEGIN
  3468. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3469. SIZEOF( SHORTINT ), DivASSSLoop );
  3470. RETURN RESULT
  3471. END "DIV";
  3472. PROCEDURE DivSSASLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3473. VAR lval, rval: SHORTINT; dval: SHORTINT;
  3474. BEGIN
  3475. SYSTEM.GET( radr, rval );
  3476. WHILE (len > 0) DO
  3477. SYSTEM.GET( ladr, lval ); dval := rval DIV lval; SYSTEM.PUT( dadr, dval );
  3478. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  3479. END;
  3480. END DivSSASLoop;
  3481. OPERATOR "DIV"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT;
  3482. BEGIN
  3483. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  3484. SIZEOF( SHORTINT ), DivSSASLoop );
  3485. RETURN RESULT
  3486. END "DIV";
  3487. (** INTEGER *)
  3488. PROCEDURE DivAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3489. VAR lval, rval: INTEGER; dval: INTEGER;
  3490. BEGIN
  3491. SYSTEM.GET( radr, rval );
  3492. WHILE (len > 0) DO
  3493. SYSTEM.GET( ladr, lval ); dval := lval DIV rval; SYSTEM.PUT( dadr, dval );
  3494. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  3495. END;
  3496. END DivAISILoop;
  3497. OPERATOR "DIV"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF INTEGER;
  3498. BEGIN
  3499. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3500. SIZEOF( INTEGER ), DivAISILoop );
  3501. RETURN RESULT
  3502. END "DIV";
  3503. PROCEDURE DivSIAILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3504. VAR lval, rval: INTEGER; dval: INTEGER;
  3505. BEGIN
  3506. SYSTEM.GET( radr, rval );
  3507. WHILE (len > 0) DO
  3508. SYSTEM.GET( ladr, lval ); dval := rval DIV lval; SYSTEM.PUT( dadr, dval );
  3509. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  3510. END;
  3511. END DivSIAILoop;
  3512. OPERATOR "DIV"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER;
  3513. BEGIN
  3514. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  3515. SIZEOF( INTEGER ), DivSIAILoop );
  3516. RETURN RESULT
  3517. END "DIV";
  3518. (** LONGINT *)
  3519. PROCEDURE DivALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3520. VAR lval, rval: LONGINT; dval: LONGINT;
  3521. BEGIN
  3522. SYSTEM.GET( radr, rval );
  3523. WHILE (len > 0) DO
  3524. SYSTEM.GET( ladr, lval ); dval := lval DIV rval; SYSTEM.PUT( dadr, dval );
  3525. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  3526. END;
  3527. END DivALSLLoop;
  3528. OPERATOR "DIV"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF LONGINT;
  3529. BEGIN
  3530. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3531. SIZEOF( LONGINT ), DivALSLLoop );
  3532. RETURN RESULT
  3533. END "DIV";
  3534. PROCEDURE DivSLALLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3535. VAR lval, rval: LONGINT; dval: LONGINT;
  3536. BEGIN
  3537. SYSTEM.GET( radr, rval );
  3538. WHILE (len > 0) DO
  3539. SYSTEM.GET( ladr, lval ); dval := rval DIV lval; SYSTEM.PUT( dadr, dval );
  3540. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  3541. END;
  3542. END DivSLALLoop;
  3543. OPERATOR "DIV"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT;
  3544. BEGIN
  3545. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  3546. SIZEOF( LONGINT ), DivSLALLoop );
  3547. RETURN RESULT
  3548. END "DIV";
  3549. (*** element-wise modulus array MOD array -> array ********************************************************************)
  3550. (** SHORTINT *)
  3551. PROCEDURE EModASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3552. VAR lval, rval: SHORTINT; dval: SHORTINT;
  3553. BEGIN
  3554. WHILE (len > 0) DO
  3555. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval MOD rval;
  3556. SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  3557. DEC( len );
  3558. END;
  3559. END EModASASLoop;
  3560. OPERATOR "MOD"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT;
  3561. BEGIN
  3562. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3563. SIZEOF( SHORTINT ), EModASASLoop );
  3564. RETURN RESULT
  3565. END "MOD";
  3566. (** INTEGER *)
  3567. PROCEDURE EModAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3568. VAR lval, rval: INTEGER; dval: INTEGER;
  3569. BEGIN
  3570. WHILE (len > 0) DO
  3571. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval MOD rval;
  3572. SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  3573. DEC( len );
  3574. END;
  3575. END EModAIAILoop;
  3576. OPERATOR "MOD"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER;
  3577. BEGIN
  3578. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3579. SIZEOF( INTEGER ), EModAIAILoop );
  3580. RETURN RESULT
  3581. END "MOD";
  3582. (** LONGINT *)
  3583. PROCEDURE EModALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3584. VAR lval, rval: LONGINT; dval: LONGINT;
  3585. BEGIN
  3586. WHILE (len > 0) DO
  3587. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval MOD rval;
  3588. SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc );
  3589. DEC( len );
  3590. END;
  3591. END EModALALLoop;
  3592. OPERATOR "MOD"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT;
  3593. BEGIN
  3594. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3595. SIZEOF( LONGINT ), EModALALLoop );
  3596. RETURN RESULT
  3597. END "MOD";
  3598. (*** modulus array MOD scalar -> array and scalar MOD array -> array ********************************************************************)
  3599. (** SHORTINT *)
  3600. PROCEDURE ModASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3601. VAR lval, rval: SHORTINT; dval: SHORTINT;
  3602. BEGIN
  3603. SYSTEM.GET( radr, rval );
  3604. WHILE (len > 0) DO
  3605. SYSTEM.GET( ladr, lval ); dval := lval MOD rval; SYSTEM.PUT( dadr, dval );
  3606. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  3607. END;
  3608. END ModASSSLoop;
  3609. OPERATOR "MOD"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF SHORTINT;
  3610. BEGIN
  3611. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3612. SIZEOF( SHORTINT ), ModASSSLoop );
  3613. RETURN RESULT
  3614. END "MOD";
  3615. PROCEDURE ModSSASLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3616. VAR lval, rval: SHORTINT; dval: SHORTINT;
  3617. BEGIN
  3618. SYSTEM.GET( radr, rval );
  3619. WHILE (len > 0) DO
  3620. SYSTEM.GET( ladr, lval ); dval := rval MOD lval; SYSTEM.PUT( dadr, dval );
  3621. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  3622. END;
  3623. END ModSSASLoop;
  3624. OPERATOR "MOD"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT;
  3625. BEGIN
  3626. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  3627. SIZEOF( SHORTINT ), ModSSASLoop );
  3628. RETURN RESULT
  3629. END "MOD";
  3630. (** INTEGER *)
  3631. PROCEDURE ModAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3632. VAR lval, rval: INTEGER; dval: INTEGER;
  3633. BEGIN
  3634. SYSTEM.GET( radr, rval );
  3635. WHILE (len > 0) DO
  3636. SYSTEM.GET( ladr, lval ); dval := lval MOD rval; SYSTEM.PUT( dadr, dval );
  3637. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  3638. END;
  3639. END ModAISILoop;
  3640. OPERATOR "MOD"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF INTEGER;
  3641. BEGIN
  3642. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3643. SIZEOF( INTEGER ), ModAISILoop );
  3644. RETURN RESULT
  3645. END "MOD";
  3646. PROCEDURE ModSIAILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3647. VAR lval, rval: INTEGER; dval: INTEGER;
  3648. BEGIN
  3649. SYSTEM.GET( radr, rval );
  3650. WHILE (len > 0) DO
  3651. SYSTEM.GET( ladr, lval ); dval := rval MOD lval; SYSTEM.PUT( dadr, dval );
  3652. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  3653. END;
  3654. END ModSIAILoop;
  3655. OPERATOR "MOD"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER;
  3656. BEGIN
  3657. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  3658. SIZEOF( INTEGER ), ModSIAILoop );
  3659. RETURN RESULT
  3660. END "MOD";
  3661. (** LONGINT *)
  3662. PROCEDURE ModALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3663. VAR lval, rval: LONGINT; dval: LONGINT;
  3664. BEGIN
  3665. SYSTEM.GET( radr, rval );
  3666. WHILE (len > 0) DO
  3667. SYSTEM.GET( ladr, lval ); dval := lval MOD rval; SYSTEM.PUT( dadr, dval );
  3668. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  3669. END;
  3670. END ModALSLLoop;
  3671. OPERATOR "MOD"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF LONGINT;
  3672. BEGIN
  3673. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3674. SIZEOF( LONGINT ), ModALSLLoop );
  3675. RETURN RESULT
  3676. END "MOD";
  3677. PROCEDURE ModSLALLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3678. VAR lval, rval: LONGINT; dval: LONGINT;
  3679. BEGIN
  3680. SYSTEM.GET( radr, rval );
  3681. WHILE (len > 0) DO
  3682. SYSTEM.GET( ladr, lval ); dval := rval MOD lval; SYSTEM.PUT( dadr, dval );
  3683. INC( ladr, linc ); INC( dadr, dinc ); DEC( len );
  3684. END;
  3685. END ModSLALLoop;
  3686. OPERATOR "MOD"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT;
  3687. BEGIN
  3688. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  3689. SIZEOF( LONGINT ), ModSLALLoop );
  3690. RETURN RESULT
  3691. END "MOD";
  3692. (*** scalar product <array,array> -> scalar ********************************************************************)
  3693. (** SHORTINT *)
  3694. PROCEDURE SPASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  3695. VAR lval, rval: SHORTINT; dval: LONGINT;
  3696. BEGIN
  3697. SYSTEM.GET( dadr, dval );
  3698. WHILE (len > 0) DO
  3699. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + rval * lval;
  3700. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  3701. END;
  3702. SYSTEM.PUT( dadr, dval );
  3703. END SPASASLoop;
  3704. OPERATOR "+*"*( CONST left, right: ARRAY [ ? ] OF SHORTINT ): LONGINT;
  3705. VAR dest: LONGINT;
  3706. BEGIN
  3707. dest := 0;
  3708. ApplyBinaryAASOp( ADDRESSOF( dest ), ADDRESSOF( left ), ADDRESSOF( right ), SPASASLoop );
  3709. RETURN dest;
  3710. END "+*";
  3711. (** INTEGER *)
  3712. PROCEDURE SPAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  3713. VAR lval, rval: INTEGER; dval: LONGINT;
  3714. BEGIN
  3715. SYSTEM.GET( dadr, dval );
  3716. WHILE (len > 0) DO
  3717. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + rval * lval;
  3718. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  3719. END;
  3720. SYSTEM.PUT( dadr, dval );
  3721. END SPAIAILoop;
  3722. OPERATOR "+*"*( CONST left, right: ARRAY [ ? ] OF INTEGER ): LONGINT;
  3723. VAR dest: LONGINT;
  3724. BEGIN
  3725. dest := 0;
  3726. ApplyBinaryAASOp( ADDRESSOF( dest ), ADDRESSOF( left ), ADDRESSOF( right ), SPAIAILoop );
  3727. RETURN dest;
  3728. END "+*";
  3729. (** LONGINT *)
  3730. PROCEDURE SPALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  3731. VAR lval, rval: LONGINT; dval: LONGINT;
  3732. BEGIN
  3733. SYSTEM.GET( dadr, dval );
  3734. WHILE (len > 0) DO
  3735. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + rval * lval;
  3736. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  3737. END;
  3738. SYSTEM.PUT( dadr, dval );
  3739. END SPALALLoop;
  3740. OPERATOR "+*"*( CONST left, right: ARRAY [ ? ] OF LONGINT ): LONGINT;
  3741. VAR dest: LONGINT;
  3742. BEGIN
  3743. dest := 0;
  3744. ApplyBinaryAASOp( ADDRESSOF( dest ), ADDRESSOF( left ), ADDRESSOF( right ), SPALALLoop );
  3745. RETURN dest;
  3746. END "+*";
  3747. (** REAL *)
  3748. PROCEDURE SPARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  3749. VAR lval, rval: REAL; dval: REAL;
  3750. BEGIN
  3751. SYSTEM.GET( dadr, dval );
  3752. WHILE (len > 0) DO
  3753. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + rval * lval;
  3754. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  3755. END;
  3756. SYSTEM.PUT( dadr, dval );
  3757. END SPARARLoop;
  3758. OPERATOR "+*"*( CONST left, right: ARRAY [ ? ] OF REAL ): REAL;
  3759. VAR dest: REAL;
  3760. BEGIN
  3761. dest := 0;
  3762. ApplyBinaryAASOp( ADDRESSOF( dest ), ADDRESSOF( left ), ADDRESSOF( right ), loopSPARAR );
  3763. RETURN dest;
  3764. END "+*";
  3765. PROCEDURE SPAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  3766. VAR lval, rval, dval: LONGREAL;
  3767. BEGIN
  3768. IF debug THEN
  3769. KernelLog.String( "SPAXAX, ladr,radr,dadr,linc,rinc,len= " ); KernelLog.Int( ladr, 10 ); KernelLog.Int( radr, 10 );
  3770. KernelLog.Int( dadr, 10 ); KernelLog.Int( linc, 10 ); KernelLog.Int( rinc, 10 );
  3771. KernelLog.Int( len, 10 ); KernelLog.Ln;
  3772. END;
  3773. SYSTEM.GET( dadr, dval );
  3774. WHILE (len > 0) DO
  3775. SYSTEM.GET( ladr, lval ); INC( ladr, linc ); SYSTEM.GET( radr, rval ); INC( radr, rinc );
  3776. dval := dval + rval * lval; DEC( len );
  3777. END;
  3778. SYSTEM.PUT( dadr, dval );
  3779. END SPAXAXLoop;
  3780. OPERATOR "+*"*( CONST left, right: ARRAY [ ? ] OF LONGREAL ): LONGREAL;
  3781. VAR dest: LONGREAL;
  3782. BEGIN
  3783. dest := 0;
  3784. ApplyBinaryAASOp( ADDRESSOF( dest ), ADDRESSOF( left ), ADDRESSOF( right ), loopSPAXAX );
  3785. RETURN dest;
  3786. END "+*";
  3787. (** COMPLEX *)
  3788. PROCEDURE SPAZAZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  3789. VAR lval, rval: COMPLEX; dval: COMPLEX;
  3790. BEGIN
  3791. SYSTEM.GET( dadr, dval );
  3792. WHILE (len > 0) DO
  3793. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  3794. RE(dval) := RE(dval) + RE(lval) * RE(rval) + IM(lval) * IM(rval);
  3795. IM(dval) := IM(dval) - RE(lval) * IM(rval) + IM(lval) * RE(rval);
  3796. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  3797. END;
  3798. SYSTEM.PUT( dadr, dval );
  3799. END SPAZAZLoop;
  3800. OPERATOR "+*"*( CONST left, right: ARRAY [ ? ] OF COMPLEX ): COMPLEX;
  3801. VAR dest: COMPLEX;
  3802. BEGIN
  3803. dest := 0;
  3804. ApplyBinaryAASOp( ADDRESSOF( dest ), ADDRESSOF( left ), ADDRESSOF( right ), loopSPAZAZ );
  3805. RETURN dest;
  3806. END "+*";
  3807. (** COMPLEX *)
  3808. PROCEDURE SPALZALZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  3809. VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; dvalRe, dvalIm: LONGREAL;
  3810. BEGIN
  3811. SYSTEM.GET( dadr, dvalRe ); SYSTEM.GET( dadr+SIZEOF(LONGREAL), dvalIm );
  3812. WHILE (len > 0) DO
  3813. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  3814. SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm );
  3815. dvalRe := dvalRe + lvalRe * rvalRe + lvalIm * rvalIm;
  3816. dvalIm := dvalIm - lvalRe * rvalIm + lvalIm * rvalRe;
  3817. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  3818. END;
  3819. SYSTEM.PUT( dadr, dvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), dvalIm );
  3820. END SPALZALZLoop;
  3821. OPERATOR "+*"*( CONST left, right: ARRAY [ ? ] OF LONGCOMPLEX ): LONGCOMPLEX;
  3822. VAR dest: LONGCOMPLEX;
  3823. BEGIN
  3824. dest := 0;
  3825. ApplyBinaryAASOp( ADDRESSOF( dest ), ADDRESSOF( left ), ADDRESSOF( right ), loopSPALZALZ );
  3826. RETURN dest;
  3827. END "+*";
  3828. (*** element-wise equal: array x array -> array of boolean ********************************************************************)
  3829. (** BOOLEAN *)
  3830. PROCEDURE EEqlABABLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3831. VAR lval, rval: BOOLEAN;
  3832. BEGIN
  3833. WHILE (len > 0) DO
  3834. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval = rval );
  3835. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  3836. END;
  3837. END EEqlABABLoop;
  3838. OPERATOR ".="*(CONST left,right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN;
  3839. BEGIN
  3840. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3841. SIZEOF( BOOLEAN ), EEqlABABLoop );
  3842. RETURN RESULT
  3843. END ".=";
  3844. (** SHORTINT *)
  3845. PROCEDURE EEqlASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3846. VAR lval, rval: SHORTINT;
  3847. BEGIN
  3848. WHILE (len > 0) DO
  3849. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval = rval );
  3850. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  3851. END;
  3852. END EEqlASASLoop;
  3853. OPERATOR ".="*(CONST left, right: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF BOOLEAN;
  3854. BEGIN
  3855. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3856. SIZEOF( BOOLEAN ), EEqlASASLoop );
  3857. RETURN RESULT
  3858. END ".=";
  3859. (** INTEGER *)
  3860. PROCEDURE EEqlAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3861. VAR lval, rval: INTEGER;
  3862. BEGIN
  3863. WHILE (len > 0) DO
  3864. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval = rval );
  3865. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  3866. END;
  3867. END EEqlAIAILoop;
  3868. OPERATOR ".="*(CONST left, right: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF BOOLEAN;
  3869. BEGIN
  3870. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3871. SIZEOF( BOOLEAN ), EEqlAIAILoop );
  3872. RETURN RESULT
  3873. END ".=";
  3874. (** LONGINT *)
  3875. PROCEDURE EEqlALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3876. VAR lval, rval: LONGINT;
  3877. BEGIN
  3878. WHILE (len > 0) DO
  3879. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval = rval );
  3880. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  3881. END;
  3882. END EEqlALALLoop;
  3883. OPERATOR ".="*(CONST left, right: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF BOOLEAN;
  3884. BEGIN
  3885. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3886. SIZEOF( BOOLEAN ), EEqlALALLoop );
  3887. RETURN RESULT
  3888. END ".=";
  3889. (** REAL *)
  3890. PROCEDURE EEqlARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3891. VAR lval, rval: REAL;
  3892. BEGIN
  3893. WHILE (len > 0) DO
  3894. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval = rval );
  3895. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  3896. END;
  3897. END EEqlARARLoop;
  3898. OPERATOR ".="*(CONST left, right: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF BOOLEAN;
  3899. BEGIN
  3900. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3901. SIZEOF( BOOLEAN ), EEqlARARLoop );
  3902. RETURN RESULT
  3903. END ".=";
  3904. (** LONGREAL *)
  3905. PROCEDURE EEqlAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  3906. VAR lval, rval: LONGREAL;
  3907. BEGIN
  3908. WHILE (len > 0) DO
  3909. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval = rval );
  3910. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  3911. END;
  3912. END EEqlAXAXLoop;
  3913. OPERATOR ".="*(CONST left, right: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF BOOLEAN;
  3914. BEGIN
  3915. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3916. SIZEOF( BOOLEAN ), EEqlAXAXLoop );
  3917. RETURN RESULT
  3918. END ".=";
  3919. (*** elementwise equal array x scalar -> array of boolean ********************************************************************)
  3920. (** BOOLEAN *)
  3921. PROCEDURE EEqlABSBLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3922. VAR lval, rval: BOOLEAN;
  3923. BEGIN
  3924. SYSTEM.GET( radr, rval );
  3925. WHILE (len > 0) DO
  3926. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc );
  3927. INC( dadr, dinc ); DEC( len );
  3928. END;
  3929. END EEqlABSBLoop;
  3930. OPERATOR ".="*(CONST left : ARRAY [?] OF BOOLEAN; right: BOOLEAN):ARRAY [ ? ] OF BOOLEAN;
  3931. BEGIN
  3932. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3933. SIZEOF( BOOLEAN ), EEqlABSBLoop );
  3934. RETURN RESULT
  3935. END ".=";
  3936. OPERATOR ".="*(left: BOOLEAN; CONST right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN;
  3937. BEGIN
  3938. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  3939. SIZEOF( BOOLEAN ), EEqlABSBLoop );
  3940. RETURN RESULT
  3941. END ".=";
  3942. (** SHORTINT *)
  3943. PROCEDURE EEqlASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3944. VAR lval, rval: SHORTINT;
  3945. BEGIN
  3946. SYSTEM.GET( radr, rval );
  3947. WHILE (len > 0) DO
  3948. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc );
  3949. INC( dadr, dinc ); DEC( len );
  3950. END;
  3951. END EEqlASSSLoop;
  3952. OPERATOR ".="*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF BOOLEAN;
  3953. BEGIN
  3954. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3955. SIZEOF( BOOLEAN ), EEqlASSSLoop );
  3956. RETURN RESULT
  3957. END ".=";
  3958. OPERATOR ".="*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF BOOLEAN;
  3959. BEGIN
  3960. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  3961. SIZEOF( BOOLEAN ), EEqlASSSLoop );
  3962. RETURN RESULT
  3963. END ".=";
  3964. (** INTEGER *)
  3965. PROCEDURE EEqlAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3966. VAR lval, rval: INTEGER;
  3967. BEGIN
  3968. SYSTEM.GET( radr, rval );
  3969. WHILE (len > 0) DO
  3970. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc );
  3971. INC( dadr, dinc ); DEC( len );
  3972. END;
  3973. END EEqlAISILoop;
  3974. OPERATOR ".="*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF BOOLEAN;
  3975. BEGIN
  3976. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3977. SIZEOF( BOOLEAN ), EEqlAISILoop );
  3978. RETURN RESULT
  3979. END ".=";
  3980. OPERATOR ".="*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF BOOLEAN;
  3981. BEGIN
  3982. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  3983. SIZEOF( BOOLEAN ), EEqlAISILoop );
  3984. RETURN RESULT
  3985. END ".=";
  3986. (** LONGINT *)
  3987. PROCEDURE EEqlALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  3988. VAR lval, rval: LONGINT;
  3989. BEGIN
  3990. SYSTEM.GET( radr, rval );
  3991. WHILE (len > 0) DO
  3992. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc );
  3993. INC( dadr, dinc ); DEC( len );
  3994. END;
  3995. END EEqlALSLLoop;
  3996. OPERATOR ".="*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF BOOLEAN;
  3997. BEGIN
  3998. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  3999. SIZEOF( BOOLEAN ), EEqlALSLLoop );
  4000. RETURN RESULT
  4001. END ".=";
  4002. OPERATOR ".="*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF BOOLEAN;
  4003. BEGIN
  4004. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4005. SIZEOF( BOOLEAN ), EEqlALSLLoop );
  4006. RETURN RESULT
  4007. END ".=";
  4008. (** REAL *)
  4009. PROCEDURE EEqlARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4010. VAR lval, rval: REAL;
  4011. BEGIN
  4012. SYSTEM.GET( radr, rval );
  4013. WHILE (len > 0) DO
  4014. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc );
  4015. INC( dadr, dinc ); DEC( len );
  4016. END;
  4017. END EEqlARSRLoop;
  4018. OPERATOR ".="*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF BOOLEAN;
  4019. BEGIN
  4020. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4021. SIZEOF( BOOLEAN ), EEqlARSRLoop );
  4022. RETURN RESULT
  4023. END ".=";
  4024. OPERATOR ".="*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF BOOLEAN;
  4025. BEGIN
  4026. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4027. SIZEOF( BOOLEAN ), EEqlARSRLoop );
  4028. RETURN RESULT
  4029. END ".=";
  4030. (** LONGREAL *)
  4031. PROCEDURE EEqlAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4032. VAR lval, rval: LONGREAL;
  4033. BEGIN
  4034. SYSTEM.GET( radr, rval );
  4035. WHILE (len > 0) DO
  4036. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc );
  4037. INC( dadr, dinc ); DEC( len );
  4038. END;
  4039. END EEqlAXSXLoop;
  4040. OPERATOR ".="*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF BOOLEAN;
  4041. BEGIN
  4042. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4043. SIZEOF( BOOLEAN ), EEqlAXSXLoop );
  4044. RETURN RESULT
  4045. END ".=";
  4046. OPERATOR ".="*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF BOOLEAN;
  4047. BEGIN
  4048. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4049. SIZEOF( BOOLEAN ), EEqlAXSXLoop );
  4050. RETURN RESULT
  4051. END ".=";
  4052. (*** elementwise nequal: array x array -> array of boolean ********************************************************************)
  4053. (** BOOLEAN *)
  4054. PROCEDURE ENeqABABLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4055. VAR lval, rval: BOOLEAN;
  4056. BEGIN
  4057. WHILE (len > 0) DO
  4058. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval # rval );
  4059. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4060. END;
  4061. END ENeqABABLoop;
  4062. OPERATOR ".#"*(CONST left,right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN;
  4063. BEGIN
  4064. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4065. SIZEOF( BOOLEAN ), ENeqABABLoop );
  4066. RETURN RESULT
  4067. END ".#";
  4068. (** SHORTINT *)
  4069. PROCEDURE ENeqASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4070. VAR lval, rval: SHORTINT;
  4071. BEGIN
  4072. WHILE (len > 0) DO
  4073. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval # rval );
  4074. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4075. END;
  4076. END ENeqASASLoop;
  4077. OPERATOR ".#"*(CONST left, right: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF BOOLEAN;
  4078. BEGIN
  4079. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4080. SIZEOF( BOOLEAN ), ENeqASASLoop );
  4081. RETURN RESULT
  4082. END ".#";
  4083. (** INTEGER*)
  4084. PROCEDURE ENeqAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4085. VAR lval, rval: INTEGER;
  4086. BEGIN
  4087. WHILE (len > 0) DO
  4088. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval # rval );
  4089. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4090. END;
  4091. END ENeqAIAILoop;
  4092. OPERATOR ".#"*(CONST left, right: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF BOOLEAN;
  4093. BEGIN
  4094. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4095. SIZEOF( BOOLEAN ), ENeqAIAILoop );
  4096. RETURN RESULT
  4097. END ".#";
  4098. (** LONGINT*)
  4099. PROCEDURE ENeqALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4100. VAR lval, rval: LONGINT;
  4101. BEGIN
  4102. WHILE (len > 0) DO
  4103. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval # rval );
  4104. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4105. END;
  4106. END ENeqALALLoop;
  4107. OPERATOR ".#"*(CONST left, right: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF BOOLEAN;
  4108. BEGIN
  4109. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4110. SIZEOF( BOOLEAN ), ENeqALALLoop );
  4111. RETURN RESULT
  4112. END ".#";
  4113. (** REAL *)
  4114. PROCEDURE ENeqARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4115. VAR lval, rval: REAL;
  4116. BEGIN
  4117. WHILE (len > 0) DO
  4118. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval # rval );
  4119. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4120. END;
  4121. END ENeqARARLoop;
  4122. OPERATOR ".#"*(CONST left, right: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF BOOLEAN;
  4123. BEGIN
  4124. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4125. SIZEOF( BOOLEAN ), ENeqARARLoop );
  4126. RETURN RESULT
  4127. END ".#";
  4128. (** LONGREAL *)
  4129. PROCEDURE ENeqAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4130. VAR lval, rval: LONGREAL;
  4131. BEGIN
  4132. WHILE (len > 0) DO
  4133. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval # rval );
  4134. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4135. END;
  4136. END ENeqAXAXLoop;
  4137. OPERATOR ".#"*(CONST left, right: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF BOOLEAN;
  4138. BEGIN
  4139. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4140. SIZEOF( BOOLEAN ), ENeqAXAXLoop );
  4141. RETURN RESULT
  4142. END ".#";
  4143. (*** elementwise nequal array x scalar -> array of boolean ********************************************************************)
  4144. (** BOOLEAN *)
  4145. PROCEDURE ENeqABSBLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4146. VAR lval, rval: BOOLEAN;
  4147. BEGIN
  4148. SYSTEM.GET( radr, rval );
  4149. WHILE (len > 0) DO
  4150. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc );
  4151. INC( dadr, dinc ); DEC( len );
  4152. END;
  4153. END ENeqABSBLoop;
  4154. OPERATOR ".#"*(CONST left : ARRAY [?] OF BOOLEAN; right: BOOLEAN):ARRAY [ ? ] OF BOOLEAN;
  4155. BEGIN
  4156. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4157. SIZEOF( BOOLEAN ), ENeqABSBLoop );
  4158. RETURN RESULT
  4159. END ".#";
  4160. OPERATOR ".#"*(left: BOOLEAN; CONST right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN;
  4161. BEGIN
  4162. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4163. SIZEOF( BOOLEAN ), ENeqABSBLoop );
  4164. RETURN RESULT
  4165. END ".#";
  4166. (** SHORTINT *)
  4167. PROCEDURE ENeqASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4168. VAR lval, rval: SHORTINT;
  4169. BEGIN
  4170. SYSTEM.GET( radr, rval );
  4171. WHILE (len > 0) DO
  4172. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc );
  4173. INC( dadr, dinc ); DEC( len );
  4174. END;
  4175. END ENeqASSSLoop;
  4176. OPERATOR ".#"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF BOOLEAN;
  4177. BEGIN
  4178. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4179. SIZEOF( BOOLEAN ), ENeqASSSLoop );
  4180. RETURN RESULT
  4181. END ".#";
  4182. OPERATOR ".#"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF BOOLEAN;
  4183. BEGIN
  4184. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4185. SIZEOF( BOOLEAN ), ENeqASSSLoop );
  4186. RETURN RESULT
  4187. END ".#";
  4188. (** INTEGER *)
  4189. PROCEDURE ENeqAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4190. VAR lval, rval: INTEGER;
  4191. BEGIN
  4192. SYSTEM.GET( radr, rval );
  4193. WHILE (len > 0) DO
  4194. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc );
  4195. INC( dadr, dinc ); DEC( len );
  4196. END;
  4197. END ENeqAISILoop;
  4198. OPERATOR ".#"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF BOOLEAN;
  4199. BEGIN
  4200. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4201. SIZEOF( BOOLEAN ), ENeqAISILoop );
  4202. RETURN RESULT
  4203. END ".#";
  4204. OPERATOR ".#"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF BOOLEAN;
  4205. BEGIN
  4206. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4207. SIZEOF( BOOLEAN ), ENeqAISILoop );
  4208. RETURN RESULT
  4209. END ".#";
  4210. (** LONGINT *)
  4211. PROCEDURE ENeqALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4212. VAR lval, rval: LONGINT;
  4213. BEGIN
  4214. SYSTEM.GET( radr, rval );
  4215. WHILE (len > 0) DO
  4216. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc );
  4217. INC( dadr, dinc ); DEC( len );
  4218. END;
  4219. END ENeqALSLLoop;
  4220. OPERATOR ".#"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF BOOLEAN;
  4221. BEGIN
  4222. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4223. SIZEOF( BOOLEAN ), ENeqALSLLoop );
  4224. RETURN RESULT
  4225. END ".#";
  4226. OPERATOR ".#"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF BOOLEAN;
  4227. BEGIN
  4228. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4229. SIZEOF( BOOLEAN ), ENeqALSLLoop );
  4230. RETURN RESULT
  4231. END ".#";
  4232. (** REAL *)
  4233. PROCEDURE ENeqARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4234. VAR lval, rval: REAL;
  4235. BEGIN
  4236. SYSTEM.GET( radr, rval );
  4237. WHILE (len > 0) DO
  4238. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc );
  4239. INC( dadr, dinc ); DEC( len );
  4240. END;
  4241. END ENeqARSRLoop;
  4242. OPERATOR ".#"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF BOOLEAN;
  4243. BEGIN
  4244. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4245. SIZEOF( BOOLEAN ), ENeqARSRLoop );
  4246. RETURN RESULT
  4247. END ".#";
  4248. OPERATOR ".#"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF BOOLEAN;
  4249. BEGIN
  4250. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4251. SIZEOF( BOOLEAN ), ENeqARSRLoop );
  4252. RETURN RESULT
  4253. END ".#";
  4254. (** LONGREAL *)
  4255. PROCEDURE ENeqAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4256. VAR lval, rval: LONGREAL;
  4257. BEGIN
  4258. SYSTEM.GET( radr, rval );
  4259. WHILE (len > 0) DO
  4260. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc );
  4261. INC( dadr, dinc ); DEC( len );
  4262. END;
  4263. END ENeqAXSXLoop;
  4264. OPERATOR ".#"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF BOOLEAN;
  4265. BEGIN
  4266. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4267. SIZEOF( BOOLEAN ), ENeqAXSXLoop );
  4268. RETURN RESULT
  4269. END ".#";
  4270. OPERATOR ".#"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF BOOLEAN;
  4271. BEGIN
  4272. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4273. SIZEOF( BOOLEAN ), ENeqAXSXLoop );
  4274. RETURN RESULT
  4275. END ".#";
  4276. (*** elementwise greater than: array x array -> array of boolean ********************************************************************)
  4277. (** SHORTINT *)
  4278. PROCEDURE EGtrASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4279. VAR lval, rval: SHORTINT;
  4280. BEGIN
  4281. WHILE (len > 0) DO
  4282. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval > rval );
  4283. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4284. END;
  4285. END EGtrASASLoop;
  4286. OPERATOR ".>"*(CONST left, right: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF BOOLEAN;
  4287. BEGIN
  4288. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4289. SIZEOF( BOOLEAN ), EGtrASASLoop );
  4290. RETURN RESULT
  4291. END ".>";
  4292. (** INTEGER *)
  4293. PROCEDURE EGtrAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4294. VAR lval, rval: INTEGER;
  4295. BEGIN
  4296. WHILE (len > 0) DO
  4297. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval > rval );
  4298. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4299. END;
  4300. END EGtrAIAILoop;
  4301. OPERATOR ".>"*(CONST left, right: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF BOOLEAN;
  4302. BEGIN
  4303. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4304. SIZEOF( BOOLEAN ), EGtrAIAILoop );
  4305. RETURN RESULT
  4306. END ".>";
  4307. (** LONGINT *)
  4308. PROCEDURE EGtrALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4309. VAR lval, rval: LONGINT;
  4310. BEGIN
  4311. WHILE (len > 0) DO
  4312. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval > rval );
  4313. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4314. END;
  4315. END EGtrALALLoop;
  4316. OPERATOR ".>"*(CONST left, right: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF BOOLEAN;
  4317. BEGIN
  4318. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4319. SIZEOF( BOOLEAN ), EGtrALALLoop );
  4320. RETURN RESULT
  4321. END ".>";
  4322. (** REAL *)
  4323. PROCEDURE EGtrARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4324. VAR lval, rval: REAL;
  4325. BEGIN
  4326. WHILE (len > 0) DO
  4327. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval > rval );
  4328. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4329. END;
  4330. END EGtrARARLoop;
  4331. OPERATOR ".>"*(CONST left, right: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF BOOLEAN;
  4332. BEGIN
  4333. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4334. SIZEOF( BOOLEAN ), EGtrARARLoop );
  4335. RETURN RESULT
  4336. END ".>";
  4337. (** LONGREAL *)
  4338. PROCEDURE EGtrAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4339. VAR lval, rval: LONGREAL;
  4340. BEGIN
  4341. WHILE (len > 0) DO
  4342. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval > rval );
  4343. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4344. END;
  4345. END EGtrAXAXLoop;
  4346. OPERATOR ".>"*(CONST left, right: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF BOOLEAN;
  4347. BEGIN
  4348. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4349. SIZEOF( BOOLEAN ), EGtrAXAXLoop );
  4350. RETURN RESULT
  4351. END ".>";
  4352. (*** elementwise greater array x scalar -> array of boolean ********************************************************************)
  4353. (** SHORTINT *)
  4354. PROCEDURE EGtrASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4355. VAR lval, rval: SHORTINT;
  4356. BEGIN
  4357. SYSTEM.GET( radr, rval );
  4358. WHILE (len > 0) DO
  4359. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc );
  4360. INC( dadr, dinc ); DEC( len );
  4361. END;
  4362. END EGtrASSSLoop;
  4363. OPERATOR ".>"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF BOOLEAN;
  4364. BEGIN
  4365. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4366. SIZEOF( BOOLEAN ), EGtrASSSLoop );
  4367. RETURN RESULT
  4368. END ".>";
  4369. OPERATOR ".<"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF BOOLEAN;
  4370. BEGIN
  4371. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4372. SIZEOF( BOOLEAN ), EGtrASSSLoop );
  4373. RETURN RESULT
  4374. END ".<";
  4375. (** INTEGER *)
  4376. PROCEDURE EGtrAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4377. VAR lval, rval: INTEGER;
  4378. BEGIN
  4379. SYSTEM.GET( radr, rval );
  4380. WHILE (len > 0) DO
  4381. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc );
  4382. INC( dadr, dinc ); DEC( len );
  4383. END;
  4384. END EGtrAISILoop;
  4385. OPERATOR ".>"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF BOOLEAN;
  4386. BEGIN
  4387. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4388. SIZEOF( BOOLEAN ), EGtrAISILoop );
  4389. RETURN RESULT
  4390. END ".>";
  4391. OPERATOR ".<"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF BOOLEAN;
  4392. BEGIN
  4393. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4394. SIZEOF( BOOLEAN ), EGtrAISILoop );
  4395. RETURN RESULT
  4396. END ".<";
  4397. (** LONGINT *)
  4398. PROCEDURE EGtrALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4399. VAR lval, rval: LONGINT;
  4400. BEGIN
  4401. SYSTEM.GET( radr, rval );
  4402. WHILE (len > 0) DO
  4403. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc );
  4404. INC( dadr, dinc ); DEC( len );
  4405. END;
  4406. END EGtrALSLLoop;
  4407. OPERATOR ".>"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF BOOLEAN;
  4408. BEGIN
  4409. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4410. SIZEOF( BOOLEAN ), EGtrALSLLoop );
  4411. RETURN RESULT
  4412. END ".>";
  4413. OPERATOR ".<"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF BOOLEAN;
  4414. BEGIN
  4415. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4416. SIZEOF( BOOLEAN ), EGtrALSLLoop );
  4417. RETURN RESULT
  4418. END ".<";
  4419. (** REAL *)
  4420. PROCEDURE EGtrARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4421. VAR lval, rval: REAL;
  4422. BEGIN
  4423. SYSTEM.GET( radr, rval );
  4424. WHILE (len > 0) DO
  4425. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc );
  4426. INC( dadr, dinc ); DEC( len );
  4427. END;
  4428. END EGtrARSRLoop;
  4429. OPERATOR ".>"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF BOOLEAN;
  4430. BEGIN
  4431. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4432. SIZEOF( BOOLEAN ), EGtrARSRLoop );
  4433. RETURN RESULT
  4434. END ".>";
  4435. OPERATOR ".<"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF BOOLEAN;
  4436. BEGIN
  4437. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4438. SIZEOF( BOOLEAN ), EGtrARSRLoop );
  4439. RETURN RESULT
  4440. END ".<";
  4441. (** LONGREAL *)
  4442. PROCEDURE EGtrAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4443. VAR lval, rval: LONGREAL;
  4444. BEGIN
  4445. SYSTEM.GET( radr, rval );
  4446. WHILE (len > 0) DO
  4447. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc );
  4448. INC( dadr, dinc ); DEC( len );
  4449. END;
  4450. END EGtrAXSXLoop;
  4451. OPERATOR ".>"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF BOOLEAN;
  4452. BEGIN
  4453. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4454. SIZEOF( BOOLEAN ), EGtrAXSXLoop );
  4455. RETURN RESULT
  4456. END ".>";
  4457. OPERATOR ".<"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF BOOLEAN;
  4458. BEGIN
  4459. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4460. SIZEOF( BOOLEAN ), EGtrAXSXLoop );
  4461. RETURN RESULT
  4462. END ".<";
  4463. (*** elementwise greater or equal: array x array -> array of boolean ********************************************************************)
  4464. (** SHORTINT *)
  4465. PROCEDURE EGeqASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4466. VAR lval, rval: SHORTINT;
  4467. BEGIN
  4468. WHILE (len > 0) DO
  4469. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval >= rval );
  4470. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4471. END;
  4472. END EGeqASASLoop;
  4473. OPERATOR ".>="*(CONST left, right: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF BOOLEAN;
  4474. BEGIN
  4475. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4476. SIZEOF( BOOLEAN ), EGeqASASLoop );
  4477. RETURN RESULT
  4478. END ".>=";
  4479. (** INTEGER *)
  4480. PROCEDURE EGeqAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4481. VAR lval, rval: INTEGER;
  4482. BEGIN
  4483. WHILE (len > 0) DO
  4484. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval >= rval );
  4485. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4486. END;
  4487. END EGeqAIAILoop;
  4488. OPERATOR ".>="*(CONST left, right: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF BOOLEAN;
  4489. BEGIN
  4490. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4491. SIZEOF( BOOLEAN ), EGeqAIAILoop );
  4492. RETURN RESULT
  4493. END ".>=";
  4494. (** LONGINT *)
  4495. PROCEDURE EGeqALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4496. VAR lval, rval: LONGINT;
  4497. BEGIN
  4498. WHILE (len > 0) DO
  4499. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval >= rval );
  4500. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4501. END;
  4502. END EGeqALALLoop;
  4503. OPERATOR ".>="*(CONST left, right: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF BOOLEAN;
  4504. BEGIN
  4505. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4506. SIZEOF( BOOLEAN ), EGeqALALLoop );
  4507. RETURN RESULT
  4508. END ".>=";
  4509. (** REAL *)
  4510. PROCEDURE EGeqARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4511. VAR lval, rval: REAL;
  4512. BEGIN
  4513. WHILE (len > 0) DO
  4514. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval >= rval );
  4515. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4516. END;
  4517. END EGeqARARLoop;
  4518. OPERATOR ".>="*(CONST left, right: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF BOOLEAN;
  4519. BEGIN
  4520. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4521. SIZEOF( BOOLEAN ), EGeqARARLoop );
  4522. RETURN RESULT
  4523. END ".>=";
  4524. (** LONGREAL *)
  4525. PROCEDURE EGeqAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4526. VAR lval, rval: LONGREAL;
  4527. BEGIN
  4528. WHILE (len > 0) DO
  4529. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval >= rval );
  4530. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4531. END;
  4532. END EGeqAXAXLoop;
  4533. OPERATOR ".>="*(CONST left, right: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF BOOLEAN;
  4534. BEGIN
  4535. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4536. SIZEOF( BOOLEAN ), EGeqAXAXLoop );
  4537. RETURN RESULT
  4538. END ".>=";
  4539. (*** elementwise geq array x scalar -> array of boolean ********************************************************************)
  4540. (** SHORTINT *)
  4541. PROCEDURE EGeqASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4542. VAR lval, rval: SHORTINT;
  4543. BEGIN
  4544. SYSTEM.GET( radr, rval );
  4545. WHILE (len > 0) DO
  4546. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc );
  4547. INC( dadr, dinc ); DEC( len );
  4548. END;
  4549. END EGeqASSSLoop;
  4550. OPERATOR ".>="*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF BOOLEAN;
  4551. BEGIN
  4552. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4553. SIZEOF( BOOLEAN ), EGeqASSSLoop );
  4554. RETURN RESULT
  4555. END ".>=";
  4556. OPERATOR ".<="*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF BOOLEAN;
  4557. BEGIN
  4558. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4559. SIZEOF( BOOLEAN ), EGeqASSSLoop );
  4560. RETURN RESULT
  4561. END ".<=";
  4562. (** INTEGER *)
  4563. PROCEDURE EGeqAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4564. VAR lval, rval: INTEGER;
  4565. BEGIN
  4566. SYSTEM.GET( radr, rval );
  4567. WHILE (len > 0) DO
  4568. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc );
  4569. INC( dadr, dinc ); DEC( len );
  4570. END;
  4571. END EGeqAISILoop;
  4572. OPERATOR ".>="*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF BOOLEAN;
  4573. BEGIN
  4574. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4575. SIZEOF( BOOLEAN ), EGeqAISILoop );
  4576. RETURN RESULT
  4577. END ".>=";
  4578. OPERATOR ".<="*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF BOOLEAN;
  4579. BEGIN
  4580. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4581. SIZEOF( BOOLEAN ), EGeqAISILoop );
  4582. RETURN RESULT
  4583. END ".<=";
  4584. (** LONGINT *)
  4585. PROCEDURE EGeqALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4586. VAR lval, rval: LONGINT;
  4587. BEGIN
  4588. SYSTEM.GET( radr, rval );
  4589. WHILE (len > 0) DO
  4590. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc );
  4591. INC( dadr, dinc ); DEC( len );
  4592. END;
  4593. END EGeqALSLLoop;
  4594. OPERATOR ".>="*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF BOOLEAN;
  4595. BEGIN
  4596. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4597. SIZEOF( BOOLEAN ), EGeqALSLLoop );
  4598. RETURN RESULT
  4599. END ".>=";
  4600. OPERATOR ".<="*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF BOOLEAN;
  4601. BEGIN
  4602. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4603. SIZEOF( BOOLEAN ), EGeqALSLLoop );
  4604. RETURN RESULT
  4605. END ".<=";
  4606. (** REAL *)
  4607. PROCEDURE EGeqARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4608. VAR lval, rval: REAL;
  4609. BEGIN
  4610. SYSTEM.GET( radr, rval );
  4611. WHILE (len > 0) DO
  4612. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc );
  4613. INC( dadr, dinc ); DEC( len );
  4614. END;
  4615. END EGeqARSRLoop;
  4616. OPERATOR ".>="*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF BOOLEAN;
  4617. BEGIN
  4618. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4619. SIZEOF( BOOLEAN ), EGeqARSRLoop );
  4620. RETURN RESULT
  4621. END ".>=";
  4622. OPERATOR ".<="*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF BOOLEAN;
  4623. BEGIN
  4624. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4625. SIZEOF( BOOLEAN ), EGeqARSRLoop );
  4626. RETURN RESULT
  4627. END ".<=";
  4628. (** LONGREAL *)
  4629. PROCEDURE EGeqAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4630. VAR lval, rval: LONGREAL;
  4631. BEGIN
  4632. SYSTEM.GET( radr, rval );
  4633. WHILE (len > 0) DO
  4634. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc );
  4635. INC( dadr, dinc ); DEC( len );
  4636. END;
  4637. END EGeqAXSXLoop;
  4638. OPERATOR ".>="*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF BOOLEAN;
  4639. BEGIN
  4640. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4641. SIZEOF( BOOLEAN ), EGeqAXSXLoop );
  4642. RETURN RESULT
  4643. END ".>=";
  4644. OPERATOR ".<="*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF BOOLEAN;
  4645. BEGIN
  4646. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4647. SIZEOF( BOOLEAN ), EGeqAXSXLoop );
  4648. RETURN RESULT
  4649. END ".<=";
  4650. (*** elementwise less than: array x array -> array of boolean ********************************************************************)
  4651. (** SHORTINT *)
  4652. PROCEDURE ELssASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4653. VAR lval, rval: SHORTINT;
  4654. BEGIN
  4655. WHILE (len > 0) DO
  4656. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval < rval );
  4657. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4658. END;
  4659. END ELssASASLoop;
  4660. OPERATOR ".<"*(CONST left, right: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF BOOLEAN;
  4661. BEGIN
  4662. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4663. SIZEOF( BOOLEAN ), ELssASASLoop );
  4664. RETURN RESULT
  4665. END ".<";
  4666. (** INTEGER *)
  4667. PROCEDURE ELssAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4668. VAR lval, rval: INTEGER;
  4669. BEGIN
  4670. WHILE (len > 0) DO
  4671. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval < rval );
  4672. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4673. END;
  4674. END ELssAIAILoop;
  4675. OPERATOR ".<"*(CONST left, right: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF BOOLEAN;
  4676. BEGIN
  4677. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4678. SIZEOF( BOOLEAN ), ELssAIAILoop );
  4679. RETURN RESULT
  4680. END ".<";
  4681. (** LONGINT*)
  4682. PROCEDURE ELssALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4683. VAR lval, rval: LONGINT;
  4684. BEGIN
  4685. WHILE (len > 0) DO
  4686. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval < rval );
  4687. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4688. END;
  4689. END ELssALALLoop;
  4690. OPERATOR ".<"*(CONST left, right: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF BOOLEAN;
  4691. BEGIN
  4692. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4693. SIZEOF( BOOLEAN ), ELssALALLoop );
  4694. RETURN RESULT
  4695. END ".<";
  4696. (** REAL *)
  4697. PROCEDURE ELssARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4698. VAR lval, rval: REAL;
  4699. BEGIN
  4700. WHILE (len > 0) DO
  4701. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval < rval );
  4702. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4703. END;
  4704. END ELssARARLoop;
  4705. OPERATOR ".<"*(CONST left, right: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF BOOLEAN;
  4706. BEGIN
  4707. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4708. SIZEOF( BOOLEAN ), ELssARARLoop );
  4709. RETURN RESULT
  4710. END ".<";
  4711. (** LONGREAL *)
  4712. PROCEDURE ELssAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4713. VAR lval, rval: LONGREAL;
  4714. BEGIN
  4715. WHILE (len > 0) DO
  4716. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval < rval );
  4717. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4718. END;
  4719. END ELssAXAXLoop;
  4720. OPERATOR ".<"*(CONST left, right: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF BOOLEAN;
  4721. BEGIN
  4722. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4723. SIZEOF( BOOLEAN ), ELssAXAXLoop );
  4724. RETURN RESULT
  4725. END ".<";
  4726. (*** elementwise less array x scalar -> array of boolean ********************************************************************)
  4727. (** SHORTINT *)
  4728. PROCEDURE ELssASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4729. VAR lval, rval: SHORTINT;
  4730. BEGIN
  4731. SYSTEM.GET( radr, rval );
  4732. WHILE (len > 0) DO
  4733. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc );
  4734. INC( dadr, dinc ); DEC( len );
  4735. END;
  4736. END ELssASSSLoop;
  4737. OPERATOR ".<"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF BOOLEAN;
  4738. BEGIN
  4739. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4740. SIZEOF( BOOLEAN ), ELssASSSLoop );
  4741. RETURN RESULT
  4742. END ".<";
  4743. OPERATOR ".>"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF BOOLEAN;
  4744. BEGIN
  4745. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4746. SIZEOF( BOOLEAN ), ELssASSSLoop );
  4747. RETURN RESULT
  4748. END ".>";
  4749. (** INTEGER *)
  4750. PROCEDURE ELssAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4751. VAR lval, rval: INTEGER;
  4752. BEGIN
  4753. SYSTEM.GET( radr, rval );
  4754. WHILE (len > 0) DO
  4755. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc );
  4756. INC( dadr, dinc ); DEC( len );
  4757. END;
  4758. END ELssAISILoop;
  4759. OPERATOR ".<"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF BOOLEAN;
  4760. BEGIN
  4761. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4762. SIZEOF( BOOLEAN ), ELssAISILoop );
  4763. RETURN RESULT
  4764. END ".<";
  4765. OPERATOR ".>"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF BOOLEAN;
  4766. BEGIN
  4767. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4768. SIZEOF( BOOLEAN ), ELssAISILoop );
  4769. RETURN RESULT
  4770. END ".>";
  4771. (** LONGINT *)
  4772. PROCEDURE ELssALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4773. VAR lval, rval: LONGINT;
  4774. BEGIN
  4775. SYSTEM.GET( radr, rval );
  4776. WHILE (len > 0) DO
  4777. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc );
  4778. INC( dadr, dinc ); DEC( len );
  4779. END;
  4780. END ELssALSLLoop;
  4781. OPERATOR ".<"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF BOOLEAN;
  4782. BEGIN
  4783. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4784. SIZEOF( BOOLEAN ), ELssALSLLoop );
  4785. RETURN RESULT
  4786. END ".<";
  4787. OPERATOR ".>"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF BOOLEAN;
  4788. BEGIN
  4789. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4790. SIZEOF( BOOLEAN ), ELssALSLLoop );
  4791. RETURN RESULT
  4792. END ".>";
  4793. (** REAL *)
  4794. PROCEDURE ELssARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4795. VAR lval, rval: REAL;
  4796. BEGIN
  4797. SYSTEM.GET( radr, rval );
  4798. WHILE (len > 0) DO
  4799. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc );
  4800. INC( dadr, dinc ); DEC( len );
  4801. END;
  4802. END ELssARSRLoop;
  4803. OPERATOR ".<"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF BOOLEAN;
  4804. BEGIN
  4805. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4806. SIZEOF( BOOLEAN ), ELssARSRLoop );
  4807. RETURN RESULT
  4808. END ".<";
  4809. OPERATOR ".>"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF BOOLEAN;
  4810. BEGIN
  4811. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4812. SIZEOF( BOOLEAN ), ELssARSRLoop );
  4813. RETURN RESULT
  4814. END ".>";
  4815. (** LONGREAL *)
  4816. PROCEDURE ELssAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4817. VAR lval, rval: LONGREAL;
  4818. BEGIN
  4819. SYSTEM.GET( radr, rval );
  4820. WHILE (len > 0) DO
  4821. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc );
  4822. INC( dadr, dinc ); DEC( len );
  4823. END;
  4824. END ELssAXSXLoop;
  4825. OPERATOR ".<"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF BOOLEAN;
  4826. BEGIN
  4827. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4828. SIZEOF( BOOLEAN ), ELssAXSXLoop );
  4829. RETURN RESULT
  4830. END ".<";
  4831. OPERATOR ".>"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF BOOLEAN;
  4832. BEGIN
  4833. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4834. SIZEOF( BOOLEAN ), ELssAXSXLoop );
  4835. RETURN RESULT
  4836. END ".>";
  4837. (*** elementwise less or equal: array x array -> array of boolean ********************************************************************)
  4838. (** SHORTINT *)
  4839. PROCEDURE ELeqASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4840. VAR lval, rval: SHORTINT;
  4841. BEGIN
  4842. WHILE (len > 0) DO
  4843. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval <= rval );
  4844. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4845. END;
  4846. END ELeqASASLoop;
  4847. OPERATOR ".<="*(CONST left, right: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF BOOLEAN;
  4848. BEGIN
  4849. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4850. SIZEOF( BOOLEAN ), ELeqASASLoop );
  4851. RETURN RESULT
  4852. END ".<=";
  4853. (** INTEGER *)
  4854. PROCEDURE ELeqAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4855. VAR lval, rval: INTEGER;
  4856. BEGIN
  4857. WHILE (len > 0) DO
  4858. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval <= rval );
  4859. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4860. END;
  4861. END ELeqAIAILoop;
  4862. OPERATOR ".<="*(CONST left, right: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF BOOLEAN;
  4863. BEGIN
  4864. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4865. SIZEOF( BOOLEAN ), ELeqAIAILoop );
  4866. RETURN RESULT
  4867. END ".<=";
  4868. (** LONGINT *)
  4869. PROCEDURE ELeqALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4870. VAR lval, rval: LONGINT;
  4871. BEGIN
  4872. WHILE (len > 0) DO
  4873. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval <= rval );
  4874. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4875. END;
  4876. END ELeqALALLoop;
  4877. OPERATOR ".<="*(CONST left, right: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF BOOLEAN;
  4878. BEGIN
  4879. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4880. SIZEOF( BOOLEAN ), ELeqALALLoop );
  4881. RETURN RESULT
  4882. END ".<=";
  4883. (** REAL *)
  4884. PROCEDURE ELeqARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4885. VAR lval, rval: REAL;
  4886. BEGIN
  4887. WHILE (len > 0) DO
  4888. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval <= rval );
  4889. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4890. END;
  4891. END ELeqARARLoop;
  4892. OPERATOR ".<="*(CONST left, right: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF BOOLEAN;
  4893. BEGIN
  4894. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4895. SIZEOF( BOOLEAN ), ELeqARARLoop );
  4896. RETURN RESULT
  4897. END ".<=";
  4898. (** LONGREAL*)
  4899. PROCEDURE ELeqAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  4900. VAR lval, rval: LONGREAL;
  4901. BEGIN
  4902. WHILE (len > 0) DO
  4903. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval <= rval );
  4904. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  4905. END;
  4906. END ELeqAXAXLoop;
  4907. OPERATOR ".<="*(CONST left, right: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF BOOLEAN;
  4908. BEGIN
  4909. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4910. SIZEOF( BOOLEAN ), ELeqAXAXLoop );
  4911. RETURN RESULT
  4912. END ".<=";
  4913. (*** elementwise leq array x scalar -> array of boolean ********************************************************************)
  4914. (** SHORTINT *)
  4915. PROCEDURE ELeqASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4916. VAR lval, rval: SHORTINT;
  4917. BEGIN
  4918. SYSTEM.GET( radr, rval );
  4919. WHILE (len > 0) DO
  4920. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc );
  4921. INC( dadr, dinc ); DEC( len );
  4922. END;
  4923. END ELeqASSSLoop;
  4924. OPERATOR ".<="*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF BOOLEAN;
  4925. BEGIN
  4926. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4927. SIZEOF( BOOLEAN ), ELeqASSSLoop );
  4928. RETURN RESULT
  4929. END ".<=";
  4930. OPERATOR ".>="*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF BOOLEAN;
  4931. BEGIN
  4932. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4933. SIZEOF( BOOLEAN ), ELeqASSSLoop );
  4934. RETURN RESULT
  4935. END ".>=";
  4936. (** INTEGER *)
  4937. PROCEDURE ELeqAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4938. VAR lval, rval: INTEGER;
  4939. BEGIN
  4940. SYSTEM.GET( radr, rval );
  4941. WHILE (len > 0) DO
  4942. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc );
  4943. INC( dadr, dinc ); DEC( len );
  4944. END;
  4945. END ELeqAISILoop;
  4946. OPERATOR ".<="*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF BOOLEAN;
  4947. BEGIN
  4948. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4949. SIZEOF( BOOLEAN ), ELeqAISILoop );
  4950. RETURN RESULT
  4951. END ".<=";
  4952. OPERATOR ".>="*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF BOOLEAN;
  4953. BEGIN
  4954. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4955. SIZEOF( BOOLEAN ), ELeqAISILoop );
  4956. RETURN RESULT
  4957. END ".>=";
  4958. (** LONGINT *)
  4959. PROCEDURE ELeqALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4960. VAR lval, rval: LONGINT;
  4961. BEGIN
  4962. SYSTEM.GET( radr, rval );
  4963. WHILE (len > 0) DO
  4964. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc );
  4965. INC( dadr, dinc ); DEC( len );
  4966. END;
  4967. END ELeqALSLLoop;
  4968. OPERATOR ".<="*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF BOOLEAN;
  4969. BEGIN
  4970. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4971. SIZEOF( BOOLEAN ), ELeqALSLLoop );
  4972. RETURN RESULT
  4973. END ".<=";
  4974. OPERATOR ".>="*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF BOOLEAN;
  4975. BEGIN
  4976. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4977. SIZEOF( BOOLEAN ), ELeqALSLLoop );
  4978. RETURN RESULT
  4979. END ".>=";
  4980. (** REAL *)
  4981. PROCEDURE ELeqARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  4982. VAR lval, rval: REAL;
  4983. BEGIN
  4984. SYSTEM.GET( radr, rval );
  4985. WHILE (len > 0) DO
  4986. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc );
  4987. INC( dadr, dinc ); DEC( len );
  4988. END;
  4989. END ELeqARSRLoop;
  4990. OPERATOR ".<="*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF BOOLEAN;
  4991. BEGIN
  4992. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  4993. SIZEOF( BOOLEAN ), ELeqARSRLoop );
  4994. RETURN RESULT
  4995. END ".<=";
  4996. OPERATOR ".>="*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF BOOLEAN;
  4997. BEGIN
  4998. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  4999. SIZEOF( BOOLEAN ), ELeqARSRLoop );
  5000. RETURN RESULT
  5001. END ".>=";
  5002. (** LONGREAL *)
  5003. PROCEDURE ELeqAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  5004. VAR lval, rval: LONGREAL;
  5005. BEGIN
  5006. SYSTEM.GET( radr, rval );
  5007. WHILE (len > 0) DO
  5008. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc );
  5009. INC( dadr, dinc ); DEC( len );
  5010. END;
  5011. END ELeqAXSXLoop;
  5012. OPERATOR ".<="*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF BOOLEAN;
  5013. BEGIN
  5014. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  5015. SIZEOF( BOOLEAN ), ELeqAXSXLoop );
  5016. RETURN RESULT
  5017. END ".<=";
  5018. OPERATOR ".>="*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF BOOLEAN;
  5019. BEGIN
  5020. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  5021. SIZEOF( BOOLEAN ), ELeqAXSXLoop );
  5022. RETURN RESULT
  5023. END ".>=";
  5024. (*** elementwise or, elementwise and ********************************************************************)
  5025. (** array x array *)
  5026. PROCEDURE ElOrABABLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  5027. VAR lval, rval: BOOLEAN;
  5028. BEGIN
  5029. WHILE (len > 0) DO
  5030. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, (lval OR rval) );
  5031. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  5032. END;
  5033. END ElOrABABLoop;
  5034. OPERATOR "OR"*(CONST left,right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN;
  5035. BEGIN
  5036. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  5037. SIZEOF( BOOLEAN ), ElOrABABLoop );
  5038. RETURN RESULT
  5039. END "OR";
  5040. PROCEDURE ElAndABABLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len:SIZE );
  5041. VAR lval, rval: BOOLEAN;
  5042. BEGIN
  5043. WHILE (len > 0) DO
  5044. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval & rval );
  5045. INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len );
  5046. END;
  5047. END ElAndABABLoop;
  5048. OPERATOR "&"*(CONST left,right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN;
  5049. BEGIN
  5050. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  5051. SIZEOF( BOOLEAN ), ElAndABABLoop );
  5052. RETURN RESULT
  5053. END "&";
  5054. (** array x boolean *)
  5055. PROCEDURE ElOrABSBLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  5056. VAR lval, rval: BOOLEAN;
  5057. BEGIN
  5058. SYSTEM.GET( radr, rval );
  5059. WHILE (len > 0) DO
  5060. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval OR rval ); INC( ladr, linc );
  5061. INC( dadr, dinc ); DEC( len );
  5062. END;
  5063. END ElOrABSBLoop;
  5064. OPERATOR "OR"*(CONST left : ARRAY [?] OF BOOLEAN; right: BOOLEAN):ARRAY [ ? ] OF BOOLEAN;
  5065. BEGIN
  5066. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  5067. SIZEOF( BOOLEAN ), ElOrABSBLoop );
  5068. RETURN RESULT
  5069. END "OR";
  5070. OPERATOR "OR"*(left: BOOLEAN; CONST right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN;
  5071. BEGIN
  5072. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  5073. SIZEOF( BOOLEAN ), ElOrABSBLoop );
  5074. RETURN RESULT
  5075. END "OR";
  5076. PROCEDURE ElAndABSBLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  5077. VAR lval, rval: BOOLEAN;
  5078. BEGIN
  5079. SYSTEM.GET( radr, rval );
  5080. WHILE (len > 0) DO
  5081. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval & rval ); INC( ladr, linc );
  5082. INC( dadr, dinc ); DEC( len );
  5083. END;
  5084. END ElAndABSBLoop;
  5085. OPERATOR "&"*(CONST left : ARRAY [?] OF BOOLEAN; right: BOOLEAN):ARRAY [ ? ] OF BOOLEAN;
  5086. BEGIN
  5087. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  5088. SIZEOF( BOOLEAN ), ElAndABSBLoop );
  5089. RETURN RESULT
  5090. END "&";
  5091. OPERATOR "&"*(left: BOOLEAN; CONST right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN;
  5092. BEGIN
  5093. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ),
  5094. SIZEOF( BOOLEAN ), ElAndABSBLoop );
  5095. RETURN RESULT
  5096. END "&";
  5097. (*** less than, greater or equal: array x array -> boolean ********************************************************************)
  5098. (** SHORTINT *)
  5099. PROCEDURE LssASASLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5100. VAR lval, rval: SHORTINT;
  5101. BEGIN
  5102. WHILE (len > 0) DO
  5103. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5104. IF rval <= lval THEN RETURN FALSE END;
  5105. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5106. END;
  5107. RETURN TRUE;
  5108. END LssASASLoop;
  5109. OPERATOR "<"*( CONST left, right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN;
  5110. BEGIN
  5111. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LssASASLoop , FALSE);
  5112. END "<";
  5113. PROCEDURE GeqASASLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5114. VAR lval, rval: SHORTINT;
  5115. BEGIN
  5116. WHILE (len > 0) DO
  5117. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5118. IF rval > lval THEN RETURN FALSE END;
  5119. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5120. END;
  5121. RETURN TRUE;
  5122. END GeqASASLoop;
  5123. OPERATOR ">="*( CONST left, right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN;
  5124. BEGIN
  5125. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqASASLoop , FALSE);
  5126. END ">=";
  5127. (** INTEGER *)
  5128. PROCEDURE LssAIAILoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5129. VAR lval, rval: INTEGER;
  5130. BEGIN
  5131. WHILE (len > 0) DO
  5132. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5133. IF rval <= lval THEN RETURN FALSE END;
  5134. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5135. END;
  5136. RETURN TRUE;
  5137. END LssAIAILoop;
  5138. OPERATOR "<"*( CONST left, right: ARRAY [ ? ] OF INTEGER ): BOOLEAN;
  5139. BEGIN
  5140. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LssAIAILoop , FALSE);
  5141. END "<";
  5142. PROCEDURE GeqAIAILoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5143. VAR lval, rval: INTEGER;
  5144. BEGIN
  5145. WHILE (len > 0) DO
  5146. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5147. IF rval > lval THEN RETURN FALSE END;
  5148. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5149. END;
  5150. RETURN TRUE;
  5151. END GeqAIAILoop;
  5152. OPERATOR ">="*( CONST left, right: ARRAY [ ? ] OF INTEGER ): BOOLEAN;
  5153. BEGIN
  5154. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqAIAILoop , FALSE);
  5155. END ">=";
  5156. (** LONGINT *)
  5157. PROCEDURE LssALALLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5158. VAR lval, rval: LONGINT;
  5159. BEGIN
  5160. WHILE (len > 0) DO
  5161. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5162. IF rval <= lval THEN RETURN FALSE END;
  5163. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5164. END;
  5165. RETURN TRUE;
  5166. END LssALALLoop;
  5167. OPERATOR "<"*( CONST left, right: ARRAY [ ? ] OF LONGINT ): BOOLEAN;
  5168. BEGIN
  5169. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LssALALLoop , FALSE);
  5170. END "<";
  5171. PROCEDURE GeqALALLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5172. VAR lval, rval: LONGINT;
  5173. BEGIN
  5174. WHILE (len > 0) DO
  5175. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5176. IF rval > lval THEN RETURN FALSE END;
  5177. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5178. END;
  5179. RETURN TRUE;
  5180. END GeqALALLoop;
  5181. OPERATOR ">="*( CONST left, right: ARRAY [ ? ] OF LONGINT ): BOOLEAN;
  5182. BEGIN
  5183. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqALALLoop , FALSE);
  5184. END ">=";
  5185. (** REAL *)
  5186. PROCEDURE LssARARLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5187. VAR lval, rval: REAL;
  5188. BEGIN
  5189. WHILE (len > 0) DO
  5190. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5191. IF rval <= lval THEN RETURN FALSE END;
  5192. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5193. END;
  5194. RETURN TRUE;
  5195. END LssARARLoop;
  5196. OPERATOR "<"*( CONST left, right: ARRAY [ ? ] OF REAL ): BOOLEAN;
  5197. BEGIN
  5198. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LssARARLoop , FALSE);
  5199. END "<";
  5200. PROCEDURE GeqARARLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5201. VAR lval, rval: REAL;
  5202. BEGIN
  5203. WHILE (len > 0) DO
  5204. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5205. IF rval > lval THEN RETURN FALSE END;
  5206. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5207. END;
  5208. RETURN TRUE;
  5209. END GeqARARLoop;
  5210. OPERATOR ">="*( CONST left, right: ARRAY [ ? ] OF REAL ): BOOLEAN;
  5211. BEGIN
  5212. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqARARLoop , FALSE);
  5213. END ">=";
  5214. (** LONGREAL *)
  5215. PROCEDURE LssAXAXLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5216. VAR lval, rval: LONGREAL;
  5217. BEGIN
  5218. WHILE (len > 0) DO
  5219. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5220. IF rval <= lval THEN RETURN FALSE END;
  5221. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5222. END;
  5223. RETURN TRUE;
  5224. END LssAXAXLoop;
  5225. OPERATOR "<"*( CONST left, right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN;
  5226. BEGIN
  5227. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LssAXAXLoop , FALSE);
  5228. END "<";
  5229. PROCEDURE GeqAXAXLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5230. VAR lval, rval: LONGREAL;
  5231. BEGIN
  5232. WHILE (len > 0) DO
  5233. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5234. IF rval > lval THEN RETURN FALSE END;
  5235. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5236. END;
  5237. RETURN TRUE;
  5238. END GeqAXAXLoop;
  5239. OPERATOR ">="*( CONST left, right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN;
  5240. BEGIN
  5241. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqAXAXLoop , FALSE);
  5242. END ">=";
  5243. (*** less than, greater or equal: array x array -> boolean ********************************************************************)
  5244. (** SHORTINT *)
  5245. PROCEDURE GtrASASLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5246. VAR lval, rval: SHORTINT;
  5247. BEGIN
  5248. WHILE (len > 0) DO
  5249. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5250. IF rval >= lval THEN RETURN FALSE END;
  5251. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5252. END;
  5253. RETURN TRUE;
  5254. END GtrASASLoop;
  5255. OPERATOR ">"*( CONST left, right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN;
  5256. BEGIN
  5257. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrASASLoop , FALSE);
  5258. END ">";
  5259. PROCEDURE LeqASASLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5260. VAR lval, rval: SHORTINT;
  5261. BEGIN
  5262. WHILE (len > 0) DO
  5263. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5264. IF rval < lval THEN RETURN FALSE END;
  5265. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5266. END;
  5267. RETURN TRUE;
  5268. END LeqASASLoop;
  5269. OPERATOR "<="*( CONST left, right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN;
  5270. BEGIN
  5271. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqASASLoop , FALSE);
  5272. END "<=";
  5273. (** INTEGER *)
  5274. PROCEDURE GtrAIAILoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5275. VAR lval, rval: INTEGER;
  5276. BEGIN
  5277. WHILE (len > 0) DO
  5278. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5279. IF rval >= lval THEN RETURN FALSE END;
  5280. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5281. END;
  5282. RETURN TRUE;
  5283. END GtrAIAILoop;
  5284. OPERATOR ">"*( CONST left, right: ARRAY [ ? ] OF INTEGER ): BOOLEAN;
  5285. BEGIN
  5286. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrAIAILoop , FALSE);
  5287. END ">";
  5288. PROCEDURE LeqAIAILoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5289. VAR lval, rval: INTEGER;
  5290. BEGIN
  5291. WHILE (len > 0) DO
  5292. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5293. IF rval < lval THEN RETURN FALSE END;
  5294. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5295. END;
  5296. RETURN TRUE;
  5297. END LeqAIAILoop;
  5298. OPERATOR "<="*( CONST left, right: ARRAY [ ? ] OF INTEGER ): BOOLEAN;
  5299. BEGIN
  5300. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqAIAILoop ,FALSE);
  5301. END "<=";
  5302. (** LONGINT *)
  5303. PROCEDURE GtrALALLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5304. VAR lval, rval: LONGINT;
  5305. BEGIN
  5306. WHILE (len > 0) DO
  5307. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5308. IF rval >= lval THEN RETURN FALSE END;
  5309. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5310. END;
  5311. RETURN TRUE;
  5312. END GtrALALLoop;
  5313. OPERATOR ">"*( CONST left, right: ARRAY [ ? ] OF LONGINT ): BOOLEAN;
  5314. BEGIN
  5315. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrALALLoop , FALSE);
  5316. END ">";
  5317. PROCEDURE LeqALALLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5318. VAR lval, rval: LONGINT;
  5319. BEGIN
  5320. WHILE (len > 0) DO
  5321. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5322. IF rval < lval THEN RETURN FALSE END;
  5323. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5324. END;
  5325. RETURN TRUE;
  5326. END LeqALALLoop;
  5327. OPERATOR "<="*( CONST left, right: ARRAY [ ? ] OF LONGINT ): BOOLEAN;
  5328. BEGIN
  5329. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqALALLoop , FALSE);
  5330. END "<=";
  5331. (** REAL *)
  5332. PROCEDURE GtrARARLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5333. VAR lval, rval: REAL;
  5334. BEGIN
  5335. WHILE (len > 0) DO
  5336. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5337. IF rval >= lval THEN RETURN FALSE END;
  5338. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5339. END;
  5340. RETURN TRUE;
  5341. END GtrARARLoop;
  5342. OPERATOR ">"*( CONST left, right: ARRAY [ ? ] OF REAL ): BOOLEAN;
  5343. BEGIN
  5344. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrARARLoop , FALSE);
  5345. END ">";
  5346. PROCEDURE LeqARARLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5347. VAR lval, rval: REAL;
  5348. BEGIN
  5349. WHILE (len > 0) DO
  5350. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5351. IF rval < lval THEN RETURN FALSE END;
  5352. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5353. END;
  5354. RETURN TRUE;
  5355. END LeqARARLoop;
  5356. OPERATOR "<="*( CONST left, right: ARRAY [ ? ] OF REAL ): BOOLEAN;
  5357. BEGIN
  5358. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqARARLoop , FALSE);
  5359. END "<=";
  5360. (** LONGREAL *)
  5361. PROCEDURE GtrAXAXLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5362. VAR lval, rval: LONGREAL;
  5363. BEGIN
  5364. WHILE (len > 0) DO
  5365. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5366. IF rval >= lval THEN RETURN FALSE END;
  5367. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5368. END;
  5369. RETURN TRUE;
  5370. END GtrAXAXLoop;
  5371. OPERATOR ">"*( CONST left, right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN;
  5372. BEGIN
  5373. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrAXAXLoop , FALSE);
  5374. END ">";
  5375. PROCEDURE LeqAXAXLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5376. VAR lval, rval: LONGREAL;
  5377. BEGIN
  5378. WHILE (len > 0) DO
  5379. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5380. IF rval < lval THEN RETURN FALSE END;
  5381. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5382. END;
  5383. RETURN TRUE;
  5384. END LeqAXAXLoop;
  5385. OPERATOR "<="*( CONST left, right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN;
  5386. BEGIN
  5387. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqAXAXLoop , FALSE);
  5388. END "<=";
  5389. (*** equals: array x array -> boolean ********************************************************************)
  5390. (** BOOLEAN *)
  5391. PROCEDURE EqlABABLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5392. VAR lval, rval: BOOLEAN;
  5393. BEGIN
  5394. WHILE (len > 0) DO
  5395. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5396. IF rval # lval THEN RETURN FALSE END;
  5397. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5398. END;
  5399. RETURN TRUE;
  5400. END EqlABABLoop;
  5401. OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF BOOLEAN ): BOOLEAN;
  5402. BEGIN
  5403. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlABABLoop, FALSE);
  5404. END "=";
  5405. OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF BOOLEAN ): BOOLEAN;
  5406. BEGIN
  5407. RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlABABLoop, FALSE);
  5408. END "#";
  5409. (** SHORTINT *)
  5410. PROCEDURE EqlASASLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5411. VAR lval, rval: SHORTINT;
  5412. BEGIN
  5413. WHILE (len > 0) DO
  5414. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5415. IF rval # lval THEN RETURN FALSE END;
  5416. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5417. END;
  5418. RETURN TRUE;
  5419. END EqlASASLoop;
  5420. OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN;
  5421. BEGIN
  5422. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlASASLoop , FALSE);
  5423. END "=";
  5424. OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN;
  5425. BEGIN
  5426. RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlASASLoop, FALSE );
  5427. END "#";
  5428. (** INTEGER *)
  5429. PROCEDURE EqlAIAILoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5430. VAR lval, rval: INTEGER;
  5431. BEGIN
  5432. WHILE (len > 0) DO
  5433. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5434. IF rval # lval THEN RETURN FALSE END;
  5435. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5436. END;
  5437. RETURN TRUE;
  5438. END EqlAIAILoop;
  5439. OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF INTEGER ): BOOLEAN;
  5440. BEGIN
  5441. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAIAILoop, FALSE );
  5442. END "=";
  5443. OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF INTEGER ): BOOLEAN;
  5444. BEGIN
  5445. RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAIAILoop, FALSE );
  5446. END "#";
  5447. (** LONGINT *)
  5448. PROCEDURE EqlALALLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5449. VAR lval, rval: LONGINT;
  5450. BEGIN
  5451. WHILE (len > 0) DO
  5452. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5453. IF rval # lval THEN RETURN FALSE END;
  5454. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5455. END;
  5456. RETURN TRUE;
  5457. END EqlALALLoop;
  5458. OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF LONGINT ): BOOLEAN;
  5459. BEGIN
  5460. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlALALLoop, FALSE );
  5461. END "=";
  5462. OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF LONGINT ): BOOLEAN;
  5463. BEGIN
  5464. RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlALALLoop, FALSE );
  5465. END "#";
  5466. (** REAL *)
  5467. PROCEDURE EqlARARLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5468. VAR lval, rval: REAL;
  5469. BEGIN
  5470. WHILE (len > 0) DO
  5471. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5472. IF rval # lval THEN RETURN FALSE END;
  5473. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5474. END;
  5475. RETURN TRUE;
  5476. END EqlARARLoop;
  5477. OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF REAL ): BOOLEAN;
  5478. BEGIN
  5479. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlARARLoop, FALSE );
  5480. END "=";
  5481. OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF REAL ): BOOLEAN;
  5482. BEGIN
  5483. RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlARARLoop, FALSE );
  5484. END "#";
  5485. (** LONGREAL *)
  5486. PROCEDURE EqlAXAXLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5487. VAR lval, rval: LONGREAL;
  5488. BEGIN
  5489. WHILE (len > 0) DO
  5490. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5491. IF rval # lval THEN RETURN FALSE END;
  5492. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5493. END;
  5494. RETURN TRUE;
  5495. END EqlAXAXLoop;
  5496. OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN;
  5497. BEGIN
  5498. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAXAXLoop, FALSE );
  5499. END "=";
  5500. OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN;
  5501. BEGIN
  5502. RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAXAXLoop, FALSE );
  5503. END "#";
  5504. (** COMPLEX *)
  5505. PROCEDURE EqlAZAZLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5506. VAR lval, rval: COMPLEX;
  5507. BEGIN
  5508. WHILE (len > 0) DO
  5509. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  5510. IF rval # lval THEN RETURN FALSE END;
  5511. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5512. END;
  5513. RETURN TRUE;
  5514. END EqlAZAZLoop;
  5515. OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF COMPLEX ): BOOLEAN;
  5516. BEGIN
  5517. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAZAZLoop, FALSE );
  5518. END "=";
  5519. OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF COMPLEX ): BOOLEAN;
  5520. BEGIN
  5521. RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAZAZLoop, FALSE );
  5522. END "#";
  5523. (** LONGCOMPLEX *)
  5524. PROCEDURE EqlALZALZLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN;
  5525. VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL;
  5526. BEGIN
  5527. WHILE (len > 0) DO
  5528. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  5529. SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm );
  5530. IF (rvalRe # lvalRe) OR (rvalIm # lvalIm) THEN RETURN FALSE END;
  5531. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  5532. END;
  5533. RETURN TRUE;
  5534. END EqlALZALZLoop;
  5535. OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF LONGCOMPLEX ): BOOLEAN;
  5536. BEGIN
  5537. RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlALZALZLoop, FALSE );
  5538. END "=";
  5539. OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF LONGCOMPLEX ): BOOLEAN;
  5540. BEGIN
  5541. RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlALZALZLoop, FALSE );
  5542. END "#";
  5543. (*** equals: array x scalar -> boolean ********************************************************************)
  5544. (** BOOLEAN *)
  5545. PROCEDURE EqlABSBLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5546. VAR lval, rval: BOOLEAN;
  5547. BEGIN
  5548. SYSTEM.GET( radr, rval );
  5549. WHILE (len > 0) DO
  5550. SYSTEM.GET( ladr, lval );
  5551. IF lval # rval THEN RETURN FALSE END;
  5552. INC( ladr, linc ); DEC( len );
  5553. END;
  5554. RETURN TRUE;
  5555. END EqlABSBLoop;
  5556. OPERATOR "="*( CONST left: ARRAY [ ? ] OF BOOLEAN;
  5557. right: BOOLEAN ): BOOLEAN;
  5558. BEGIN
  5559. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlABSBLoop );
  5560. END "=";
  5561. OPERATOR "="*( left: BOOLEAN;
  5562. CONST right: ARRAY [ ? ] OF BOOLEAN ): BOOLEAN;
  5563. BEGIN
  5564. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), EqlABSBLoop );
  5565. END "=";
  5566. OPERATOR "#"*( CONST left: ARRAY [ ? ] OF BOOLEAN;
  5567. right: BOOLEAN ): BOOLEAN;
  5568. BEGIN
  5569. RETURN ~(left = right);
  5570. END "#";
  5571. OPERATOR "#"*( left: BOOLEAN;
  5572. CONST right: ARRAY [ ? ] OF BOOLEAN ): BOOLEAN;
  5573. BEGIN
  5574. RETURN ~( left = right );
  5575. END "#";
  5576. (** SHORTINT *)
  5577. PROCEDURE EqlASSSLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5578. VAR lval, rval: SHORTINT;
  5579. BEGIN
  5580. SYSTEM.GET( radr, rval );
  5581. WHILE (len > 0) DO
  5582. SYSTEM.GET( ladr, lval );
  5583. IF lval # rval THEN RETURN FALSE END;
  5584. INC( ladr, linc ); DEC( len );
  5585. END;
  5586. RETURN TRUE;
  5587. END EqlASSSLoop;
  5588. OPERATOR "="*( CONST left: ARRAY [ ? ] OF SHORTINT;right: SHORTINT ): BOOLEAN;
  5589. BEGIN
  5590. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlASSSLoop );
  5591. END "=";
  5592. OPERATOR "="*( left: SHORTINT;CONST right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN;
  5593. BEGIN
  5594. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), EqlASSSLoop );
  5595. END "=";
  5596. OPERATOR "#"*( CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): BOOLEAN;
  5597. BEGIN
  5598. RETURN ~( left= right );
  5599. END "#";
  5600. OPERATOR "#"*( left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN;
  5601. BEGIN
  5602. RETURN ~( left= right );
  5603. END "#";
  5604. (** INTEGER *)
  5605. PROCEDURE EqlAISILoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5606. VAR lval, rval: INTEGER;
  5607. BEGIN
  5608. SYSTEM.GET( radr, rval );
  5609. WHILE (len > 0) DO
  5610. SYSTEM.GET( ladr, lval );
  5611. IF lval # rval THEN RETURN FALSE END;
  5612. INC( ladr, linc ); DEC( len );
  5613. END;
  5614. RETURN TRUE;
  5615. END EqlAISILoop;
  5616. OPERATOR "="*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): BOOLEAN;
  5617. BEGIN
  5618. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAISILoop );
  5619. END "=";
  5620. OPERATOR "="*( left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER ): BOOLEAN;
  5621. BEGIN
  5622. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), EqlAISILoop );
  5623. END "=";
  5624. OPERATOR "#"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): BOOLEAN;
  5625. BEGIN
  5626. RETURN ~( left = right );
  5627. END "#";
  5628. OPERATOR "#"*( left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER ): BOOLEAN;
  5629. BEGIN
  5630. RETURN ~( left = right );
  5631. END "#";
  5632. (** LONGINT *)
  5633. PROCEDURE EqlALSLLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5634. VAR lval, rval: LONGINT;
  5635. BEGIN
  5636. SYSTEM.GET( radr, rval );
  5637. WHILE (len > 0) DO
  5638. SYSTEM.GET( ladr, lval );
  5639. IF lval # rval THEN RETURN FALSE END;
  5640. INC( ladr, linc ); DEC( len );
  5641. END;
  5642. RETURN TRUE;
  5643. END EqlALSLLoop;
  5644. OPERATOR "="*( CONST left: ARRAY [ ? ] OF LONGINT;
  5645. right: LONGINT ): BOOLEAN;
  5646. BEGIN
  5647. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlALSLLoop );
  5648. END "=";
  5649. OPERATOR "="*( left: LONGINT;
  5650. CONST right: ARRAY [ ? ] OF LONGINT ): BOOLEAN;
  5651. BEGIN
  5652. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), EqlALSLLoop );
  5653. END "=";
  5654. OPERATOR "#"*( CONST left: ARRAY [ ? ] OF LONGINT;
  5655. right: LONGINT ): BOOLEAN;
  5656. BEGIN
  5657. RETURN ~(left = right);
  5658. END "#";
  5659. OPERATOR "#"*( left: LONGINT;
  5660. CONST right: ARRAY [ ? ] OF LONGINT ): BOOLEAN;
  5661. BEGIN
  5662. RETURN ~(left = right);
  5663. END "#";
  5664. (** REAL *)
  5665. PROCEDURE EqlARSRLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5666. VAR lval, rval: REAL;
  5667. BEGIN
  5668. SYSTEM.GET( radr, rval );
  5669. WHILE (len > 0) DO
  5670. SYSTEM.GET( ladr, lval );
  5671. IF lval # rval THEN RETURN FALSE END;
  5672. INC( ladr, linc ); DEC( len );
  5673. END;
  5674. RETURN TRUE;
  5675. END EqlARSRLoop;
  5676. OPERATOR "="*( CONST left: ARRAY [ ? ] OF REAL;
  5677. right: REAL ): BOOLEAN;
  5678. BEGIN
  5679. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlARSRLoop );
  5680. END "=";
  5681. OPERATOR "="*( left: REAL;
  5682. CONST right: ARRAY [ ? ] OF REAL ): BOOLEAN;
  5683. BEGIN
  5684. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), EqlARSRLoop );
  5685. END "=";
  5686. OPERATOR "#"*( CONST left: ARRAY [ ? ] OF REAL;
  5687. right: REAL ): BOOLEAN;
  5688. BEGIN
  5689. RETURN ~( left = right );
  5690. END "#";
  5691. OPERATOR "#"*( left: REAL;
  5692. CONST right: ARRAY [ ? ] OF REAL ): BOOLEAN;
  5693. BEGIN
  5694. RETURN ~( left = right );
  5695. END "#";
  5696. (** LONGREAL *)
  5697. PROCEDURE EqlAXSXLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5698. VAR lval, rval: LONGREAL;
  5699. BEGIN
  5700. SYSTEM.GET( radr, rval );
  5701. WHILE (len > 0) DO
  5702. SYSTEM.GET( ladr, lval );
  5703. IF lval # rval THEN RETURN FALSE END;
  5704. INC( ladr, linc ); DEC( len );
  5705. END;
  5706. RETURN TRUE;
  5707. END EqlAXSXLoop;
  5708. OPERATOR "="*( CONST left: ARRAY [ ? ] OF LONGREAL;
  5709. right: LONGREAL ): BOOLEAN;
  5710. BEGIN
  5711. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAXSXLoop );
  5712. END "=";
  5713. OPERATOR "="*( left: LONGREAL;
  5714. CONST right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN;
  5715. BEGIN
  5716. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), EqlAXSXLoop );
  5717. END "=";
  5718. OPERATOR "#"*( CONST left: ARRAY [ ? ] OF LONGREAL;
  5719. right: LONGREAL ): BOOLEAN;
  5720. BEGIN
  5721. RETURN ~( left = right );
  5722. END "#";
  5723. OPERATOR "#"*( left: LONGREAL;CONST right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN;
  5724. BEGIN
  5725. RETURN ~( left= right );
  5726. END "#";
  5727. (*** gtr : array x scalar -> boolean ********************************************************************)
  5728. (** SHORTINT *)
  5729. PROCEDURE GtrASSSLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5730. VAR lval, rval: SHORTINT;
  5731. BEGIN
  5732. SYSTEM.GET( radr, rval );
  5733. WHILE (len > 0) DO
  5734. SYSTEM.GET( ladr, lval );
  5735. IF lval <= rval THEN RETURN FALSE END;
  5736. INC( ladr, linc ); DEC( len );
  5737. END;
  5738. RETURN TRUE;
  5739. END GtrASSSLoop;
  5740. OPERATOR ">"*( CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): BOOLEAN;
  5741. BEGIN
  5742. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrASSSLoop );
  5743. END ">";
  5744. OPERATOR "<"*( left: SHORTINT;CONST right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN;
  5745. BEGIN
  5746. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GtrASSSLoop );
  5747. END "<";
  5748. (** INTEGER *)
  5749. PROCEDURE GtrAISILoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5750. VAR lval, rval: INTEGER;
  5751. BEGIN
  5752. SYSTEM.GET( radr, rval );
  5753. WHILE (len > 0) DO
  5754. SYSTEM.GET( ladr, lval );
  5755. IF lval <= rval THEN RETURN FALSE END;
  5756. INC( ladr, linc ); DEC( len );
  5757. END;
  5758. RETURN TRUE;
  5759. END GtrAISILoop;
  5760. OPERATOR ">"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): BOOLEAN;
  5761. BEGIN
  5762. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrAISILoop );
  5763. END ">";
  5764. OPERATOR "<"*( left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER ): BOOLEAN;
  5765. BEGIN
  5766. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GtrAISILoop );
  5767. END "<";
  5768. (** LONGINT *)
  5769. PROCEDURE GtrALSLLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5770. VAR lval, rval: LONGINT;
  5771. BEGIN
  5772. SYSTEM.GET( radr, rval );
  5773. WHILE (len > 0) DO
  5774. SYSTEM.GET( ladr, lval );
  5775. IF lval <= rval THEN RETURN FALSE END;
  5776. INC( ladr, linc ); DEC( len );
  5777. END;
  5778. RETURN TRUE;
  5779. END GtrALSLLoop;
  5780. OPERATOR ">"*( CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): BOOLEAN;
  5781. BEGIN
  5782. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrALSLLoop );
  5783. END ">";
  5784. OPERATOR "<"*( left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT ): BOOLEAN;
  5785. BEGIN
  5786. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GtrALSLLoop );
  5787. END "<";
  5788. (** REAL *)
  5789. PROCEDURE GtrARSRLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5790. VAR lval, rval: REAL;
  5791. BEGIN
  5792. SYSTEM.GET( radr, rval );
  5793. WHILE (len > 0) DO
  5794. SYSTEM.GET( ladr, lval );
  5795. IF lval <= rval THEN RETURN FALSE END;
  5796. INC( ladr, linc ); DEC( len );
  5797. END;
  5798. RETURN TRUE;
  5799. END GtrARSRLoop;
  5800. OPERATOR ">"*( CONST left: ARRAY [ ? ] OF REAL;
  5801. right: REAL ): BOOLEAN;
  5802. BEGIN
  5803. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrARSRLoop );
  5804. END ">";
  5805. OPERATOR "<"*( left: REAL;
  5806. CONST right: ARRAY [ ? ] OF REAL ): BOOLEAN;
  5807. BEGIN
  5808. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GtrARSRLoop );
  5809. END "<";
  5810. (** LONGREAL *)
  5811. PROCEDURE GtrAXSXLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5812. VAR lval, rval: LONGREAL;
  5813. BEGIN
  5814. SYSTEM.GET( radr, rval );
  5815. WHILE (len > 0) DO
  5816. SYSTEM.GET( ladr, lval );
  5817. IF lval <= rval THEN RETURN FALSE END;
  5818. INC( ladr, linc ); DEC( len );
  5819. END;
  5820. RETURN TRUE;
  5821. END GtrAXSXLoop;
  5822. OPERATOR ">"*( CONST left: ARRAY [ ? ] OF LONGREAL;
  5823. right: LONGREAL ): BOOLEAN;
  5824. BEGIN
  5825. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrAXSXLoop );
  5826. END ">";
  5827. OPERATOR "<"*( left: LONGREAL;
  5828. CONST right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN;
  5829. BEGIN
  5830. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GtrAXSXLoop );
  5831. END "<";
  5832. (*** geq : array x scalar -> boolean ********************************************************************)
  5833. (** SHORTINT *)
  5834. PROCEDURE GeqASSSLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5835. VAR lval, rval: SHORTINT;
  5836. BEGIN
  5837. SYSTEM.GET( radr, rval );
  5838. WHILE (len > 0) DO
  5839. SYSTEM.GET( ladr, lval );
  5840. IF lval < rval THEN RETURN FALSE END;
  5841. INC( ladr, linc ); DEC( len );
  5842. END;
  5843. RETURN TRUE;
  5844. END GeqASSSLoop;
  5845. OPERATOR ">="*( CONST left: ARRAY [ ? ] OF SHORTINT;
  5846. right: SHORTINT ): BOOLEAN;
  5847. BEGIN
  5848. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqASSSLoop );
  5849. END ">=";
  5850. OPERATOR "<="*( left: SHORTINT;
  5851. CONST right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN;
  5852. BEGIN
  5853. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GeqASSSLoop );
  5854. END "<=";
  5855. (** INTEGER *)
  5856. PROCEDURE GeqAISILoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5857. VAR lval, rval: INTEGER;
  5858. BEGIN
  5859. SYSTEM.GET( radr, rval );
  5860. WHILE (len > 0) DO
  5861. SYSTEM.GET( ladr, lval );
  5862. IF lval < rval THEN RETURN FALSE END;
  5863. INC( ladr, linc ); DEC( len );
  5864. END;
  5865. RETURN TRUE;
  5866. END GeqAISILoop;
  5867. OPERATOR ">="*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): BOOLEAN;
  5868. BEGIN
  5869. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqAISILoop );
  5870. END ">=";
  5871. OPERATOR "<="*( left: INTEGER;
  5872. CONST right: ARRAY [ ? ] OF INTEGER ): BOOLEAN;
  5873. BEGIN
  5874. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GeqAISILoop );
  5875. END "<=";
  5876. (** LONGINT *)
  5877. PROCEDURE GeqALSLLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5878. VAR lval, rval: LONGINT;
  5879. BEGIN
  5880. SYSTEM.GET( radr, rval );
  5881. WHILE (len > 0) DO
  5882. SYSTEM.GET( ladr, lval );
  5883. IF lval < rval THEN RETURN FALSE END;
  5884. INC( ladr, linc ); DEC( len );
  5885. END;
  5886. RETURN TRUE;
  5887. END GeqALSLLoop;
  5888. OPERATOR ">="*( CONST left: ARRAY [ ? ] OF LONGINT;
  5889. right: LONGINT ): BOOLEAN;
  5890. BEGIN
  5891. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqALSLLoop );
  5892. END ">=";
  5893. OPERATOR "<="*( left: LONGINT;
  5894. CONST right: ARRAY [ ? ] OF LONGINT ): BOOLEAN;
  5895. BEGIN
  5896. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GeqALSLLoop );
  5897. END "<=";
  5898. (** REAL *)
  5899. PROCEDURE GeqARSRLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5900. VAR lval, rval: REAL;
  5901. BEGIN
  5902. SYSTEM.GET( radr, rval );
  5903. WHILE (len > 0) DO
  5904. SYSTEM.GET( ladr, lval );
  5905. IF lval < rval THEN RETURN FALSE END;
  5906. INC( ladr, linc ); DEC( len );
  5907. END;
  5908. RETURN TRUE;
  5909. END GeqARSRLoop;
  5910. OPERATOR ">="*( CONST left: ARRAY [ ? ] OF REAL;
  5911. right: REAL ): BOOLEAN;
  5912. BEGIN
  5913. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqARSRLoop );
  5914. END ">=";
  5915. OPERATOR "<="*( left: REAL; CONST right: ARRAY [ ? ] OF REAL ): BOOLEAN;
  5916. BEGIN
  5917. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GeqARSRLoop );
  5918. END "<=";
  5919. (** LONGREAL *)
  5920. PROCEDURE GeqAXSXLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5921. VAR lval, rval: LONGREAL;
  5922. BEGIN
  5923. SYSTEM.GET( radr, rval );
  5924. WHILE (len > 0) DO
  5925. SYSTEM.GET( ladr, lval );
  5926. IF lval < rval THEN RETURN FALSE END;
  5927. INC( ladr, linc ); DEC( len );
  5928. END;
  5929. RETURN TRUE;
  5930. END GeqAXSXLoop;
  5931. OPERATOR ">="*( CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): BOOLEAN;
  5932. BEGIN
  5933. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqAXSXLoop );
  5934. END ">=";
  5935. OPERATOR "<="*( left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN;
  5936. BEGIN
  5937. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GeqAXSXLoop );
  5938. END "<=";
  5939. (*** leq : array x scalar -> boolean ********************************************************************)
  5940. (** SHORTINT *)
  5941. PROCEDURE LeqASSSLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5942. VAR lval, rval: SHORTINT;
  5943. BEGIN
  5944. SYSTEM.GET( radr, rval );
  5945. WHILE (len > 0) DO
  5946. SYSTEM.GET( ladr, lval );
  5947. IF lval > rval THEN RETURN FALSE END;
  5948. INC( ladr, linc ); DEC( len );
  5949. END;
  5950. RETURN TRUE;
  5951. END LeqASSSLoop;
  5952. OPERATOR "<="*( CONST left: ARRAY [ ? ] OF SHORTINT;right: SHORTINT ): BOOLEAN;
  5953. BEGIN
  5954. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqASSSLoop );
  5955. END "<=";
  5956. OPERATOR ">="*( left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN;
  5957. BEGIN
  5958. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LeqASSSLoop );
  5959. END ">=";
  5960. (** INTEGER *)
  5961. PROCEDURE LeqAISILoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5962. VAR lval, rval: INTEGER;
  5963. BEGIN
  5964. SYSTEM.GET( radr, rval );
  5965. WHILE (len > 0) DO
  5966. SYSTEM.GET( ladr, lval );
  5967. IF lval > rval THEN RETURN FALSE END;
  5968. INC( ladr, linc ); DEC( len );
  5969. END;
  5970. RETURN TRUE;
  5971. END LeqAISILoop;
  5972. OPERATOR "<="*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): BOOLEAN;
  5973. BEGIN
  5974. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqAISILoop );
  5975. END "<=";
  5976. OPERATOR ">="*( left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER ): BOOLEAN;
  5977. BEGIN
  5978. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LeqAISILoop );
  5979. END ">=";
  5980. (** LONGINT *)
  5981. PROCEDURE LeqALSLLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  5982. VAR lval, rval: LONGINT;
  5983. BEGIN
  5984. SYSTEM.GET( radr, rval );
  5985. WHILE (len > 0) DO
  5986. SYSTEM.GET( ladr, lval );
  5987. IF lval > rval THEN RETURN FALSE END;
  5988. INC( ladr, linc ); DEC( len );
  5989. END;
  5990. RETURN TRUE;
  5991. END LeqALSLLoop;
  5992. OPERATOR "<="*( CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): BOOLEAN;
  5993. BEGIN
  5994. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqALSLLoop );
  5995. END "<=";
  5996. OPERATOR ">="*( left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT ): BOOLEAN;
  5997. BEGIN
  5998. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LeqALSLLoop );
  5999. END ">=";
  6000. (** REAL *)
  6001. PROCEDURE LeqARSRLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  6002. VAR lval, rval: REAL;
  6003. BEGIN
  6004. SYSTEM.GET( radr, rval );
  6005. WHILE (len > 0) DO
  6006. SYSTEM.GET( ladr, lval );
  6007. IF lval > rval THEN RETURN FALSE END;
  6008. INC( ladr, linc ); DEC( len );
  6009. END;
  6010. RETURN TRUE;
  6011. END LeqARSRLoop;
  6012. OPERATOR "<="*( CONST left: ARRAY [ ? ] OF REAL; right: REAL ): BOOLEAN;
  6013. BEGIN
  6014. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqARSRLoop );
  6015. END "<=";
  6016. OPERATOR ">="*( left: REAL; CONST right: ARRAY [ ? ] OF REAL ): BOOLEAN;
  6017. BEGIN
  6018. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LeqARSRLoop );
  6019. END ">=";
  6020. (** LONGREAL *)
  6021. PROCEDURE LeqAXSXLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  6022. VAR lval, rval: LONGREAL;
  6023. BEGIN
  6024. SYSTEM.GET( radr, rval );
  6025. WHILE (len > 0) DO
  6026. SYSTEM.GET( ladr, lval );
  6027. IF lval > rval THEN RETURN FALSE END;
  6028. INC( ladr, linc ); DEC( len );
  6029. END;
  6030. RETURN TRUE;
  6031. END LeqAXSXLoop;
  6032. OPERATOR "<="*( CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): BOOLEAN;
  6033. BEGIN
  6034. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqAXSXLoop );
  6035. END "<=";
  6036. OPERATOR ">="*( left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN;
  6037. BEGIN
  6038. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LeqAXSXLoop );
  6039. END ">=";
  6040. (*** lss: array x scalar -> boolean ********************************************************************)
  6041. (** SHORTINT *)
  6042. PROCEDURE LssASSSLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  6043. VAR lval, rval: SHORTINT;
  6044. BEGIN
  6045. SYSTEM.GET( radr, rval );
  6046. WHILE (len > 0) DO
  6047. SYSTEM.GET( ladr, lval );
  6048. IF lval >= rval THEN RETURN FALSE END;
  6049. INC( ladr, linc ); DEC( len );
  6050. END;
  6051. RETURN TRUE;
  6052. END LssASSSLoop;
  6053. OPERATOR "<"*( CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): BOOLEAN;
  6054. BEGIN
  6055. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LssASSSLoop );
  6056. END "<";
  6057. OPERATOR ">"*( left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN;
  6058. BEGIN
  6059. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LssASSSLoop );
  6060. END ">";
  6061. (** INTEGER *)
  6062. PROCEDURE LssAISILoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  6063. VAR lval, rval: INTEGER;
  6064. BEGIN
  6065. SYSTEM.GET( radr, rval );
  6066. WHILE (len > 0) DO
  6067. SYSTEM.GET( ladr, lval );
  6068. IF lval >= rval THEN RETURN FALSE END;
  6069. INC( ladr, linc ); DEC( len );
  6070. END;
  6071. RETURN TRUE;
  6072. END LssAISILoop;
  6073. OPERATOR "<"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): BOOLEAN;
  6074. BEGIN
  6075. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LssAISILoop );
  6076. END "<";
  6077. OPERATOR ">"*( left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER ): BOOLEAN;
  6078. BEGIN
  6079. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LssAISILoop );
  6080. END ">";
  6081. (** LONGINT *)
  6082. PROCEDURE LssALSLLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  6083. VAR lval, rval: LONGINT;
  6084. BEGIN
  6085. SYSTEM.GET( radr, rval );
  6086. WHILE (len > 0) DO
  6087. SYSTEM.GET( ladr, lval );
  6088. IF lval >= rval THEN RETURN FALSE END;
  6089. INC( ladr, linc ); DEC( len );
  6090. END;
  6091. RETURN TRUE;
  6092. END LssALSLLoop;
  6093. OPERATOR "<"*( CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): BOOLEAN;
  6094. BEGIN
  6095. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LssALSLLoop );
  6096. END "<";
  6097. OPERATOR ">"*( left: LONGINT;CONST right: ARRAY [ ? ] OF LONGINT ): BOOLEAN;
  6098. BEGIN
  6099. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LssALSLLoop );
  6100. END ">";
  6101. (** REAL *)
  6102. PROCEDURE LssARSRLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  6103. VAR lval, rval: REAL;
  6104. BEGIN
  6105. SYSTEM.GET( radr, rval );
  6106. WHILE (len > 0) DO
  6107. SYSTEM.GET( ladr, lval );
  6108. IF lval >= rval THEN RETURN FALSE END;
  6109. INC( ladr, linc ); DEC( len );
  6110. END;
  6111. RETURN TRUE;
  6112. END LssARSRLoop;
  6113. OPERATOR "<"*( CONST left: ARRAY [ ? ] OF REAL;
  6114. right: REAL ): BOOLEAN;
  6115. BEGIN
  6116. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LssARSRLoop );
  6117. END "<";
  6118. OPERATOR ">"*( left: REAL;
  6119. CONST right: ARRAY [ ? ] OF REAL ): BOOLEAN;
  6120. BEGIN
  6121. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LssARSRLoop );
  6122. END ">";
  6123. (** LONGREAL *)
  6124. PROCEDURE LssAXSXLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN;
  6125. VAR lval, rval: LONGREAL;
  6126. BEGIN
  6127. SYSTEM.GET( radr, rval );
  6128. WHILE (len > 0) DO
  6129. SYSTEM.GET( ladr, lval );
  6130. IF lval >= rval THEN RETURN FALSE END;
  6131. INC( ladr, linc ); DEC( len );
  6132. END;
  6133. RETURN TRUE;
  6134. END LssAXSXLoop;
  6135. OPERATOR "<"*( CONST left: ARRAY [ ? ] OF LONGREAL;
  6136. right: LONGREAL ): BOOLEAN;
  6137. BEGIN
  6138. RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LssAXSXLoop );
  6139. END "<";
  6140. OPERATOR ">"*( left: LONGREAL;
  6141. CONST right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN;
  6142. BEGIN
  6143. RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LssAXSXLoop );
  6144. END ">";
  6145. (**** binary max/min operators array x scalar-> array ********************************************************************)
  6146. PROCEDURE MaxAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6147. VAR lval, val: LONGREAL;
  6148. BEGIN
  6149. SYSTEM.GET( radr, val );
  6150. WHILE (len > 0) DO
  6151. SYSTEM.GET( ladr, lval );
  6152. INC( ladr, linc ); DEC( len );
  6153. IF lval>val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END;;
  6154. INC(dadr,dinc);
  6155. END;
  6156. END MaxAXSXLoop;
  6157. OPERATOR "MAX"*(CONST left: ARRAY [?] OF LONGREAL; right: LONGREAL): ARRAY [?] OF LONGREAL;
  6158. TYPE Type = LONGREAL;
  6159. BEGIN
  6160. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MaxAXSXLoop );
  6161. RETURN RESULT
  6162. END "MAX";
  6163. PROCEDURE MaxARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6164. VAR lval, val: REAL;
  6165. BEGIN
  6166. SYSTEM.GET( radr, val );
  6167. WHILE (len > 0) DO
  6168. SYSTEM.GET( ladr, lval );
  6169. INC( ladr, linc ); DEC( len );
  6170. IF lval>val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END;;
  6171. INC(dadr,dinc);
  6172. END;
  6173. END MaxARSRLoop;
  6174. OPERATOR "MAX"*(CONST left: ARRAY [?] OF REAL; right: REAL): ARRAY [?] OF REAL;
  6175. TYPE Type = REAL;
  6176. BEGIN
  6177. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MaxARSRLoop );
  6178. RETURN RESULT
  6179. END "MAX";
  6180. PROCEDURE MaxALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6181. VAR lval, val: LONGINT;
  6182. BEGIN
  6183. SYSTEM.GET( radr, val );
  6184. WHILE (len > 0) DO
  6185. SYSTEM.GET( ladr, lval );
  6186. INC( ladr, linc ); DEC( len );
  6187. IF lval>val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END;
  6188. INC(dadr,dinc);
  6189. END;
  6190. END MaxALSLLoop;
  6191. OPERATOR "MAX"*(CONST left: ARRAY [?] OF LONGINT; right: LONGINT): ARRAY [?] OF LONGINT;
  6192. TYPE Type = LONGINT;
  6193. BEGIN
  6194. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MaxALSLLoop );
  6195. RETURN RESULT
  6196. END "MAX";
  6197. PROCEDURE MaxAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6198. VAR lval, val: INTEGER;
  6199. BEGIN
  6200. SYSTEM.GET( radr, val );
  6201. WHILE (len > 0) DO
  6202. SYSTEM.GET( ladr, lval );
  6203. INC( ladr, linc ); DEC( len );
  6204. IF lval>val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END;
  6205. INC(dadr,dinc);
  6206. END;
  6207. END MaxAISILoop;
  6208. OPERATOR "MAX"*(CONST left: ARRAY [?] OF INTEGER; right: INTEGER): ARRAY [?] OF INTEGER;
  6209. TYPE Type = INTEGER;
  6210. BEGIN
  6211. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MaxAISILoop );
  6212. RETURN RESULT
  6213. END "MAX";
  6214. PROCEDURE MaxASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6215. VAR lval, val: SHORTINT;
  6216. BEGIN
  6217. SYSTEM.GET( radr, val );
  6218. WHILE (len > 0) DO
  6219. SYSTEM.GET( ladr, lval );
  6220. INC( ladr, linc ); DEC( len );
  6221. IF lval>val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END;
  6222. INC(dadr,dinc);
  6223. END;
  6224. END MaxASSSLoop;
  6225. OPERATOR "MAX"*(CONST left: ARRAY [?] OF SHORTINT; right: SHORTINT): ARRAY [?] OF SHORTINT;
  6226. TYPE Type = SHORTINT;
  6227. BEGIN
  6228. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MaxASSSLoop );
  6229. RETURN RESULT
  6230. END "MAX";
  6231. PROCEDURE MinAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6232. VAR lval, val: LONGREAL;
  6233. BEGIN
  6234. SYSTEM.GET( radr, val );
  6235. WHILE (len > 0) DO
  6236. SYSTEM.GET( ladr, lval );
  6237. INC( ladr, linc ); DEC( len );
  6238. IF lval<val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END;;
  6239. INC(dadr,dinc);
  6240. END;
  6241. END MinAXSXLoop;
  6242. OPERATOR "MIN"*(CONST left: ARRAY [?] OF LONGREAL; right: LONGREAL): ARRAY [?] OF LONGREAL;
  6243. TYPE Type = LONGREAL;
  6244. BEGIN
  6245. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MinAXSXLoop );
  6246. RETURN RESULT
  6247. END "MIN";
  6248. PROCEDURE MinARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6249. VAR lval, val: REAL;
  6250. BEGIN
  6251. SYSTEM.GET( radr, val );
  6252. WHILE (len > 0) DO
  6253. SYSTEM.GET( ladr, lval );
  6254. INC( ladr, linc ); DEC( len );
  6255. IF lval<val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END;;
  6256. INC(dadr,dinc);
  6257. END;
  6258. END MinARSRLoop;
  6259. OPERATOR "MIN"*(CONST left: ARRAY [?] OF REAL; right: REAL): ARRAY [?] OF REAL;
  6260. TYPE Type = REAL;
  6261. BEGIN
  6262. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MinARSRLoop );
  6263. RETURN RESULT
  6264. END "MIN";
  6265. PROCEDURE MinALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6266. VAR lval, val: LONGINT;
  6267. BEGIN
  6268. SYSTEM.GET( radr, val );
  6269. WHILE (len > 0) DO
  6270. SYSTEM.GET( ladr, lval );
  6271. INC( ladr, linc ); DEC( len );
  6272. IF lval<val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END;
  6273. INC(dadr,dinc);
  6274. END;
  6275. END MinALSLLoop;
  6276. OPERATOR "MIN"*(CONST left: ARRAY [?] OF LONGINT; right: LONGINT): ARRAY [?] OF LONGINT;
  6277. TYPE Type = LONGINT;
  6278. BEGIN
  6279. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MinALSLLoop );
  6280. RETURN RESULT
  6281. END "MIN";
  6282. PROCEDURE MinAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6283. VAR lval, val: INTEGER;
  6284. BEGIN
  6285. SYSTEM.GET( radr, val );
  6286. WHILE (len > 0) DO
  6287. SYSTEM.GET( ladr, lval );
  6288. INC( ladr, linc ); DEC( len );
  6289. IF lval<val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END;
  6290. INC(dadr,dinc);
  6291. END;
  6292. END MinAISILoop;
  6293. OPERATOR "MIN"*(CONST left: ARRAY [?] OF INTEGER; right: INTEGER): ARRAY [?] OF INTEGER;
  6294. TYPE Type = INTEGER;
  6295. BEGIN
  6296. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MinAISILoop );
  6297. RETURN RESULT
  6298. END "MIN";
  6299. PROCEDURE MinASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6300. VAR lval, val: SHORTINT;
  6301. BEGIN
  6302. SYSTEM.GET( radr, val );
  6303. WHILE (len > 0) DO
  6304. SYSTEM.GET( ladr, lval );
  6305. INC( ladr, linc ); DEC( len );
  6306. IF lval<val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END;
  6307. INC(dadr,dinc);
  6308. END;
  6309. END MinASSSLoop;
  6310. OPERATOR "MIN"*(CONST left: ARRAY [?] OF SHORTINT; right: SHORTINT): ARRAY [?] OF SHORTINT;
  6311. TYPE Type = SHORTINT;
  6312. BEGIN
  6313. ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MinASSSLoop );
  6314. RETURN RESULT
  6315. END "MIN";
  6316. (**** binary max/min operators array x array -> array ********************************************************************)
  6317. PROCEDURE MaxAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  6318. VAR lval, rval: LONGREAL;
  6319. BEGIN
  6320. WHILE (len > 0) DO
  6321. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  6322. INC( ladr, linc ); INC(radr,rinc ); DEC( len );
  6323. IF lval>rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END;
  6324. INC(dadr,dinc);
  6325. END;
  6326. END MaxAXAXLoop;
  6327. OPERATOR "MAX"*(CONST left, right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL;
  6328. BEGIN
  6329. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), MaxAXAXLoop );
  6330. RETURN RESULT
  6331. END "MAX";
  6332. PROCEDURE MaxARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  6333. VAR lval, rval: REAL ;
  6334. BEGIN
  6335. WHILE (len > 0) DO
  6336. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  6337. INC( ladr, linc ); INC(radr,rinc ); DEC( len );
  6338. IF lval>rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END;
  6339. INC(dadr,dinc);
  6340. END;
  6341. END MaxARARLoop;
  6342. OPERATOR "MAX"*(CONST left, right: ARRAY [?] OF REAL): ARRAY [?] OF REAL;
  6343. BEGIN
  6344. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), MaxARARLoop );
  6345. RETURN RESULT
  6346. END "MAX";
  6347. PROCEDURE MaxALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  6348. VAR lval, rval: LONGINT;
  6349. BEGIN
  6350. WHILE (len > 0) DO
  6351. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  6352. INC( ladr, linc ); INC(radr,rinc ); DEC( len );
  6353. IF lval>rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END;
  6354. INC(dadr,dinc);
  6355. END;
  6356. END MaxALALLoop;
  6357. OPERATOR "MAX"*(CONST left, right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT ;
  6358. BEGIN
  6359. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MaxALALLoop );
  6360. RETURN RESULT
  6361. END "MAX";
  6362. PROCEDURE MaxAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  6363. VAR lval, rval: INTEGER;
  6364. BEGIN
  6365. WHILE (len > 0) DO
  6366. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  6367. INC( ladr, linc ); INC(radr,rinc ); DEC( len );
  6368. IF lval>rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END;
  6369. INC(dadr,dinc);
  6370. END;
  6371. END MaxAIAILoop;
  6372. OPERATOR "MAX"*(CONST left, right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER;
  6373. BEGIN
  6374. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), MaxAIAILoop );
  6375. RETURN RESULT
  6376. END "MAX";
  6377. PROCEDURE MaxASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  6378. VAR lval, rval: SHORTINT;
  6379. BEGIN
  6380. WHILE (len > 0) DO
  6381. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  6382. INC( ladr, linc ); INC(radr,rinc ); DEC( len );
  6383. IF lval>rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END;
  6384. INC(dadr,dinc);
  6385. END;
  6386. END MaxASASLoop;
  6387. OPERATOR "MAX"*(CONST left, right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT;
  6388. BEGIN
  6389. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), MaxASASLoop );
  6390. RETURN RESULT
  6391. END "MAX";
  6392. PROCEDURE MinAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  6393. VAR lval, rval: LONGREAL;
  6394. BEGIN
  6395. WHILE (len > 0) DO
  6396. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  6397. INC( ladr, linc ); INC(radr,rinc ); DEC( len );
  6398. IF lval<rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END;
  6399. INC(dadr,dinc);
  6400. END;
  6401. END MinAXAXLoop;
  6402. OPERATOR "MIN"*(CONST left, right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL;
  6403. BEGIN
  6404. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), MinAXAXLoop );
  6405. RETURN RESULT
  6406. END "MIN";
  6407. PROCEDURE MinARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  6408. VAR lval, rval: REAL ;
  6409. BEGIN
  6410. WHILE (len > 0) DO
  6411. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  6412. INC( ladr, linc ); INC(radr,rinc ); DEC( len );
  6413. IF lval<rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END;
  6414. INC(dadr,dinc);
  6415. END;
  6416. END MinARARLoop;
  6417. OPERATOR "MIN"*(CONST left, right: ARRAY [?] OF REAL): ARRAY [?] OF REAL;
  6418. BEGIN
  6419. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), MinARARLoop );
  6420. RETURN RESULT
  6421. END "MIN";
  6422. (*PROCEDURE MinALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  6423. VAR lval, rval: LONGINT;
  6424. BEGIN
  6425. WHILE (len > 0) DO
  6426. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  6427. INC( ladr, linc ); INC(radr,rinc ); DEC( len );
  6428. IF lval<rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END;
  6429. INC(dadr,dinc);
  6430. END;
  6431. END MinALALLoop;
  6432. *)
  6433. TYPE
  6434. LongintPtr = POINTER {UNSAFE} TO RECORD val: LONGINT END;
  6435. PROCEDURE MinALALLoop( ladr, radr, dadr: LongintPtr; linc, rinc, dinc, len: SIZE);
  6436. BEGIN
  6437. WHILE (len > 0) DO
  6438. IF ladr.val < ladr.val THEN dadr.val := ladr.val ELSE dadr.val := radr.val END;
  6439. ladr := ladr + linc;
  6440. radr := radr + rinc;
  6441. dadr := dadr + dinc;
  6442. DEC(len);
  6443. END;
  6444. END MinALALLoop;
  6445. OPERATOR "MIN"*(CONST left, right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT ;
  6446. BEGIN
  6447. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MinALALLoop );
  6448. RETURN RESULT
  6449. END "MIN";
  6450. PROCEDURE MinAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  6451. VAR lval, rval: INTEGER;
  6452. BEGIN
  6453. WHILE (len > 0) DO
  6454. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  6455. INC( ladr, linc ); INC(radr,rinc ); DEC( len );
  6456. IF lval<rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END;
  6457. INC(dadr,dinc);
  6458. END;
  6459. END MinAIAILoop;
  6460. OPERATOR "MIN"*(CONST left, right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER;
  6461. BEGIN
  6462. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), MinAIAILoop );
  6463. RETURN RESULT
  6464. END "MIN";
  6465. PROCEDURE MinASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE );
  6466. VAR lval, rval: SHORTINT;
  6467. BEGIN
  6468. WHILE (len > 0) DO
  6469. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );
  6470. INC( ladr, linc ); INC(radr,rinc ); DEC( len );
  6471. IF lval<rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END;
  6472. INC(dadr,dinc);
  6473. END;
  6474. END MinASASLoop;
  6475. OPERATOR "MIN"*(CONST left, right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT;
  6476. BEGIN
  6477. ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), MinASASLoop );
  6478. RETURN RESULT
  6479. END "MIN";
  6480. (**** unary operators array -> scalar ********************************************************************)
  6481. (*** min: array -> scalar ****************************************)
  6482. (** SHORTINT *)
  6483. PROCEDURE MinASLoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6484. VAR lval, dval: SHORTINT;
  6485. BEGIN
  6486. SYSTEM.GET( dadr, dval );
  6487. WHILE (len > 0) DO
  6488. SYSTEM.GET( ladr, lval );
  6489. IF lval < dval THEN dval := lval END;
  6490. INC( ladr, linc ); DEC( len );
  6491. END;
  6492. SYSTEM.PUT( dadr, dval );
  6493. END MinASLoop;
  6494. OPERATOR "MIN"*( CONST left: ARRAY [ ? ] OF SHORTINT ): SHORTINT;
  6495. TYPE Type = SHORTINT;
  6496. VAR val: Type;
  6497. BEGIN
  6498. val := MAX( Type );
  6499. ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MinASLoop ); RETURN val;
  6500. END "MIN";
  6501. (** INTEGER *)
  6502. PROCEDURE MinAILoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6503. VAR lval, dval: INTEGER;
  6504. BEGIN
  6505. SYSTEM.GET( dadr, dval );
  6506. WHILE (len > 0) DO
  6507. SYSTEM.GET( ladr, lval );
  6508. IF lval < dval THEN dval := lval END;
  6509. INC( ladr, linc ); DEC( len );
  6510. END;
  6511. SYSTEM.PUT( dadr, dval );
  6512. END MinAILoop;
  6513. OPERATOR "MIN"*( CONST left: ARRAY [ ? ] OF INTEGER ): INTEGER;
  6514. TYPE Type = INTEGER;
  6515. VAR val: Type;
  6516. BEGIN
  6517. val := MAX( Type );
  6518. ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MinAILoop ); RETURN val;
  6519. END "MIN";
  6520. (** LONGINT *)
  6521. PROCEDURE MinALLoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6522. VAR lval, dval: LONGINT;
  6523. BEGIN
  6524. SYSTEM.GET( dadr, dval );
  6525. WHILE (len > 0) DO
  6526. SYSTEM.GET( ladr, lval );
  6527. IF lval < dval THEN dval := lval END;
  6528. INC( ladr, linc ); DEC( len );
  6529. END;
  6530. SYSTEM.PUT( dadr, dval );
  6531. END MinALLoop;
  6532. OPERATOR "MIN"*( CONST left: ARRAY [ ? ] OF LONGINT ): LONGINT;
  6533. TYPE Type = LONGINT;
  6534. VAR val: Type;
  6535. BEGIN
  6536. val := MAX( Type );
  6537. ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MinALLoop ); RETURN val;
  6538. END "MIN";
  6539. (** REAL *)
  6540. PROCEDURE MinARLoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6541. VAR lval, dval: REAL;
  6542. BEGIN
  6543. SYSTEM.GET( dadr, dval );
  6544. WHILE (len > 0) DO
  6545. SYSTEM.GET( ladr, lval );
  6546. IF lval < dval THEN dval := lval END;
  6547. INC( ladr, linc ); DEC( len );
  6548. END;
  6549. SYSTEM.PUT( dadr, dval );
  6550. END MinARLoop;
  6551. OPERATOR "MIN"*( CONST left: ARRAY [ ? ] OF REAL ): REAL;
  6552. TYPE Type = REAL;
  6553. VAR val: Type;
  6554. BEGIN
  6555. val := MAX( Type );
  6556. ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MinARLoop ); RETURN val;
  6557. END "MIN";
  6558. (** LONGREAL *)
  6559. PROCEDURE MinAXLoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6560. VAR lval, dval: LONGREAL;
  6561. BEGIN
  6562. SYSTEM.GET( dadr, dval );
  6563. WHILE (len > 0) DO
  6564. SYSTEM.GET( ladr, lval );
  6565. IF lval < dval THEN dval := lval END;
  6566. INC( ladr, linc ); DEC( len );
  6567. END;
  6568. SYSTEM.PUT( dadr, dval );
  6569. END MinAXLoop;
  6570. OPERATOR "MIN"*( CONST left: ARRAY [ ? ] OF LONGREAL ): LONGREAL;
  6571. TYPE Type = LONGREAL;
  6572. VAR val: Type;
  6573. BEGIN
  6574. val := MAX( Type );
  6575. ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MinAXLoop ); RETURN val;
  6576. END "MIN";
  6577. (*** max: array -> scalar ********************************************************************)
  6578. (** SHORTINT *)
  6579. PROCEDURE MaxASLoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6580. VAR lval, dval: SHORTINT;
  6581. BEGIN
  6582. SYSTEM.GET( dadr, dval );
  6583. WHILE (len > 0) DO
  6584. SYSTEM.GET( ladr, lval );
  6585. IF lval > dval THEN dval := lval END;
  6586. INC( ladr, linc ); DEC( len );
  6587. END;
  6588. SYSTEM.PUT( dadr, dval );
  6589. END MaxASLoop;
  6590. OPERATOR "MAX"*( CONST left: ARRAY [ ? ] OF SHORTINT ): SHORTINT;
  6591. TYPE Type = SHORTINT;
  6592. VAR val: Type;
  6593. BEGIN
  6594. val := MIN( Type );
  6595. ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MaxASLoop ); RETURN val;
  6596. END "MAX";
  6597. (** INTEGER *)
  6598. PROCEDURE MaxAILoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6599. VAR lval, dval: INTEGER;
  6600. BEGIN
  6601. SYSTEM.GET( dadr, dval );
  6602. WHILE (len > 0) DO
  6603. SYSTEM.GET( ladr, lval );
  6604. IF lval > dval THEN dval := lval END;
  6605. INC( ladr, linc ); DEC( len );
  6606. END;
  6607. SYSTEM.PUT( dadr, dval );
  6608. END MaxAILoop;
  6609. OPERATOR "MAX"*( CONST left: ARRAY [ ? ] OF INTEGER ): INTEGER;
  6610. TYPE Type = INTEGER;
  6611. VAR val: Type;
  6612. BEGIN
  6613. val := MIN( Type );
  6614. ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MaxAILoop ); RETURN val;
  6615. END "MAX";
  6616. (** LONGINT *)
  6617. PROCEDURE MaxALLoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6618. VAR lval, dval: LONGINT;
  6619. BEGIN
  6620. SYSTEM.GET( dadr, dval );
  6621. WHILE (len > 0) DO
  6622. SYSTEM.GET( ladr, lval );
  6623. IF lval > dval THEN dval := lval END;
  6624. INC( ladr, linc ); DEC( len );
  6625. END;
  6626. SYSTEM.PUT( dadr, dval );
  6627. END MaxALLoop;
  6628. OPERATOR "MAX"*( CONST left: ARRAY [ ? ] OF LONGINT ): LONGINT;
  6629. TYPE Type = LONGINT;
  6630. VAR val: Type;
  6631. BEGIN
  6632. val := MIN( Type );
  6633. ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MaxALLoop ); RETURN val;
  6634. END "MAX";
  6635. (** REAL *)
  6636. PROCEDURE MaxARLoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6637. VAR lval, dval: REAL;
  6638. BEGIN
  6639. SYSTEM.GET( dadr, dval );
  6640. WHILE (len > 0) DO
  6641. SYSTEM.GET( ladr, lval );
  6642. IF lval > dval THEN dval := lval END;
  6643. INC( ladr, linc ); DEC( len );
  6644. END;
  6645. SYSTEM.PUT( dadr, dval );
  6646. END MaxARLoop;
  6647. OPERATOR "MAX"*( CONST left: ARRAY [ ? ] OF REAL ): REAL;
  6648. TYPE Type = REAL;
  6649. VAR val: Type;
  6650. BEGIN
  6651. val := MIN( Type );
  6652. ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MaxARLoop ); RETURN val;
  6653. END "MAX";
  6654. (** LONGREAL *)
  6655. PROCEDURE MaxAXLoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6656. VAR lval, dval: LONGREAL;
  6657. BEGIN
  6658. SYSTEM.GET( dadr, dval );
  6659. WHILE (len > 0) DO
  6660. SYSTEM.GET( ladr, lval );
  6661. IF lval > dval THEN dval := lval END;
  6662. INC( ladr, linc ); DEC( len );
  6663. END;
  6664. SYSTEM.PUT( dadr, dval );
  6665. END MaxAXLoop;
  6666. OPERATOR "MAX"*( CONST left: ARRAY [ ? ] OF LONGREAL ): LONGREAL;
  6667. TYPE Type = LONGREAL;
  6668. VAR val: Type;
  6669. BEGIN
  6670. val := MIN( Type );
  6671. ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MaxAXLoop ); RETURN val;
  6672. END "MAX";
  6673. (*** LEN: array -> array **)
  6674. OPERATOR "LEN"*(CONST left: ARRAY [?]): ARRAY [*] OF LONGINT;
  6675. VAR src,dim,i: LONGINT;
  6676. BEGIN
  6677. src := SYSTEM.VAL(LONGINT,left);
  6678. dim := GetDim( src );
  6679. IF (DIM(RESULT)#1) OR (LEN(RESULT,0) # dim) THEN NEW(RESULT,dim) END;
  6680. FOR i := 0 TO dim-1 DO RESULT[i] := GetLen(src,i) END;
  6681. RETURN RESULT
  6682. END "LEN";
  6683. (*** SUM: array -> scalar ********************************************************************)
  6684. (** SHORTINT *)
  6685. PROCEDURE SumASLoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6686. VAR lval, dval: SHORTINT;
  6687. BEGIN
  6688. SYSTEM.GET( dadr, dval );
  6689. WHILE (len > 0) DO
  6690. SYSTEM.GET( ladr, lval ); dval := dval + lval; INC( ladr, linc ); DEC( len );
  6691. END;
  6692. SYSTEM.PUT( dadr, dval );
  6693. END SumASLoop;
  6694. OPERATOR "SUM"*( CONST left: ARRAY [ ? ] OF SHORTINT ): SHORTINT;
  6695. TYPE Type = SHORTINT;
  6696. VAR val: Type;
  6697. BEGIN
  6698. val := 0; ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), SumASLoop );
  6699. RETURN val;
  6700. END "SUM";
  6701. (** INTEGER *)
  6702. PROCEDURE SumAILoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6703. VAR lval, dval: INTEGER;
  6704. BEGIN
  6705. SYSTEM.GET( dadr, dval );
  6706. WHILE (len > 0) DO
  6707. SYSTEM.GET( ladr, lval ); dval := dval + lval; INC( ladr, linc ); DEC( len );
  6708. END;
  6709. SYSTEM.PUT( dadr, dval );
  6710. END SumAILoop;
  6711. OPERATOR "SUM"*( CONST left: ARRAY [ ? ] OF INTEGER ): INTEGER;
  6712. TYPE Type = INTEGER;
  6713. VAR val: Type;
  6714. BEGIN
  6715. val := 0; ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), SumAILoop );
  6716. RETURN val;
  6717. END "SUM";
  6718. (** LONGINT *)
  6719. PROCEDURE SumALLoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6720. VAR lval, dval: LONGINT;
  6721. BEGIN
  6722. SYSTEM.GET( dadr, dval );
  6723. WHILE (len > 0) DO
  6724. SYSTEM.GET( ladr, lval ); dval := dval + lval; INC( ladr, linc ); DEC( len );
  6725. END;
  6726. SYSTEM.PUT( dadr, dval );
  6727. END SumALLoop;
  6728. OPERATOR "SUM"*( CONST left: ARRAY [ ? ] OF LONGINT ): LONGINT;
  6729. TYPE Type = LONGINT;
  6730. VAR val: Type;
  6731. BEGIN
  6732. val := 0; ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), SumALLoop );
  6733. RETURN val;
  6734. END "SUM";
  6735. (** REAL *)
  6736. PROCEDURE SumARLoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6737. VAR lval, dval: REAL;
  6738. BEGIN
  6739. SYSTEM.GET( dadr, dval );
  6740. WHILE (len > 0) DO
  6741. SYSTEM.GET( ladr, lval ); dval := dval + lval; INC( ladr, linc ); DEC( len );
  6742. END;
  6743. SYSTEM.PUT( dadr, dval );
  6744. END SumARLoop;
  6745. OPERATOR "SUM"*( CONST left: ARRAY [ ? ] OF REAL ): REAL;
  6746. TYPE Type = REAL;
  6747. VAR val: Type;
  6748. BEGIN
  6749. val := 0; ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), SumARLoop );
  6750. RETURN val;
  6751. END "SUM";
  6752. (** LONGREAL *)
  6753. PROCEDURE SumAXLoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6754. VAR lval, dval: LONGREAL;
  6755. BEGIN
  6756. SYSTEM.GET( dadr, dval );
  6757. WHILE (len > 0) DO
  6758. SYSTEM.GET( ladr, lval ); dval := dval + lval; INC( ladr, linc ); DEC( len );
  6759. END;
  6760. SYSTEM.PUT( dadr, dval );
  6761. END SumAXLoop;
  6762. OPERATOR "SUM"*( CONST left: ARRAY [ ? ] OF LONGREAL ): LONGREAL;
  6763. TYPE Type = LONGREAL;
  6764. VAR val: Type;
  6765. BEGIN
  6766. val := 0; ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), SumAXLoop );
  6767. RETURN val;
  6768. END "SUM";
  6769. (** COMPLEX *)
  6770. PROCEDURE SumAZLoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6771. VAR lval, dval: COMPLEX;
  6772. BEGIN
  6773. SYSTEM.GET( dadr, dval );
  6774. WHILE (len > 0) DO
  6775. SYSTEM.GET( ladr, lval ); dval := dval + lval; INC( ladr, linc ); DEC( len );
  6776. END;
  6777. SYSTEM.PUT( dadr, dval );
  6778. END SumAZLoop;
  6779. OPERATOR "SUM"*( CONST left: ARRAY [ ? ] OF COMPLEX ): COMPLEX;
  6780. TYPE Type = COMPLEX;
  6781. VAR val: Type;
  6782. BEGIN
  6783. val := 0; ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), SumAZLoop );
  6784. RETURN val;
  6785. END "SUM";
  6786. (** LONGCOMPLEX *)
  6787. PROCEDURE SumALZLoop( ladr, dadr: ADDRESS; linc, len: SIZE );
  6788. VAR lvalRe, lvalIm, dvalRe, dvalIm: LONGREAL;
  6789. BEGIN
  6790. SYSTEM.GET( dadr, dvalRe ); SYSTEM.GET( dadr+SIZEOF(LONGREAL), dvalIm );
  6791. WHILE (len > 0) DO
  6792. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  6793. dvalRe := dvalRe + lvalRe; dvalIm := dvalIm + lvalIm;
  6794. INC( ladr, linc ); DEC( len );
  6795. END;
  6796. SYSTEM.PUT( dadr, dvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), dvalIm );
  6797. END SumALZLoop;
  6798. OPERATOR "SUM"*( CONST left: ARRAY [ ? ] OF LONGCOMPLEX ): LONGCOMPLEX;
  6799. TYPE Type = LONGCOMPLEX;
  6800. VAR val: Type;
  6801. BEGIN
  6802. val := 0; ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), SumALZLoop );
  6803. RETURN val;
  6804. END "SUM";
  6805. (*** monadic ABS array -> array ********************************************************************)
  6806. (** SHORTINT *)
  6807. PROCEDURE AbsLoopS( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6808. VAR lval: SHORTINT;
  6809. BEGIN
  6810. WHILE (len > 0) DO
  6811. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, ABS( lval ) ); INC( ladr, linc );
  6812. INC( dadr, dinc ); DEC( len );
  6813. END;
  6814. END AbsLoopS;
  6815. OPERATOR "ABS"*(CONST src: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT;
  6816. BEGIN
  6817. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( SHORTINT ), AbsLoopS );
  6818. RETURN RESULT
  6819. END "ABS";
  6820. (** INTEGER *)
  6821. PROCEDURE AbsLoopI( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6822. VAR lval: INTEGER;
  6823. BEGIN
  6824. WHILE (len > 0) DO
  6825. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, ABS( lval ) ); INC( ladr, linc );
  6826. INC( dadr, dinc ); DEC( len );
  6827. END;
  6828. END AbsLoopI;
  6829. OPERATOR "ABS"*(CONST src: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER;
  6830. BEGIN
  6831. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( INTEGER ), AbsLoopI );
  6832. RETURN RESULT
  6833. END "ABS";
  6834. (** LONGINT *)
  6835. PROCEDURE AbsLoopL( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6836. VAR lval: LONGINT;
  6837. BEGIN
  6838. WHILE (len > 0) DO
  6839. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, ABS( lval ) ); INC( ladr, linc );
  6840. INC( dadr, dinc ); DEC( len );
  6841. END;
  6842. END AbsLoopL;
  6843. OPERATOR "ABS"*(CONST src: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT;
  6844. BEGIN
  6845. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ), AbsLoopL );
  6846. RETURN RESULT
  6847. END "ABS";
  6848. (** REAL *)
  6849. PROCEDURE AbsLoopR( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6850. VAR lval: REAL;
  6851. BEGIN
  6852. WHILE (len > 0) DO
  6853. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, ABS( lval ) ); INC( ladr, linc );
  6854. INC( dadr, dinc ); DEC( len );
  6855. END;
  6856. END AbsLoopR;
  6857. OPERATOR "ABS"*(CONST src: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL;
  6858. BEGIN
  6859. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), AbsLoopR );
  6860. RETURN RESULT
  6861. END "ABS";
  6862. (** LONGREAL *)
  6863. PROCEDURE AbsLoopX( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6864. VAR lval: LONGREAL;
  6865. BEGIN
  6866. WHILE (len > 0) DO
  6867. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, ABS( lval ) ); INC( ladr, linc );
  6868. INC( dadr, dinc ); DEC( len );
  6869. END;
  6870. END AbsLoopX;
  6871. OPERATOR "ABS"*(CONST src: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL;
  6872. BEGIN
  6873. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), AbsLoopX );
  6874. RETURN RESULT
  6875. END "ABS";
  6876. (** COMPLEX *)
  6877. PROCEDURE AbsLoopZ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6878. VAR lval: COMPLEX;
  6879. BEGIN
  6880. WHILE (len > 0) DO
  6881. SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, ABS(lval) ); INC( ladr, linc );
  6882. INC( dadr, dinc ); DEC( len );
  6883. END;
  6884. END AbsLoopZ;
  6885. OPERATOR "ABS"*(CONST src: ARRAY [ ? ] OF COMPLEX): ARRAY [ ? ] OF REAL;
  6886. BEGIN
  6887. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), AbsLoopZ );
  6888. RETURN RESULT
  6889. END "ABS";
  6890. (** LONGCOMPLEX *)
  6891. PROCEDURE AbsLoopLZ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE );
  6892. VAR lvalRe, lvalIm: LONGREAL;
  6893. BEGIN
  6894. WHILE (len > 0) DO
  6895. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  6896. SYSTEM.PUT( dadr, MathL.sqrt(lvalRe*lvalRe + lvalIm*lvalIm) );
  6897. INC( ladr, linc );
  6898. INC( dadr, dinc ); DEC( len );
  6899. END;
  6900. END AbsLoopLZ;
  6901. OPERATOR "ABS"*(CONST src: ARRAY [ ? ] OF LONGCOMPLEX): ARRAY [ ? ] OF LONGREAL;
  6902. BEGIN
  6903. ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), AbsLoopLZ );
  6904. RETURN RESULT
  6905. END "ABS";
  6906. (*** assign number to array (initialisation) ********************************************************************)
  6907. (** BOOLEAN *)
  6908. PROCEDURE AssignSBABLoop( ladr, dadr: ADDRESS; dinc, len: SIZE );
  6909. VAR lval: BOOLEAN;
  6910. BEGIN
  6911. SYSTEM.GET( ladr, lval );
  6912. WHILE (len > 0) DO SYSTEM.PUT( dadr, lval ); INC( dadr, dinc ); DEC( len ); END;
  6913. END AssignSBABLoop;
  6914. OPERATOR ":="*(VAR dest: ARRAY [?] OF BOOLEAN; right: BOOLEAN);
  6915. BEGIN
  6916. ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSBABLoop );
  6917. END ":=";
  6918. (** SHORTINT*)
  6919. PROCEDURE AssignSSASLoop( ladr, dadr: ADDRESS; dinc, len: SIZE );
  6920. VAR lval: SHORTINT;
  6921. BEGIN
  6922. SYSTEM.GET( ladr, lval );
  6923. WHILE (len > 0) DO SYSTEM.PUT( dadr, lval ); INC( dadr, dinc ); DEC( len ); END;
  6924. END AssignSSASLoop;
  6925. OPERATOR ":="*(VAR dest: ARRAY [?] OF SHORTINT; right: SHORTINT);
  6926. BEGIN
  6927. ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSSASLoop );
  6928. END ":=";
  6929. (**INTEGER *)
  6930. PROCEDURE AssignSIAILoop( ladr, dadr: ADDRESS; dinc, len: SIZE );
  6931. VAR lval: INTEGER;
  6932. BEGIN
  6933. SYSTEM.GET( ladr, lval );
  6934. WHILE (len > 0) DO SYSTEM.PUT( dadr, lval ); INC( dadr, dinc ); DEC( len ); END;
  6935. END AssignSIAILoop;
  6936. OPERATOR ":="*(VAR dest: ARRAY [?] OF INTEGER; right: INTEGER);
  6937. BEGIN
  6938. ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSIAILoop );
  6939. END ":=";
  6940. (** LONGINT *)
  6941. PROCEDURE AssignSLALLoop( ladr, dadr: ADDRESS; dinc, len: SIZE );
  6942. VAR lval: LONGINT;
  6943. BEGIN
  6944. SYSTEM.GET( ladr, lval );
  6945. WHILE (len > 0) DO SYSTEM.PUT( dadr, lval ); INC( dadr, dinc ); DEC( len ); END;
  6946. END AssignSLALLoop;
  6947. OPERATOR ":="*(VAR dest: ARRAY [?] OF LONGINT; right: LONGINT);
  6948. BEGIN
  6949. ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSLALLoop );
  6950. END ":=";
  6951. (** REAL *)
  6952. PROCEDURE AssignSRARLoop( ladr, dadr: ADDRESS; dinc, len: SIZE );
  6953. VAR lval: REAL;
  6954. BEGIN
  6955. SYSTEM.GET( ladr, lval );
  6956. WHILE (len > 0) DO SYSTEM.PUT( dadr, lval ); INC( dadr, dinc ); DEC( len ); END;
  6957. END AssignSRARLoop;
  6958. OPERATOR ":="*(VAR dest: ARRAY [?] OF REAL; right: REAL);
  6959. BEGIN
  6960. ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSRARLoop );
  6961. END ":=";
  6962. (** LONGREAL *)
  6963. PROCEDURE AssignSXAXLoop( ladr, dadr: ADDRESS; dinc, len: SIZE );
  6964. VAR lval: LONGREAL;
  6965. BEGIN
  6966. SYSTEM.GET( ladr, lval );
  6967. WHILE (len > 0) DO SYSTEM.PUT( dadr, lval ); INC( dadr, dinc ); DEC( len ); END;
  6968. END AssignSXAXLoop;
  6969. OPERATOR ":="*(VAR dest: ARRAY [?] OF LONGREAL; right: LONGREAL);
  6970. BEGIN
  6971. ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSXAXLoop );
  6972. END ":=";
  6973. (** COMPLEX *)
  6974. PROCEDURE AssignSZAZLoop( ladr, dadr: ADDRESS; dinc, len: SIZE );
  6975. VAR lval: COMPLEX;
  6976. BEGIN
  6977. SYSTEM.GET( ladr, lval );
  6978. WHILE (len > 0) DO SYSTEM.PUT( dadr, lval ); INC( dadr, dinc ); DEC( len ); END;
  6979. END AssignSZAZLoop;
  6980. OPERATOR ":="*(VAR dest: ARRAY [?] OF COMPLEX; right: COMPLEX);
  6981. BEGIN
  6982. ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSZAZLoop );
  6983. END ":=";
  6984. (** LONGCOMPLEX *)
  6985. PROCEDURE AssignSLZALZLoop( ladr, dadr: ADDRESS; dinc, len: SIZE );
  6986. VAR lvalRe, lvalIm: LONGREAL;
  6987. BEGIN
  6988. SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm );
  6989. WHILE (len > 0) DO SYSTEM.PUT( dadr, lvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), lvalIm ); INC( dadr, dinc ); DEC( len ); END;
  6990. END AssignSLZALZLoop;
  6991. OPERATOR ":="*(VAR dest: ARRAY [?] OF LONGCOMPLEX; right: LONGCOMPLEX);
  6992. BEGIN
  6993. ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSLZALZLoop );
  6994. END ":=";
  6995. (*** matrix multipliation ********************************************************************)
  6996. PROCEDURE AllocateMatrix( dest: ADDRESS;
  6997. rows, cols, elementsize: LONGINT ): ANY;
  6998. VAR p: ANY;
  6999. BEGIN
  7000. (*
  7001. KernelLog.String( "ALLOCATE MATRIX WAS CALLED" ); KernelLog.Ln;
  7002. *)
  7003. SYSTEM.NEW( p, rows * cols * elementsize ); PutLen( dest, 1, cols );
  7004. PutLen( dest, 0, rows ); PutInc( dest, 1, elementsize );
  7005. PutInc( dest, 0, elementsize * cols ); PutAdr( dest, SYSTEM.VAL( LONGINT, p ) );
  7006. PutPtr( dest, p); RETURN p;
  7007. END AllocateMatrix;
  7008. PROCEDURE AllocateVector( dest: ADDRESS; l0, elementsize: LONGINT ): ANY;
  7009. VAR p: ANY;
  7010. BEGIN
  7011. SYSTEM.NEW( p, l0 * elementsize ); PutLen( dest, 0, l0 );
  7012. PutInc( dest, 0, elementsize ); PutAdr( dest, SYSTEM.VAL( LONGINT, p ) );
  7013. PutPtr( dest, p ); RETURN p;
  7014. END AllocateVector;
  7015. PROCEDURE ApplyMatMulLoop( dest, left, right: ADDRESS; Size: LONGINT;
  7016. loop: BinaryAASLoop;
  7017. fast: FastMatMul ); (* Size= element-size *)
  7018. VAR ladr, radr, dadr, dadri, radri, rowsL, colsL, rowsR, colsR, incL, incR, incD, strideR, strideL, strideD, colsRi: LONGINT;
  7019. p: ANY; overlap: BOOLEAN; destOld, destNew: ADDRESS;
  7020. BEGIN
  7021. (*
  7022. <- 1 ->
  7023. xxx xxxx -> xxxx
  7024. ^ xxx xxxx xxxx
  7025. 0 xxx xxxx xxxx
  7026. v xxx xxxx
  7027. xxx xxxx
  7028. Len(..,1): #columns ; Inc(..,1): inc in rows
  7029. Len(..,0): #rows ; Inc(..,0): inc between rows
  7030. *)
  7031. (* apply multiplication D = L * R *)
  7032. rowsL := GetLen( left, 0 ); (* # left rows = # dest rows*)
  7033. colsL := GetLen( left, 1 ); (* # left columns *)
  7034. rowsR := GetLen( right, 0 ); (* # right rows =!= left columns *)
  7035. colsR := GetLen( right, 1 ); (* # right columns = # dest columns*)
  7036. (* check geometric restriction *)
  7037. IF colsL # rowsR THEN Halt( GeometryMismatch, left, right, 0 ); END;
  7038. IF GetAdr( dest ) = 0 THEN p := AllocateMatrix( dest, rowsL, colsR, Size );
  7039. ELSIF (GetLen( dest, 0 ) # rowsL) OR (GetLen( dest, 1 ) # colsR) THEN
  7040. IF RangeFlag IN GetFlags( dest ) THEN
  7041. Halt( GeometryMismatch, left, right, dest )
  7042. ELSE p := AllocateMatrix( dest, rowsL, colsR, Size );
  7043. END;
  7044. END;
  7045. overlap := Overlap( left, dest ) OR Overlap( right, dest );
  7046. IF overlap THEN
  7047. destOld := dest; destNew := 0;
  7048. p := AllocateSame( destNew, destOld, Size );
  7049. CopyContent( destNew, destOld, Size ); (* for INCMUL ! *)
  7050. dest := destNew;
  7051. END;
  7052. IF (GetLen( dest, 0 ) # rowsL) OR (GetLen( dest, 1 ) # colsR) THEN
  7053. HALT( 9999 )
  7054. END;
  7055. ladr := GetAdr( left ); radr := GetAdr( right ); dadr := GetAdr( dest );
  7056. incL := GetIncr( left, 1 ); strideL := GetIncr( left, 0 ); (* increment and stride of left matrix *)
  7057. incR := GetIncr( right, 1 ); strideR := GetIncr( right, 0 ); (* increment and stride of right matrix *)
  7058. incD := GetIncr( dest, 1 ); strideD := GetIncr( dest, 0 ); (* increment and stride of dest matrix *)
  7059. (*
  7060. KernelLog.String("incD="); KernelLog.Int(incD,10); KernelLog.Ln;
  7061. KernelLog.String("strideD="); KernelLog.Int(strideD,10); KernelLog.Ln;
  7062. KernelLog.String("Len(dest,0) [rows]="); KernelLog.Int(GetLen(dest,0),10); KernelLog.Ln;
  7063. KernelLog.String("Len(dest,1) [cols]="); KernelLog.Int(GetLen(dest,1),10); KernelLog.Ln;
  7064. *)
  7065. IF rowsL = 0 THEN RETURN
  7066. ELSIF colsL=0 THEN RETURN
  7067. ELSIF colsR=0 THEN RETURN
  7068. ELSIF (fast = NIL ) OR
  7069. ~(fast( ladr, radr, dadr, incL, strideL, incR, strideR, incD, strideD, rowsL, colsL, rowsR, colsR )) THEN
  7070. WHILE (rowsL > 0) DO (* outer loop: traverse rows of left matrix *)
  7071. radri := radr; dadri := dadr; colsRi := colsR;
  7072. WHILE (colsRi > 0) DO (* inner loop: traverse columns of right matrix *)
  7073. loop( ladr, radri, dadri, incL, strideR, colsL ); INC( radri, incR );
  7074. INC( dadri, incD ); DEC( colsRi );
  7075. END;
  7076. INC( ladr, strideL ); INC( dadr, strideD ); DEC( rowsL );
  7077. END;
  7078. END;
  7079. IF overlap THEN CopyContent( destOld, dest, Size );
  7080. END;
  7081. END ApplyMatMulLoop;
  7082. PROCEDURE ApplyMatVecMulLoop( dest, left, right: ADDRESS;
  7083. Size: LONGINT; loop: BinaryAASLoop;
  7084. fast: FastMatMul ); (* Size= element-size *)
  7085. VAR ladr, radr, dadr, li1, li0, ri0, di0, l1, l2: LONGINT; p: ANY;
  7086. overlap: BOOLEAN; destOld, destNew: ADDRESS;
  7087. BEGIN
  7088. (*
  7089. <- 0 ->
  7090. xxx T(xxx) -> T(xxxxx)
  7091. xxx
  7092. 1 xxx
  7093. xxx
  7094. xxx
  7095. Len(..,0): #columns ; Inc(..,0): inc in rows
  7096. Len(..,1): #rows ; Inc(..,1): inc between rows
  7097. *)
  7098. (* check geometric restriction *)
  7099. IF GetLen( left, 1 ) # GetLen( right, 0 ) THEN
  7100. Halt( GeometryMismatch, left, right,0 );
  7101. END;
  7102. l1 := GetLen( left, 0 ); (* number of destination's rows *)
  7103. l2 := GetLen( left, 1 ); (* inner loop len *)
  7104. IF GetAdr( dest ) = 0 THEN p := AllocateVector( dest, l1, Size );
  7105. ELSIF (GetLen( dest, 0 ) # l1) THEN
  7106. IF RangeFlag IN GetFlags( dest ) THEN
  7107. Halt( GeometryMismatch, left, right, dest );
  7108. ELSE p := AllocateVector( dest, l1, Size );
  7109. END;
  7110. END;
  7111. overlap := Overlap( left, dest ) OR Overlap( right, dest );
  7112. IF overlap THEN
  7113. destOld := dest; destNew := 0;
  7114. p := AllocateSame( destNew, destOld, Size );
  7115. CopyContent( destNew, destOld, Size ); (* for INCMUL ! *)
  7116. dest := destNew;
  7117. END;
  7118. (*
  7119. IF GetAdr( dest ) = -1 THEN p := AllocateVector( dest, l1, Size ); ELSE
  7120. IF (GetLen( dest, 0 ) # l1) THEN HALT( 102 ) END;
  7121. END;
  7122. *)
  7123. ladr := GetAdr( left ); radr := GetAdr( right ); dadr := GetAdr( dest );
  7124. li0 := GetIncr( left, 1 ); li1 := GetIncr( left, 0 ); ri0 := GetIncr( right, 0 );
  7125. di0 := GetIncr( dest, 0 );
  7126. IF l1=0 THEN RETURN
  7127. ELSIF l2=0 THEN RETURN
  7128. ELSIF (fast = NIL ) OR
  7129. ~(fast( ladr, radr, dadr, li0, li1, ri0, ri0, di0, di0, l1, l2, l2, 1 )) THEN
  7130. WHILE (l1 > 0) DO (* inner loop: traverse columns of right matrix *)
  7131. loop( ladr, radr, dadr, li0, ri0, l2 ); INC( ladr, li1 ); INC( dadr, di0 );
  7132. DEC( l1 );
  7133. END;
  7134. END;
  7135. IF overlap THEN CopyContent( destOld, dest, Size );
  7136. END;
  7137. END ApplyMatVecMulLoop;
  7138. PROCEDURE ApplyVecMatMulLoop( dest, left, right: ADDRESS;
  7139. Size: LONGINT; loop: BinaryAASLoop;
  7140. fast: FastMatMul ); (* Size= element-size *)
  7141. VAR ladr, radr, dadr, li0, ri1, ri0, di0, l0, l2: LONGINT; p: ANY;
  7142. overlap: BOOLEAN; destOld, destNew: ADDRESS;
  7143. BEGIN
  7144. (*
  7145. <- 0 ->
  7146. xxx xxxx -> xxxx
  7147. xxxx
  7148. 1 xxxx
  7149. Len(..,0): #columns ; Inc(..,0): inc in rows
  7150. Len(..,1): #rows ; Inc(..,1): inc between rows
  7151. *)
  7152. (* check geometric restriction *)
  7153. IF GetLen( left, 0 ) # GetLen( right, 0 ) THEN HALT( GeometryMismatch ); END;
  7154. l0 := GetLen( right, 1 ); (* number of destination's column *)
  7155. l2 := GetLen( right, 0 ); (* inner loop len *)
  7156. IF GetAdr( dest ) = 0 THEN p := AllocateVector( dest, l0, Size );
  7157. ELSIF (GetLen( dest, 0 ) # l0) THEN
  7158. IF RangeFlag IN GetFlags( dest ) THEN HALT( GeometryMismatch )
  7159. ELSE p := AllocateVector( dest, l0, Size );
  7160. END;
  7161. END;
  7162. overlap := Overlap( left, dest ) OR Overlap( right, dest );
  7163. IF overlap THEN
  7164. destOld := dest; destNew := 0;
  7165. p := AllocateSame( destNew, destOld, Size );
  7166. CopyContent( destNew, destOld, Size ); (* for INCMUL ! *)
  7167. dest := destNew;
  7168. END;
  7169. (*
  7170. IF GetAdr( dest ) = -1 THEN p := AllocateVector( dest, l0, Size ); ELSE
  7171. IF (GetLen( dest, 0 ) # l0) THEN HALT( 102 ) END;
  7172. END;
  7173. *)
  7174. ladr := GetAdr( left ); radr := GetAdr( right ); dadr := GetAdr( dest );
  7175. li0 := GetIncr( left, 0 ); ri0 := GetIncr( right, 1 ); ri1 := GetIncr( right, 0 );
  7176. di0 := GetIncr( dest, 0 );
  7177. IF l2=0 THEN RETURN
  7178. ELSIF l0=0 THEN RETURN
  7179. ELSIF (fast = NIL ) OR ~fast( ladr, radr, dadr, li0, li0, ri0, ri1, di0, di0, 1, l2, l2, l0 ) THEN
  7180. WHILE (l0 > 0) DO (* inner loop: traverse columns of right matrix *)
  7181. loop( ladr, radr, dadr, li0, ri1, l2 ); INC( radr, ri0 ); INC( dadr, di0 );
  7182. DEC( l0 );
  7183. END;
  7184. END;
  7185. IF overlap THEN CopyContent( destOld, dest, Size );
  7186. END;
  7187. END ApplyVecMatMulLoop;
  7188. (** SHORTINT *)
  7189. PROCEDURE MatMulASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  7190. VAR lval, rval, dval: SHORTINT;
  7191. BEGIN
  7192. dval := 0;
  7193. WHILE (len > 0) DO
  7194. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval;
  7195. (* KernelLog.String("mul with: "); KernelLog.Int(lval,10); KernelLog.Int(rval,10); KernelLog.Ln; *)
  7196. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  7197. END;
  7198. SYSTEM.PUT( dadr, dval );
  7199. END MatMulASASLoop;
  7200. OPERATOR "*"*(CONST left, right: ARRAY [ * , * ] OF SHORTINT ): ARRAY [ * , * ] OF SHORTINT;
  7201. BEGIN
  7202. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7203. SIZEOF( SHORTINT ), MatMulASASLoop, NIL );
  7204. RETURN RESULT
  7205. END "*";
  7206. OPERATOR "*"*(CONST left: ARRAY [ * , * ] OF SHORTINT; CONST right: ARRAY [ * ] OF SHORTINT): ARRAY [ * ] OF SHORTINT;
  7207. BEGIN
  7208. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7209. SIZEOF( SHORTINT ), MatMulASASLoop, NIL );
  7210. RETURN RESULT
  7211. END "*";
  7212. OPERATOR "*"*( CONST left: ARRAY [ * ] OF SHORTINT; CONST right: ARRAY [ * , * ] OF SHORTINT ): ARRAY [ * ] OF SHORTINT;
  7213. BEGIN
  7214. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7215. SIZEOF( SHORTINT ), MatMulASASLoop, NIL );
  7216. RETURN RESULT
  7217. END "*";
  7218. (** INTEGER *)
  7219. PROCEDURE MatMulAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  7220. VAR lval, rval, dval: INTEGER;
  7221. BEGIN
  7222. dval := 0;
  7223. WHILE (len > 0) DO
  7224. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval;
  7225. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  7226. END;
  7227. SYSTEM.PUT( dadr, dval );
  7228. END MatMulAIAILoop;
  7229. OPERATOR "*"*( CONST left, right: ARRAY [ * , * ] OF INTEGER ): ARRAY [ * , * ] OF INTEGER;
  7230. BEGIN
  7231. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7232. SIZEOF( INTEGER ), MatMulAIAILoop, NIL );
  7233. RETURN RESULT
  7234. END "*";
  7235. OPERATOR "*"*(CONST left: ARRAY [ * , * ] OF INTEGER;
  7236. CONST right: ARRAY [ * ] OF INTEGER ): ARRAY [ * ] OF INTEGER;
  7237. BEGIN
  7238. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7239. SIZEOF( INTEGER ), MatMulAIAILoop, NIL );
  7240. RETURN RESULT
  7241. END "*";
  7242. OPERATOR "*"*(CONST left: ARRAY [ * ] OF INTEGER;
  7243. CONST right: ARRAY [ * , * ] OF INTEGER ): ARRAY [ * ] OF INTEGER;
  7244. BEGIN
  7245. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7246. SIZEOF( INTEGER ), MatMulAIAILoop, NIL );
  7247. RETURN RESULT
  7248. END "*";
  7249. (** LONGINT *)
  7250. PROCEDURE MatMulALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  7251. VAR lval, rval, dval: LONGINT;
  7252. BEGIN
  7253. dval := 0;
  7254. WHILE (len > 0) DO
  7255. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval;
  7256. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  7257. END;
  7258. SYSTEM.PUT( dadr, dval );
  7259. END MatMulALALLoop;
  7260. OPERATOR "*"*(CONST left, right: ARRAY [ * , * ] OF LONGINT ): ARRAY [ * , * ] OF LONGINT;
  7261. BEGIN
  7262. (*
  7263. KernelLog.String("MatMulALAL");
  7264. KernelLog.Int(SYSTEM.VAL(LONGINT,dest),10);
  7265. KernelLog.Int(SYSTEM.VAL(LONGINT,left),10);
  7266. KernelLog.Int(SYSTEM.VAL(LONGINT,right),10);
  7267. KernelLog.Ln;
  7268. *)
  7269. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7270. SIZEOF( LONGINT ), MatMulALALLoop, NIL );
  7271. RETURN RESULT
  7272. END "*";
  7273. OPERATOR "*"*(CONST left: ARRAY [ * , * ] OF LONGINT; CONST right: ARRAY [ * ] OF LONGINT ): ARRAY [ * ] OF LONGINT;
  7274. BEGIN
  7275. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7276. SIZEOF( LONGINT ), MatMulALALLoop, NIL );
  7277. RETURN RESULT
  7278. END "*";
  7279. OPERATOR "*"*(CONST left: ARRAY [ * ] OF LONGINT;
  7280. CONST right: ARRAY [ * , * ] OF LONGINT): ARRAY [ * ] OF LONGINT;
  7281. BEGIN
  7282. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7283. SIZEOF( LONGINT ), MatMulALALLoop, NIL );
  7284. RETURN RESULT
  7285. END "*";
  7286. (** REAL *)
  7287. PROCEDURE MatMulARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  7288. VAR lval, rval, dval: REAL;
  7289. BEGIN
  7290. dval := 0;
  7291. WHILE (len > 0) DO
  7292. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval;
  7293. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  7294. END;
  7295. SYSTEM.PUT( dadr, dval );
  7296. END MatMulARARLoop;
  7297. (*
  7298. Optimized for small matrices (Alexey Morozov)
  7299. use of CONST for left, right makes execution slower, it seems that a new descriptor is created in this case
  7300. *)
  7301. OPERATOR "*"*(CONST left, right: ARRAY [ * , * ] OF REAL ): ARRAY [ * , * ] OF REAL;
  7302. VAR flags: SET; dadr, ladr, radr: LONGINT;
  7303. BEGIN
  7304. dadr := GetAdr(ADDRESSOF(RESULT));
  7305. ladr := GetAdr(ADDRESSOF(left));
  7306. radr := GetAdr(ADDRESSOF(right));
  7307. (* account possible inplace left := left*right, right := left*right, left := left*left, right := right*right *)
  7308. IF (ladr # dadr) & (radr # dadr) THEN
  7309. flags := SmallArrayMask * SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(left)+MathFlagsOffset)) * SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(right)+MathFlagsOffset));
  7310. CASE SYSTEM.VAL(LONGINT,flags) OF
  7311. Mat2x2:
  7312. IF SYSTEM.VAL(LONGINT,SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset)) * SmallArrayMask) # Mat2x2 THEN
  7313. IF dadr = 0 THEN NEW(RESULT,2,2); dadr := GetAdr(ADDRESSOF(RESULT));
  7314. ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0);
  7315. END;
  7316. END;
  7317. IF matMulR2x2 # NIL THEN matMulR2x2(dadr,ladr,radr);
  7318. ELSE
  7319. RESULT[0,0] := left[0,0]*right[0,0] + left[0,1]*right[1,0];
  7320. RESULT[0,1] := left[0,0]*right[0,1] + left[0,1]*right[1,1];
  7321. RESULT[1,0] := left[1,0]*right[0,0] + left[1,1]*right[1,0];
  7322. RESULT[1,1] := left[1,0]*right[0,1] + left[1,1]*right[1,1];
  7323. END;
  7324. |Mat3x3:
  7325. IF SYSTEM.VAL(LONGINT,SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset)) * SmallArrayMask) # Mat3x3 THEN
  7326. IF dadr = 0 THEN NEW(RESULT,3,3);dadr := GetAdr(ADDRESSOF(RESULT));
  7327. ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0);
  7328. END;
  7329. END;
  7330. IF matMulR3x3 # NIL THEN matMulR3x3(dadr,ladr,radr);
  7331. ELSE
  7332. RESULT[0,0] := left[0,0]*right[0,0] + left[0,1]*right[1,0] + left[0,2]*right[2,0];
  7333. RESULT[0,1] := left[0,0]*right[0,1] + left[0,1]*right[1,1] + left[0,2]*right[2,1];
  7334. RESULT[0,2] := left[0,0]*right[0,2] + left[0,1]*right[1,2] + left[0,2]*right[2,2];
  7335. RESULT[1,0] := left[1,0]*right[0,0] + left[1,1]*right[1,0] + left[1,2]*right[2,0];
  7336. RESULT[1,1] := left[1,0]*right[0,1] + left[1,1]*right[1,1] + left[1,2]*right[2,1];
  7337. RESULT[1,2] := left[1,0]*right[0,2] + left[1,1]*right[1,2] + left[1,2]*right[2,2];
  7338. RESULT[2,0] := left[2,0]*right[0,0] + left[2,1]*right[1,0] + left[2,2]*right[2,0];
  7339. RESULT[2,1] := left[2,0]*right[0,1] + left[2,1]*right[1,1] + left[2,2]*right[2,1];
  7340. RESULT[2,2] := left[2,0]*right[0,2] + left[2,1]*right[1,2] + left[2,2]*right[2,2];
  7341. END;
  7342. |Mat4x4:
  7343. IF SYSTEM.VAL(LONGINT,SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset)) * SmallArrayMask) # Mat4x4 THEN
  7344. IF dadr = 0 THEN NEW(RESULT,4,4); dadr := GetAdr(ADDRESSOF(RESULT));
  7345. ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0);
  7346. END;
  7347. END;
  7348. IF matMulR4x4 # NIL THEN matMulR4x4(dadr,ladr,radr);
  7349. ELSE
  7350. RESULT[0,0] := left[0,0]*right[0,0] + left[0,1]*right[1,0] + left[0,2]*right[2,0] + left[0,3]*right[3,0];
  7351. RESULT[0,1] := left[0,0]*right[0,1] + left[0,1]*right[1,1] + left[0,2]*right[2,1] + left[0,3]*right[3,1];
  7352. RESULT[0,2] := left[0,0]*right[0,2] + left[0,1]*right[1,2] + left[0,2]*right[2,2] + left[0,3]*right[3,2];
  7353. RESULT[0,3] := left[0,0]*right[0,3] + left[0,1]*right[1,3] + left[0,2]*right[2,3] + left[0,3]*right[3,3];
  7354. RESULT[1,0] := left[1,0]*right[0,0] + left[1,1]*right[1,0] + left[1,2]*right[2,0] + left[1,3]*right[3,0];
  7355. RESULT[1,1] := left[1,0]*right[0,1] + left[1,1]*right[1,1] + left[1,2]*right[2,1] + left[1,3]*right[3,1];
  7356. RESULT[1,2] := left[1,0]*right[0,2] + left[1,1]*right[1,2] + left[1,2]*right[2,2] + left[1,3]*right[3,2];
  7357. RESULT[1,3] := left[1,0]*right[0,3] + left[1,1]*right[1,3] + left[1,2]*right[2,3] + left[1,3]*right[3,3];
  7358. RESULT[2,0] := left[2,0]*right[0,0] + left[2,1]*right[1,0] + left[2,2]*right[2,0] + left[2,3]*right[3,0];
  7359. RESULT[2,1] := left[2,0]*right[0,1] + left[2,1]*right[1,1] + left[2,2]*right[2,1] + left[2,3]*right[3,1];
  7360. RESULT[2,2] := left[2,0]*right[0,2] + left[2,1]*right[1,2] + left[2,2]*right[2,2] + left[2,3]*right[3,2];
  7361. RESULT[2,3] := left[2,0]*right[0,3] + left[2,1]*right[1,3] + left[2,2]*right[2,3] + left[2,3]*right[3,3];
  7362. RESULT[3,0] := left[3,0]*right[0,0] + left[3,1]*right[1,0] + left[3,2]*right[2,0] + left[3,3]*right[3,0];
  7363. RESULT[3,1] := left[3,0]*right[0,1] + left[3,1]*right[1,1] + left[3,2]*right[2,1] + left[3,3]*right[3,1];
  7364. RESULT[3,2] := left[3,0]*right[0,2] + left[3,1]*right[1,2] + left[3,2]*right[2,2] + left[3,3]*right[3,2];
  7365. RESULT[3,3] := left[3,0]*right[0,3] + left[3,1]*right[1,3] + left[3,2]*right[2,3] + left[3,3]*right[3,3];
  7366. END;
  7367. ELSE
  7368. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  7369. loopMatMulARAR, matMulR );
  7370. END;
  7371. ELSE
  7372. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  7373. loopMatMulARAR, matMulR );
  7374. END;
  7375. RETURN RESULT
  7376. END "*";
  7377. (*
  7378. Optimized for small arrays (Alexey Morozov)
  7379. use of CONST for left, right makes execution slower, it seems that a new descriptor is created in this case
  7380. *)
  7381. OPERATOR "*"*(CONST left: ARRAY [ * , * ] OF REAL; CONST right: ARRAY [ * ] OF REAL ): ARRAY [ * ] OF REAL;
  7382. VAR
  7383. flags: SET; dadr, ladr, radr: LONGINT;
  7384. v0, v1, v2: REAL;
  7385. BEGIN
  7386. dadr := GetAdr(ADDRESSOF(RESULT));
  7387. ladr := GetAdr(ADDRESSOF(left));
  7388. radr := GetAdr(ADDRESSOF(right));
  7389. flags := SmallArrayMask * SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(left)+MathFlagsOffset)) * SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(right)+MathFlagsOffset));
  7390. CASE SYSTEM.VAL(LONGINT,flags) OF
  7391. MatVec2x2:
  7392. IF SYSTEM.VAL(LONGINT,SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset)) * SmallArrayMask) # Vec2 THEN
  7393. IF dadr = 0 THEN NEW(RESULT,2);dadr := GetAdr(ADDRESSOF(RESULT));
  7394. ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0);
  7395. END;
  7396. END;
  7397. IF matVecMulR2x2 # NIL THEN matVecMulR2x2(dadr,ladr,radr);
  7398. ELSE
  7399. (* account possible overlapping *)
  7400. v0 := right[0];
  7401. RESULT[0] := left[0,0]*v0 + left[0,1]*right[1];
  7402. RESULT[1] := left[1,0]*v0 + left[1,1]*right[1];
  7403. END;
  7404. |MatVec3x3:
  7405. IF SYSTEM.VAL(LONGINT,SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset)) * SmallArrayMask) # Vec3 THEN
  7406. IF dadr = 0 THEN NEW(RESULT,3);dadr := GetAdr(ADDRESSOF(RESULT));
  7407. ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0);
  7408. END;
  7409. END;
  7410. IF matVecMulR3x3 # NIL THEN matVecMulR3x3(dadr,ladr,radr);
  7411. ELSE
  7412. (* account possible overlapping *)
  7413. v0 := right[0]; v1 := right[1];
  7414. RESULT[0] := left[0,0]*v0 + left[0,1]*v1 + left[0,2]*right[2];
  7415. RESULT[1] := left[1,0]*v0 + left[1,1]*v1 + left[1,2]*right[2];
  7416. RESULT[2] := left[2,0]*v0 + left[2,1]*v1 + left[2,2]*right[2];
  7417. END;
  7418. |MatVec4x4:
  7419. IF SYSTEM.VAL(LONGINT,SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset)) * SmallArrayMask) # Vec4 THEN
  7420. IF dadr = 0 THEN NEW(RESULT,4);dadr := GetAdr(ADDRESSOF(RESULT));
  7421. ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0);
  7422. END;
  7423. END;
  7424. IF matVecMulR4x4 # NIL THEN matVecMulR4x4(dadr,ladr,radr);
  7425. ELSE
  7426. (* account possible overlapping *)
  7427. v0 := right[0]; v1 := right[1]; v2 := right[2];
  7428. RESULT[0] := left[0,0]*v0 + left[0,1]*v1 + left[0,2]*v2 + left[0,3]*right[3];
  7429. RESULT[1] := left[1,0]*v0 + left[1,1]*v1 + left[1,2]*v2 + left[1,3]*right[3];
  7430. RESULT[2] := left[2,0]*v0 + left[2,1]*v1 + left[2,2]*v2 + left[2,3]*right[3];
  7431. RESULT[3] := left[3,0]*v0 + left[3,1]*v1 + left[3,2]*v2 + left[3,3]*right[3];
  7432. END;
  7433. ELSE
  7434. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7435. SIZEOF( REAL ), loopMatMulARAR, matMulR );
  7436. END;
  7437. RETURN RESULT
  7438. END "*";
  7439. OPERATOR "*"*( CONST left: ARRAY [ * ] OF REAL;
  7440. CONST right: ARRAY [ * , * ] OF REAL ): ARRAY [ * ] OF REAL;
  7441. BEGIN
  7442. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7443. SIZEOF( REAL ), loopMatMulARAR, matMulR );
  7444. RETURN RESULT
  7445. END "*";
  7446. (** LONGREAL *)
  7447. PROCEDURE MatMulAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  7448. VAR lval, rval, dval: LONGREAL;
  7449. BEGIN
  7450. dval := 0;
  7451. WHILE (len > 0) DO
  7452. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval;
  7453. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  7454. END;
  7455. SYSTEM.PUT( dadr, dval );
  7456. END MatMulAXAXLoop;
  7457. (*
  7458. Optimized for small matrices (Alexey Morozov)
  7459. use of CONST for left, right makes execution slower, it seems that a new descriptor is created in this case
  7460. *)
  7461. OPERATOR "*"*( CONST left, right: ARRAY [ * , * ] OF LONGREAL): ARRAY [ * , * ] OF LONGREAL;
  7462. VAR
  7463. flags: SET; dadr, ladr, radr: LONGINT;
  7464. BEGIN
  7465. dadr := GetAdr(ADDRESSOF(RESULT));
  7466. ladr := GetAdr(ADDRESSOF(left));
  7467. radr := GetAdr(ADDRESSOF(right));
  7468. IF (ladr # dadr) & (radr # dadr) THEN
  7469. flags := SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(left)+MathFlagsOffset)) * SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(right)+MathFlagsOffset));
  7470. CASE SYSTEM.VAL(LONGINT,flags) OF
  7471. Mat2x2:
  7472. IF SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset) # Mat2x2 THEN
  7473. IF dadr = 0 THEN NEW(RESULT,2,2);
  7474. ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0);
  7475. END;
  7476. END;
  7477. IF matMulLR2x2 # NIL THEN matMulLR2x2(dadr,ladr,radr);
  7478. ELSE
  7479. RESULT[0,0] := left[0,0]*right[0,0] + left[0,1]*right[1,0];
  7480. RESULT[0,1] := left[0,0]*right[0,1] + left[0,1]*right[1,1];
  7481. RESULT[1,0] := left[1,0]*right[0,0] + left[1,1]*right[1,0];
  7482. RESULT[1,1] := left[1,0]*right[0,1] + left[1,1]*right[1,1];
  7483. END;
  7484. |Mat3x3:
  7485. IF SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset) # Mat3x3 THEN
  7486. IF dadr = 0 THEN NEW(RESULT,3,3);
  7487. ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0);
  7488. END;
  7489. END;
  7490. IF matMulLR3x3 # NIL THEN matMulLR3x3(dadr,ladr,radr);
  7491. ELSE
  7492. RESULT[0,0] := left[0,0]*right[0,0] + left[0,1]*right[1,0] + left[0,2]*right[2,0];
  7493. RESULT[0,1] := left[0,0]*right[0,1] + left[0,1]*right[1,1] + left[0,2]*right[2,1];
  7494. RESULT[0,2] := left[0,0]*right[0,2] + left[0,1]*right[1,2] + left[0,2]*right[2,2];
  7495. RESULT[1,0] := left[1,0]*right[0,0] + left[1,1]*right[1,0] + left[1,2]*right[2,0];
  7496. RESULT[1,1] := left[1,0]*right[0,1] + left[1,1]*right[1,1] + left[1,2]*right[2,1];
  7497. RESULT[1,2] := left[1,0]*right[0,2] + left[1,1]*right[1,2] + left[1,2]*right[2,2];
  7498. RESULT[2,0] := left[2,0]*right[0,0] + left[2,1]*right[1,0] + left[2,2]*right[2,0];
  7499. RESULT[2,1] := left[2,0]*right[0,1] + left[2,1]*right[1,1] + left[2,2]*right[2,1];
  7500. RESULT[2,2] := left[2,0]*right[0,2] + left[2,1]*right[1,2] + left[2,2]*right[2,2];
  7501. END;
  7502. |Mat4x4:
  7503. IF SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset) # Mat4x4 THEN
  7504. IF dadr = 0 THEN NEW(RESULT,4,4);
  7505. ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0);
  7506. END;
  7507. END;
  7508. IF matMulLR4x4 # NIL THEN matMulLR4x4(dadr,ladr,radr);
  7509. ELSE
  7510. RESULT[0,0] := left[0,0]*right[0,0] + left[0,1]*right[1,0] + left[0,2]*right[2,0] + left[0,3]*right[3,0];
  7511. RESULT[0,1] := left[0,0]*right[0,1] + left[0,1]*right[1,1] + left[0,2]*right[2,1] + left[0,3]*right[3,1];
  7512. RESULT[0,2] := left[0,0]*right[0,2] + left[0,1]*right[1,2] + left[0,2]*right[2,2] + left[0,3]*right[3,2];
  7513. RESULT[0,3] := left[0,0]*right[0,3] + left[0,1]*right[1,3] + left[0,2]*right[2,3] + left[0,3]*right[3,3];
  7514. RESULT[1,0] := left[1,0]*right[0,0] + left[1,1]*right[1,0] + left[1,2]*right[2,0] + left[1,3]*right[3,0];
  7515. RESULT[1,1] := left[1,0]*right[0,1] + left[1,1]*right[1,1] + left[1,2]*right[2,1] + left[1,3]*right[3,1];
  7516. RESULT[1,2] := left[1,0]*right[0,2] + left[1,1]*right[1,2] + left[1,2]*right[2,2] + left[1,3]*right[3,2];
  7517. RESULT[1,3] := left[1,0]*right[0,3] + left[1,1]*right[1,3] + left[1,2]*right[2,3] + left[1,3]*right[3,3];
  7518. RESULT[2,0] := left[2,0]*right[0,0] + left[2,1]*right[1,0] + left[2,2]*right[2,0] + left[2,3]*right[3,0];
  7519. RESULT[2,1] := left[2,0]*right[0,1] + left[2,1]*right[1,1] + left[2,2]*right[2,1] + left[2,3]*right[3,1];
  7520. RESULT[2,2] := left[2,0]*right[0,2] + left[2,1]*right[1,2] + left[2,2]*right[2,2] + left[2,3]*right[3,2];
  7521. RESULT[2,3] := left[2,0]*right[0,3] + left[2,1]*right[1,3] + left[2,2]*right[2,3] + left[2,3]*right[3,3];
  7522. RESULT[3,0] := left[3,0]*right[0,0] + left[3,1]*right[1,0] + left[3,2]*right[2,0] + left[3,3]*right[3,0];
  7523. RESULT[3,1] := left[3,0]*right[0,1] + left[3,1]*right[1,1] + left[3,2]*right[2,1] + left[3,3]*right[3,1];
  7524. RESULT[3,2] := left[3,0]*right[0,2] + left[3,1]*right[1,2] + left[3,2]*right[2,2] + left[3,3]*right[3,2];
  7525. RESULT[3,3] := left[3,0]*right[0,3] + left[3,1]*right[1,3] + left[3,2]*right[2,3] + left[3,3]*right[3,3];
  7526. END;
  7527. ELSE
  7528. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ),
  7529. loopMatMulAXAX, matMulX );
  7530. END;
  7531. ELSE
  7532. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ),
  7533. loopMatMulAXAX, matMulX );
  7534. END;
  7535. RETURN RESULT
  7536. END "*";
  7537. (*
  7538. Optimized for small arrays (Alexey Morozov)
  7539. use of CONST for left, right makes execution slower, it seems that a new descriptor is created in this case
  7540. *)
  7541. OPERATOR "*"*(CONST left: ARRAY [ * , * ] OF LONGREAL;
  7542. CONST right: ARRAY [ * ] OF LONGREAL ): ARRAY [ * ] OF LONGREAL;
  7543. VAR
  7544. flags: SET; dadr, ladr, radr: LONGINT;
  7545. v0, v1, v2: LONGREAL;
  7546. BEGIN
  7547. dadr := GetAdr(ADDRESSOF(RESULT));
  7548. ladr := GetAdr(ADDRESSOF(left));
  7549. radr := GetAdr(ADDRESSOF(right));
  7550. flags := SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(left)+MathFlagsOffset)) * SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(right)+MathFlagsOffset));
  7551. CASE SYSTEM.VAL(LONGINT,flags) OF
  7552. MatVec2x2:
  7553. IF SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset) # Vec2 THEN
  7554. IF dadr = 0 THEN NEW(RESULT,2);
  7555. ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0);
  7556. END;
  7557. END;
  7558. IF matVecMulLR2x2 # NIL THEN matVecMulLR2x2(dadr,ladr,radr);
  7559. ELSE
  7560. (* account possible overlapping *)
  7561. v0 := right[0];
  7562. RESULT[0] := left[0,0]*v0 + left[0,1]*right[1];
  7563. RESULT[1] := left[1,0]*v0 + left[1,1]*right[1];
  7564. END;
  7565. |MatVec3x3:
  7566. IF SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset) # Vec3 THEN
  7567. IF dadr = 0 THEN NEW(RESULT,3);
  7568. ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0);
  7569. END;
  7570. END;
  7571. IF matVecMulLR3x3 # NIL THEN matVecMulLR3x3(dadr,ladr,radr);
  7572. ELSE
  7573. (* account possible overlapping *)
  7574. v0 := right[0]; v1 := right[1];
  7575. RESULT[0] := left[0,0]*v0 + left[0,1]*v1 + left[0,2]*right[2];
  7576. RESULT[1] := left[1,0]*v0 + left[1,1]*v1 + left[1,2]*right[2];
  7577. RESULT[2] := left[2,0]*v0 + left[2,1]*v1 + left[2,2]*right[2];
  7578. END;
  7579. |MatVec4x4:
  7580. IF SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset) # Vec4 THEN
  7581. IF dadr = 0 THEN NEW(RESULT,4);
  7582. ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0);
  7583. END;
  7584. END;
  7585. IF matVecMulLR4x4 # NIL THEN matVecMulLR4x4(dadr,ladr,radr);
  7586. ELSE
  7587. (* account possible overlapping *)
  7588. v0 := right[0]; v1 := right[1]; v2 := right[2];
  7589. RESULT[0] := left[0,0]*v0 + left[0,1]*v1 + left[0,2]*v2 + left[0,3]*right[3];
  7590. RESULT[1] := left[1,0]*v0 + left[1,1]*v1 + left[1,2]*v2 + left[1,3]*right[3];
  7591. RESULT[2] := left[2,0]*v0 + left[2,1]*v1 + left[2,2]*v2 + left[2,3]*right[3];
  7592. RESULT[3] := left[3,0]*v0 + left[3,1]*v1 + left[3,2]*v2 + left[3,3]*right[3];
  7593. END;
  7594. ELSE
  7595. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7596. SIZEOF( LONGREAL ), loopMatMulAXAX, matMulX );
  7597. END;
  7598. RETURN RESULT
  7599. END "*";
  7600. OPERATOR "*"*( CONST left: ARRAY [ * ] OF LONGREAL;
  7601. CONST right: ARRAY [ * , * ] OF LONGREAL ): ARRAY [ * ] OF LONGREAL;
  7602. BEGIN
  7603. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7604. SIZEOF( LONGREAL ), loopMatMulAXAX, matMulX );
  7605. RETURN RESULT
  7606. END "*";
  7607. (** SHORTINT *)
  7608. PROCEDURE MatMulIncASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  7609. VAR lval, rval, dval: SHORTINT;
  7610. BEGIN
  7611. SYSTEM.GET( dadr, dval );
  7612. WHILE (len > 0) DO
  7613. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval;
  7614. (* KernelLog.String("mul with: "); KernelLog.Int(lval,10); KernelLog.Int(rval,10); KernelLog.Ln; *)
  7615. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  7616. END;
  7617. SYSTEM.PUT( dadr, dval );
  7618. END MatMulIncASASLoop;
  7619. OPERATOR "INCMUL"*(CONST left, right: ARRAY [ * , * ] OF SHORTINT ): ARRAY [ * , * ] OF SHORTINT;
  7620. BEGIN
  7621. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7622. SIZEOF( SHORTINT ), MatMulIncASASLoop, NIL );
  7623. RETURN RESULT
  7624. END "INCMUL";
  7625. OPERATOR "INCMUL"*(CONST left: ARRAY [ * , * ] OF SHORTINT;
  7626. CONST right: ARRAY [ * ] OF SHORTINT ): ARRAY [ * ] OF SHORTINT;
  7627. BEGIN
  7628. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7629. SIZEOF( SHORTINT ), MatMulIncASASLoop, NIL );
  7630. RETURN RESULT
  7631. END "INCMUL";
  7632. OPERATOR "INCMUL"*( CONST left: ARRAY [ * ] OF SHORTINT;
  7633. CONST right: ARRAY [ * , * ] OF SHORTINT ): ARRAY [ * ] OF SHORTINT;
  7634. BEGIN
  7635. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7636. SIZEOF( SHORTINT ), MatMulIncASASLoop, NIL );
  7637. RETURN RESULT
  7638. END "INCMUL";
  7639. OPERATOR "DECMUL"*(CONST left, right: ARRAY [ * , * ] OF SHORTINT ): ARRAY [ * , * ] OF SHORTINT;
  7640. BEGIN
  7641. RESULT := -RESULT;
  7642. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7643. SIZEOF( SHORTINT ), MatMulIncASASLoop, NIL );
  7644. RESULT := -RESULT;
  7645. RETURN RESULT
  7646. END "DECMUL";
  7647. OPERATOR "DECMUL"*(CONST left: ARRAY [ * , * ] OF SHORTINT;
  7648. CONST right: ARRAY [ * ] OF SHORTINT ): ARRAY [ * ] OF SHORTINT;
  7649. BEGIN
  7650. RESULT := -RESULT;
  7651. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7652. SIZEOF( SHORTINT ), MatMulIncASASLoop, NIL );
  7653. RESULT := -RESULT;
  7654. RETURN RESULT
  7655. END "DECMUL";
  7656. OPERATOR "DECMUL"*( CONST left: ARRAY [ * ] OF SHORTINT;
  7657. CONST right: ARRAY [ * , * ] OF SHORTINT ): ARRAY [ * ] OF SHORTINT;
  7658. BEGIN
  7659. RESULT := -RESULT;
  7660. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7661. SIZEOF( SHORTINT ), MatMulIncASASLoop, NIL );
  7662. RESULT := -RESULT;
  7663. RETURN RESULT
  7664. END "DECMUL";
  7665. (** INTEGER *)
  7666. PROCEDURE MatMulIncAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  7667. VAR lval, rval, dval: INTEGER;
  7668. BEGIN
  7669. SYSTEM.GET( dadr, dval );
  7670. WHILE (len > 0) DO
  7671. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval;
  7672. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  7673. END;
  7674. SYSTEM.PUT( dadr, dval );
  7675. END MatMulIncAIAILoop;
  7676. OPERATOR "INCMUL"*(CONST left, right: ARRAY [ * , * ] OF INTEGER ): ARRAY [ * , * ] OF INTEGER;
  7677. BEGIN
  7678. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7679. SIZEOF( INTEGER ), MatMulIncAIAILoop, NIL );
  7680. RETURN RESULT
  7681. END "INCMUL";
  7682. OPERATOR "INCMUL"*(CONST left: ARRAY [ * , * ] OF INTEGER; CONST right: ARRAY [ * ] OF INTEGER): ARRAY [ * ] OF INTEGER;
  7683. BEGIN
  7684. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7685. SIZEOF( INTEGER ), MatMulIncAIAILoop, NIL );
  7686. RETURN RESULT
  7687. END "INCMUL";
  7688. OPERATOR "INCMUL"*( CONST left: ARRAY [ * ] OF INTEGER; CONST right: ARRAY [ * , * ] OF INTEGER ): ARRAY [ * ] OF INTEGER;
  7689. BEGIN
  7690. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7691. SIZEOF( INTEGER ), MatMulIncAIAILoop, NIL );
  7692. RETURN RESULT
  7693. END "INCMUL";
  7694. OPERATOR "DECMUL"*(CONST left, right: ARRAY [ * , * ] OF INTEGER ): ARRAY [ * , * ] OF INTEGER;
  7695. BEGIN
  7696. RESULT := -RESULT;
  7697. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7698. SIZEOF( INTEGER ), MatMulIncAIAILoop, NIL );
  7699. RESULT := -RESULT;
  7700. RETURN RESULT
  7701. END "DECMUL";
  7702. OPERATOR "DECMUL"*( CONST left: ARRAY [ * , * ] OF INTEGER; CONST right: ARRAY [ * ] OF INTEGER ): ARRAY [ * ] OF INTEGER;
  7703. BEGIN
  7704. RESULT := -RESULT;
  7705. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7706. SIZEOF( INTEGER ), MatMulIncAIAILoop, NIL );
  7707. RESULT := -RESULT;
  7708. RETURN RESULT
  7709. END "DECMUL";
  7710. OPERATOR "DECMUL"*( CONST left: ARRAY [ * ] OF INTEGER; CONST right: ARRAY [ * , * ] OF INTEGER ): ARRAY [ * ] OF INTEGER;
  7711. BEGIN
  7712. RESULT := -RESULT;
  7713. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7714. SIZEOF( INTEGER ), MatMulIncAIAILoop, NIL );
  7715. RESULT := -RESULT;
  7716. RETURN RESULT
  7717. END "DECMUL";
  7718. (** LONGINT *)
  7719. PROCEDURE MatMulIncALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  7720. VAR lval, rval, dval: LONGINT;
  7721. BEGIN
  7722. SYSTEM.GET( dadr, dval );
  7723. WHILE (len > 0) DO
  7724. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval;
  7725. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  7726. END;
  7727. SYSTEM.PUT( dadr, dval );
  7728. END MatMulIncALALLoop;
  7729. OPERATOR "INCMUL"*(CONST left, right: ARRAY [ * , * ] OF LONGINT ): ARRAY [ * , * ] OF LONGINT;
  7730. BEGIN
  7731. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7732. SIZEOF( LONGINT ), MatMulIncALALLoop, NIL );
  7733. RETURN RESULT
  7734. END "INCMUL";
  7735. OPERATOR "INCMUL"*(CONST left: ARRAY [ * , * ] OF LONGINT; CONST right: ARRAY [ * ] OF LONGINT ): ARRAY [ * ] OF LONGINT;
  7736. BEGIN
  7737. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7738. SIZEOF( LONGINT ), MatMulIncALALLoop, NIL );
  7739. RETURN RESULT
  7740. END "INCMUL";
  7741. OPERATOR "INCMUL"*( CONST left: ARRAY [ * ] OF LONGINT; CONST right: ARRAY [ * , * ] OF LONGINT ): ARRAY [ * ] OF LONGINT;
  7742. BEGIN
  7743. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7744. SIZEOF( LONGINT ), MatMulIncALALLoop, NIL );
  7745. RETURN RESULT
  7746. END "INCMUL";
  7747. OPERATOR "DECMUL"*( CONST left, right: ARRAY [ * , * ] OF LONGINT ): ARRAY [ * , * ] OF LONGINT;
  7748. BEGIN
  7749. RESULT := -RESULT;
  7750. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7751. SIZEOF( LONGINT ), MatMulIncALALLoop, NIL );
  7752. RESULT := -RESULT;
  7753. RETURN RESULT
  7754. END "DECMUL";
  7755. OPERATOR "DECMUL"*(CONST left: ARRAY [ * , * ] OF LONGINT; CONST right: ARRAY [ * ] OF LONGINT ): ARRAY [ * ] OF LONGINT;
  7756. BEGIN
  7757. RESULT := -RESULT;
  7758. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7759. SIZEOF( LONGINT ), MatMulIncALALLoop, NIL );
  7760. RESULT := -RESULT;
  7761. RETURN RESULT
  7762. END "DECMUL";
  7763. OPERATOR "DECMUL"*(CONST left: ARRAY [ * ] OF LONGINT; CONST right: ARRAY [ * , * ] OF LONGINT ): ARRAY [ * ] OF LONGINT;
  7764. BEGIN
  7765. RESULT := -RESULT;
  7766. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7767. SIZEOF( LONGINT ), MatMulIncALALLoop, NIL );
  7768. RESULT := -RESULT;
  7769. RETURN RESULT
  7770. END "DECMUL";
  7771. (** REAL *)
  7772. PROCEDURE MatMulIncARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  7773. VAR lval, rval, dval: REAL;
  7774. BEGIN
  7775. SYSTEM.GET( dadr, dval );
  7776. WHILE (len > 0) DO
  7777. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval;
  7778. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  7779. END;
  7780. SYSTEM.PUT( dadr, dval );
  7781. END MatMulIncARARLoop;
  7782. OPERATOR "INCMUL"*(CONST left, right: ARRAY [ * , * ] OF REAL ): ARRAY [ * , * ] OF REAL;
  7783. BEGIN
  7784. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  7785. loopMatMulIncARAR, matMulIncR );
  7786. RETURN RESULT
  7787. END "INCMUL";
  7788. OPERATOR "INCMUL"*(CONST left: ARRAY [ * , * ] OF REAL;CONST right: ARRAY [ * ] OF REAL ): ARRAY [ * ] OF REAL;
  7789. BEGIN
  7790. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7791. SIZEOF( REAL ), loopMatMulIncARAR, matMulIncR );
  7792. RETURN RESULT
  7793. END "INCMUL";
  7794. OPERATOR "INCMUL"*( CONST left: ARRAY [ * ] OF REAL; CONST right: ARRAY [ * , * ] OF REAL ): ARRAY [ * ] OF REAL;
  7795. BEGIN
  7796. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7797. SIZEOF( REAL ), loopMatMulIncARAR, matMulIncR );
  7798. RETURN RESULT
  7799. END "INCMUL";
  7800. OPERATOR "DECMUL"*(CONST left, right: ARRAY [ * , * ] OF REAL ): ARRAY [ * , * ] OF REAL;
  7801. BEGIN
  7802. RESULT := -RESULT;
  7803. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  7804. loopMatMulIncARAR, matMulIncR );
  7805. RESULT := -RESULT;
  7806. RETURN RESULT
  7807. END "DECMUL";
  7808. OPERATOR "DECMUL"*( CONST left: ARRAY [ * , * ] OF REAL; CONST right: ARRAY [ * ] OF REAL ): ARRAY [ * ] OF REAL;
  7809. BEGIN
  7810. RESULT := -RESULT;
  7811. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7812. SIZEOF( REAL ), loopMatMulIncARAR, matMulIncR );
  7813. RESULT := -RESULT;
  7814. RETURN RESULT
  7815. END "DECMUL";
  7816. OPERATOR "DECMUL"*(CONST left: ARRAY [ * ] OF REAL; CONST right: ARRAY [ * , * ] OF REAL ): ARRAY [ * ] OF REAL;
  7817. BEGIN
  7818. RESULT := -RESULT;
  7819. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7820. SIZEOF( REAL ), loopMatMulIncARAR, matMulIncR );
  7821. RESULT := -RESULT;
  7822. RETURN RESULT
  7823. END "DECMUL";
  7824. (** LONGREAL *)
  7825. PROCEDURE MatMulIncAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE );
  7826. VAR lval, rval, dval: LONGREAL;
  7827. BEGIN
  7828. SYSTEM.GET( dadr, dval );
  7829. WHILE (len > 0) DO
  7830. SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval;
  7831. INC( ladr, linc ); INC( radr, rinc ); DEC( len );
  7832. END;
  7833. SYSTEM.PUT( dadr, dval );
  7834. END MatMulIncAXAXLoop;
  7835. OPERATOR "INCMUL"*(CONST left, right: ARRAY [ * , * ] OF LONGREAL ): ARRAY [ * , * ] OF LONGREAL;
  7836. BEGIN
  7837. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7838. SIZEOF( LONGREAL ), loopMatMulIncAXAX, matMulIncX );
  7839. RETURN RESULT
  7840. END "INCMUL";
  7841. OPERATOR "INCMUL"*(CONST left: ARRAY [ * , * ] OF LONGREAL; CONST right: ARRAY [ * ] OF LONGREAL ): ARRAY [ * ] OF LONGREAL;
  7842. BEGIN
  7843. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7844. SIZEOF( LONGREAL ), loopMatMulIncAXAX, matMulIncX );
  7845. RETURN RESULT
  7846. END "INCMUL";
  7847. OPERATOR "INCMUL"*( CONST left: ARRAY [ * ] OF LONGREAL; CONST right: ARRAY [ * , * ] OF LONGREAL ): ARRAY [ * ] OF LONGREAL;
  7848. BEGIN
  7849. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7850. SIZEOF( LONGREAL ), loopMatMulIncAXAX, matMulIncX );
  7851. RETURN RESULT
  7852. END "INCMUL";
  7853. OPERATOR "DECMUL"*(CONST left, right: ARRAY [ * , * ] OF LONGREAL ): ARRAY [ * , * ] OF LONGREAL;
  7854. BEGIN
  7855. RESULT := -RESULT;
  7856. ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7857. SIZEOF( LONGREAL ), loopMatMulIncAXAX, matMulIncX );
  7858. RESULT := -RESULT;
  7859. RETURN RESULT
  7860. END "DECMUL";
  7861. OPERATOR "DECMUL"*( CONST left: ARRAY [ * , * ] OF LONGREAL; CONST right: ARRAY [ * ] OF LONGREAL ): ARRAY [ * ] OF LONGREAL;
  7862. BEGIN
  7863. RESULT := -RESULT;
  7864. ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7865. SIZEOF( LONGREAL ), loopMatMulIncAXAX, matMulIncX );
  7866. RESULT := -RESULT;
  7867. RETURN RESULT
  7868. END "DECMUL";
  7869. OPERATOR "DECMUL"*( CONST left: ARRAY [ * ] OF LONGREAL; CONST right: ARRAY [ * , * ] OF LONGREAL ): ARRAY [ * ] OF LONGREAL;
  7870. BEGIN
  7871. RESULT := -RESULT;
  7872. ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  7873. SIZEOF( LONGREAL ), loopMatMulIncAXAX, matMulIncX );
  7874. RESULT := -RESULT;
  7875. RETURN RESULT
  7876. END "DECMUL";
  7877. (*** Cross product ********************************************************************)
  7878. OPERATOR "*"*(CONST left, right: ARRAY [ * ] OF SHORTINT ): ARRAY [ * ] OF SHORTINT;
  7879. VAR vl1, vl2, vl3, vr1, vr2, vr3: SHORTINT;
  7880. BEGIN
  7881. IF (LEN( left,0 ) # 3) OR (LEN( right,0 ) # 3) THEN
  7882. Halt( GeometryMismatch, ADDRESSOF( left ), ADDRESSOF( right ), 0 )
  7883. END;
  7884. IF LEN( RESULT,0 ) # 3 THEN NEW( RESULT, 3 ) END; (* will trap if not allowed *)
  7885. vl1 := left[0]; vl2 := left[1]; vl3 := left[2]; vr1 := right[0]; vr2 := right[1];
  7886. vr3 := right[2]; RESULT[0] := vl2 * vr3 - vl3 * vr2;
  7887. RESULT[1] := vl3 * vr1 - vl1 * vr3; RESULT[2] := vl1 * vr2 - vl2 * vr1;
  7888. RETURN RESULT
  7889. END "*";
  7890. OPERATOR "*"*(CONST left, right: ARRAY [ * ] OF INTEGER ): ARRAY [ * ] OF INTEGER;
  7891. VAR vl1, vl2, vl3, vr1, vr2, vr3: INTEGER;
  7892. BEGIN
  7893. IF (LEN( left,0 ) # 3) OR (LEN( right,0 ) # 3) THEN
  7894. Halt( GeometryMismatch, ADDRESSOF( left ), ADDRESSOF( right ), 0 )
  7895. END;
  7896. IF LEN( RESULT,0 ) # 3 THEN NEW( RESULT, 3 ) END; (* will trap if not allowed *)
  7897. vl1 := left[0]; vl2 := left[1]; vl3 := left[2]; vr1 := right[0]; vr2 := right[1];
  7898. vr3 := right[2]; RESULT[0] := vl2 * vr3 - vl3 * vr2;
  7899. RESULT[1] := vl3 * vr1 - vl1 * vr3; RESULT[2] := vl1 * vr2 - vl2 * vr1;
  7900. RETURN RESULT
  7901. END "*";
  7902. OPERATOR "*"*(CONST left, right: ARRAY [ * ] OF LONGINT ): ARRAY [ * ] OF LONGINT;
  7903. VAR vl1, vl2, vl3, vr1, vr2, vr3: LONGINT;
  7904. BEGIN
  7905. IF (LEN( left,0 ) # 3) OR (LEN( right,0 ) # 3) THEN
  7906. Halt( GeometryMismatch, ADDRESSOF( left ), ADDRESSOF( right ), 0 )
  7907. END;
  7908. IF LEN( RESULT,0 ) # 3 THEN NEW( RESULT, 3 ) END; (* will trap if not allowed *)
  7909. vl1 := left[0]; vl2 := left[1]; vl3 := left[2]; vr1 := right[0]; vr2 := right[1];
  7910. vr3 := right[2]; RESULT[0] := vl2 * vr3 - vl3 * vr2;
  7911. RESULT[1] := vl3 * vr1 - vl1 * vr3; RESULT[2] := vl1 * vr2 - vl2 * vr1;
  7912. RETURN RESULT
  7913. END "*";
  7914. OPERATOR "*"*(CONST left, right: ARRAY [ * ] OF REAL ): ARRAY [ * ] OF REAL;
  7915. VAR vl1, vl2, vl3, vr1, vr2, vr3: REAL;
  7916. BEGIN
  7917. IF (LEN( left,0 ) # 3) OR (LEN( right,0 ) # 3) THEN
  7918. Halt( GeometryMismatch, ADDRESSOF( left ), ADDRESSOF( right ), 0 )
  7919. END;
  7920. IF LEN( RESULT,0 ) # 3 THEN NEW( RESULT, 3 ) END; (* will trap if not allowed *)
  7921. vl1 := left[0]; vl2 := left[1]; vl3 := left[2]; vr1 := right[0]; vr2 := right[1];
  7922. vr3 := right[2]; RESULT[0] := vl2 * vr3 - vl3 * vr2;
  7923. RESULT[1] := vl3 * vr1 - vl1 * vr3; RESULT[2] := vl1 * vr2 - vl2 * vr1;
  7924. RETURN RESULT
  7925. END "*";
  7926. OPERATOR "*"*(CONST left, right: ARRAY [ * ] OF LONGREAL ): ARRAY [ * ] OF LONGREAL;
  7927. VAR vl1, vl2, vl3, vr1, vr2, vr3: LONGREAL;
  7928. BEGIN
  7929. IF (LEN( left,0 ) # 3) OR (LEN( right,0 ) # 3) THEN
  7930. Halt( GeometryMismatch, ADDRESSOF( left ), ADDRESSOF( right ), 0 )
  7931. END;
  7932. IF LEN( RESULT,0 ) # 3 THEN NEW( RESULT, 3 ) END; (* will trap if not allowed *)
  7933. vl1 := left[0]; vl2 := left[1]; vl3 := left[2]; vr1 := right[0]; vr2 := right[1];
  7934. vr3 := right[2]; RESULT[0] := vl2 * vr3 - vl3 * vr2;
  7935. RESULT[1] := vl3 * vr1 - vl1 * vr3; RESULT[2] := vl1 * vr2 - vl2 * vr1;
  7936. RETURN RESULT
  7937. END "*";
  7938. OPERATOR "*"*(CONST left, right: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF LONGREAL;
  7939. VAR tensor: Tensor;
  7940. BEGIN
  7941. IF (DIM(left) = 2) & (DIM(right)=2) THEN
  7942. EnsureArrayDesc(2, SYSTEM.VAL(Tensor, RESULT));
  7943. ELSIF (DIM(left) = 2) & (DIM(right)=1) THEN
  7944. EnsureArrayDesc(1, SYSTEM.VAL(Tensor, RESULT));
  7945. ELSE HALT(200);
  7946. END;
  7947. ApplyMatMulLoop(SYSTEM.VAL(Tensor, RESULT), SYSTEM.VAL(Tensor, left), SYSTEM.VAL(Tensor, right), SIZEOF( LONGREAL ),
  7948. loopMatMulAXAX, matMulX );
  7949. RETURN RESULT
  7950. END "*";
  7951. OPERATOR "*"*(CONST left, right: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF REAL;
  7952. BEGIN
  7953. IF (DIM(left) = 2) & (DIM(right)=2) THEN
  7954. EnsureArrayDesc(2, SYSTEM.VAL(Tensor, RESULT));
  7955. ELSIF (DIM(left) = 2) & (DIM(right)=1) THEN
  7956. EnsureArrayDesc(1, SYSTEM.VAL(Tensor, RESULT));
  7957. ELSE HALT(200);
  7958. END;
  7959. ApplyMatMulLoop(SYSTEM.VAL(Tensor, RESULT), SYSTEM.VAL(Tensor, left), SYSTEM.VAL(Tensor, right), SIZEOF( REAL ),
  7960. loopMatMulARAR, matMulR );
  7961. RETURN RESULT
  7962. END "*";
  7963. OPERATOR "*"*(CONST left, right: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF LONGINT;
  7964. BEGIN
  7965. IF (DIM(left) = 2) & (DIM(right)=2) THEN
  7966. EnsureArrayDesc(2, SYSTEM.VAL(Tensor, RESULT));
  7967. ELSIF (DIM(left) = 2) & (DIM(right)=1) THEN
  7968. EnsureArrayDesc(1, SYSTEM.VAL(Tensor, RESULT));
  7969. ELSE HALT(200);
  7970. END;
  7971. ApplyMatMulLoop(SYSTEM.VAL(Tensor, RESULT), SYSTEM.VAL(Tensor, left), SYSTEM.VAL(Tensor, right), SIZEOF( LONGINT ),
  7972. MatMulALALLoop, NIL );
  7973. RETURN RESULT
  7974. END "*";
  7975. OPERATOR "*"*(CONST left, right: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF INTEGER;
  7976. BEGIN
  7977. IF (DIM(left) = 2) & (DIM(right)=2) THEN
  7978. EnsureArrayDesc(2, SYSTEM.VAL(Tensor, RESULT));
  7979. ELSIF (DIM(left) = 2) & (DIM(right)=1) THEN
  7980. EnsureArrayDesc(1, SYSTEM.VAL(Tensor, RESULT));
  7981. ELSE HALT(200);
  7982. END;
  7983. ApplyMatMulLoop(SYSTEM.VAL(Tensor, RESULT), SYSTEM.VAL(Tensor, left), SYSTEM.VAL(Tensor, right), SIZEOF( INTEGER ),
  7984. MatMulAIAILoop,NIL );
  7985. RETURN RESULT
  7986. END "*";
  7987. OPERATOR "*"*(CONST left, right: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF SHORTINT;
  7988. BEGIN
  7989. IF (DIM(left) = 2) & (DIM(right)=2) THEN
  7990. EnsureArrayDesc(2, SYSTEM.VAL(Tensor, RESULT));
  7991. ELSIF (DIM(left) = 2) & (DIM(right)=1) THEN
  7992. EnsureArrayDesc(1, SYSTEM.VAL(Tensor, RESULT));
  7993. ELSE HALT(200);
  7994. END;
  7995. ApplyMatMulLoop(SYSTEM.VAL(Tensor, RESULT), SYSTEM.VAL(Tensor, left), SYSTEM.VAL(Tensor, right), SIZEOF( SHORTINT ),
  7996. MatMulASASLoop, NIL );
  7997. RETURN RESULT
  7998. END "*";
  7999. (** Transpose ********************************************************************)
  8000. PROCEDURE Overlap( src1, src2: ADDRESS ): BOOLEAN;
  8001. VAR from1, from2, to1, to2: ADDRESS; dim: LONGINT;
  8002. BEGIN
  8003. from1 := GetAdr( src1 ); from2 := GetAdr( src2 ); to1 := from1; to2 := from2;
  8004. dim := GetDim( src1 ) - 1;
  8005. WHILE (dim > 0) DO
  8006. to1 := to1 + (GetLen( src1, dim ) - 1) * GetIncr( src1, dim ); DEC( dim );
  8007. END;
  8008. dim := GetDim( src2 ) - 1;
  8009. WHILE (dim > 0) DO
  8010. to2 := to2 + (GetLen( src2, dim ) - 1) * GetIncr( src2, dim ); DEC( dim );
  8011. END;
  8012. IF from1 < from2 THEN RETURN to1 >= from2;
  8013. ELSIF from2 < from1 THEN RETURN to2 >= from1;
  8014. ELSE RETURN TRUE;
  8015. END;
  8016. END Overlap;
  8017. (*
  8018. PROCEDURE Overlap( src1, src2, dim: ADDRESS ): BOOLEAN;
  8019. VAR from1, from2, to1, to2: ADDRESS;
  8020. BEGIN
  8021. from1 := GetAdr( src1 ); from2 := GetAdr( src2 ); to1 := from1; to2 := from2;
  8022. DEC( dim );
  8023. WHILE (dim > 0) DO
  8024. to1 := to1 + (GetLen( src1, dim ) - 1) * GetIncr( src1, dim );
  8025. to2 := to2 + (GetLen( src2, dim ) - 1) * GetIncr( src2, dim ); DEC( dim );
  8026. END;
  8027. IF from1 < from2 THEN RETURN to1 >= from2;
  8028. ELSIF from2 < from1 THEN RETURN to2 >= from1;
  8029. ELSE RETURN TRUE;
  8030. END;
  8031. END Overlap;
  8032. *)
  8033. PROCEDURE AllocateTransposed( VAR dest: ADDRESS; src: ADDRESS;
  8034. elementsize: SIZE ): ANY;
  8035. VAR ptr, data: ANY; Size: LONGINT;
  8036. (* allocate a structure in dest compatible with src, if necessary. returns if allocation has taken place *)
  8037. PROCEDURE TransposedShape( l, r: LONGINT ): BOOLEAN;
  8038. VAR dim,max: LONGINT;
  8039. BEGIN
  8040. dim := GetDim( l );
  8041. IF dim # GetDim( r ) THEN RETURN FALSE END;
  8042. max := dim-1;
  8043. WHILE (dim > 0) DO
  8044. DEC( dim );
  8045. IF GetLen( l, max-dim ) # GetLen( r, dim ) THEN RETURN FALSE END;
  8046. END;
  8047. RETURN TRUE;
  8048. END TransposedShape;
  8049. PROCEDURE UseDescriptor;
  8050. VAR tag: LONGINT;
  8051. BEGIN
  8052. SYSTEM.GET( src - 4, tag );
  8053. Heaps.NewRec( ptr, tag, FALSE );
  8054. dest := SYSTEM.VAL( LONGINT, ptr );
  8055. END UseDescriptor;
  8056. PROCEDURE NewData;
  8057. VAR max,dim, len, size: LONGINT;
  8058. BEGIN
  8059. dim := GetDim( src ); size := elementsize;
  8060. PutDim( dest, dim );
  8061. PutSize( dest, elementsize );
  8062. max := dim-1;
  8063. WHILE (dim > 0) DO
  8064. DEC( dim );
  8065. len := GetLen( src, max-dim ); PutLen( dest, dim, len );
  8066. PutInc( dest, dim, size ); size := size * len;
  8067. END;
  8068. SYSTEM.NEW( data, size );
  8069. PutAdr( dest, data );
  8070. PutPtr( dest, data );
  8071. END NewData;
  8072. BEGIN
  8073. IF dest # 0 THEN Size := GetSize( dest ); ASSERT( Size = elementsize ); END;
  8074. IF debug THEN KernelLog.String( "Allocate same " ); Report( "allocation source", src ); Report( "allocation des", dest ); END;
  8075. IF dest = 0 THEN (* NIL pointer, guaranteed to be tensor *)
  8076. IF TensorFlag IN GetFlags( src ) THEN UseDescriptor();
  8077. ELSE ptr := GetArrayDesc( GetDim( src ) ); dest := SYSTEM.VAL( LONGINT, ptr );
  8078. END;
  8079. PutFlags(dest, {TensorFlag});
  8080. NewData(); RETURN ptr;
  8081. ELSIF GetDim( dest ) # GetDim( src ) THEN (* different dimension *)
  8082. (* check if re-allocation of descriptor is allowed *)
  8083. IF ~(TensorFlag IN GetFlags( dest )) &
  8084. ~(TemporaryFlag IN GetFlags( dest )) THEN (* no, not allowed*)
  8085. HALT( 100 );
  8086. END;
  8087. UseDescriptor();
  8088. PutFlags(dest, {TensorFlag});
  8089. NewData(); RETURN ptr;
  8090. ELSIF (GetAdr( dest ) = 0) OR ~TransposedShape( dest, src ) THEN
  8091. (* check if re-allocation of array data is allowed *)
  8092. IF RangeFlag IN GetFlags( dest ) THEN (* no! not allowed *)
  8093. HALT( 100 );
  8094. END;
  8095. NewData();
  8096. RETURN data;
  8097. ELSE (* nothing to do *)
  8098. RETURN NIL;
  8099. END;
  8100. END AllocateTransposed;
  8101. PROCEDURE Transpose*( dest, left: ADDRESS; Size: LONGINT );
  8102. VAR len0, len1, linc0, linc1, dinc0, dinc1, ladr, dadr: LONGINT; p: ANY;
  8103. PROCEDURE CopyLoop( src, dest, srcinc, destinc, len: LONGINT );
  8104. BEGIN
  8105. WHILE (len > 0) DO
  8106. SYSTEM.MOVE( src, dest, Size ); INC( src, srcinc ); INC( dest, destinc );
  8107. DEC( len );
  8108. END;
  8109. END CopyLoop;
  8110. BEGIN
  8111. IF TemporaryFlag IN GetFlags( dest ) THEN (* destination is on the stack: can optimize transposition *)
  8112. PutAdr( dest, GetAdr( left ) ); PutPtr( dest, GetPtr( left ) );
  8113. PutLen( dest, 1, GetLen( left, 0 ) ); PutLen( dest, 0, GetLen( left, 1 ) );
  8114. PutInc( dest, 1, GetIncr( left, 0 ) ); PutInc( dest, 0, GetIncr( left, 1 ) );
  8115. ELSE
  8116. len0 := GetLen( left, 0 ); len1 := GetLen( left, 1 );
  8117. p := AllocateTransposed(dest,left,Size);
  8118. IF Overlap( left, dest ) THEN (* copy data first, then transpose *)
  8119. SYSTEM.NEW( p, len0 * len1 * Size ); dinc0 := Size; dinc1 := len0 * Size;
  8120. dadr := SYSTEM.VAL( LONGINT, p ); linc0 := GetIncr( left, 0 );
  8121. linc1 := GetIncr( left, 1 ); ladr := GetAdr( left );
  8122. WHILE (len0 > 0) DO
  8123. CopyLoop( ladr, dadr, linc1, dinc1, len1 ); INC( ladr, linc0 );
  8124. INC( dadr, dinc0 ); DEC( len0 );
  8125. END;
  8126. len0 := GetLen( left, 0 ); linc0 := Size; linc1 := len0 * Size;
  8127. ladr := SYSTEM.VAL( LONGINT, p );
  8128. ELSE
  8129. linc0 := GetIncr( left, 0 ); linc1 := GetIncr( left, 1 ); ladr := GetAdr( left );
  8130. END;
  8131. dinc0 := GetIncr( dest, 0 ); dinc1 := GetIncr( dest, 1 );
  8132. dadr := GetAdr( dest );
  8133. IF (Size = 4) & (transpose4 # NIL ) THEN
  8134. transpose4( ladr, dadr, linc0, linc1, dinc0, dinc1, len0, len1 );
  8135. ELSIF (Size = 8) & (transpose8 # NIL ) THEN
  8136. transpose8( ladr, dadr, linc0, linc1, dinc0, dinc1, len0, len1 );
  8137. ELSE
  8138. WHILE (len0 > 0) DO
  8139. CopyLoop( ladr, dadr, linc1, dinc0, len1 ); INC( ladr, linc0 );
  8140. INC( dadr, dinc1 ); DEC( len0 );
  8141. END;
  8142. END;
  8143. END;
  8144. END Transpose;
  8145. OPERATOR "`"*(CONST left: ARRAY [ * , * ] OF SHORTINT): ARRAY [ * , * ] OF SHORTINT;
  8146. BEGIN
  8147. Transpose( ADDRESSOF( RESULT ), ADDRESSOF( left ), SIZEOF( SHORTINT ) );
  8148. RETURN RESULT
  8149. END "`";
  8150. OPERATOR "`"*( CONST left: ARRAY [ * , * ] OF INTEGER ):ARRAY [ * , * ] OF INTEGER ;
  8151. BEGIN
  8152. Transpose( ADDRESSOF( RESULT ), ADDRESSOF( left ), SIZEOF( INTEGER ) );
  8153. RETURN RESULT
  8154. END "`";
  8155. OPERATOR "`"*( CONST left: ARRAY [ * , * ] OF LONGINT ): ARRAY [ * , * ] OF LONGINT;
  8156. BEGIN
  8157. Transpose( ADDRESSOF( RESULT ), ADDRESSOF( left ), SIZEOF( LONGINT ) );
  8158. RETURN RESULT
  8159. END "`";
  8160. OPERATOR "`"*( CONST left: ARRAY [ * , * ] OF REAL ): ARRAY [ * , * ] OF REAL;
  8161. BEGIN
  8162. Transpose( ADDRESSOF( RESULT ), ADDRESSOF( left ), SIZEOF( REAL ) );
  8163. RETURN RESULT
  8164. END "`";
  8165. OPERATOR "`"*( CONST left: ARRAY [ * , * ] OF LONGREAL ): ARRAY [ * , * ] OF LONGREAL;
  8166. BEGIN
  8167. Transpose( ADDRESSOF( RESULT ), ADDRESSOF( left ), SIZEOF( LONGREAL ) );
  8168. RETURN RESULT
  8169. END "`";
  8170. PROCEDURE CheckTensorGeometry( left, right, dest: ADDRESS; ldim, rdim: LONGINT ): BOOLEAN;
  8171. VAR i: LONGINT;
  8172. BEGIN
  8173. FOR i := 0 TO rdim - 1 DO
  8174. IF GetLen( right, i ) # GetLen( dest, i ) THEN RETURN FALSE END;
  8175. END;
  8176. FOR i := 0 TO ldim - 1 DO
  8177. IF GetLen( left, i ) # GetLen( dest, rdim + i ) THEN RETURN FALSE END;
  8178. END;
  8179. RETURN TRUE;
  8180. END CheckTensorGeometry;
  8181. (*
  8182. PROCEDURE Zero(p: ANY; size: LONGINT);
  8183. VAR adr: LONGINT;
  8184. BEGIN
  8185. adr := SYSTEM.VAL(LONGINT,p);
  8186. WHILE(size>0) DO
  8187. SYSTEM.PUT8(adr,0); DEC(size);INC(adr);
  8188. END;
  8189. END Zero;
  8190. *)
  8191. PROCEDURE DoReshape*( VAR dest: LONGINT; src: LONGINT; CONST shape: ARRAY [ * ] OF LONGINT );
  8192. VAR i, Size: LONGINT; ptr, data: ANY; new: LONGINT;
  8193. oldSize, newSize: LONGINT; oldDim, newDim: LONGINT;
  8194. squeezingReshape: BOOLEAN;
  8195. PROCEDURE NewDescriptor;
  8196. BEGIN
  8197. ptr := GetArrayDesc( newDim ); new := SYSTEM.VAL( LONGINT, ptr );
  8198. END NewDescriptor;
  8199. (* Added by Alexey
  8200. Returns TRUE if the new shape is the result of squeezing (removing of singleton dimensions)
  8201. *)
  8202. PROCEDURE SqueezingReshape(): BOOLEAN;
  8203. VAR
  8204. i, j, n: LONGINT;
  8205. BEGIN
  8206. IF oldDim > newDim THEN
  8207. i := 0; j := 0;
  8208. WHILE (i < oldDim) & (j < newDim) DO
  8209. n := GetLen(src,i);
  8210. IF n = shape[j] THEN INC(j); END;
  8211. INC(i);
  8212. END;
  8213. WHILE (i < oldDim) & (GetLen(src,i) = 1) DO INC(i); END; (* account for a trailing sequence of 1 *)
  8214. ELSE
  8215. squeezingReshape := FALSE;
  8216. END;
  8217. squeezingReshape := (i = oldDim) & (j = newDim);
  8218. RETURN squeezingReshape;
  8219. END SqueezingReshape;
  8220. (*returns TRUE if the target is already allocated coninuous memory of correct length*)
  8221. PROCEDURE TargetContinuous(): BOOLEAN;
  8222. VAR
  8223. i, n: LONGINT;
  8224. continue: BOOLEAN;
  8225. BEGIN
  8226. i := GetDim(dest)-1; n := GetIncr(dest,i);
  8227. continue := TRUE;
  8228. WHILE (i > 0) & continue DO
  8229. n := n * GetLen(dest,i);
  8230. DEC(i);
  8231. continue := GetIncr(dest,i) = n;
  8232. END;
  8233. (*TRACE(i,continue,Size,GetSize(dest));*)
  8234. (*tod obviously size is not what I expect it to be*)
  8235. IF (i = 0) & continue & (Size=GetSize(dest)) THEN (* destination array is continuous memory of the proper lenght *)
  8236. RETURN TRUE;
  8237. ELSE
  8238. RETURN FALSE;
  8239. END;
  8240. END TargetContinuous;
  8241. (* returns TRUE if reshape preserves contiguity pattern and thus is valid even for subranged arrays *)
  8242. PROCEDURE PreservesContiguity(): BOOLEAN;
  8243. VAR
  8244. i, n: LONGINT;
  8245. continue: BOOLEAN;
  8246. BEGIN
  8247. i := oldDim-1; n := GetIncr(src,i);
  8248. continue := TRUE;
  8249. WHILE (i > 0) & continue DO
  8250. n := n * GetLen(src,i);
  8251. DEC(i);
  8252. continue := GetIncr(src,i) = n;
  8253. END;
  8254. IF (i = 0) & continue THEN (* array can be fully linearized and, therefore, can be reshaped to any size *)
  8255. RETURN TRUE;
  8256. ELSE Err("Not yet implemented!");
  8257. END;
  8258. END PreservesContiguity;
  8259. (* Added by Alexey *)
  8260. PROCEDURE NewDescriptorForSameData;
  8261. VAR len, size, i, j: LONGINT;
  8262. BEGIN
  8263. ptr := GetArrayDesc( newDim ); new := SYSTEM.VAL( LONGINT, ptr );
  8264. IF ~squeezingReshape THEN
  8265. size := Size;
  8266. FOR i := newDim - 1 TO 0 BY -1 DO
  8267. len := shape[i]; PutInc( new, i, size ); PutLen( new, i, len );
  8268. size := size * len;
  8269. END;
  8270. ELSE (* squeezing reshape *)
  8271. j := 0; len := shape[j];
  8272. FOR i := 0 TO oldDim-1 DO
  8273. IF GetLen(src,i) = len THEN
  8274. PutInc(new,j,GetIncr(src,i)); PutLen(new,j,len);
  8275. INC(j);
  8276. IF j < newDim THEN len := shape[j]; END;
  8277. END;
  8278. END;
  8279. END;
  8280. IF RangeFlag IN GetFlags(src) THEN (* keep range awareness for case of squeezing reshape and preservation of contiguity *)
  8281. PutFlags(new,GetFlags(new)+{RangeFlag});
  8282. END;
  8283. PutAdr( new, GetAdr(src) );
  8284. PutPtr( new, GetPtr(src) ); PutDim( new, newDim );
  8285. PutSize( new, Size );
  8286. END NewDescriptorForSameData;
  8287. PROCEDURE NewData;
  8288. VAR len, size, i: LONGINT;
  8289. BEGIN
  8290. size := Size;
  8291. FOR i := newDim - 1 TO 0 BY -1 DO
  8292. len := shape[i]; PutInc( new, i, size ); PutLen( new, i, len );
  8293. size := size * len;
  8294. END;
  8295. SYSTEM.NEW( data, size ); (* Zero(data,size*Size); *)
  8296. PutAdr( new, data );
  8297. PutPtr( new, data ); PutDim( new, newDim );
  8298. PutSize( new, Size );
  8299. END NewData;
  8300. PROCEDURE CopyData;
  8301. VAR d, s, dadr: LONGINT;
  8302. PROCEDURE Loop( dim: LONGINT; sadr: LONGINT );
  8303. VAR inc, len, i: LONGINT;
  8304. BEGIN
  8305. IF dim = d THEN
  8306. inc := GetIncr( src, dim ); len := GetLen( src, dim );
  8307. FOR i := 0 TO len - 1 DO
  8308. SYSTEM.MOVE( sadr, dadr, s ); INC( dadr, s ); INC( sadr, inc );
  8309. END;
  8310. ELSE
  8311. inc := GetIncr( src, dim ); len := GetLen( src, dim ); INC( dim );
  8312. FOR i := 0 TO len - 1 DO Loop( dim, sadr ); INC( sadr, inc ); END;
  8313. END;
  8314. END Loop;
  8315. BEGIN
  8316. s := Size; ASSERT( GetSize( src ) = s ); d := GetDim( src ) - 1;
  8317. WHILE (d >= 0) & (GetIncr( src, d ) = s) DO
  8318. s := s * GetLen( src, d ); DEC( d );
  8319. END;
  8320. IF d = -1 THEN (* special case: both continuous *)
  8321. SYSTEM.MOVE( GetAdr( src ), GetAdr( new ), s );
  8322. ELSE dadr := GetAdr( new ); Loop( 0, GetAdr( src ) );
  8323. END;
  8324. END CopyData;
  8325. PROCEDURE CopyDataBack;
  8326. VAR d, s: LONGINT; sadr: LONGINT;
  8327. PROCEDURE Loop( dim: LONGINT; dadr: LONGINT );
  8328. VAR inc, len, i: LONGINT;
  8329. BEGIN
  8330. IF dim = d THEN
  8331. inc := GetIncr( dest, dim ); len := GetLen( dest, dim );
  8332. FOR i := 0 TO len - 1 DO
  8333. SYSTEM.MOVE( sadr, dadr, s ); INC( dadr, inc ); INC( sadr, s );
  8334. END;
  8335. ELSE
  8336. inc := GetIncr( dest, dim ); len := GetLen( dest, dim ); INC( dim );
  8337. FOR i := 0 TO len - 1 DO Loop( dim, dadr ); INC( dadr, inc ); END;
  8338. END;
  8339. END Loop;
  8340. BEGIN
  8341. s := Size; ASSERT( GetSize( dest ) = s ); d := GetDim( dest ) - 1;
  8342. WHILE (d >= 0) & (GetIncr( dest, d ) = s) DO
  8343. s := s * GetLen( dest, d ); DEC( d );
  8344. END;
  8345. IF d = -1 THEN (* special case: both continuous *)
  8346. SYSTEM.MOVE( GetAdr( new ), GetAdr( dest ), s );
  8347. ELSE sadr := GetAdr( new ); Loop( 0, GetAdr( dest ) );
  8348. END;
  8349. END CopyDataBack;
  8350. PROCEDURE CopyDescriptor( src, dest: LONGINT );
  8351. BEGIN
  8352. ASSERT( GetDim( src ) = GetDim( dest ) );
  8353. SYSTEM.MOVE( src, dest, MathLenOffset + GetDim( src ) * 8 );
  8354. END CopyDescriptor;
  8355. PROCEDURE ShapeDiffers( ): BOOLEAN;
  8356. VAR i: LONGINT;
  8357. BEGIN
  8358. ASSERT(GetDim(dest) = newDim);
  8359. FOR i := 0 TO newDim - 1 DO
  8360. IF GetLen(dest,i) # shape[i] THEN RETURN TRUE END;
  8361. END;
  8362. RETURN FALSE;
  8363. END ShapeDiffers;
  8364. BEGIN
  8365. (*
  8366. cases
  8367. 1.) descriptor may be replaced = dimension may vary: dest = TENSOR
  8368. 2.) descriptor may be reshaped: dest = ARRAY but no RANGE
  8369. 3.) descriptor may not be reshaped: dest = RANGE
  8370. *)
  8371. (* first check invariants *)
  8372. oldDim := GetDim( src );
  8373. IF oldDim = 0 THEN oldSize := 0
  8374. ELSE
  8375. oldSize := 1;
  8376. FOR i := 0 TO oldDim - 1 DO oldSize := oldSize * GetLen( src, i ); END;
  8377. END;
  8378. newDim := LEN( shape, 0 );
  8379. IF newDim = 0 THEN newSize := 0
  8380. ELSE
  8381. newSize := 1;
  8382. FOR i := 0 TO newDim - 1 DO newSize := newSize * shape[i]; END;
  8383. END;
  8384. IF oldSize # newSize THEN Err( "RESHAPE: Total length mismatch" ); END;
  8385. Size := GetSize( src );
  8386. ASSERT( (Size > 0) & (Size < 128) ); (*! heuristic, remove upper bound *)
  8387. IF dest = src THEN (* added by Alexey *)
  8388. IF ~(RangeFlag IN GetFlags(dest)) OR PreservesContiguity() OR SqueezingReshape() THEN
  8389. NewDescriptorForSameData;
  8390. dest := new;
  8391. ELSIF ((newDim = oldDim) & ~ShapeDiffers()) THEN
  8392. (* create a copy of the original descriptor *)
  8393. ptr := GetArrayDesc(newDim); dest := SYSTEM.VAL(LONGINT,ptr); CopyDescriptor(src,dest);
  8394. ELSE
  8395. Err( "RESHAPE: given RANGE array can not be reshaped!" );
  8396. END;
  8397. ELSIF (dest = 0) THEN (* is tensor for sure *)
  8398. NewDescriptor; NewData; CopyData; dest := new;
  8399. ELSIF TargetContinuous() THEN
  8400. NewDescriptor; new:=dest; CopyData;
  8401. (*todo: check if target continous memory of correct size, if so don't allocate memory*)
  8402. ELSIF (newDim # GetDim( dest )) THEN (* must be tensor *)
  8403. IF ~(TensorFlag IN GetFlags( dest )) THEN (* no, not allowed*)
  8404. Err( "RESHAPE: new dimension only allowed for TENSOR" );
  8405. END;
  8406. NewDescriptor; NewData; CopyData; dest := new;
  8407. ELSIF ShapeDiffers() THEN (* same dim but shape of destination does not match *)
  8408. IF RangeFlag IN GetFlags( dest ) THEN Err( "RESHAPE: new shape not allowed for RANGE" ); END;
  8409. NewDescriptor; NewData; CopyData; CopyDescriptor( new, dest );
  8410. ELSIF ~SameShape( src, dest ) THEN (* shape for destination matches but that of src is different *)
  8411. NewDescriptor; NewData; CopyData; CopyDataBack;
  8412. ELSE (* same shape, just copy *)
  8413. CopyContent( src, dest, Size ); RETURN;
  8414. END;
  8415. END DoReshape;
  8416. PROCEDURE AllocateTensorA*( CONST a: ARRAY OF SIZE; elementSize: SIZE; tag: ADDRESS; VAR dest: UnsafeArray );
  8417. VAR descr, data: ANY; same: BOOLEAN; i: LONGINT; dim: LONGINT;
  8418. PROCEDURE NewData;
  8419. VAR len, size, i: SIZE;
  8420. BEGIN
  8421. size := elementSize;
  8422. FOR i := dim - 1 TO 0 BY -1 DO
  8423. len := a[i];
  8424. PutInc( dest, i, size ); PutLen( dest, i, len ); size := size * len;
  8425. END;
  8426. IF tag = 0 THEN
  8427. SYSTEM.NEW( data, size ); (* Zero(data,size*Size); *)
  8428. PutAdr( dest, data );
  8429. ELSE
  8430. Heaps.NewArr(data, tag, size DIV elementSize,1,FALSE);
  8431. PutAdr(dest, data + ArrDataArrayOffset);
  8432. END;
  8433. PutPtr( dest, data ); PutSize( dest, elementSize );
  8434. END NewData;
  8435. PROCEDURE ClearData;
  8436. (*! todo *)
  8437. END ClearData;
  8438. BEGIN
  8439. dim := LEN( a,0 );
  8440. IF (dest = 0) OR (dim # GetDim( dest )) THEN
  8441. IF dest # 0 THEN
  8442. IF (~(TensorFlag IN GetFlags( dest ))) THEN Err( "Array's number of dimension must not be modified (no TENSOR !)" ); END;
  8443. END;
  8444. descr := GetArrayDesc( LEN( a,0 ) ); dest := descr;
  8445. NewData;
  8446. ELSE
  8447. i := 0;
  8448. WHILE (i < dim) & same DO
  8449. IF GetLen( dest, i ) # a[i] THEN same := FALSE; END;
  8450. INC( i );
  8451. END;
  8452. IF ~same THEN
  8453. IF (RangeFlag IN GetFlags( dest )) THEN Err( "Array's shape must not be modified (is RANGE !) " ); END;
  8454. NewData
  8455. ELSE ClearData
  8456. END;
  8457. END;
  8458. END AllocateTensorA;
  8459. PROCEDURE AllocateArrayA*( CONST a: ARRAY OF SIZE; elementSize: SIZE; tag: ADDRESS; dest: UnsafeArray );
  8460. BEGIN
  8461. AllocateTensorA(a,elementSize,tag,dest);
  8462. END AllocateArrayA;
  8463. PROCEDURE AllocateTensorX*( VAR destA: ARRAY [?]; CONST a: ARRAY [ * ] OF LONGINT; Size: SIZE; tag: ADDRESS );
  8464. VAR descr, data: ANY; same: BOOLEAN; i: LONGINT; dim: SIZE; dest: ADDRESS;
  8465. PROCEDURE NewData;
  8466. VAR len, size: SIZE; i: LONGINT;
  8467. BEGIN
  8468. size := Size;
  8469. FOR i := dim - 1 TO 0 BY -1 DO
  8470. len := a[i];
  8471. (*
  8472. KernelLog.Int(len,10); KernelLog.Ln;
  8473. *)
  8474. PutInc( dest, i, size ); PutLen( dest, i, len ); size := size * len;
  8475. END;
  8476. IF tag = 0 THEN
  8477. SYSTEM.NEW( data, size ); (* Zero(data,size*Size); *)
  8478. PutAdr( dest, data );
  8479. ELSE
  8480. Heaps.NewArr(data, tag, size DIV Size,1,FALSE);
  8481. PutAdr( dest, data+ ArrDataArrayOffset );
  8482. END;
  8483. PutPtr( dest, data ); PutSize( dest, Size );
  8484. END NewData;
  8485. PROCEDURE ClearData;
  8486. (*! todo *)
  8487. END ClearData;
  8488. BEGIN
  8489. dim := LEN( a,0 );
  8490. dest := SYSTEM.VAL(ADDRESS,destA);
  8491. (*! check range flag! *)
  8492. IF (dest = 0) OR (dim # GetDim( dest )) THEN
  8493. IF dest # 0 THEN
  8494. IF (~(TensorFlag IN GetFlags( dest ))) THEN Err( "Array's number of dimension must not be modified (no TENSOR !)" ); END;
  8495. END;
  8496. descr := GetArrayDesc( LEN( a,0 ) ); dest := descr;
  8497. NewData;
  8498. ELSE
  8499. i := 0;
  8500. WHILE (i < dim) & same DO
  8501. IF GetLen( dest, i ) # a[i] THEN same := FALSE; END;
  8502. INC( i );
  8503. END;
  8504. IF ~same THEN
  8505. IF (RangeFlag IN GetFlags( dest )) THEN Err( "Array's shape must not be modified (is RANGE !) " ); END;
  8506. NewData
  8507. ELSE ClearData
  8508. END;
  8509. END;
  8510. SYSTEM.PUT(ADDRESSOF(destA),dest);
  8511. END AllocateTensorX;
  8512. PROCEDURE LenA*( VAR dest: ARRAY [ * ] OF SIZE; src: ADDRESS );
  8513. VAR dim, i: LONGINT;
  8514. BEGIN
  8515. dim := GetDim( src );
  8516. IF LEN( dest, 0 ) # dim THEN NEW( dest, dim ); END;
  8517. FOR i := 0 TO dim - 1 DO dest[i] := GetLen( src, i ); END;
  8518. END LenA;
  8519. PROCEDURE IncrA*( VAR dest: ARRAY [ * ] OF SIZE; src: ADDRESS );
  8520. VAR dim, len: SIZE; i: LONGINT;
  8521. BEGIN
  8522. dim := GetDim( src ); len := LEN( dest, 0 );
  8523. IF len # dim THEN NEW( dest, dim ); END;
  8524. FOR i := 0 TO dim - 1 DO dest[i] := GetIncr( src, i ); END;
  8525. END IncrA;
  8526. PROCEDURE Len*(src: ADDRESS; d: SIZE): SIZE;
  8527. VAR dim: SIZE;
  8528. BEGIN
  8529. dim := GetDim(src);
  8530. IF (d<0) OR (d>=dim) THEN HALT(100)
  8531. ELSE
  8532. RETURN GetLen(src,d);
  8533. END;
  8534. END Len;
  8535. PROCEDURE Incr*(src: ADDRESS; d: SIZE): SIZE;
  8536. VAR dim: SIZE;
  8537. BEGIN
  8538. dim := GetDim(src);
  8539. IF (d<0) OR (d>=dim) THEN HALT(100)
  8540. ELSE
  8541. RETURN GetIncr(src,d);
  8542. END;
  8543. END Incr;
  8544. PROCEDURE AllocateTensor( VAR dest: ADDRESS; left, right: ADDRESS;
  8545. Size: SIZE ): ANY;
  8546. VAR ldim, rdim: SIZE; ptr, data: ANY;
  8547. PROCEDURE NewData;
  8548. VAR len, size, i: SIZE;
  8549. BEGIN
  8550. size := 1;
  8551. FOR i := 0 TO ldim - 1 DO
  8552. len := GetLen( left, i ); size := size * len; PutLen( dest, i, len );
  8553. END;
  8554. FOR i := 0 TO rdim - 1 DO
  8555. len := GetLen( right, i ); size := size * len; PutLen( dest, ldim + i, len );
  8556. END;
  8557. SYSTEM.NEW( data, size * Size ); (* Zero(data,size*Size); *)
  8558. (*
  8559. KernelLog.String("adr data="); KernelLog.Int(SYSTEM.VAL(LONGINT,data),10); KernelLog.Ln;
  8560. KernelLog.String("adr dest="); KernelLog.Int(dest,10); KernelLog.Ln;
  8561. *)
  8562. size := Size;
  8563. FOR i := ldim + rdim - 1 TO 0 BY -1 DO
  8564. PutInc( dest, i, size ); size := size * GetLen( dest, i );
  8565. END;
  8566. PutAdr( dest, data );
  8567. PutPtr( dest, data );
  8568. END NewData;
  8569. BEGIN
  8570. ldim := GetDim( left ); rdim := GetDim( right );
  8571. IF dest = 0 THEN (* NIL pointer, guaranteed to be tensor *)
  8572. ptr := GetArrayDesc( ldim + rdim ); dest := ptr;
  8573. NewData(); RETURN ptr;
  8574. ELSIF (ldim + rdim # GetDim( dest )) THEN
  8575. IF ~(TensorFlag IN GetFlags( dest )) &
  8576. ~(TemporaryFlag IN GetFlags( dest )) THEN (* no, not allowed*)
  8577. HALT( 100 );
  8578. END;
  8579. ptr := GetArrayDesc( ldim + rdim ); dest := ptr;
  8580. NewData(); RETURN ptr;
  8581. ELSIF ~CheckTensorGeometry( left, right, dest, ldim, rdim ) THEN (* dimension matches but not geometry *)
  8582. IF RangeFlag IN GetFlags( dest ) THEN (* no! not allowed *)
  8583. HALT( 100 );
  8584. END;
  8585. NewData(); RETURN data;
  8586. END;
  8587. RETURN NIL;
  8588. END AllocateTensor;
  8589. (* find the largest block with a regular pattern of the form offset+{i*linc: 0<=i<len} for two arrays simultaneously. d is dimension applying to the resulting loop *)
  8590. PROCEDURE FindPatternTensor( left, right: ADDRESS;
  8591. VAR rdim, len, linc, ri: SIZE );
  8592. (* geometric precondition: lengths must coincide *)
  8593. VAR ldim: LONGINT;
  8594. BEGIN
  8595. ldim := GetDim( left ) - 1; rdim := GetDim( right ) - 1;
  8596. len := GetLen( left, ldim ); ASSERT( len = GetLen( right, rdim ) );
  8597. WHILE (len = 1) & (ldim > 0) & (rdim > 0) DO
  8598. DEC( ldim ); DEC( rdim ); len := GetLen( left, ldim );
  8599. ASSERT( GetLen( left, ldim ) = GetLen( right, rdim ) );
  8600. END;
  8601. linc := GetIncr( left, ldim ); ri := GetIncr( right, rdim ); DEC( rdim );
  8602. DEC( ldim );
  8603. WHILE (ldim >= 0) & (rdim >= 0) & (GetIncr( left, ldim ) = len * linc) &
  8604. (GetIncr( right, rdim ) = len * ri) DO
  8605. len := len * GetLen( left, ldim );
  8606. ASSERT( GetLen( left, ldim ) = GetLen( right, rdim ) ); DEC( rdim );
  8607. DEC( ldim );
  8608. END;
  8609. INC( ldim ); INC( rdim );
  8610. IF debug THEN
  8611. KernelLog.String( "FindPatternTensor: " ); KernelLog.Int( rdim, 10 ); KernelLog.Int( len, 10 );
  8612. KernelLog.Int( linc, 10 ); KernelLog.Int( ri, 10 ); KernelLog.Ln;
  8613. END;
  8614. END FindPatternTensor;
  8615. PROCEDURE ApplyTensorAAAOp( d, l, r: ADDRESS; elementSize: LONGINT;
  8616. Loop: BinaryASALoop );
  8617. VAR loopd, looplen, loopri, loopdi, lDim, rDim: LONGINT; p: ANY;
  8618. origdest: LONGINT; left, right, dest: ADDRESS;
  8619. PROCEDURE Traverse( ladr, radr, dadr: ADDRESS; ldim, rdim: LONGINT );
  8620. VAR len: LONGINT; linc, rinc, dinc: LONGINT;
  8621. BEGIN
  8622. IF (ldim < lDim) THEN
  8623. len := GetLen( left, ldim ); linc := GetIncr( left, ldim );
  8624. dinc := GetIncr( dest, ldim + rdim ); INC( ldim );
  8625. WHILE (len > 0) DO
  8626. Traverse( ladr, radr, dadr, ldim, rdim ); INC( ladr, linc );
  8627. INC( dadr, dinc ); DEC( len );
  8628. END;
  8629. ELSIF (rdim # loopd) THEN
  8630. len := GetLen( right, rdim ); rinc := GetIncr( right, rdim );
  8631. dinc := GetIncr( dest, ldim + rdim ); INC( rdim );
  8632. WHILE (len > 0) DO
  8633. Traverse( ladr, radr, dadr, ldim, rdim ); INC( radr, rinc );
  8634. INC( dadr, dinc ); DEC( len );
  8635. END;
  8636. ELSE
  8637. (*
  8638. KernelLog.String("MulALSLLoop"); KernelLog.Int(dadr,10); KernelLog.Int(loopdi,10); KernelLog.Int(looplen,10);
  8639. KernelLog.Int(GetAdr(dest),10);
  8640. KernelLog.Int(GetAdr(dest)+clen,10);
  8641. KernelLog.Ln;
  8642. *)
  8643. Loop( radr, ladr, dadr, loopri, loopdi, looplen );
  8644. (* loop over right matrix and destination highest continuous dimension D[x,y,z,..] := L[x,y] ** R[z,..] *)
  8645. END;
  8646. END Traverse;
  8647. BEGIN
  8648. SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); SYSTEM.GET( r, right );
  8649. (* check array lengths *)
  8650. origdest := 0; lDim := GetDim( left ); rDim := GetDim( right );
  8651. p := AllocateTensor( dest, left, right, elementSize );
  8652. (*
  8653. IF (dest = 0) OR (GetPtr( dest ) = 0) THEN
  8654. p := AllocateTensor( left, right, dest, elementSize )
  8655. ELSIF ~CheckTensorGeometry( left, right, dest, lDim, rDim ) THEN
  8656. IF GetPtr( dest ) = -1 THEN HALT( GeometryMismatch )
  8657. ELSE p := AllocateTensor( left, right, dest, elementSize );
  8658. END;
  8659. (*! to be done: treat overlapping memory *)
  8660. END;
  8661. *)
  8662. (* debugging *)
  8663. IF debug THEN Report( "AAA:left", left ); Report( "AAA:right", right ); Report( "AAA:dest", dest ); END;
  8664. (* check pattern: longest piece that can be done with a loop *)
  8665. FindPatternTensor( dest, right, loopd, looplen, loopri, loopdi );
  8666. (* run through dimensions *)
  8667. Traverse( GetAdr( left ), GetAdr( right ), GetAdr( dest ), 0, 0 );
  8668. SYSTEM.PUT( d, dest );
  8669. END ApplyTensorAAAOp;
  8670. OPERATOR "**"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT;
  8671. BEGIN
  8672. ApplyTensorAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  8673. SIZEOF( SHORTINT ), MulASSSLoop );
  8674. RETURN RESULT
  8675. END "**";
  8676. OPERATOR "**"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER;
  8677. BEGIN
  8678. ApplyTensorAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  8679. SIZEOF( INTEGER ), MulAISILoop );
  8680. RETURN RESULT
  8681. END "**";
  8682. OPERATOR "**"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT;
  8683. BEGIN
  8684. ApplyTensorAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  8685. SIZEOF( LONGINT ), MulALSLLoop );
  8686. RETURN RESULT
  8687. END "**";
  8688. OPERATOR "**"*(CONST left,right: ARRAY [?] OF REAL): ARRAY [?] OF REAL;
  8689. BEGIN
  8690. ApplyTensorAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ),
  8691. loopMulARSR );
  8692. RETURN RESULT
  8693. END "**";
  8694. OPERATOR "**"*(CONST left,right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL;
  8695. BEGIN
  8696. ApplyTensorAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ),
  8697. SIZEOF( LONGREAL ), loopMulAXSX );
  8698. RETURN RESULT
  8699. END "**";
  8700. OPERATOR "**"*(CONST left,right: ARRAY [?] OF COMPLEX): ARRAY [?] OF COMPLEX;
  8701. BEGIN
  8702. ApplyTensorAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( COMPLEX ),
  8703. loopMulAZSZ );
  8704. RETURN RESULT
  8705. END "**";
  8706. OPERATOR "**"*(CONST left,right: ARRAY [?] OF LONGCOMPLEX): ARRAY [?] OF LONGCOMPLEX;
  8707. BEGIN
  8708. ApplyTensorAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGCOMPLEX ),
  8709. loopMulALZSLZ );
  8710. RETURN RESULT
  8711. END "**";
  8712. PROCEDURE InitOptimization;
  8713. VAR p: PROCEDURE;
  8714. BEGIN
  8715. GETPROCEDURE("FoxArrayBaseOptimized","Install",p);
  8716. IF p # NIL THEN
  8717. p;
  8718. ELSE
  8719. KernelLog.String( "Warning: ArrayBase runtime library optimizer not installed." ); KernelLog.Ln;
  8720. END;
  8721. END InitOptimization;
  8722. PROCEDURE CopyDescriptor*(VAR destPtr: ANY; src: LONGINT; prefixIndices, prefixRanges, suffixIndices, suffixRanges: LONGINT);
  8723. VAR size: SIZE; srcDim, destDim,i,len,incr: LONGINT; dest: ADDRESS;
  8724. BEGIN
  8725. IF src = 0 THEN
  8726. HALT(100);
  8727. ELSE
  8728. srcDim := GetDim(src);
  8729. destDim := srcDim - prefixIndices - suffixIndices;
  8730. (*
  8731. KernelLog.String("srcDim "); KernelLog.Int(srcDim,1); KernelLog.Ln;
  8732. KernelLog.String("prefixIndices "); KernelLog.Int(prefixIndices,1); KernelLog.Ln;
  8733. KernelLog.String("prefixRanges "); KernelLog.Int(prefixRanges,1); KernelLog.Ln;
  8734. KernelLog.String("suffixIndices "); KernelLog.Int(suffixIndices,1); KernelLog.Ln;
  8735. KernelLog.String("suffixRanges "); KernelLog.Int(suffixRanges,1); KernelLog.Ln;
  8736. KernelLog.String("destDim "); KernelLog.Int(destDim,1); KernelLog.Ln;
  8737. *)
  8738. destPtr := GetArrayDesc(destDim);
  8739. dest := SYSTEM.VAL(LONGINT,destPtr);
  8740. (* SYSTEM.MOVE(src,dest,MathLenOffset); *)
  8741. PutAdr(dest,GetAdr(src));
  8742. PutPtr(dest,GetPtr(src));
  8743. PutFlags(dest,GetFlags(src));
  8744. PutSize(dest,GetSize(src));
  8745. FOR i := 0 TO srcDim-suffixIndices-suffixRanges-prefixIndices-prefixRanges-1 DO
  8746. srcDim := i + prefixIndices + prefixRanges;
  8747. destDim := i + prefixRanges;
  8748. len := GetLen(src,srcDim);
  8749. incr := GetIncr(src,srcDim);
  8750. PutLen(dest,destDim,len);
  8751. PutInc(dest,destDim,incr);
  8752. END;
  8753. (*
  8754. Report("copy descriptor src",src);
  8755. Report("copy descriptor dest",dest);
  8756. *)
  8757. END;
  8758. END CopyDescriptor;
  8759. (* when Reshape is called by a compiler, the arguments are - for the compiler - replaced as follows, this makes them compatible
  8760. VAR dest: ARRAY [?] OF basetype
  8761. CONST src: ARRAY [?] OF basetype
  8762. CONST shape: ARRAY [*] OF LONGINT
  8763. *)
  8764. PROCEDURE Reshape*(CONST left: ARRAY [?]; CONST right: ARRAY [*] OF LONGINT): ARRAY [?];
  8765. BEGIN
  8766. DoReshape(SYSTEM.VAL(LONGINT,RESULT), SYSTEM.VAL(LONGINT,left), right);
  8767. RETURN RESULT
  8768. END Reshape;
  8769. (* OLIVIER *)
  8770. (** creates a degenerated range from an integer.
  8771. - makes it possible to convert the result of an integer-valued procedure F() into a range
  8772. without executing the procedure twice as it would happen in "(F() .. F() BY 1)"
  8773. **)
  8774. PROCEDURE RangeFromInteger*(CONST integer: LONGINT): RANGE;
  8775. BEGIN RETURN (integer .. integer BY 1)
  8776. END RangeFromInteger;
  8777. (* OLIVIER *)
  8778. (** create an array with the same data but with more dimensions
  8779. - each element in the array 'keptDimensions' corresponds to a dimension in the resulting array
  8780. - if element = TRUE: use a dimension from the source array, i.e. reuse length and increment
  8781. - if element = FALSE: insert a new dimension having length = 1 and increment = 0
  8782. e.g.:
  8783. ExpandDimensions(array, [FALSE, TRUE, FALSE, FALSE, TRUE])
  8784. performs the following type transformation:
  8785. ARRAY [10, 20] OF REAL -> ARRAY [1, 10, 1, 1, 20] OF REAL
  8786. **)
  8787. PROCEDURE ExpandDimensions*(CONST sourceArray: ARRAY [?]; CONST keptDimensions: ARRAY [*] OF BOOLEAN): ARRAY [?];
  8788. VAR
  8789. targetDimensionality, sourceIndex, targetIndex: LONGINT;
  8790. sourceADDRESS, targetADDRESS: LONGINT;
  8791. targetArrayDescriptor: ANY;
  8792. BEGIN
  8793. sourceADDRESS := SYSTEM.VAL(LONGINT, sourceArray);
  8794. targetDimensionality := LEN(keptDimensions, 0);
  8795. targetArrayDescriptor := GetArrayDesc(targetDimensionality); (* create a new array descriptor *)
  8796. SYSTEM.PUT(ADDRESSOF(RESULT), targetArrayDescriptor);
  8797. targetADDRESS := SYSTEM.VAL(LONGINT, RESULT);
  8798. PutAdr(targetADDRESS, GetAdr(sourceADDRESS));
  8799. PutPtr(targetADDRESS, GetPtr(sourceADDRESS));
  8800. PutFlags(targetADDRESS, {TensorFlag});
  8801. PutSize(targetADDRESS, GetSize(sourceADDRESS));
  8802. (* set increments and lengths *)
  8803. sourceIndex := 0;
  8804. FOR targetIndex := 0 TO targetDimensionality - 1 DO
  8805. IF keptDimensions[targetIndex] THEN
  8806. (* reuse length and increment from source array *)
  8807. ASSERT(sourceIndex < DIM(sourceArray));
  8808. PutLen(targetADDRESS, targetIndex, GetLen(sourceADDRESS, sourceIndex));
  8809. PutInc(targetADDRESS, targetIndex, GetIncr(sourceADDRESS, sourceIndex));
  8810. INC(sourceIndex)
  8811. ELSE
  8812. (* set length = 1 and increment = 0 *)
  8813. PutLen(targetADDRESS, targetIndex, 1);
  8814. PutInc(targetADDRESS, targetIndex, 0);
  8815. END
  8816. END;
  8817. (* Report("expand dimensions: ", targetADDRESS); *)
  8818. RETURN RESULT
  8819. END ExpandDimensions;
  8820. (* index ranges *)
  8821. (* the length of a range, i.e. the number of indices that it stands for *)
  8822. OPERATOR "LEN"*(CONST range: RANGE): LONGINT;
  8823. VAR
  8824. temp, result: LONGINT;
  8825. BEGIN
  8826. IF (LAST(range) < FIRST(range)) OR (FIRST(range) < 0) OR (STEP(range) < 1) THEN
  8827. (* invalid range *)
  8828. result := 0
  8829. ELSIF LAST(range) = MAX(LONGINT) THEN
  8830. (* open-ended range *)
  8831. result := MAX(LONGINT)
  8832. ELSE
  8833. temp := 1 + LAST(range) - FIRST(range);
  8834. result := temp DIV STEP(range);
  8835. IF (temp MOD STEP(range)) # 0 THEN
  8836. INC(result)
  8837. END
  8838. END;
  8839. RETURN result
  8840. END "LEN";
  8841. OPERATOR "ALL"*(CONST x: ARRAY [?] OF SHORTINT; op: PROCEDURE(x: SHORTINT): SHORTINT): ARRAY[?] OF SHORTINT; (*should also accept operator ?*)
  8842. BEGIN
  8843. ApplyGenericUnaryAAOpS(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(SHORTINT),GenericLoopS,op);
  8844. RETURN RESULT;
  8845. END "ALL";
  8846. OPERATOR "ALL"*(CONST x: ARRAY [?] OF INTEGER; op: PROCEDURE(x: INTEGER): INTEGER): ARRAY[?] OF INTEGER; (*should also accept operator ?*)
  8847. BEGIN
  8848. ApplyGenericUnaryAAOpI(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(INTEGER),GenericLoopI,op);
  8849. RETURN RESULT;
  8850. END "ALL";
  8851. OPERATOR "ALL"*(CONST x: ARRAY [?] OF LONGINT; op: PROCEDURE(x: LONGINT): LONGINT): ARRAY[?] OF LONGINT; (*should also accept operator ?*)
  8852. BEGIN
  8853. ApplyGenericUnaryAAOpL(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(LONGINT),GenericLoopL,op);
  8854. RETURN RESULT;
  8855. END "ALL";
  8856. OPERATOR "ALL"*(CONST x: ARRAY [?] OF HUGEINT; op: PROCEDURE(x: HUGEINT): HUGEINT): ARRAY[?] OF HUGEINT; (*should also accept operator ?*)
  8857. BEGIN
  8858. ApplyGenericUnaryAAOpH(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(HUGEINT),GenericLoopH,op);
  8859. RETURN RESULT;
  8860. END "ALL";
  8861. OPERATOR "ALL"*(CONST x: ARRAY [?] OF REAL; op: PROCEDURE(x: REAL): REAL): ARRAY[?] OF REAL; (*should also accept operator ?*)
  8862. BEGIN
  8863. ApplyGenericUnaryAAOpR(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(REAL),GenericLoopR,op);
  8864. RETURN RESULT;
  8865. END "ALL";
  8866. OPERATOR "ALL"*(CONST x: ARRAY [?] OF LONGREAL; op: PROCEDURE(x: LONGREAL): LONGREAL): ARRAY[?] OF LONGREAL; (*should also accept operator ?*)
  8867. BEGIN
  8868. ApplyGenericUnaryAAOpX(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(LONGREAL),GenericLoopX,op);
  8869. RETURN RESULT;
  8870. END "ALL";
  8871. OPERATOR "ALL"*(CONST x: ARRAY [?] OF COMPLEX; op: PROCEDURE(x: COMPLEX): COMPLEX): ARRAY[?] OF COMPLEX; (*should also accept operator ?*)
  8872. BEGIN
  8873. ApplyGenericUnaryAAOpZ(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(COMPLEX),GenericLoopZ,op);
  8874. RETURN RESULT;
  8875. END "ALL";
  8876. OPERATOR "ALL"*(CONST x: ARRAY [?] OF LONGCOMPLEX; op: PROCEDURE(x: LONGCOMPLEX): LONGCOMPLEX): ARRAY[?] OF LONGCOMPLEX; (*should also accept operator ?*)
  8877. BEGIN
  8878. ApplyGenericUnaryAAOpLZ(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(LONGCOMPLEX),GenericLoopLZ,op);
  8879. RETURN RESULT;
  8880. END "ALL";
  8881. BEGIN
  8882. alloc := 0; SetDefaults(); InitOptimization(); (* CreateTypePool; *)
  8883. END FoxArrayBase.
  8884. Compiler.Compile FoxArrayBase.Mod ~
  8885. SystemTools.ListModules