numbers.c 269 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882888388848885888688878888888988908891889288938894889588968897889888998900890189028903890489058906890789088909891089118912891389148915891689178918891989208921892289238924892589268927892889298930893189328933893489358936893789388939894089418942894389448945894689478948894989508951895289538954895589568957895889598960896189628963896489658966896789688969897089718972897389748975897689778978897989808981898289838984898589868987898889898990899189928993899489958996899789988999900090019002900390049005900690079008900990109011901290139014901590169017901890199020902190229023902490259026902790289029903090319032903390349035903690379038903990409041904290439044904590469047904890499050905190529053905490559056905790589059906090619062906390649065906690679068906990709071907290739074907590769077907890799080908190829083908490859086908790889089909090919092909390949095909690979098909991009101910291039104910591069107910891099110911191129113911491159116911791189119912091219122912391249125912691279128912991309131913291339134913591369137913891399140914191429143914491459146914791489149915091519152915391549155915691579158915991609161916291639164916591669167916891699170917191729173917491759176917791789179918091819182918391849185918691879188918991909191919291939194919591969197919891999200920192029203920492059206920792089209921092119212921392149215921692179218921992209221922292239224922592269227922892299230923192329233923492359236923792389239924092419242924392449245924692479248924992509251925292539254925592569257925892599260926192629263926492659266926792689269927092719272927392749275927692779278927992809281928292839284928592869287928892899290929192929293929492959296929792989299930093019302930393049305930693079308930993109311931293139314931593169317931893199320932193229323932493259326932793289329933093319332933393349335933693379338933993409341934293439344934593469347934893499350935193529353935493559356935793589359936093619362936393649365936693679368936993709371937293739374937593769377937893799380938193829383938493859386938793889389939093919392939393949395939693979398939994009401940294039404940594069407940894099410941194129413941494159416941794189419942094219422942394249425942694279428942994309431943294339434943594369437943894399440944194429443944494459446944794489449945094519452945394549455945694579458945994609461946294639464946594669467946894699470947194729473947494759476947794789479948094819482948394849485948694879488948994909491949294939494949594969497949894999500950195029503950495059506950795089509951095119512951395149515951695179518951995209521952295239524952595269527952895299530953195329533953495359536953795389539954095419542954395449545954695479548954995509551955295539554955595569557955895599560956195629563956495659566956795689569957095719572957395749575957695779578957995809581958295839584958595869587958895899590959195929593959495959596959795989599960096019602960396049605960696079608960996109611961296139614961596169617961896199620962196229623962496259626962796289629963096319632963396349635963696379638963996409641964296439644964596469647964896499650965196529653965496559656965796589659966096619662966396649665966696679668966996709671967296739674967596769677967896799680968196829683968496859686968796889689969096919692969396949695969696979698969997009701970297039704970597069707970897099710971197129713971497159716971797189719972097219722972397249725972697279728972997309731973297339734
  1. /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
  2. *
  3. * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
  4. * and Bellcore. See scm_divide.
  5. *
  6. *
  7. * This library is free software; you can redistribute it and/or
  8. * modify it under the terms of the GNU Lesser General Public License
  9. * as published by the Free Software Foundation; either version 3 of
  10. * the License, or (at your option) any later version.
  11. *
  12. * This library is distributed in the hope that it will be useful, but
  13. * WITHOUT ANY WARRANTY; without even the implied warranty of
  14. * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  15. * Lesser General Public License for more details.
  16. *
  17. * You should have received a copy of the GNU Lesser General Public
  18. * License along with this library; if not, write to the Free Software
  19. * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  20. * 02110-1301 USA
  21. */
  22. /* General assumptions:
  23. * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
  24. * If an object satisfies integer?, it's either an inum, a bignum, or a real.
  25. * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
  26. * XXX What about infinities? They are equal to their own floor! -mhw
  27. * All objects satisfying SCM_FRACTIONP are never an integer.
  28. */
  29. /* TODO:
  30. - see if special casing bignums and reals in integer-exponent when
  31. possible (to use mpz_pow and mpf_pow_ui) is faster.
  32. - look in to better short-circuiting of common cases in
  33. integer-expt and elsewhere.
  34. - see if direct mpz operations can help in ash and elsewhere.
  35. */
  36. #ifdef HAVE_CONFIG_H
  37. # include <config.h>
  38. #endif
  39. #include <verify.h>
  40. #include <math.h>
  41. #include <string.h>
  42. #include <unicase.h>
  43. #include <unictype.h>
  44. #if HAVE_COMPLEX_H
  45. #include <complex.h>
  46. #endif
  47. #include "libguile/_scm.h"
  48. #include "libguile/feature.h"
  49. #include "libguile/ports.h"
  50. #include "libguile/root.h"
  51. #include "libguile/smob.h"
  52. #include "libguile/strings.h"
  53. #include "libguile/bdw-gc.h"
  54. #include "libguile/validate.h"
  55. #include "libguile/numbers.h"
  56. #include "libguile/deprecation.h"
  57. #include "libguile/eq.h"
  58. /* values per glibc, if not already defined */
  59. #ifndef M_LOG10E
  60. #define M_LOG10E 0.43429448190325182765
  61. #endif
  62. #ifndef M_LN2
  63. #define M_LN2 0.69314718055994530942
  64. #endif
  65. #ifndef M_PI
  66. #define M_PI 3.14159265358979323846
  67. #endif
  68. typedef scm_t_signed_bits scm_t_inum;
  69. #define scm_from_inum(x) (scm_from_signed_integer (x))
  70. /* Tests to see if a C double is neither infinite nor a NaN.
  71. TODO: if it's available, use C99's isfinite(x) instead */
  72. #define DOUBLE_IS_FINITE(x) (!isinf(x) && !isnan(x))
  73. /* On some platforms, isinf(x) returns 0, 1 or -1, indicating the sign
  74. of the infinity, but other platforms return a boolean only. */
  75. #define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0))
  76. #define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0))
  77. /*
  78. Wonder if this might be faster for some of our code? A switch on
  79. the numtag would jump directly to the right case, and the
  80. SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
  81. #define SCM_I_NUMTAG_NOTNUM 0
  82. #define SCM_I_NUMTAG_INUM 1
  83. #define SCM_I_NUMTAG_BIG scm_tc16_big
  84. #define SCM_I_NUMTAG_REAL scm_tc16_real
  85. #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
  86. #define SCM_I_NUMTAG(x) \
  87. (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
  88. : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
  89. : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
  90. : SCM_I_NUMTAG_NOTNUM)))
  91. */
  92. /* the macro above will not work as is with fractions */
  93. /* Default to 1, because as we used to hard-code `free' as the
  94. deallocator, we know that overriding these functions with
  95. instrumented `malloc' / `free' is OK. */
  96. int scm_install_gmp_memory_functions = 1;
  97. static SCM flo0;
  98. static SCM exactly_one_half;
  99. static SCM flo_log10e;
  100. #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
  101. /* FLOBUFLEN is the maximum number of characters neccessary for the
  102. * printed or scm_string representation of an inexact number.
  103. */
  104. #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
  105. #if !defined (HAVE_ASINH)
  106. static double asinh (double x) { return log (x + sqrt (x * x + 1)); }
  107. #endif
  108. #if !defined (HAVE_ACOSH)
  109. static double acosh (double x) { return log (x + sqrt (x * x - 1)); }
  110. #endif
  111. #if !defined (HAVE_ATANH)
  112. static double atanh (double x) { return 0.5 * log ((1 + x) / (1 - x)); }
  113. #endif
  114. /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
  115. xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
  116. in March 2006), mpz_cmp_d now handles infinities properly. */
  117. #if 1
  118. #define xmpz_cmp_d(z, d) \
  119. (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
  120. #else
  121. #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
  122. #endif
  123. #if defined (GUILE_I)
  124. #if defined HAVE_COMPLEX_DOUBLE
  125. /* For an SCM object Z which is a complex number (ie. satisfies
  126. SCM_COMPLEXP), return its value as a C level "complex double". */
  127. #define SCM_COMPLEX_VALUE(z) \
  128. (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
  129. static inline SCM scm_from_complex_double (complex double z) SCM_UNUSED;
  130. /* Convert a C "complex double" to an SCM value. */
  131. static inline SCM
  132. scm_from_complex_double (complex double z)
  133. {
  134. return scm_c_make_rectangular (creal (z), cimag (z));
  135. }
  136. #endif /* HAVE_COMPLEX_DOUBLE */
  137. #endif /* GUILE_I */
  138. static mpz_t z_negative_one;
  139. /* Clear the `mpz_t' embedded in bignum PTR. */
  140. static void
  141. finalize_bignum (GC_PTR ptr, GC_PTR data)
  142. {
  143. SCM bignum;
  144. bignum = SCM_PACK_POINTER (ptr);
  145. mpz_clear (SCM_I_BIG_MPZ (bignum));
  146. }
  147. /* The next three functions (custom_libgmp_*) are passed to
  148. mp_set_memory_functions (in GMP) so that memory used by the digits
  149. themselves is known to the garbage collector. This is needed so
  150. that GC will be run at appropriate times. Otherwise, a program which
  151. creates many large bignums would malloc a huge amount of memory
  152. before the GC runs. */
  153. static void *
  154. custom_gmp_malloc (size_t alloc_size)
  155. {
  156. return scm_malloc (alloc_size);
  157. }
  158. static void *
  159. custom_gmp_realloc (void *old_ptr, size_t old_size, size_t new_size)
  160. {
  161. return scm_realloc (old_ptr, new_size);
  162. }
  163. static void
  164. custom_gmp_free (void *ptr, size_t size)
  165. {
  166. free (ptr);
  167. }
  168. /* Return a new uninitialized bignum. */
  169. static inline SCM
  170. make_bignum (void)
  171. {
  172. scm_t_bits *p;
  173. /* Allocate one word for the type tag and enough room for an `mpz_t'. */
  174. p = scm_gc_malloc_pointerless (sizeof (scm_t_bits) + sizeof (mpz_t),
  175. "bignum");
  176. p[0] = scm_tc16_big;
  177. scm_i_set_finalizer (p, finalize_bignum, NULL);
  178. return SCM_PACK (p);
  179. }
  180. SCM
  181. scm_i_mkbig ()
  182. {
  183. /* Return a newly created bignum. */
  184. SCM z = make_bignum ();
  185. mpz_init (SCM_I_BIG_MPZ (z));
  186. return z;
  187. }
  188. static SCM
  189. scm_i_inum2big (scm_t_inum x)
  190. {
  191. /* Return a newly created bignum initialized to X. */
  192. SCM z = make_bignum ();
  193. #if SIZEOF_VOID_P == SIZEOF_LONG
  194. mpz_init_set_si (SCM_I_BIG_MPZ (z), x);
  195. #else
  196. /* Note that in this case, you'll also have to check all mpz_*_ui and
  197. mpz_*_si invocations in Guile. */
  198. #error creation of mpz not implemented for this inum size
  199. #endif
  200. return z;
  201. }
  202. SCM
  203. scm_i_long2big (long x)
  204. {
  205. /* Return a newly created bignum initialized to X. */
  206. SCM z = make_bignum ();
  207. mpz_init_set_si (SCM_I_BIG_MPZ (z), x);
  208. return z;
  209. }
  210. SCM
  211. scm_i_ulong2big (unsigned long x)
  212. {
  213. /* Return a newly created bignum initialized to X. */
  214. SCM z = make_bignum ();
  215. mpz_init_set_ui (SCM_I_BIG_MPZ (z), x);
  216. return z;
  217. }
  218. SCM
  219. scm_i_clonebig (SCM src_big, int same_sign_p)
  220. {
  221. /* Copy src_big's value, negate it if same_sign_p is false, and return. */
  222. SCM z = make_bignum ();
  223. mpz_init_set (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (src_big));
  224. if (!same_sign_p)
  225. mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z));
  226. return z;
  227. }
  228. int
  229. scm_i_bigcmp (SCM x, SCM y)
  230. {
  231. /* Return neg if x < y, pos if x > y, and 0 if x == y */
  232. /* presume we already know x and y are bignums */
  233. int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  234. scm_remember_upto_here_2 (x, y);
  235. return result;
  236. }
  237. SCM
  238. scm_i_dbl2big (double d)
  239. {
  240. /* results are only defined if d is an integer */
  241. SCM z = make_bignum ();
  242. mpz_init_set_d (SCM_I_BIG_MPZ (z), d);
  243. return z;
  244. }
  245. /* Convert a integer in double representation to a SCM number. */
  246. SCM
  247. scm_i_dbl2num (double u)
  248. {
  249. /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
  250. powers of 2, so there's no rounding when making "double" values
  251. from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
  252. get rounded on a 64-bit machine, hence the "+1".
  253. The use of floor() to force to an integer value ensures we get a
  254. "numerically closest" value without depending on how a
  255. double->long cast or how mpz_set_d will round. For reference,
  256. double->long probably follows the hardware rounding mode,
  257. mpz_set_d truncates towards zero. */
  258. /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
  259. representable as a double? */
  260. if (u < (double) (SCM_MOST_POSITIVE_FIXNUM+1)
  261. && u >= (double) SCM_MOST_NEGATIVE_FIXNUM)
  262. return SCM_I_MAKINUM ((scm_t_inum) u);
  263. else
  264. return scm_i_dbl2big (u);
  265. }
  266. /* scm_i_big2dbl() rounds to the closest representable double, in accordance
  267. with R5RS exact->inexact.
  268. The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
  269. (ie. truncate towards zero), then adjust to get the closest double by
  270. examining the next lower bit and adding 1 (to the absolute value) if
  271. necessary.
  272. Bignums exactly half way between representable doubles are rounded to the
  273. next higher absolute value (ie. away from zero). This seems like an
  274. adequate interpretation of R5RS "numerically closest", and it's easier
  275. and faster than a full "nearest-even" style.
  276. The bit test must be done on the absolute value of the mpz_t, which means
  277. we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
  278. negatives as twos complement.
  279. In GMP before 4.2, mpz_get_d rounding was unspecified. It ended up
  280. following the hardware rounding mode, but applied to the absolute
  281. value of the mpz_t operand. This is not what we want so we put the
  282. high DBL_MANT_DIG bits into a temporary. Starting with GMP 4.2
  283. (released in March 2006) mpz_get_d now always truncates towards zero.
  284. ENHANCE-ME: The temporary init+clear to force the rounding in GMP
  285. before 4.2 is a slowdown. It'd be faster to pick out the relevant
  286. high bits with mpz_getlimbn. */
  287. double
  288. scm_i_big2dbl (SCM b)
  289. {
  290. double result;
  291. size_t bits;
  292. bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2);
  293. #if 1
  294. {
  295. /* For GMP earlier than 4.2, force truncation towards zero */
  296. /* FIXME: DBL_MANT_DIG is the number of base-`FLT_RADIX' digits,
  297. _not_ the number of bits, so this code will break badly on a
  298. system with non-binary doubles. */
  299. mpz_t tmp;
  300. if (bits > DBL_MANT_DIG)
  301. {
  302. size_t shift = bits - DBL_MANT_DIG;
  303. mpz_init2 (tmp, DBL_MANT_DIG);
  304. mpz_tdiv_q_2exp (tmp, SCM_I_BIG_MPZ (b), shift);
  305. result = ldexp (mpz_get_d (tmp), shift);
  306. mpz_clear (tmp);
  307. }
  308. else
  309. {
  310. result = mpz_get_d (SCM_I_BIG_MPZ (b));
  311. }
  312. }
  313. #else
  314. /* GMP 4.2 or later */
  315. result = mpz_get_d (SCM_I_BIG_MPZ (b));
  316. #endif
  317. if (bits > DBL_MANT_DIG)
  318. {
  319. unsigned long pos = bits - DBL_MANT_DIG - 1;
  320. /* test bit number "pos" in absolute value */
  321. if (mpz_getlimbn (SCM_I_BIG_MPZ (b), pos / GMP_NUMB_BITS)
  322. & ((mp_limb_t) 1 << (pos % GMP_NUMB_BITS)))
  323. {
  324. result += ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b)), pos + 1);
  325. }
  326. }
  327. scm_remember_upto_here_1 (b);
  328. return result;
  329. }
  330. SCM
  331. scm_i_normbig (SCM b)
  332. {
  333. /* convert a big back to a fixnum if it'll fit */
  334. /* presume b is a bignum */
  335. if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b)))
  336. {
  337. scm_t_inum val = mpz_get_si (SCM_I_BIG_MPZ (b));
  338. if (SCM_FIXABLE (val))
  339. b = SCM_I_MAKINUM (val);
  340. }
  341. return b;
  342. }
  343. static SCM_C_INLINE_KEYWORD SCM
  344. scm_i_mpz2num (mpz_t b)
  345. {
  346. /* convert a mpz number to a SCM number. */
  347. if (mpz_fits_slong_p (b))
  348. {
  349. scm_t_inum val = mpz_get_si (b);
  350. if (SCM_FIXABLE (val))
  351. return SCM_I_MAKINUM (val);
  352. }
  353. {
  354. SCM z = make_bignum ();
  355. mpz_init_set (SCM_I_BIG_MPZ (z), b);
  356. return z;
  357. }
  358. }
  359. /* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
  360. static SCM scm_divide2real (SCM x, SCM y);
  361. static SCM
  362. scm_i_make_ratio (SCM numerator, SCM denominator)
  363. #define FUNC_NAME "make-ratio"
  364. {
  365. /* First make sure the arguments are proper.
  366. */
  367. if (SCM_I_INUMP (denominator))
  368. {
  369. if (scm_is_eq (denominator, SCM_INUM0))
  370. scm_num_overflow ("make-ratio");
  371. if (scm_is_eq (denominator, SCM_INUM1))
  372. return numerator;
  373. }
  374. else
  375. {
  376. if (!(SCM_BIGP(denominator)))
  377. SCM_WRONG_TYPE_ARG (2, denominator);
  378. }
  379. if (!SCM_I_INUMP (numerator) && !SCM_BIGP (numerator))
  380. SCM_WRONG_TYPE_ARG (1, numerator);
  381. /* Then flip signs so that the denominator is positive.
  382. */
  383. if (scm_is_true (scm_negative_p (denominator)))
  384. {
  385. numerator = scm_difference (numerator, SCM_UNDEFINED);
  386. denominator = scm_difference (denominator, SCM_UNDEFINED);
  387. }
  388. /* Now consider for each of the four fixnum/bignum combinations
  389. whether the rational number is really an integer.
  390. */
  391. if (SCM_I_INUMP (numerator))
  392. {
  393. scm_t_inum x = SCM_I_INUM (numerator);
  394. if (scm_is_eq (numerator, SCM_INUM0))
  395. return SCM_INUM0;
  396. if (SCM_I_INUMP (denominator))
  397. {
  398. scm_t_inum y;
  399. y = SCM_I_INUM (denominator);
  400. if (x == y)
  401. return SCM_INUM1;
  402. if ((x % y) == 0)
  403. return SCM_I_MAKINUM (x / y);
  404. }
  405. else
  406. {
  407. /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
  408. of that value for the denominator, as a bignum. Apart from
  409. that case, abs(bignum) > abs(inum) so inum/bignum is not an
  410. integer. */
  411. if (x == SCM_MOST_NEGATIVE_FIXNUM
  412. && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator),
  413. - SCM_MOST_NEGATIVE_FIXNUM) == 0)
  414. return SCM_I_MAKINUM(-1);
  415. }
  416. }
  417. else if (SCM_BIGP (numerator))
  418. {
  419. if (SCM_I_INUMP (denominator))
  420. {
  421. scm_t_inum yy = SCM_I_INUM (denominator);
  422. if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), yy))
  423. return scm_divide (numerator, denominator);
  424. }
  425. else
  426. {
  427. if (scm_is_eq (numerator, denominator))
  428. return SCM_INUM1;
  429. if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator),
  430. SCM_I_BIG_MPZ (denominator)))
  431. return scm_divide(numerator, denominator);
  432. }
  433. }
  434. /* No, it's a proper fraction.
  435. */
  436. {
  437. SCM divisor = scm_gcd (numerator, denominator);
  438. if (!(scm_is_eq (divisor, SCM_INUM1)))
  439. {
  440. numerator = scm_divide (numerator, divisor);
  441. denominator = scm_divide (denominator, divisor);
  442. }
  443. return scm_double_cell (scm_tc16_fraction,
  444. SCM_UNPACK (numerator),
  445. SCM_UNPACK (denominator), 0);
  446. }
  447. }
  448. #undef FUNC_NAME
  449. double
  450. scm_i_fraction2double (SCM z)
  451. {
  452. return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z),
  453. SCM_FRACTION_DENOMINATOR (z)));
  454. }
  455. static int
  456. double_is_non_negative_zero (double x)
  457. {
  458. static double zero = 0.0;
  459. return !memcmp (&x, &zero, sizeof(double));
  460. }
  461. SCM_PRIMITIVE_GENERIC (scm_exact_p, "exact?", 1, 0, 0,
  462. (SCM x),
  463. "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
  464. "otherwise.")
  465. #define FUNC_NAME s_scm_exact_p
  466. {
  467. if (SCM_INEXACTP (x))
  468. return SCM_BOOL_F;
  469. else if (SCM_NUMBERP (x))
  470. return SCM_BOOL_T;
  471. else
  472. return scm_wta_dispatch_1 (g_scm_exact_p, x, 1, s_scm_exact_p);
  473. }
  474. #undef FUNC_NAME
  475. int
  476. scm_is_exact (SCM val)
  477. {
  478. return scm_is_true (scm_exact_p (val));
  479. }
  480. SCM_PRIMITIVE_GENERIC (scm_inexact_p, "inexact?", 1, 0, 0,
  481. (SCM x),
  482. "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
  483. "else.")
  484. #define FUNC_NAME s_scm_inexact_p
  485. {
  486. if (SCM_INEXACTP (x))
  487. return SCM_BOOL_T;
  488. else if (SCM_NUMBERP (x))
  489. return SCM_BOOL_F;
  490. else
  491. return scm_wta_dispatch_1 (g_scm_inexact_p, x, 1, s_scm_inexact_p);
  492. }
  493. #undef FUNC_NAME
  494. int
  495. scm_is_inexact (SCM val)
  496. {
  497. return scm_is_true (scm_inexact_p (val));
  498. }
  499. SCM_PRIMITIVE_GENERIC (scm_odd_p, "odd?", 1, 0, 0,
  500. (SCM n),
  501. "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
  502. "otherwise.")
  503. #define FUNC_NAME s_scm_odd_p
  504. {
  505. if (SCM_I_INUMP (n))
  506. {
  507. scm_t_inum val = SCM_I_INUM (n);
  508. return scm_from_bool ((val & 1L) != 0);
  509. }
  510. else if (SCM_BIGP (n))
  511. {
  512. int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n));
  513. scm_remember_upto_here_1 (n);
  514. return scm_from_bool (odd_p);
  515. }
  516. else if (SCM_REALP (n))
  517. {
  518. double val = SCM_REAL_VALUE (n);
  519. if (DOUBLE_IS_FINITE (val))
  520. {
  521. double rem = fabs (fmod (val, 2.0));
  522. if (rem == 1.0)
  523. return SCM_BOOL_T;
  524. else if (rem == 0.0)
  525. return SCM_BOOL_F;
  526. }
  527. }
  528. return scm_wta_dispatch_1 (g_scm_odd_p, n, 1, s_scm_odd_p);
  529. }
  530. #undef FUNC_NAME
  531. SCM_PRIMITIVE_GENERIC (scm_even_p, "even?", 1, 0, 0,
  532. (SCM n),
  533. "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
  534. "otherwise.")
  535. #define FUNC_NAME s_scm_even_p
  536. {
  537. if (SCM_I_INUMP (n))
  538. {
  539. scm_t_inum val = SCM_I_INUM (n);
  540. return scm_from_bool ((val & 1L) == 0);
  541. }
  542. else if (SCM_BIGP (n))
  543. {
  544. int even_p = mpz_even_p (SCM_I_BIG_MPZ (n));
  545. scm_remember_upto_here_1 (n);
  546. return scm_from_bool (even_p);
  547. }
  548. else if (SCM_REALP (n))
  549. {
  550. double val = SCM_REAL_VALUE (n);
  551. if (DOUBLE_IS_FINITE (val))
  552. {
  553. double rem = fabs (fmod (val, 2.0));
  554. if (rem == 1.0)
  555. return SCM_BOOL_F;
  556. else if (rem == 0.0)
  557. return SCM_BOOL_T;
  558. }
  559. }
  560. return scm_wta_dispatch_1 (g_scm_even_p, n, 1, s_scm_even_p);
  561. }
  562. #undef FUNC_NAME
  563. SCM_PRIMITIVE_GENERIC (scm_finite_p, "finite?", 1, 0, 0,
  564. (SCM x),
  565. "Return @code{#t} if the real number @var{x} is neither\n"
  566. "infinite nor a NaN, @code{#f} otherwise.")
  567. #define FUNC_NAME s_scm_finite_p
  568. {
  569. if (SCM_REALP (x))
  570. return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x)));
  571. else if (scm_is_real (x))
  572. return SCM_BOOL_T;
  573. else
  574. return scm_wta_dispatch_1 (g_scm_finite_p, x, 1, s_scm_finite_p);
  575. }
  576. #undef FUNC_NAME
  577. SCM_PRIMITIVE_GENERIC (scm_inf_p, "inf?", 1, 0, 0,
  578. (SCM x),
  579. "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
  580. "@samp{-inf.0}. Otherwise return @code{#f}.")
  581. #define FUNC_NAME s_scm_inf_p
  582. {
  583. if (SCM_REALP (x))
  584. return scm_from_bool (isinf (SCM_REAL_VALUE (x)));
  585. else if (scm_is_real (x))
  586. return SCM_BOOL_F;
  587. else
  588. return scm_wta_dispatch_1 (g_scm_inf_p, x, 1, s_scm_inf_p);
  589. }
  590. #undef FUNC_NAME
  591. SCM_PRIMITIVE_GENERIC (scm_nan_p, "nan?", 1, 0, 0,
  592. (SCM x),
  593. "Return @code{#t} if the real number @var{x} is a NaN,\n"
  594. "or @code{#f} otherwise.")
  595. #define FUNC_NAME s_scm_nan_p
  596. {
  597. if (SCM_REALP (x))
  598. return scm_from_bool (isnan (SCM_REAL_VALUE (x)));
  599. else if (scm_is_real (x))
  600. return SCM_BOOL_F;
  601. else
  602. return scm_wta_dispatch_1 (g_scm_nan_p, x, 1, s_scm_nan_p);
  603. }
  604. #undef FUNC_NAME
  605. /* Guile's idea of infinity. */
  606. static double guile_Inf;
  607. /* Guile's idea of not a number. */
  608. static double guile_NaN;
  609. static void
  610. guile_ieee_init (void)
  611. {
  612. /* Some version of gcc on some old version of Linux used to crash when
  613. trying to make Inf and NaN. */
  614. #ifdef INFINITY
  615. /* C99 INFINITY, when available.
  616. FIXME: The standard allows for INFINITY to be something that overflows
  617. at compile time. We ought to have a configure test to check for that
  618. before trying to use it. (But in practice we believe this is not a
  619. problem on any system guile is likely to target.) */
  620. guile_Inf = INFINITY;
  621. #elif defined HAVE_DINFINITY
  622. /* OSF */
  623. extern unsigned int DINFINITY[2];
  624. guile_Inf = (*((double *) (DINFINITY)));
  625. #else
  626. double tmp = 1e+10;
  627. guile_Inf = tmp;
  628. for (;;)
  629. {
  630. guile_Inf *= 1e+10;
  631. if (guile_Inf == tmp)
  632. break;
  633. tmp = guile_Inf;
  634. }
  635. #endif
  636. #ifdef NAN
  637. /* C99 NAN, when available */
  638. guile_NaN = NAN;
  639. #elif defined HAVE_DQNAN
  640. {
  641. /* OSF */
  642. extern unsigned int DQNAN[2];
  643. guile_NaN = (*((double *)(DQNAN)));
  644. }
  645. #else
  646. guile_NaN = guile_Inf / guile_Inf;
  647. #endif
  648. }
  649. SCM_DEFINE (scm_inf, "inf", 0, 0, 0,
  650. (void),
  651. "Return Inf.")
  652. #define FUNC_NAME s_scm_inf
  653. {
  654. static int initialized = 0;
  655. if (! initialized)
  656. {
  657. guile_ieee_init ();
  658. initialized = 1;
  659. }
  660. return scm_from_double (guile_Inf);
  661. }
  662. #undef FUNC_NAME
  663. SCM_DEFINE (scm_nan, "nan", 0, 0, 0,
  664. (void),
  665. "Return NaN.")
  666. #define FUNC_NAME s_scm_nan
  667. {
  668. static int initialized = 0;
  669. if (!initialized)
  670. {
  671. guile_ieee_init ();
  672. initialized = 1;
  673. }
  674. return scm_from_double (guile_NaN);
  675. }
  676. #undef FUNC_NAME
  677. SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0,
  678. (SCM x),
  679. "Return the absolute value of @var{x}.")
  680. #define FUNC_NAME s_scm_abs
  681. {
  682. if (SCM_I_INUMP (x))
  683. {
  684. scm_t_inum xx = SCM_I_INUM (x);
  685. if (xx >= 0)
  686. return x;
  687. else if (SCM_POSFIXABLE (-xx))
  688. return SCM_I_MAKINUM (-xx);
  689. else
  690. return scm_i_inum2big (-xx);
  691. }
  692. else if (SCM_LIKELY (SCM_REALP (x)))
  693. {
  694. double xx = SCM_REAL_VALUE (x);
  695. /* If x is a NaN then xx<0 is false so we return x unchanged */
  696. if (xx < 0.0)
  697. return scm_from_double (-xx);
  698. /* Handle signed zeroes properly */
  699. else if (SCM_UNLIKELY (xx == 0.0))
  700. return flo0;
  701. else
  702. return x;
  703. }
  704. else if (SCM_BIGP (x))
  705. {
  706. const int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
  707. if (sgn < 0)
  708. return scm_i_clonebig (x, 0);
  709. else
  710. return x;
  711. }
  712. else if (SCM_FRACTIONP (x))
  713. {
  714. if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x))))
  715. return x;
  716. return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
  717. SCM_FRACTION_DENOMINATOR (x));
  718. }
  719. else
  720. return scm_wta_dispatch_1 (g_scm_abs, x, 1, s_scm_abs);
  721. }
  722. #undef FUNC_NAME
  723. SCM_PRIMITIVE_GENERIC (scm_quotient, "quotient", 2, 0, 0,
  724. (SCM x, SCM y),
  725. "Return the quotient of the numbers @var{x} and @var{y}.")
  726. #define FUNC_NAME s_scm_quotient
  727. {
  728. if (SCM_LIKELY (scm_is_integer (x)))
  729. {
  730. if (SCM_LIKELY (scm_is_integer (y)))
  731. return scm_truncate_quotient (x, y);
  732. else
  733. return scm_wta_dispatch_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient);
  734. }
  735. else
  736. return scm_wta_dispatch_2 (g_scm_quotient, x, y, SCM_ARG1, s_scm_quotient);
  737. }
  738. #undef FUNC_NAME
  739. SCM_PRIMITIVE_GENERIC (scm_remainder, "remainder", 2, 0, 0,
  740. (SCM x, SCM y),
  741. "Return the remainder of the numbers @var{x} and @var{y}.\n"
  742. "@lisp\n"
  743. "(remainder 13 4) @result{} 1\n"
  744. "(remainder -13 4) @result{} -1\n"
  745. "@end lisp")
  746. #define FUNC_NAME s_scm_remainder
  747. {
  748. if (SCM_LIKELY (scm_is_integer (x)))
  749. {
  750. if (SCM_LIKELY (scm_is_integer (y)))
  751. return scm_truncate_remainder (x, y);
  752. else
  753. return scm_wta_dispatch_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder);
  754. }
  755. else
  756. return scm_wta_dispatch_2 (g_scm_remainder, x, y, SCM_ARG1, s_scm_remainder);
  757. }
  758. #undef FUNC_NAME
  759. SCM_PRIMITIVE_GENERIC (scm_modulo, "modulo", 2, 0, 0,
  760. (SCM x, SCM y),
  761. "Return the modulo of the numbers @var{x} and @var{y}.\n"
  762. "@lisp\n"
  763. "(modulo 13 4) @result{} 1\n"
  764. "(modulo -13 4) @result{} 3\n"
  765. "@end lisp")
  766. #define FUNC_NAME s_scm_modulo
  767. {
  768. if (SCM_LIKELY (scm_is_integer (x)))
  769. {
  770. if (SCM_LIKELY (scm_is_integer (y)))
  771. return scm_floor_remainder (x, y);
  772. else
  773. return scm_wta_dispatch_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo);
  774. }
  775. else
  776. return scm_wta_dispatch_2 (g_scm_modulo, x, y, SCM_ARG1, s_scm_modulo);
  777. }
  778. #undef FUNC_NAME
  779. /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
  780. two-valued functions. It is called from primitive generics that take
  781. two arguments and return two values, when the core procedure is
  782. unable to handle the given argument types. If there are GOOPS
  783. methods for this primitive generic, it dispatches to GOOPS and, if
  784. successful, expects two values to be returned, which are placed in
  785. *rp1 and *rp2. If there are no GOOPS methods, it throws a
  786. wrong-type-arg exception.
  787. FIXME: This obviously belongs somewhere else, but until we decide on
  788. the right API, it is here as a static function, because it is needed
  789. by the *_divide functions below.
  790. */
  791. static void
  792. two_valued_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos,
  793. const char *subr, SCM *rp1, SCM *rp2)
  794. {
  795. SCM vals = scm_wta_dispatch_2 (gf, a1, a2, pos, subr);
  796. scm_i_extract_values_2 (vals, rp1, rp2);
  797. }
  798. SCM_DEFINE (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
  799. (SCM x, SCM y),
  800. "Return the integer @var{q} such that\n"
  801. "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
  802. "where @math{0 <= @var{r} < abs(@var{y})}.\n"
  803. "@lisp\n"
  804. "(euclidean-quotient 123 10) @result{} 12\n"
  805. "(euclidean-quotient 123 -10) @result{} -12\n"
  806. "(euclidean-quotient -123 10) @result{} -13\n"
  807. "(euclidean-quotient -123 -10) @result{} 13\n"
  808. "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
  809. "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
  810. "@end lisp")
  811. #define FUNC_NAME s_scm_euclidean_quotient
  812. {
  813. if (scm_is_false (scm_negative_p (y)))
  814. return scm_floor_quotient (x, y);
  815. else
  816. return scm_ceiling_quotient (x, y);
  817. }
  818. #undef FUNC_NAME
  819. SCM_DEFINE (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
  820. (SCM x, SCM y),
  821. "Return the real number @var{r} such that\n"
  822. "@math{0 <= @var{r} < abs(@var{y})} and\n"
  823. "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
  824. "for some integer @var{q}.\n"
  825. "@lisp\n"
  826. "(euclidean-remainder 123 10) @result{} 3\n"
  827. "(euclidean-remainder 123 -10) @result{} 3\n"
  828. "(euclidean-remainder -123 10) @result{} 7\n"
  829. "(euclidean-remainder -123 -10) @result{} 7\n"
  830. "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
  831. "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
  832. "@end lisp")
  833. #define FUNC_NAME s_scm_euclidean_remainder
  834. {
  835. if (scm_is_false (scm_negative_p (y)))
  836. return scm_floor_remainder (x, y);
  837. else
  838. return scm_ceiling_remainder (x, y);
  839. }
  840. #undef FUNC_NAME
  841. SCM_DEFINE (scm_i_euclidean_divide, "euclidean/", 2, 0, 0,
  842. (SCM x, SCM y),
  843. "Return the integer @var{q} and the real number @var{r}\n"
  844. "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
  845. "and @math{0 <= @var{r} < abs(@var{y})}.\n"
  846. "@lisp\n"
  847. "(euclidean/ 123 10) @result{} 12 and 3\n"
  848. "(euclidean/ 123 -10) @result{} -12 and 3\n"
  849. "(euclidean/ -123 10) @result{} -13 and 7\n"
  850. "(euclidean/ -123 -10) @result{} 13 and 7\n"
  851. "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
  852. "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
  853. "@end lisp")
  854. #define FUNC_NAME s_scm_i_euclidean_divide
  855. {
  856. if (scm_is_false (scm_negative_p (y)))
  857. return scm_i_floor_divide (x, y);
  858. else
  859. return scm_i_ceiling_divide (x, y);
  860. }
  861. #undef FUNC_NAME
  862. void
  863. scm_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
  864. {
  865. if (scm_is_false (scm_negative_p (y)))
  866. return scm_floor_divide (x, y, qp, rp);
  867. else
  868. return scm_ceiling_divide (x, y, qp, rp);
  869. }
  870. static SCM scm_i_inexact_floor_quotient (double x, double y);
  871. static SCM scm_i_exact_rational_floor_quotient (SCM x, SCM y);
  872. SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-quotient", 2, 0, 0,
  873. (SCM x, SCM y),
  874. "Return the floor of @math{@var{x} / @var{y}}.\n"
  875. "@lisp\n"
  876. "(floor-quotient 123 10) @result{} 12\n"
  877. "(floor-quotient 123 -10) @result{} -13\n"
  878. "(floor-quotient -123 10) @result{} -13\n"
  879. "(floor-quotient -123 -10) @result{} 12\n"
  880. "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
  881. "(floor-quotient 16/3 -10/7) @result{} -4\n"
  882. "@end lisp")
  883. #define FUNC_NAME s_scm_floor_quotient
  884. {
  885. if (SCM_LIKELY (SCM_I_INUMP (x)))
  886. {
  887. scm_t_inum xx = SCM_I_INUM (x);
  888. if (SCM_LIKELY (SCM_I_INUMP (y)))
  889. {
  890. scm_t_inum yy = SCM_I_INUM (y);
  891. scm_t_inum xx1 = xx;
  892. scm_t_inum qq;
  893. if (SCM_LIKELY (yy > 0))
  894. {
  895. if (SCM_UNLIKELY (xx < 0))
  896. xx1 = xx - yy + 1;
  897. }
  898. else if (SCM_UNLIKELY (yy == 0))
  899. scm_num_overflow (s_scm_floor_quotient);
  900. else if (xx > 0)
  901. xx1 = xx - yy - 1;
  902. qq = xx1 / yy;
  903. if (SCM_LIKELY (SCM_FIXABLE (qq)))
  904. return SCM_I_MAKINUM (qq);
  905. else
  906. return scm_i_inum2big (qq);
  907. }
  908. else if (SCM_BIGP (y))
  909. {
  910. int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
  911. scm_remember_upto_here_1 (y);
  912. if (sign > 0)
  913. return SCM_I_MAKINUM ((xx < 0) ? -1 : 0);
  914. else
  915. return SCM_I_MAKINUM ((xx > 0) ? -1 : 0);
  916. }
  917. else if (SCM_REALP (y))
  918. return scm_i_inexact_floor_quotient (xx, SCM_REAL_VALUE (y));
  919. else if (SCM_FRACTIONP (y))
  920. return scm_i_exact_rational_floor_quotient (x, y);
  921. else
  922. return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
  923. s_scm_floor_quotient);
  924. }
  925. else if (SCM_BIGP (x))
  926. {
  927. if (SCM_LIKELY (SCM_I_INUMP (y)))
  928. {
  929. scm_t_inum yy = SCM_I_INUM (y);
  930. if (SCM_UNLIKELY (yy == 0))
  931. scm_num_overflow (s_scm_floor_quotient);
  932. else if (SCM_UNLIKELY (yy == 1))
  933. return x;
  934. else
  935. {
  936. SCM q = scm_i_mkbig ();
  937. if (yy > 0)
  938. mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
  939. else
  940. {
  941. mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
  942. mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
  943. }
  944. scm_remember_upto_here_1 (x);
  945. return scm_i_normbig (q);
  946. }
  947. }
  948. else if (SCM_BIGP (y))
  949. {
  950. SCM q = scm_i_mkbig ();
  951. mpz_fdiv_q (SCM_I_BIG_MPZ (q),
  952. SCM_I_BIG_MPZ (x),
  953. SCM_I_BIG_MPZ (y));
  954. scm_remember_upto_here_2 (x, y);
  955. return scm_i_normbig (q);
  956. }
  957. else if (SCM_REALP (y))
  958. return scm_i_inexact_floor_quotient
  959. (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
  960. else if (SCM_FRACTIONP (y))
  961. return scm_i_exact_rational_floor_quotient (x, y);
  962. else
  963. return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
  964. s_scm_floor_quotient);
  965. }
  966. else if (SCM_REALP (x))
  967. {
  968. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  969. SCM_BIGP (y) || SCM_FRACTIONP (y))
  970. return scm_i_inexact_floor_quotient
  971. (SCM_REAL_VALUE (x), scm_to_double (y));
  972. else
  973. return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
  974. s_scm_floor_quotient);
  975. }
  976. else if (SCM_FRACTIONP (x))
  977. {
  978. if (SCM_REALP (y))
  979. return scm_i_inexact_floor_quotient
  980. (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
  981. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  982. return scm_i_exact_rational_floor_quotient (x, y);
  983. else
  984. return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
  985. s_scm_floor_quotient);
  986. }
  987. else
  988. return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
  989. s_scm_floor_quotient);
  990. }
  991. #undef FUNC_NAME
  992. static SCM
  993. scm_i_inexact_floor_quotient (double x, double y)
  994. {
  995. if (SCM_UNLIKELY (y == 0))
  996. scm_num_overflow (s_scm_floor_quotient); /* or return a NaN? */
  997. else
  998. return scm_from_double (floor (x / y));
  999. }
  1000. static SCM
  1001. scm_i_exact_rational_floor_quotient (SCM x, SCM y)
  1002. {
  1003. return scm_floor_quotient
  1004. (scm_product (scm_numerator (x), scm_denominator (y)),
  1005. scm_product (scm_numerator (y), scm_denominator (x)));
  1006. }
  1007. static SCM scm_i_inexact_floor_remainder (double x, double y);
  1008. static SCM scm_i_exact_rational_floor_remainder (SCM x, SCM y);
  1009. SCM_PRIMITIVE_GENERIC (scm_floor_remainder, "floor-remainder", 2, 0, 0,
  1010. (SCM x, SCM y),
  1011. "Return the real number @var{r} such that\n"
  1012. "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
  1013. "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
  1014. "@lisp\n"
  1015. "(floor-remainder 123 10) @result{} 3\n"
  1016. "(floor-remainder 123 -10) @result{} -7\n"
  1017. "(floor-remainder -123 10) @result{} 7\n"
  1018. "(floor-remainder -123 -10) @result{} -3\n"
  1019. "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
  1020. "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
  1021. "@end lisp")
  1022. #define FUNC_NAME s_scm_floor_remainder
  1023. {
  1024. if (SCM_LIKELY (SCM_I_INUMP (x)))
  1025. {
  1026. scm_t_inum xx = SCM_I_INUM (x);
  1027. if (SCM_LIKELY (SCM_I_INUMP (y)))
  1028. {
  1029. scm_t_inum yy = SCM_I_INUM (y);
  1030. if (SCM_UNLIKELY (yy == 0))
  1031. scm_num_overflow (s_scm_floor_remainder);
  1032. else
  1033. {
  1034. scm_t_inum rr = xx % yy;
  1035. int needs_adjustment;
  1036. if (SCM_LIKELY (yy > 0))
  1037. needs_adjustment = (rr < 0);
  1038. else
  1039. needs_adjustment = (rr > 0);
  1040. if (needs_adjustment)
  1041. rr += yy;
  1042. return SCM_I_MAKINUM (rr);
  1043. }
  1044. }
  1045. else if (SCM_BIGP (y))
  1046. {
  1047. int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
  1048. scm_remember_upto_here_1 (y);
  1049. if (sign > 0)
  1050. {
  1051. if (xx < 0)
  1052. {
  1053. SCM r = scm_i_mkbig ();
  1054. mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
  1055. scm_remember_upto_here_1 (y);
  1056. return scm_i_normbig (r);
  1057. }
  1058. else
  1059. return x;
  1060. }
  1061. else if (xx <= 0)
  1062. return x;
  1063. else
  1064. {
  1065. SCM r = scm_i_mkbig ();
  1066. mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
  1067. scm_remember_upto_here_1 (y);
  1068. return scm_i_normbig (r);
  1069. }
  1070. }
  1071. else if (SCM_REALP (y))
  1072. return scm_i_inexact_floor_remainder (xx, SCM_REAL_VALUE (y));
  1073. else if (SCM_FRACTIONP (y))
  1074. return scm_i_exact_rational_floor_remainder (x, y);
  1075. else
  1076. return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
  1077. s_scm_floor_remainder);
  1078. }
  1079. else if (SCM_BIGP (x))
  1080. {
  1081. if (SCM_LIKELY (SCM_I_INUMP (y)))
  1082. {
  1083. scm_t_inum yy = SCM_I_INUM (y);
  1084. if (SCM_UNLIKELY (yy == 0))
  1085. scm_num_overflow (s_scm_floor_remainder);
  1086. else
  1087. {
  1088. scm_t_inum rr;
  1089. if (yy > 0)
  1090. rr = mpz_fdiv_ui (SCM_I_BIG_MPZ (x), yy);
  1091. else
  1092. rr = -mpz_cdiv_ui (SCM_I_BIG_MPZ (x), -yy);
  1093. scm_remember_upto_here_1 (x);
  1094. return SCM_I_MAKINUM (rr);
  1095. }
  1096. }
  1097. else if (SCM_BIGP (y))
  1098. {
  1099. SCM r = scm_i_mkbig ();
  1100. mpz_fdiv_r (SCM_I_BIG_MPZ (r),
  1101. SCM_I_BIG_MPZ (x),
  1102. SCM_I_BIG_MPZ (y));
  1103. scm_remember_upto_here_2 (x, y);
  1104. return scm_i_normbig (r);
  1105. }
  1106. else if (SCM_REALP (y))
  1107. return scm_i_inexact_floor_remainder
  1108. (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
  1109. else if (SCM_FRACTIONP (y))
  1110. return scm_i_exact_rational_floor_remainder (x, y);
  1111. else
  1112. return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
  1113. s_scm_floor_remainder);
  1114. }
  1115. else if (SCM_REALP (x))
  1116. {
  1117. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  1118. SCM_BIGP (y) || SCM_FRACTIONP (y))
  1119. return scm_i_inexact_floor_remainder
  1120. (SCM_REAL_VALUE (x), scm_to_double (y));
  1121. else
  1122. return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
  1123. s_scm_floor_remainder);
  1124. }
  1125. else if (SCM_FRACTIONP (x))
  1126. {
  1127. if (SCM_REALP (y))
  1128. return scm_i_inexact_floor_remainder
  1129. (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
  1130. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  1131. return scm_i_exact_rational_floor_remainder (x, y);
  1132. else
  1133. return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
  1134. s_scm_floor_remainder);
  1135. }
  1136. else
  1137. return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
  1138. s_scm_floor_remainder);
  1139. }
  1140. #undef FUNC_NAME
  1141. static SCM
  1142. scm_i_inexact_floor_remainder (double x, double y)
  1143. {
  1144. /* Although it would be more efficient to use fmod here, we can't
  1145. because it would in some cases produce results inconsistent with
  1146. scm_i_inexact_floor_quotient, such that x != q * y + r (not even
  1147. close). In particular, when x is very close to a multiple of y,
  1148. then r might be either 0.0 or y, but those two cases must
  1149. correspond to different choices of q. If r = 0.0 then q must be
  1150. x/y, and if r = y then q must be x/y-1. If quotient chooses one
  1151. and remainder chooses the other, it would be bad. */
  1152. if (SCM_UNLIKELY (y == 0))
  1153. scm_num_overflow (s_scm_floor_remainder); /* or return a NaN? */
  1154. else
  1155. return scm_from_double (x - y * floor (x / y));
  1156. }
  1157. static SCM
  1158. scm_i_exact_rational_floor_remainder (SCM x, SCM y)
  1159. {
  1160. SCM xd = scm_denominator (x);
  1161. SCM yd = scm_denominator (y);
  1162. SCM r1 = scm_floor_remainder (scm_product (scm_numerator (x), yd),
  1163. scm_product (scm_numerator (y), xd));
  1164. return scm_divide (r1, scm_product (xd, yd));
  1165. }
  1166. static void scm_i_inexact_floor_divide (double x, double y,
  1167. SCM *qp, SCM *rp);
  1168. static void scm_i_exact_rational_floor_divide (SCM x, SCM y,
  1169. SCM *qp, SCM *rp);
  1170. SCM_PRIMITIVE_GENERIC (scm_i_floor_divide, "floor/", 2, 0, 0,
  1171. (SCM x, SCM y),
  1172. "Return the integer @var{q} and the real number @var{r}\n"
  1173. "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
  1174. "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
  1175. "@lisp\n"
  1176. "(floor/ 123 10) @result{} 12 and 3\n"
  1177. "(floor/ 123 -10) @result{} -13 and -7\n"
  1178. "(floor/ -123 10) @result{} -13 and 7\n"
  1179. "(floor/ -123 -10) @result{} 12 and -3\n"
  1180. "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
  1181. "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
  1182. "@end lisp")
  1183. #define FUNC_NAME s_scm_i_floor_divide
  1184. {
  1185. SCM q, r;
  1186. scm_floor_divide(x, y, &q, &r);
  1187. return scm_values (scm_list_2 (q, r));
  1188. }
  1189. #undef FUNC_NAME
  1190. #define s_scm_floor_divide s_scm_i_floor_divide
  1191. #define g_scm_floor_divide g_scm_i_floor_divide
  1192. void
  1193. scm_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp)
  1194. {
  1195. if (SCM_LIKELY (SCM_I_INUMP (x)))
  1196. {
  1197. scm_t_inum xx = SCM_I_INUM (x);
  1198. if (SCM_LIKELY (SCM_I_INUMP (y)))
  1199. {
  1200. scm_t_inum yy = SCM_I_INUM (y);
  1201. if (SCM_UNLIKELY (yy == 0))
  1202. scm_num_overflow (s_scm_floor_divide);
  1203. else
  1204. {
  1205. scm_t_inum qq = xx / yy;
  1206. scm_t_inum rr = xx % yy;
  1207. int needs_adjustment;
  1208. if (SCM_LIKELY (yy > 0))
  1209. needs_adjustment = (rr < 0);
  1210. else
  1211. needs_adjustment = (rr > 0);
  1212. if (needs_adjustment)
  1213. {
  1214. rr += yy;
  1215. qq--;
  1216. }
  1217. if (SCM_LIKELY (SCM_FIXABLE (qq)))
  1218. *qp = SCM_I_MAKINUM (qq);
  1219. else
  1220. *qp = scm_i_inum2big (qq);
  1221. *rp = SCM_I_MAKINUM (rr);
  1222. }
  1223. return;
  1224. }
  1225. else if (SCM_BIGP (y))
  1226. {
  1227. int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
  1228. scm_remember_upto_here_1 (y);
  1229. if (sign > 0)
  1230. {
  1231. if (xx < 0)
  1232. {
  1233. SCM r = scm_i_mkbig ();
  1234. mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
  1235. scm_remember_upto_here_1 (y);
  1236. *qp = SCM_I_MAKINUM (-1);
  1237. *rp = scm_i_normbig (r);
  1238. }
  1239. else
  1240. {
  1241. *qp = SCM_INUM0;
  1242. *rp = x;
  1243. }
  1244. }
  1245. else if (xx <= 0)
  1246. {
  1247. *qp = SCM_INUM0;
  1248. *rp = x;
  1249. }
  1250. else
  1251. {
  1252. SCM r = scm_i_mkbig ();
  1253. mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
  1254. scm_remember_upto_here_1 (y);
  1255. *qp = SCM_I_MAKINUM (-1);
  1256. *rp = scm_i_normbig (r);
  1257. }
  1258. return;
  1259. }
  1260. else if (SCM_REALP (y))
  1261. return scm_i_inexact_floor_divide (xx, SCM_REAL_VALUE (y), qp, rp);
  1262. else if (SCM_FRACTIONP (y))
  1263. return scm_i_exact_rational_floor_divide (x, y, qp, rp);
  1264. else
  1265. return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
  1266. s_scm_floor_divide, qp, rp);
  1267. }
  1268. else if (SCM_BIGP (x))
  1269. {
  1270. if (SCM_LIKELY (SCM_I_INUMP (y)))
  1271. {
  1272. scm_t_inum yy = SCM_I_INUM (y);
  1273. if (SCM_UNLIKELY (yy == 0))
  1274. scm_num_overflow (s_scm_floor_divide);
  1275. else
  1276. {
  1277. SCM q = scm_i_mkbig ();
  1278. SCM r = scm_i_mkbig ();
  1279. if (yy > 0)
  1280. mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
  1281. SCM_I_BIG_MPZ (x), yy);
  1282. else
  1283. {
  1284. mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
  1285. SCM_I_BIG_MPZ (x), -yy);
  1286. mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
  1287. }
  1288. scm_remember_upto_here_1 (x);
  1289. *qp = scm_i_normbig (q);
  1290. *rp = scm_i_normbig (r);
  1291. }
  1292. return;
  1293. }
  1294. else if (SCM_BIGP (y))
  1295. {
  1296. SCM q = scm_i_mkbig ();
  1297. SCM r = scm_i_mkbig ();
  1298. mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
  1299. SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  1300. scm_remember_upto_here_2 (x, y);
  1301. *qp = scm_i_normbig (q);
  1302. *rp = scm_i_normbig (r);
  1303. return;
  1304. }
  1305. else if (SCM_REALP (y))
  1306. return scm_i_inexact_floor_divide
  1307. (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
  1308. else if (SCM_FRACTIONP (y))
  1309. return scm_i_exact_rational_floor_divide (x, y, qp, rp);
  1310. else
  1311. return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
  1312. s_scm_floor_divide, qp, rp);
  1313. }
  1314. else if (SCM_REALP (x))
  1315. {
  1316. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  1317. SCM_BIGP (y) || SCM_FRACTIONP (y))
  1318. return scm_i_inexact_floor_divide
  1319. (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
  1320. else
  1321. return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
  1322. s_scm_floor_divide, qp, rp);
  1323. }
  1324. else if (SCM_FRACTIONP (x))
  1325. {
  1326. if (SCM_REALP (y))
  1327. return scm_i_inexact_floor_divide
  1328. (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
  1329. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  1330. return scm_i_exact_rational_floor_divide (x, y, qp, rp);
  1331. else
  1332. return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
  1333. s_scm_floor_divide, qp, rp);
  1334. }
  1335. else
  1336. return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG1,
  1337. s_scm_floor_divide, qp, rp);
  1338. }
  1339. static void
  1340. scm_i_inexact_floor_divide (double x, double y, SCM *qp, SCM *rp)
  1341. {
  1342. if (SCM_UNLIKELY (y == 0))
  1343. scm_num_overflow (s_scm_floor_divide); /* or return a NaN? */
  1344. else
  1345. {
  1346. double q = floor (x / y);
  1347. double r = x - q * y;
  1348. *qp = scm_from_double (q);
  1349. *rp = scm_from_double (r);
  1350. }
  1351. }
  1352. static void
  1353. scm_i_exact_rational_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp)
  1354. {
  1355. SCM r1;
  1356. SCM xd = scm_denominator (x);
  1357. SCM yd = scm_denominator (y);
  1358. scm_floor_divide (scm_product (scm_numerator (x), yd),
  1359. scm_product (scm_numerator (y), xd),
  1360. qp, &r1);
  1361. *rp = scm_divide (r1, scm_product (xd, yd));
  1362. }
  1363. static SCM scm_i_inexact_ceiling_quotient (double x, double y);
  1364. static SCM scm_i_exact_rational_ceiling_quotient (SCM x, SCM y);
  1365. SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0,
  1366. (SCM x, SCM y),
  1367. "Return the ceiling of @math{@var{x} / @var{y}}.\n"
  1368. "@lisp\n"
  1369. "(ceiling-quotient 123 10) @result{} 13\n"
  1370. "(ceiling-quotient 123 -10) @result{} -12\n"
  1371. "(ceiling-quotient -123 10) @result{} -12\n"
  1372. "(ceiling-quotient -123 -10) @result{} 13\n"
  1373. "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
  1374. "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
  1375. "@end lisp")
  1376. #define FUNC_NAME s_scm_ceiling_quotient
  1377. {
  1378. if (SCM_LIKELY (SCM_I_INUMP (x)))
  1379. {
  1380. scm_t_inum xx = SCM_I_INUM (x);
  1381. if (SCM_LIKELY (SCM_I_INUMP (y)))
  1382. {
  1383. scm_t_inum yy = SCM_I_INUM (y);
  1384. if (SCM_UNLIKELY (yy == 0))
  1385. scm_num_overflow (s_scm_ceiling_quotient);
  1386. else
  1387. {
  1388. scm_t_inum xx1 = xx;
  1389. scm_t_inum qq;
  1390. if (SCM_LIKELY (yy > 0))
  1391. {
  1392. if (SCM_LIKELY (xx >= 0))
  1393. xx1 = xx + yy - 1;
  1394. }
  1395. else if (xx < 0)
  1396. xx1 = xx + yy + 1;
  1397. qq = xx1 / yy;
  1398. if (SCM_LIKELY (SCM_FIXABLE (qq)))
  1399. return SCM_I_MAKINUM (qq);
  1400. else
  1401. return scm_i_inum2big (qq);
  1402. }
  1403. }
  1404. else if (SCM_BIGP (y))
  1405. {
  1406. int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
  1407. scm_remember_upto_here_1 (y);
  1408. if (SCM_LIKELY (sign > 0))
  1409. {
  1410. if (SCM_LIKELY (xx > 0))
  1411. return SCM_INUM1;
  1412. else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
  1413. && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
  1414. - SCM_MOST_NEGATIVE_FIXNUM) == 0))
  1415. {
  1416. /* Special case: x == fixnum-min && y == abs (fixnum-min) */
  1417. scm_remember_upto_here_1 (y);
  1418. return SCM_I_MAKINUM (-1);
  1419. }
  1420. else
  1421. return SCM_INUM0;
  1422. }
  1423. else if (xx >= 0)
  1424. return SCM_INUM0;
  1425. else
  1426. return SCM_INUM1;
  1427. }
  1428. else if (SCM_REALP (y))
  1429. return scm_i_inexact_ceiling_quotient (xx, SCM_REAL_VALUE (y));
  1430. else if (SCM_FRACTIONP (y))
  1431. return scm_i_exact_rational_ceiling_quotient (x, y);
  1432. else
  1433. return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
  1434. s_scm_ceiling_quotient);
  1435. }
  1436. else if (SCM_BIGP (x))
  1437. {
  1438. if (SCM_LIKELY (SCM_I_INUMP (y)))
  1439. {
  1440. scm_t_inum yy = SCM_I_INUM (y);
  1441. if (SCM_UNLIKELY (yy == 0))
  1442. scm_num_overflow (s_scm_ceiling_quotient);
  1443. else if (SCM_UNLIKELY (yy == 1))
  1444. return x;
  1445. else
  1446. {
  1447. SCM q = scm_i_mkbig ();
  1448. if (yy > 0)
  1449. mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
  1450. else
  1451. {
  1452. mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
  1453. mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
  1454. }
  1455. scm_remember_upto_here_1 (x);
  1456. return scm_i_normbig (q);
  1457. }
  1458. }
  1459. else if (SCM_BIGP (y))
  1460. {
  1461. SCM q = scm_i_mkbig ();
  1462. mpz_cdiv_q (SCM_I_BIG_MPZ (q),
  1463. SCM_I_BIG_MPZ (x),
  1464. SCM_I_BIG_MPZ (y));
  1465. scm_remember_upto_here_2 (x, y);
  1466. return scm_i_normbig (q);
  1467. }
  1468. else if (SCM_REALP (y))
  1469. return scm_i_inexact_ceiling_quotient
  1470. (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
  1471. else if (SCM_FRACTIONP (y))
  1472. return scm_i_exact_rational_ceiling_quotient (x, y);
  1473. else
  1474. return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
  1475. s_scm_ceiling_quotient);
  1476. }
  1477. else if (SCM_REALP (x))
  1478. {
  1479. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  1480. SCM_BIGP (y) || SCM_FRACTIONP (y))
  1481. return scm_i_inexact_ceiling_quotient
  1482. (SCM_REAL_VALUE (x), scm_to_double (y));
  1483. else
  1484. return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
  1485. s_scm_ceiling_quotient);
  1486. }
  1487. else if (SCM_FRACTIONP (x))
  1488. {
  1489. if (SCM_REALP (y))
  1490. return scm_i_inexact_ceiling_quotient
  1491. (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
  1492. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  1493. return scm_i_exact_rational_ceiling_quotient (x, y);
  1494. else
  1495. return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
  1496. s_scm_ceiling_quotient);
  1497. }
  1498. else
  1499. return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
  1500. s_scm_ceiling_quotient);
  1501. }
  1502. #undef FUNC_NAME
  1503. static SCM
  1504. scm_i_inexact_ceiling_quotient (double x, double y)
  1505. {
  1506. if (SCM_UNLIKELY (y == 0))
  1507. scm_num_overflow (s_scm_ceiling_quotient); /* or return a NaN? */
  1508. else
  1509. return scm_from_double (ceil (x / y));
  1510. }
  1511. static SCM
  1512. scm_i_exact_rational_ceiling_quotient (SCM x, SCM y)
  1513. {
  1514. return scm_ceiling_quotient
  1515. (scm_product (scm_numerator (x), scm_denominator (y)),
  1516. scm_product (scm_numerator (y), scm_denominator (x)));
  1517. }
  1518. static SCM scm_i_inexact_ceiling_remainder (double x, double y);
  1519. static SCM scm_i_exact_rational_ceiling_remainder (SCM x, SCM y);
  1520. SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder, "ceiling-remainder", 2, 0, 0,
  1521. (SCM x, SCM y),
  1522. "Return the real number @var{r} such that\n"
  1523. "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
  1524. "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
  1525. "@lisp\n"
  1526. "(ceiling-remainder 123 10) @result{} -7\n"
  1527. "(ceiling-remainder 123 -10) @result{} 3\n"
  1528. "(ceiling-remainder -123 10) @result{} -3\n"
  1529. "(ceiling-remainder -123 -10) @result{} 7\n"
  1530. "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
  1531. "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
  1532. "@end lisp")
  1533. #define FUNC_NAME s_scm_ceiling_remainder
  1534. {
  1535. if (SCM_LIKELY (SCM_I_INUMP (x)))
  1536. {
  1537. scm_t_inum xx = SCM_I_INUM (x);
  1538. if (SCM_LIKELY (SCM_I_INUMP (y)))
  1539. {
  1540. scm_t_inum yy = SCM_I_INUM (y);
  1541. if (SCM_UNLIKELY (yy == 0))
  1542. scm_num_overflow (s_scm_ceiling_remainder);
  1543. else
  1544. {
  1545. scm_t_inum rr = xx % yy;
  1546. int needs_adjustment;
  1547. if (SCM_LIKELY (yy > 0))
  1548. needs_adjustment = (rr > 0);
  1549. else
  1550. needs_adjustment = (rr < 0);
  1551. if (needs_adjustment)
  1552. rr -= yy;
  1553. return SCM_I_MAKINUM (rr);
  1554. }
  1555. }
  1556. else if (SCM_BIGP (y))
  1557. {
  1558. int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
  1559. scm_remember_upto_here_1 (y);
  1560. if (SCM_LIKELY (sign > 0))
  1561. {
  1562. if (SCM_LIKELY (xx > 0))
  1563. {
  1564. SCM r = scm_i_mkbig ();
  1565. mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
  1566. scm_remember_upto_here_1 (y);
  1567. mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
  1568. return scm_i_normbig (r);
  1569. }
  1570. else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
  1571. && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
  1572. - SCM_MOST_NEGATIVE_FIXNUM) == 0))
  1573. {
  1574. /* Special case: x == fixnum-min && y == abs (fixnum-min) */
  1575. scm_remember_upto_here_1 (y);
  1576. return SCM_INUM0;
  1577. }
  1578. else
  1579. return x;
  1580. }
  1581. else if (xx >= 0)
  1582. return x;
  1583. else
  1584. {
  1585. SCM r = scm_i_mkbig ();
  1586. mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
  1587. scm_remember_upto_here_1 (y);
  1588. mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
  1589. return scm_i_normbig (r);
  1590. }
  1591. }
  1592. else if (SCM_REALP (y))
  1593. return scm_i_inexact_ceiling_remainder (xx, SCM_REAL_VALUE (y));
  1594. else if (SCM_FRACTIONP (y))
  1595. return scm_i_exact_rational_ceiling_remainder (x, y);
  1596. else
  1597. return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
  1598. s_scm_ceiling_remainder);
  1599. }
  1600. else if (SCM_BIGP (x))
  1601. {
  1602. if (SCM_LIKELY (SCM_I_INUMP (y)))
  1603. {
  1604. scm_t_inum yy = SCM_I_INUM (y);
  1605. if (SCM_UNLIKELY (yy == 0))
  1606. scm_num_overflow (s_scm_ceiling_remainder);
  1607. else
  1608. {
  1609. scm_t_inum rr;
  1610. if (yy > 0)
  1611. rr = -mpz_cdiv_ui (SCM_I_BIG_MPZ (x), yy);
  1612. else
  1613. rr = mpz_fdiv_ui (SCM_I_BIG_MPZ (x), -yy);
  1614. scm_remember_upto_here_1 (x);
  1615. return SCM_I_MAKINUM (rr);
  1616. }
  1617. }
  1618. else if (SCM_BIGP (y))
  1619. {
  1620. SCM r = scm_i_mkbig ();
  1621. mpz_cdiv_r (SCM_I_BIG_MPZ (r),
  1622. SCM_I_BIG_MPZ (x),
  1623. SCM_I_BIG_MPZ (y));
  1624. scm_remember_upto_here_2 (x, y);
  1625. return scm_i_normbig (r);
  1626. }
  1627. else if (SCM_REALP (y))
  1628. return scm_i_inexact_ceiling_remainder
  1629. (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
  1630. else if (SCM_FRACTIONP (y))
  1631. return scm_i_exact_rational_ceiling_remainder (x, y);
  1632. else
  1633. return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
  1634. s_scm_ceiling_remainder);
  1635. }
  1636. else if (SCM_REALP (x))
  1637. {
  1638. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  1639. SCM_BIGP (y) || SCM_FRACTIONP (y))
  1640. return scm_i_inexact_ceiling_remainder
  1641. (SCM_REAL_VALUE (x), scm_to_double (y));
  1642. else
  1643. return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
  1644. s_scm_ceiling_remainder);
  1645. }
  1646. else if (SCM_FRACTIONP (x))
  1647. {
  1648. if (SCM_REALP (y))
  1649. return scm_i_inexact_ceiling_remainder
  1650. (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
  1651. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  1652. return scm_i_exact_rational_ceiling_remainder (x, y);
  1653. else
  1654. return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
  1655. s_scm_ceiling_remainder);
  1656. }
  1657. else
  1658. return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
  1659. s_scm_ceiling_remainder);
  1660. }
  1661. #undef FUNC_NAME
  1662. static SCM
  1663. scm_i_inexact_ceiling_remainder (double x, double y)
  1664. {
  1665. /* Although it would be more efficient to use fmod here, we can't
  1666. because it would in some cases produce results inconsistent with
  1667. scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
  1668. close). In particular, when x is very close to a multiple of y,
  1669. then r might be either 0.0 or -y, but those two cases must
  1670. correspond to different choices of q. If r = 0.0 then q must be
  1671. x/y, and if r = -y then q must be x/y+1. If quotient chooses one
  1672. and remainder chooses the other, it would be bad. */
  1673. if (SCM_UNLIKELY (y == 0))
  1674. scm_num_overflow (s_scm_ceiling_remainder); /* or return a NaN? */
  1675. else
  1676. return scm_from_double (x - y * ceil (x / y));
  1677. }
  1678. static SCM
  1679. scm_i_exact_rational_ceiling_remainder (SCM x, SCM y)
  1680. {
  1681. SCM xd = scm_denominator (x);
  1682. SCM yd = scm_denominator (y);
  1683. SCM r1 = scm_ceiling_remainder (scm_product (scm_numerator (x), yd),
  1684. scm_product (scm_numerator (y), xd));
  1685. return scm_divide (r1, scm_product (xd, yd));
  1686. }
  1687. static void scm_i_inexact_ceiling_divide (double x, double y,
  1688. SCM *qp, SCM *rp);
  1689. static void scm_i_exact_rational_ceiling_divide (SCM x, SCM y,
  1690. SCM *qp, SCM *rp);
  1691. SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide, "ceiling/", 2, 0, 0,
  1692. (SCM x, SCM y),
  1693. "Return the integer @var{q} and the real number @var{r}\n"
  1694. "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
  1695. "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
  1696. "@lisp\n"
  1697. "(ceiling/ 123 10) @result{} 13 and -7\n"
  1698. "(ceiling/ 123 -10) @result{} -12 and 3\n"
  1699. "(ceiling/ -123 10) @result{} -12 and -3\n"
  1700. "(ceiling/ -123 -10) @result{} 13 and 7\n"
  1701. "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
  1702. "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
  1703. "@end lisp")
  1704. #define FUNC_NAME s_scm_i_ceiling_divide
  1705. {
  1706. SCM q, r;
  1707. scm_ceiling_divide(x, y, &q, &r);
  1708. return scm_values (scm_list_2 (q, r));
  1709. }
  1710. #undef FUNC_NAME
  1711. #define s_scm_ceiling_divide s_scm_i_ceiling_divide
  1712. #define g_scm_ceiling_divide g_scm_i_ceiling_divide
  1713. void
  1714. scm_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp)
  1715. {
  1716. if (SCM_LIKELY (SCM_I_INUMP (x)))
  1717. {
  1718. scm_t_inum xx = SCM_I_INUM (x);
  1719. if (SCM_LIKELY (SCM_I_INUMP (y)))
  1720. {
  1721. scm_t_inum yy = SCM_I_INUM (y);
  1722. if (SCM_UNLIKELY (yy == 0))
  1723. scm_num_overflow (s_scm_ceiling_divide);
  1724. else
  1725. {
  1726. scm_t_inum qq = xx / yy;
  1727. scm_t_inum rr = xx % yy;
  1728. int needs_adjustment;
  1729. if (SCM_LIKELY (yy > 0))
  1730. needs_adjustment = (rr > 0);
  1731. else
  1732. needs_adjustment = (rr < 0);
  1733. if (needs_adjustment)
  1734. {
  1735. rr -= yy;
  1736. qq++;
  1737. }
  1738. if (SCM_LIKELY (SCM_FIXABLE (qq)))
  1739. *qp = SCM_I_MAKINUM (qq);
  1740. else
  1741. *qp = scm_i_inum2big (qq);
  1742. *rp = SCM_I_MAKINUM (rr);
  1743. }
  1744. return;
  1745. }
  1746. else if (SCM_BIGP (y))
  1747. {
  1748. int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
  1749. scm_remember_upto_here_1 (y);
  1750. if (SCM_LIKELY (sign > 0))
  1751. {
  1752. if (SCM_LIKELY (xx > 0))
  1753. {
  1754. SCM r = scm_i_mkbig ();
  1755. mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
  1756. scm_remember_upto_here_1 (y);
  1757. mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
  1758. *qp = SCM_INUM1;
  1759. *rp = scm_i_normbig (r);
  1760. }
  1761. else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
  1762. && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
  1763. - SCM_MOST_NEGATIVE_FIXNUM) == 0))
  1764. {
  1765. /* Special case: x == fixnum-min && y == abs (fixnum-min) */
  1766. scm_remember_upto_here_1 (y);
  1767. *qp = SCM_I_MAKINUM (-1);
  1768. *rp = SCM_INUM0;
  1769. }
  1770. else
  1771. {
  1772. *qp = SCM_INUM0;
  1773. *rp = x;
  1774. }
  1775. }
  1776. else if (xx >= 0)
  1777. {
  1778. *qp = SCM_INUM0;
  1779. *rp = x;
  1780. }
  1781. else
  1782. {
  1783. SCM r = scm_i_mkbig ();
  1784. mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
  1785. scm_remember_upto_here_1 (y);
  1786. mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
  1787. *qp = SCM_INUM1;
  1788. *rp = scm_i_normbig (r);
  1789. }
  1790. return;
  1791. }
  1792. else if (SCM_REALP (y))
  1793. return scm_i_inexact_ceiling_divide (xx, SCM_REAL_VALUE (y), qp, rp);
  1794. else if (SCM_FRACTIONP (y))
  1795. return scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
  1796. else
  1797. return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
  1798. s_scm_ceiling_divide, qp, rp);
  1799. }
  1800. else if (SCM_BIGP (x))
  1801. {
  1802. if (SCM_LIKELY (SCM_I_INUMP (y)))
  1803. {
  1804. scm_t_inum yy = SCM_I_INUM (y);
  1805. if (SCM_UNLIKELY (yy == 0))
  1806. scm_num_overflow (s_scm_ceiling_divide);
  1807. else
  1808. {
  1809. SCM q = scm_i_mkbig ();
  1810. SCM r = scm_i_mkbig ();
  1811. if (yy > 0)
  1812. mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
  1813. SCM_I_BIG_MPZ (x), yy);
  1814. else
  1815. {
  1816. mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
  1817. SCM_I_BIG_MPZ (x), -yy);
  1818. mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
  1819. }
  1820. scm_remember_upto_here_1 (x);
  1821. *qp = scm_i_normbig (q);
  1822. *rp = scm_i_normbig (r);
  1823. }
  1824. return;
  1825. }
  1826. else if (SCM_BIGP (y))
  1827. {
  1828. SCM q = scm_i_mkbig ();
  1829. SCM r = scm_i_mkbig ();
  1830. mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
  1831. SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  1832. scm_remember_upto_here_2 (x, y);
  1833. *qp = scm_i_normbig (q);
  1834. *rp = scm_i_normbig (r);
  1835. return;
  1836. }
  1837. else if (SCM_REALP (y))
  1838. return scm_i_inexact_ceiling_divide
  1839. (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
  1840. else if (SCM_FRACTIONP (y))
  1841. return scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
  1842. else
  1843. return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
  1844. s_scm_ceiling_divide, qp, rp);
  1845. }
  1846. else if (SCM_REALP (x))
  1847. {
  1848. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  1849. SCM_BIGP (y) || SCM_FRACTIONP (y))
  1850. return scm_i_inexact_ceiling_divide
  1851. (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
  1852. else
  1853. return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
  1854. s_scm_ceiling_divide, qp, rp);
  1855. }
  1856. else if (SCM_FRACTIONP (x))
  1857. {
  1858. if (SCM_REALP (y))
  1859. return scm_i_inexact_ceiling_divide
  1860. (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
  1861. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  1862. return scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
  1863. else
  1864. return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
  1865. s_scm_ceiling_divide, qp, rp);
  1866. }
  1867. else
  1868. return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG1,
  1869. s_scm_ceiling_divide, qp, rp);
  1870. }
  1871. static void
  1872. scm_i_inexact_ceiling_divide (double x, double y, SCM *qp, SCM *rp)
  1873. {
  1874. if (SCM_UNLIKELY (y == 0))
  1875. scm_num_overflow (s_scm_ceiling_divide); /* or return a NaN? */
  1876. else
  1877. {
  1878. double q = ceil (x / y);
  1879. double r = x - q * y;
  1880. *qp = scm_from_double (q);
  1881. *rp = scm_from_double (r);
  1882. }
  1883. }
  1884. static void
  1885. scm_i_exact_rational_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp)
  1886. {
  1887. SCM r1;
  1888. SCM xd = scm_denominator (x);
  1889. SCM yd = scm_denominator (y);
  1890. scm_ceiling_divide (scm_product (scm_numerator (x), yd),
  1891. scm_product (scm_numerator (y), xd),
  1892. qp, &r1);
  1893. *rp = scm_divide (r1, scm_product (xd, yd));
  1894. }
  1895. static SCM scm_i_inexact_truncate_quotient (double x, double y);
  1896. static SCM scm_i_exact_rational_truncate_quotient (SCM x, SCM y);
  1897. SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-quotient", 2, 0, 0,
  1898. (SCM x, SCM y),
  1899. "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
  1900. "@lisp\n"
  1901. "(truncate-quotient 123 10) @result{} 12\n"
  1902. "(truncate-quotient 123 -10) @result{} -12\n"
  1903. "(truncate-quotient -123 10) @result{} -12\n"
  1904. "(truncate-quotient -123 -10) @result{} 12\n"
  1905. "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
  1906. "(truncate-quotient 16/3 -10/7) @result{} -3\n"
  1907. "@end lisp")
  1908. #define FUNC_NAME s_scm_truncate_quotient
  1909. {
  1910. if (SCM_LIKELY (SCM_I_INUMP (x)))
  1911. {
  1912. scm_t_inum xx = SCM_I_INUM (x);
  1913. if (SCM_LIKELY (SCM_I_INUMP (y)))
  1914. {
  1915. scm_t_inum yy = SCM_I_INUM (y);
  1916. if (SCM_UNLIKELY (yy == 0))
  1917. scm_num_overflow (s_scm_truncate_quotient);
  1918. else
  1919. {
  1920. scm_t_inum qq = xx / yy;
  1921. if (SCM_LIKELY (SCM_FIXABLE (qq)))
  1922. return SCM_I_MAKINUM (qq);
  1923. else
  1924. return scm_i_inum2big (qq);
  1925. }
  1926. }
  1927. else if (SCM_BIGP (y))
  1928. {
  1929. if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
  1930. && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
  1931. - SCM_MOST_NEGATIVE_FIXNUM) == 0))
  1932. {
  1933. /* Special case: x == fixnum-min && y == abs (fixnum-min) */
  1934. scm_remember_upto_here_1 (y);
  1935. return SCM_I_MAKINUM (-1);
  1936. }
  1937. else
  1938. return SCM_INUM0;
  1939. }
  1940. else if (SCM_REALP (y))
  1941. return scm_i_inexact_truncate_quotient (xx, SCM_REAL_VALUE (y));
  1942. else if (SCM_FRACTIONP (y))
  1943. return scm_i_exact_rational_truncate_quotient (x, y);
  1944. else
  1945. return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
  1946. s_scm_truncate_quotient);
  1947. }
  1948. else if (SCM_BIGP (x))
  1949. {
  1950. if (SCM_LIKELY (SCM_I_INUMP (y)))
  1951. {
  1952. scm_t_inum yy = SCM_I_INUM (y);
  1953. if (SCM_UNLIKELY (yy == 0))
  1954. scm_num_overflow (s_scm_truncate_quotient);
  1955. else if (SCM_UNLIKELY (yy == 1))
  1956. return x;
  1957. else
  1958. {
  1959. SCM q = scm_i_mkbig ();
  1960. if (yy > 0)
  1961. mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
  1962. else
  1963. {
  1964. mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
  1965. mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
  1966. }
  1967. scm_remember_upto_here_1 (x);
  1968. return scm_i_normbig (q);
  1969. }
  1970. }
  1971. else if (SCM_BIGP (y))
  1972. {
  1973. SCM q = scm_i_mkbig ();
  1974. mpz_tdiv_q (SCM_I_BIG_MPZ (q),
  1975. SCM_I_BIG_MPZ (x),
  1976. SCM_I_BIG_MPZ (y));
  1977. scm_remember_upto_here_2 (x, y);
  1978. return scm_i_normbig (q);
  1979. }
  1980. else if (SCM_REALP (y))
  1981. return scm_i_inexact_truncate_quotient
  1982. (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
  1983. else if (SCM_FRACTIONP (y))
  1984. return scm_i_exact_rational_truncate_quotient (x, y);
  1985. else
  1986. return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
  1987. s_scm_truncate_quotient);
  1988. }
  1989. else if (SCM_REALP (x))
  1990. {
  1991. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  1992. SCM_BIGP (y) || SCM_FRACTIONP (y))
  1993. return scm_i_inexact_truncate_quotient
  1994. (SCM_REAL_VALUE (x), scm_to_double (y));
  1995. else
  1996. return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
  1997. s_scm_truncate_quotient);
  1998. }
  1999. else if (SCM_FRACTIONP (x))
  2000. {
  2001. if (SCM_REALP (y))
  2002. return scm_i_inexact_truncate_quotient
  2003. (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
  2004. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  2005. return scm_i_exact_rational_truncate_quotient (x, y);
  2006. else
  2007. return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
  2008. s_scm_truncate_quotient);
  2009. }
  2010. else
  2011. return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
  2012. s_scm_truncate_quotient);
  2013. }
  2014. #undef FUNC_NAME
  2015. static SCM
  2016. scm_i_inexact_truncate_quotient (double x, double y)
  2017. {
  2018. if (SCM_UNLIKELY (y == 0))
  2019. scm_num_overflow (s_scm_truncate_quotient); /* or return a NaN? */
  2020. else
  2021. return scm_from_double (trunc (x / y));
  2022. }
  2023. static SCM
  2024. scm_i_exact_rational_truncate_quotient (SCM x, SCM y)
  2025. {
  2026. return scm_truncate_quotient
  2027. (scm_product (scm_numerator (x), scm_denominator (y)),
  2028. scm_product (scm_numerator (y), scm_denominator (x)));
  2029. }
  2030. static SCM scm_i_inexact_truncate_remainder (double x, double y);
  2031. static SCM scm_i_exact_rational_truncate_remainder (SCM x, SCM y);
  2032. SCM_PRIMITIVE_GENERIC (scm_truncate_remainder, "truncate-remainder", 2, 0, 0,
  2033. (SCM x, SCM y),
  2034. "Return the real number @var{r} such that\n"
  2035. "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
  2036. "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
  2037. "@lisp\n"
  2038. "(truncate-remainder 123 10) @result{} 3\n"
  2039. "(truncate-remainder 123 -10) @result{} 3\n"
  2040. "(truncate-remainder -123 10) @result{} -3\n"
  2041. "(truncate-remainder -123 -10) @result{} -3\n"
  2042. "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
  2043. "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
  2044. "@end lisp")
  2045. #define FUNC_NAME s_scm_truncate_remainder
  2046. {
  2047. if (SCM_LIKELY (SCM_I_INUMP (x)))
  2048. {
  2049. scm_t_inum xx = SCM_I_INUM (x);
  2050. if (SCM_LIKELY (SCM_I_INUMP (y)))
  2051. {
  2052. scm_t_inum yy = SCM_I_INUM (y);
  2053. if (SCM_UNLIKELY (yy == 0))
  2054. scm_num_overflow (s_scm_truncate_remainder);
  2055. else
  2056. return SCM_I_MAKINUM (xx % yy);
  2057. }
  2058. else if (SCM_BIGP (y))
  2059. {
  2060. if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
  2061. && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
  2062. - SCM_MOST_NEGATIVE_FIXNUM) == 0))
  2063. {
  2064. /* Special case: x == fixnum-min && y == abs (fixnum-min) */
  2065. scm_remember_upto_here_1 (y);
  2066. return SCM_INUM0;
  2067. }
  2068. else
  2069. return x;
  2070. }
  2071. else if (SCM_REALP (y))
  2072. return scm_i_inexact_truncate_remainder (xx, SCM_REAL_VALUE (y));
  2073. else if (SCM_FRACTIONP (y))
  2074. return scm_i_exact_rational_truncate_remainder (x, y);
  2075. else
  2076. return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
  2077. s_scm_truncate_remainder);
  2078. }
  2079. else if (SCM_BIGP (x))
  2080. {
  2081. if (SCM_LIKELY (SCM_I_INUMP (y)))
  2082. {
  2083. scm_t_inum yy = SCM_I_INUM (y);
  2084. if (SCM_UNLIKELY (yy == 0))
  2085. scm_num_overflow (s_scm_truncate_remainder);
  2086. else
  2087. {
  2088. scm_t_inum rr = (mpz_tdiv_ui (SCM_I_BIG_MPZ (x),
  2089. (yy > 0) ? yy : -yy)
  2090. * mpz_sgn (SCM_I_BIG_MPZ (x)));
  2091. scm_remember_upto_here_1 (x);
  2092. return SCM_I_MAKINUM (rr);
  2093. }
  2094. }
  2095. else if (SCM_BIGP (y))
  2096. {
  2097. SCM r = scm_i_mkbig ();
  2098. mpz_tdiv_r (SCM_I_BIG_MPZ (r),
  2099. SCM_I_BIG_MPZ (x),
  2100. SCM_I_BIG_MPZ (y));
  2101. scm_remember_upto_here_2 (x, y);
  2102. return scm_i_normbig (r);
  2103. }
  2104. else if (SCM_REALP (y))
  2105. return scm_i_inexact_truncate_remainder
  2106. (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
  2107. else if (SCM_FRACTIONP (y))
  2108. return scm_i_exact_rational_truncate_remainder (x, y);
  2109. else
  2110. return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
  2111. s_scm_truncate_remainder);
  2112. }
  2113. else if (SCM_REALP (x))
  2114. {
  2115. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  2116. SCM_BIGP (y) || SCM_FRACTIONP (y))
  2117. return scm_i_inexact_truncate_remainder
  2118. (SCM_REAL_VALUE (x), scm_to_double (y));
  2119. else
  2120. return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
  2121. s_scm_truncate_remainder);
  2122. }
  2123. else if (SCM_FRACTIONP (x))
  2124. {
  2125. if (SCM_REALP (y))
  2126. return scm_i_inexact_truncate_remainder
  2127. (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
  2128. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  2129. return scm_i_exact_rational_truncate_remainder (x, y);
  2130. else
  2131. return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
  2132. s_scm_truncate_remainder);
  2133. }
  2134. else
  2135. return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
  2136. s_scm_truncate_remainder);
  2137. }
  2138. #undef FUNC_NAME
  2139. static SCM
  2140. scm_i_inexact_truncate_remainder (double x, double y)
  2141. {
  2142. /* Although it would be more efficient to use fmod here, we can't
  2143. because it would in some cases produce results inconsistent with
  2144. scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
  2145. close). In particular, when x is very close to a multiple of y,
  2146. then r might be either 0.0 or sgn(x)*|y|, but those two cases must
  2147. correspond to different choices of q. If quotient chooses one and
  2148. remainder chooses the other, it would be bad. */
  2149. if (SCM_UNLIKELY (y == 0))
  2150. scm_num_overflow (s_scm_truncate_remainder); /* or return a NaN? */
  2151. else
  2152. return scm_from_double (x - y * trunc (x / y));
  2153. }
  2154. static SCM
  2155. scm_i_exact_rational_truncate_remainder (SCM x, SCM y)
  2156. {
  2157. SCM xd = scm_denominator (x);
  2158. SCM yd = scm_denominator (y);
  2159. SCM r1 = scm_truncate_remainder (scm_product (scm_numerator (x), yd),
  2160. scm_product (scm_numerator (y), xd));
  2161. return scm_divide (r1, scm_product (xd, yd));
  2162. }
  2163. static void scm_i_inexact_truncate_divide (double x, double y,
  2164. SCM *qp, SCM *rp);
  2165. static void scm_i_exact_rational_truncate_divide (SCM x, SCM y,
  2166. SCM *qp, SCM *rp);
  2167. SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide, "truncate/", 2, 0, 0,
  2168. (SCM x, SCM y),
  2169. "Return the integer @var{q} and the real number @var{r}\n"
  2170. "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
  2171. "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
  2172. "@lisp\n"
  2173. "(truncate/ 123 10) @result{} 12 and 3\n"
  2174. "(truncate/ 123 -10) @result{} -12 and 3\n"
  2175. "(truncate/ -123 10) @result{} -12 and -3\n"
  2176. "(truncate/ -123 -10) @result{} 12 and -3\n"
  2177. "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
  2178. "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
  2179. "@end lisp")
  2180. #define FUNC_NAME s_scm_i_truncate_divide
  2181. {
  2182. SCM q, r;
  2183. scm_truncate_divide(x, y, &q, &r);
  2184. return scm_values (scm_list_2 (q, r));
  2185. }
  2186. #undef FUNC_NAME
  2187. #define s_scm_truncate_divide s_scm_i_truncate_divide
  2188. #define g_scm_truncate_divide g_scm_i_truncate_divide
  2189. void
  2190. scm_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp)
  2191. {
  2192. if (SCM_LIKELY (SCM_I_INUMP (x)))
  2193. {
  2194. scm_t_inum xx = SCM_I_INUM (x);
  2195. if (SCM_LIKELY (SCM_I_INUMP (y)))
  2196. {
  2197. scm_t_inum yy = SCM_I_INUM (y);
  2198. if (SCM_UNLIKELY (yy == 0))
  2199. scm_num_overflow (s_scm_truncate_divide);
  2200. else
  2201. {
  2202. scm_t_inum qq = xx / yy;
  2203. scm_t_inum rr = xx % yy;
  2204. if (SCM_LIKELY (SCM_FIXABLE (qq)))
  2205. *qp = SCM_I_MAKINUM (qq);
  2206. else
  2207. *qp = scm_i_inum2big (qq);
  2208. *rp = SCM_I_MAKINUM (rr);
  2209. }
  2210. return;
  2211. }
  2212. else if (SCM_BIGP (y))
  2213. {
  2214. if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
  2215. && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
  2216. - SCM_MOST_NEGATIVE_FIXNUM) == 0))
  2217. {
  2218. /* Special case: x == fixnum-min && y == abs (fixnum-min) */
  2219. scm_remember_upto_here_1 (y);
  2220. *qp = SCM_I_MAKINUM (-1);
  2221. *rp = SCM_INUM0;
  2222. }
  2223. else
  2224. {
  2225. *qp = SCM_INUM0;
  2226. *rp = x;
  2227. }
  2228. return;
  2229. }
  2230. else if (SCM_REALP (y))
  2231. return scm_i_inexact_truncate_divide (xx, SCM_REAL_VALUE (y), qp, rp);
  2232. else if (SCM_FRACTIONP (y))
  2233. return scm_i_exact_rational_truncate_divide (x, y, qp, rp);
  2234. else
  2235. return two_valued_wta_dispatch_2
  2236. (g_scm_truncate_divide, x, y, SCM_ARG2,
  2237. s_scm_truncate_divide, qp, rp);
  2238. }
  2239. else if (SCM_BIGP (x))
  2240. {
  2241. if (SCM_LIKELY (SCM_I_INUMP (y)))
  2242. {
  2243. scm_t_inum yy = SCM_I_INUM (y);
  2244. if (SCM_UNLIKELY (yy == 0))
  2245. scm_num_overflow (s_scm_truncate_divide);
  2246. else
  2247. {
  2248. SCM q = scm_i_mkbig ();
  2249. scm_t_inum rr;
  2250. if (yy > 0)
  2251. rr = mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q),
  2252. SCM_I_BIG_MPZ (x), yy);
  2253. else
  2254. {
  2255. rr = mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q),
  2256. SCM_I_BIG_MPZ (x), -yy);
  2257. mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
  2258. }
  2259. rr *= mpz_sgn (SCM_I_BIG_MPZ (x));
  2260. scm_remember_upto_here_1 (x);
  2261. *qp = scm_i_normbig (q);
  2262. *rp = SCM_I_MAKINUM (rr);
  2263. }
  2264. return;
  2265. }
  2266. else if (SCM_BIGP (y))
  2267. {
  2268. SCM q = scm_i_mkbig ();
  2269. SCM r = scm_i_mkbig ();
  2270. mpz_tdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
  2271. SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  2272. scm_remember_upto_here_2 (x, y);
  2273. *qp = scm_i_normbig (q);
  2274. *rp = scm_i_normbig (r);
  2275. }
  2276. else if (SCM_REALP (y))
  2277. return scm_i_inexact_truncate_divide
  2278. (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
  2279. else if (SCM_FRACTIONP (y))
  2280. return scm_i_exact_rational_truncate_divide (x, y, qp, rp);
  2281. else
  2282. return two_valued_wta_dispatch_2
  2283. (g_scm_truncate_divide, x, y, SCM_ARG2,
  2284. s_scm_truncate_divide, qp, rp);
  2285. }
  2286. else if (SCM_REALP (x))
  2287. {
  2288. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  2289. SCM_BIGP (y) || SCM_FRACTIONP (y))
  2290. return scm_i_inexact_truncate_divide
  2291. (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
  2292. else
  2293. return two_valued_wta_dispatch_2
  2294. (g_scm_truncate_divide, x, y, SCM_ARG2,
  2295. s_scm_truncate_divide, qp, rp);
  2296. }
  2297. else if (SCM_FRACTIONP (x))
  2298. {
  2299. if (SCM_REALP (y))
  2300. return scm_i_inexact_truncate_divide
  2301. (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
  2302. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  2303. return scm_i_exact_rational_truncate_divide (x, y, qp, rp);
  2304. else
  2305. return two_valued_wta_dispatch_2
  2306. (g_scm_truncate_divide, x, y, SCM_ARG2,
  2307. s_scm_truncate_divide, qp, rp);
  2308. }
  2309. else
  2310. return two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG1,
  2311. s_scm_truncate_divide, qp, rp);
  2312. }
  2313. static void
  2314. scm_i_inexact_truncate_divide (double x, double y, SCM *qp, SCM *rp)
  2315. {
  2316. if (SCM_UNLIKELY (y == 0))
  2317. scm_num_overflow (s_scm_truncate_divide); /* or return a NaN? */
  2318. else
  2319. {
  2320. double q = trunc (x / y);
  2321. double r = x - q * y;
  2322. *qp = scm_from_double (q);
  2323. *rp = scm_from_double (r);
  2324. }
  2325. }
  2326. static void
  2327. scm_i_exact_rational_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp)
  2328. {
  2329. SCM r1;
  2330. SCM xd = scm_denominator (x);
  2331. SCM yd = scm_denominator (y);
  2332. scm_truncate_divide (scm_product (scm_numerator (x), yd),
  2333. scm_product (scm_numerator (y), xd),
  2334. qp, &r1);
  2335. *rp = scm_divide (r1, scm_product (xd, yd));
  2336. }
  2337. static SCM scm_i_inexact_centered_quotient (double x, double y);
  2338. static SCM scm_i_bigint_centered_quotient (SCM x, SCM y);
  2339. static SCM scm_i_exact_rational_centered_quotient (SCM x, SCM y);
  2340. SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
  2341. (SCM x, SCM y),
  2342. "Return the integer @var{q} such that\n"
  2343. "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
  2344. "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
  2345. "@lisp\n"
  2346. "(centered-quotient 123 10) @result{} 12\n"
  2347. "(centered-quotient 123 -10) @result{} -12\n"
  2348. "(centered-quotient -123 10) @result{} -12\n"
  2349. "(centered-quotient -123 -10) @result{} 12\n"
  2350. "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
  2351. "(centered-quotient 16/3 -10/7) @result{} -4\n"
  2352. "@end lisp")
  2353. #define FUNC_NAME s_scm_centered_quotient
  2354. {
  2355. if (SCM_LIKELY (SCM_I_INUMP (x)))
  2356. {
  2357. scm_t_inum xx = SCM_I_INUM (x);
  2358. if (SCM_LIKELY (SCM_I_INUMP (y)))
  2359. {
  2360. scm_t_inum yy = SCM_I_INUM (y);
  2361. if (SCM_UNLIKELY (yy == 0))
  2362. scm_num_overflow (s_scm_centered_quotient);
  2363. else
  2364. {
  2365. scm_t_inum qq = xx / yy;
  2366. scm_t_inum rr = xx % yy;
  2367. if (SCM_LIKELY (xx > 0))
  2368. {
  2369. if (SCM_LIKELY (yy > 0))
  2370. {
  2371. if (rr >= (yy + 1) / 2)
  2372. qq++;
  2373. }
  2374. else
  2375. {
  2376. if (rr >= (1 - yy) / 2)
  2377. qq--;
  2378. }
  2379. }
  2380. else
  2381. {
  2382. if (SCM_LIKELY (yy > 0))
  2383. {
  2384. if (rr < -yy / 2)
  2385. qq--;
  2386. }
  2387. else
  2388. {
  2389. if (rr < yy / 2)
  2390. qq++;
  2391. }
  2392. }
  2393. if (SCM_LIKELY (SCM_FIXABLE (qq)))
  2394. return SCM_I_MAKINUM (qq);
  2395. else
  2396. return scm_i_inum2big (qq);
  2397. }
  2398. }
  2399. else if (SCM_BIGP (y))
  2400. {
  2401. /* Pass a denormalized bignum version of x (even though it
  2402. can fit in a fixnum) to scm_i_bigint_centered_quotient */
  2403. return scm_i_bigint_centered_quotient (scm_i_long2big (xx), y);
  2404. }
  2405. else if (SCM_REALP (y))
  2406. return scm_i_inexact_centered_quotient (xx, SCM_REAL_VALUE (y));
  2407. else if (SCM_FRACTIONP (y))
  2408. return scm_i_exact_rational_centered_quotient (x, y);
  2409. else
  2410. return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
  2411. s_scm_centered_quotient);
  2412. }
  2413. else if (SCM_BIGP (x))
  2414. {
  2415. if (SCM_LIKELY (SCM_I_INUMP (y)))
  2416. {
  2417. scm_t_inum yy = SCM_I_INUM (y);
  2418. if (SCM_UNLIKELY (yy == 0))
  2419. scm_num_overflow (s_scm_centered_quotient);
  2420. else if (SCM_UNLIKELY (yy == 1))
  2421. return x;
  2422. else
  2423. {
  2424. SCM q = scm_i_mkbig ();
  2425. scm_t_inum rr;
  2426. /* Arrange for rr to initially be non-positive,
  2427. because that simplifies the test to see
  2428. if it is within the needed bounds. */
  2429. if (yy > 0)
  2430. {
  2431. rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
  2432. SCM_I_BIG_MPZ (x), yy);
  2433. scm_remember_upto_here_1 (x);
  2434. if (rr < -yy / 2)
  2435. mpz_sub_ui (SCM_I_BIG_MPZ (q),
  2436. SCM_I_BIG_MPZ (q), 1);
  2437. }
  2438. else
  2439. {
  2440. rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
  2441. SCM_I_BIG_MPZ (x), -yy);
  2442. scm_remember_upto_here_1 (x);
  2443. mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
  2444. if (rr < yy / 2)
  2445. mpz_add_ui (SCM_I_BIG_MPZ (q),
  2446. SCM_I_BIG_MPZ (q), 1);
  2447. }
  2448. return scm_i_normbig (q);
  2449. }
  2450. }
  2451. else if (SCM_BIGP (y))
  2452. return scm_i_bigint_centered_quotient (x, y);
  2453. else if (SCM_REALP (y))
  2454. return scm_i_inexact_centered_quotient
  2455. (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
  2456. else if (SCM_FRACTIONP (y))
  2457. return scm_i_exact_rational_centered_quotient (x, y);
  2458. else
  2459. return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
  2460. s_scm_centered_quotient);
  2461. }
  2462. else if (SCM_REALP (x))
  2463. {
  2464. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  2465. SCM_BIGP (y) || SCM_FRACTIONP (y))
  2466. return scm_i_inexact_centered_quotient
  2467. (SCM_REAL_VALUE (x), scm_to_double (y));
  2468. else
  2469. return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
  2470. s_scm_centered_quotient);
  2471. }
  2472. else if (SCM_FRACTIONP (x))
  2473. {
  2474. if (SCM_REALP (y))
  2475. return scm_i_inexact_centered_quotient
  2476. (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
  2477. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  2478. return scm_i_exact_rational_centered_quotient (x, y);
  2479. else
  2480. return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
  2481. s_scm_centered_quotient);
  2482. }
  2483. else
  2484. return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
  2485. s_scm_centered_quotient);
  2486. }
  2487. #undef FUNC_NAME
  2488. static SCM
  2489. scm_i_inexact_centered_quotient (double x, double y)
  2490. {
  2491. if (SCM_LIKELY (y > 0))
  2492. return scm_from_double (floor (x/y + 0.5));
  2493. else if (SCM_LIKELY (y < 0))
  2494. return scm_from_double (ceil (x/y - 0.5));
  2495. else if (y == 0)
  2496. scm_num_overflow (s_scm_centered_quotient); /* or return a NaN? */
  2497. else
  2498. return scm_nan ();
  2499. }
  2500. /* Assumes that both x and y are bigints, though
  2501. x might be able to fit into a fixnum. */
  2502. static SCM
  2503. scm_i_bigint_centered_quotient (SCM x, SCM y)
  2504. {
  2505. SCM q, r, min_r;
  2506. /* Note that x might be small enough to fit into a
  2507. fixnum, so we must not let it escape into the wild */
  2508. q = scm_i_mkbig ();
  2509. r = scm_i_mkbig ();
  2510. /* min_r will eventually become -abs(y)/2 */
  2511. min_r = scm_i_mkbig ();
  2512. mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r),
  2513. SCM_I_BIG_MPZ (y), 1);
  2514. /* Arrange for rr to initially be non-positive,
  2515. because that simplifies the test to see
  2516. if it is within the needed bounds. */
  2517. if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
  2518. {
  2519. mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
  2520. SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  2521. scm_remember_upto_here_2 (x, y);
  2522. mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r));
  2523. if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
  2524. mpz_sub_ui (SCM_I_BIG_MPZ (q),
  2525. SCM_I_BIG_MPZ (q), 1);
  2526. }
  2527. else
  2528. {
  2529. mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
  2530. SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  2531. scm_remember_upto_here_2 (x, y);
  2532. if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
  2533. mpz_add_ui (SCM_I_BIG_MPZ (q),
  2534. SCM_I_BIG_MPZ (q), 1);
  2535. }
  2536. scm_remember_upto_here_2 (r, min_r);
  2537. return scm_i_normbig (q);
  2538. }
  2539. static SCM
  2540. scm_i_exact_rational_centered_quotient (SCM x, SCM y)
  2541. {
  2542. return scm_centered_quotient
  2543. (scm_product (scm_numerator (x), scm_denominator (y)),
  2544. scm_product (scm_numerator (y), scm_denominator (x)));
  2545. }
  2546. static SCM scm_i_inexact_centered_remainder (double x, double y);
  2547. static SCM scm_i_bigint_centered_remainder (SCM x, SCM y);
  2548. static SCM scm_i_exact_rational_centered_remainder (SCM x, SCM y);
  2549. SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0,
  2550. (SCM x, SCM y),
  2551. "Return the real number @var{r} such that\n"
  2552. "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
  2553. "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
  2554. "for some integer @var{q}.\n"
  2555. "@lisp\n"
  2556. "(centered-remainder 123 10) @result{} 3\n"
  2557. "(centered-remainder 123 -10) @result{} 3\n"
  2558. "(centered-remainder -123 10) @result{} -3\n"
  2559. "(centered-remainder -123 -10) @result{} -3\n"
  2560. "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
  2561. "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
  2562. "@end lisp")
  2563. #define FUNC_NAME s_scm_centered_remainder
  2564. {
  2565. if (SCM_LIKELY (SCM_I_INUMP (x)))
  2566. {
  2567. scm_t_inum xx = SCM_I_INUM (x);
  2568. if (SCM_LIKELY (SCM_I_INUMP (y)))
  2569. {
  2570. scm_t_inum yy = SCM_I_INUM (y);
  2571. if (SCM_UNLIKELY (yy == 0))
  2572. scm_num_overflow (s_scm_centered_remainder);
  2573. else
  2574. {
  2575. scm_t_inum rr = xx % yy;
  2576. if (SCM_LIKELY (xx > 0))
  2577. {
  2578. if (SCM_LIKELY (yy > 0))
  2579. {
  2580. if (rr >= (yy + 1) / 2)
  2581. rr -= yy;
  2582. }
  2583. else
  2584. {
  2585. if (rr >= (1 - yy) / 2)
  2586. rr += yy;
  2587. }
  2588. }
  2589. else
  2590. {
  2591. if (SCM_LIKELY (yy > 0))
  2592. {
  2593. if (rr < -yy / 2)
  2594. rr += yy;
  2595. }
  2596. else
  2597. {
  2598. if (rr < yy / 2)
  2599. rr -= yy;
  2600. }
  2601. }
  2602. return SCM_I_MAKINUM (rr);
  2603. }
  2604. }
  2605. else if (SCM_BIGP (y))
  2606. {
  2607. /* Pass a denormalized bignum version of x (even though it
  2608. can fit in a fixnum) to scm_i_bigint_centered_remainder */
  2609. return scm_i_bigint_centered_remainder (scm_i_long2big (xx), y);
  2610. }
  2611. else if (SCM_REALP (y))
  2612. return scm_i_inexact_centered_remainder (xx, SCM_REAL_VALUE (y));
  2613. else if (SCM_FRACTIONP (y))
  2614. return scm_i_exact_rational_centered_remainder (x, y);
  2615. else
  2616. return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
  2617. s_scm_centered_remainder);
  2618. }
  2619. else if (SCM_BIGP (x))
  2620. {
  2621. if (SCM_LIKELY (SCM_I_INUMP (y)))
  2622. {
  2623. scm_t_inum yy = SCM_I_INUM (y);
  2624. if (SCM_UNLIKELY (yy == 0))
  2625. scm_num_overflow (s_scm_centered_remainder);
  2626. else
  2627. {
  2628. scm_t_inum rr;
  2629. /* Arrange for rr to initially be non-positive,
  2630. because that simplifies the test to see
  2631. if it is within the needed bounds. */
  2632. if (yy > 0)
  2633. {
  2634. rr = - mpz_cdiv_ui (SCM_I_BIG_MPZ (x), yy);
  2635. scm_remember_upto_here_1 (x);
  2636. if (rr < -yy / 2)
  2637. rr += yy;
  2638. }
  2639. else
  2640. {
  2641. rr = - mpz_cdiv_ui (SCM_I_BIG_MPZ (x), -yy);
  2642. scm_remember_upto_here_1 (x);
  2643. if (rr < yy / 2)
  2644. rr -= yy;
  2645. }
  2646. return SCM_I_MAKINUM (rr);
  2647. }
  2648. }
  2649. else if (SCM_BIGP (y))
  2650. return scm_i_bigint_centered_remainder (x, y);
  2651. else if (SCM_REALP (y))
  2652. return scm_i_inexact_centered_remainder
  2653. (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
  2654. else if (SCM_FRACTIONP (y))
  2655. return scm_i_exact_rational_centered_remainder (x, y);
  2656. else
  2657. return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
  2658. s_scm_centered_remainder);
  2659. }
  2660. else if (SCM_REALP (x))
  2661. {
  2662. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  2663. SCM_BIGP (y) || SCM_FRACTIONP (y))
  2664. return scm_i_inexact_centered_remainder
  2665. (SCM_REAL_VALUE (x), scm_to_double (y));
  2666. else
  2667. return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
  2668. s_scm_centered_remainder);
  2669. }
  2670. else if (SCM_FRACTIONP (x))
  2671. {
  2672. if (SCM_REALP (y))
  2673. return scm_i_inexact_centered_remainder
  2674. (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
  2675. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  2676. return scm_i_exact_rational_centered_remainder (x, y);
  2677. else
  2678. return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
  2679. s_scm_centered_remainder);
  2680. }
  2681. else
  2682. return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
  2683. s_scm_centered_remainder);
  2684. }
  2685. #undef FUNC_NAME
  2686. static SCM
  2687. scm_i_inexact_centered_remainder (double x, double y)
  2688. {
  2689. double q;
  2690. /* Although it would be more efficient to use fmod here, we can't
  2691. because it would in some cases produce results inconsistent with
  2692. scm_i_inexact_centered_quotient, such that x != r + q * y (not even
  2693. close). In particular, when x-y/2 is very close to a multiple of
  2694. y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
  2695. two cases must correspond to different choices of q. If quotient
  2696. chooses one and remainder chooses the other, it would be bad. */
  2697. if (SCM_LIKELY (y > 0))
  2698. q = floor (x/y + 0.5);
  2699. else if (SCM_LIKELY (y < 0))
  2700. q = ceil (x/y - 0.5);
  2701. else if (y == 0)
  2702. scm_num_overflow (s_scm_centered_remainder); /* or return a NaN? */
  2703. else
  2704. return scm_nan ();
  2705. return scm_from_double (x - q * y);
  2706. }
  2707. /* Assumes that both x and y are bigints, though
  2708. x might be able to fit into a fixnum. */
  2709. static SCM
  2710. scm_i_bigint_centered_remainder (SCM x, SCM y)
  2711. {
  2712. SCM r, min_r;
  2713. /* Note that x might be small enough to fit into a
  2714. fixnum, so we must not let it escape into the wild */
  2715. r = scm_i_mkbig ();
  2716. /* min_r will eventually become -abs(y)/2 */
  2717. min_r = scm_i_mkbig ();
  2718. mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r),
  2719. SCM_I_BIG_MPZ (y), 1);
  2720. /* Arrange for rr to initially be non-positive,
  2721. because that simplifies the test to see
  2722. if it is within the needed bounds. */
  2723. if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
  2724. {
  2725. mpz_cdiv_r (SCM_I_BIG_MPZ (r),
  2726. SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  2727. mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r));
  2728. if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
  2729. mpz_add (SCM_I_BIG_MPZ (r),
  2730. SCM_I_BIG_MPZ (r),
  2731. SCM_I_BIG_MPZ (y));
  2732. }
  2733. else
  2734. {
  2735. mpz_fdiv_r (SCM_I_BIG_MPZ (r),
  2736. SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  2737. if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
  2738. mpz_sub (SCM_I_BIG_MPZ (r),
  2739. SCM_I_BIG_MPZ (r),
  2740. SCM_I_BIG_MPZ (y));
  2741. }
  2742. scm_remember_upto_here_2 (x, y);
  2743. return scm_i_normbig (r);
  2744. }
  2745. static SCM
  2746. scm_i_exact_rational_centered_remainder (SCM x, SCM y)
  2747. {
  2748. SCM xd = scm_denominator (x);
  2749. SCM yd = scm_denominator (y);
  2750. SCM r1 = scm_centered_remainder (scm_product (scm_numerator (x), yd),
  2751. scm_product (scm_numerator (y), xd));
  2752. return scm_divide (r1, scm_product (xd, yd));
  2753. }
  2754. static void scm_i_inexact_centered_divide (double x, double y,
  2755. SCM *qp, SCM *rp);
  2756. static void scm_i_bigint_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp);
  2757. static void scm_i_exact_rational_centered_divide (SCM x, SCM y,
  2758. SCM *qp, SCM *rp);
  2759. SCM_PRIMITIVE_GENERIC (scm_i_centered_divide, "centered/", 2, 0, 0,
  2760. (SCM x, SCM y),
  2761. "Return the integer @var{q} and the real number @var{r}\n"
  2762. "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
  2763. "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
  2764. "@lisp\n"
  2765. "(centered/ 123 10) @result{} 12 and 3\n"
  2766. "(centered/ 123 -10) @result{} -12 and 3\n"
  2767. "(centered/ -123 10) @result{} -12 and -3\n"
  2768. "(centered/ -123 -10) @result{} 12 and -3\n"
  2769. "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
  2770. "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
  2771. "@end lisp")
  2772. #define FUNC_NAME s_scm_i_centered_divide
  2773. {
  2774. SCM q, r;
  2775. scm_centered_divide(x, y, &q, &r);
  2776. return scm_values (scm_list_2 (q, r));
  2777. }
  2778. #undef FUNC_NAME
  2779. #define s_scm_centered_divide s_scm_i_centered_divide
  2780. #define g_scm_centered_divide g_scm_i_centered_divide
  2781. void
  2782. scm_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
  2783. {
  2784. if (SCM_LIKELY (SCM_I_INUMP (x)))
  2785. {
  2786. scm_t_inum xx = SCM_I_INUM (x);
  2787. if (SCM_LIKELY (SCM_I_INUMP (y)))
  2788. {
  2789. scm_t_inum yy = SCM_I_INUM (y);
  2790. if (SCM_UNLIKELY (yy == 0))
  2791. scm_num_overflow (s_scm_centered_divide);
  2792. else
  2793. {
  2794. scm_t_inum qq = xx / yy;
  2795. scm_t_inum rr = xx % yy;
  2796. if (SCM_LIKELY (xx > 0))
  2797. {
  2798. if (SCM_LIKELY (yy > 0))
  2799. {
  2800. if (rr >= (yy + 1) / 2)
  2801. { qq++; rr -= yy; }
  2802. }
  2803. else
  2804. {
  2805. if (rr >= (1 - yy) / 2)
  2806. { qq--; rr += yy; }
  2807. }
  2808. }
  2809. else
  2810. {
  2811. if (SCM_LIKELY (yy > 0))
  2812. {
  2813. if (rr < -yy / 2)
  2814. { qq--; rr += yy; }
  2815. }
  2816. else
  2817. {
  2818. if (rr < yy / 2)
  2819. { qq++; rr -= yy; }
  2820. }
  2821. }
  2822. if (SCM_LIKELY (SCM_FIXABLE (qq)))
  2823. *qp = SCM_I_MAKINUM (qq);
  2824. else
  2825. *qp = scm_i_inum2big (qq);
  2826. *rp = SCM_I_MAKINUM (rr);
  2827. }
  2828. return;
  2829. }
  2830. else if (SCM_BIGP (y))
  2831. {
  2832. /* Pass a denormalized bignum version of x (even though it
  2833. can fit in a fixnum) to scm_i_bigint_centered_divide */
  2834. return scm_i_bigint_centered_divide (scm_i_long2big (xx), y, qp, rp);
  2835. }
  2836. else if (SCM_REALP (y))
  2837. return scm_i_inexact_centered_divide (xx, SCM_REAL_VALUE (y), qp, rp);
  2838. else if (SCM_FRACTIONP (y))
  2839. return scm_i_exact_rational_centered_divide (x, y, qp, rp);
  2840. else
  2841. return two_valued_wta_dispatch_2
  2842. (g_scm_centered_divide, x, y, SCM_ARG2,
  2843. s_scm_centered_divide, qp, rp);
  2844. }
  2845. else if (SCM_BIGP (x))
  2846. {
  2847. if (SCM_LIKELY (SCM_I_INUMP (y)))
  2848. {
  2849. scm_t_inum yy = SCM_I_INUM (y);
  2850. if (SCM_UNLIKELY (yy == 0))
  2851. scm_num_overflow (s_scm_centered_divide);
  2852. else
  2853. {
  2854. SCM q = scm_i_mkbig ();
  2855. scm_t_inum rr;
  2856. /* Arrange for rr to initially be non-positive,
  2857. because that simplifies the test to see
  2858. if it is within the needed bounds. */
  2859. if (yy > 0)
  2860. {
  2861. rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
  2862. SCM_I_BIG_MPZ (x), yy);
  2863. scm_remember_upto_here_1 (x);
  2864. if (rr < -yy / 2)
  2865. {
  2866. mpz_sub_ui (SCM_I_BIG_MPZ (q),
  2867. SCM_I_BIG_MPZ (q), 1);
  2868. rr += yy;
  2869. }
  2870. }
  2871. else
  2872. {
  2873. rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
  2874. SCM_I_BIG_MPZ (x), -yy);
  2875. scm_remember_upto_here_1 (x);
  2876. mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
  2877. if (rr < yy / 2)
  2878. {
  2879. mpz_add_ui (SCM_I_BIG_MPZ (q),
  2880. SCM_I_BIG_MPZ (q), 1);
  2881. rr -= yy;
  2882. }
  2883. }
  2884. *qp = scm_i_normbig (q);
  2885. *rp = SCM_I_MAKINUM (rr);
  2886. }
  2887. return;
  2888. }
  2889. else if (SCM_BIGP (y))
  2890. return scm_i_bigint_centered_divide (x, y, qp, rp);
  2891. else if (SCM_REALP (y))
  2892. return scm_i_inexact_centered_divide
  2893. (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
  2894. else if (SCM_FRACTIONP (y))
  2895. return scm_i_exact_rational_centered_divide (x, y, qp, rp);
  2896. else
  2897. return two_valued_wta_dispatch_2
  2898. (g_scm_centered_divide, x, y, SCM_ARG2,
  2899. s_scm_centered_divide, qp, rp);
  2900. }
  2901. else if (SCM_REALP (x))
  2902. {
  2903. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  2904. SCM_BIGP (y) || SCM_FRACTIONP (y))
  2905. return scm_i_inexact_centered_divide
  2906. (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
  2907. else
  2908. return two_valued_wta_dispatch_2
  2909. (g_scm_centered_divide, x, y, SCM_ARG2,
  2910. s_scm_centered_divide, qp, rp);
  2911. }
  2912. else if (SCM_FRACTIONP (x))
  2913. {
  2914. if (SCM_REALP (y))
  2915. return scm_i_inexact_centered_divide
  2916. (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
  2917. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  2918. return scm_i_exact_rational_centered_divide (x, y, qp, rp);
  2919. else
  2920. return two_valued_wta_dispatch_2
  2921. (g_scm_centered_divide, x, y, SCM_ARG2,
  2922. s_scm_centered_divide, qp, rp);
  2923. }
  2924. else
  2925. return two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG1,
  2926. s_scm_centered_divide, qp, rp);
  2927. }
  2928. static void
  2929. scm_i_inexact_centered_divide (double x, double y, SCM *qp, SCM *rp)
  2930. {
  2931. double q, r;
  2932. if (SCM_LIKELY (y > 0))
  2933. q = floor (x/y + 0.5);
  2934. else if (SCM_LIKELY (y < 0))
  2935. q = ceil (x/y - 0.5);
  2936. else if (y == 0)
  2937. scm_num_overflow (s_scm_centered_divide); /* or return a NaN? */
  2938. else
  2939. q = guile_NaN;
  2940. r = x - q * y;
  2941. *qp = scm_from_double (q);
  2942. *rp = scm_from_double (r);
  2943. }
  2944. /* Assumes that both x and y are bigints, though
  2945. x might be able to fit into a fixnum. */
  2946. static void
  2947. scm_i_bigint_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
  2948. {
  2949. SCM q, r, min_r;
  2950. /* Note that x might be small enough to fit into a
  2951. fixnum, so we must not let it escape into the wild */
  2952. q = scm_i_mkbig ();
  2953. r = scm_i_mkbig ();
  2954. /* min_r will eventually become -abs(y/2) */
  2955. min_r = scm_i_mkbig ();
  2956. mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r),
  2957. SCM_I_BIG_MPZ (y), 1);
  2958. /* Arrange for rr to initially be non-positive,
  2959. because that simplifies the test to see
  2960. if it is within the needed bounds. */
  2961. if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
  2962. {
  2963. mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
  2964. SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  2965. mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r));
  2966. if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
  2967. {
  2968. mpz_sub_ui (SCM_I_BIG_MPZ (q),
  2969. SCM_I_BIG_MPZ (q), 1);
  2970. mpz_add (SCM_I_BIG_MPZ (r),
  2971. SCM_I_BIG_MPZ (r),
  2972. SCM_I_BIG_MPZ (y));
  2973. }
  2974. }
  2975. else
  2976. {
  2977. mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
  2978. SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  2979. if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
  2980. {
  2981. mpz_add_ui (SCM_I_BIG_MPZ (q),
  2982. SCM_I_BIG_MPZ (q), 1);
  2983. mpz_sub (SCM_I_BIG_MPZ (r),
  2984. SCM_I_BIG_MPZ (r),
  2985. SCM_I_BIG_MPZ (y));
  2986. }
  2987. }
  2988. scm_remember_upto_here_2 (x, y);
  2989. *qp = scm_i_normbig (q);
  2990. *rp = scm_i_normbig (r);
  2991. }
  2992. static void
  2993. scm_i_exact_rational_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
  2994. {
  2995. SCM r1;
  2996. SCM xd = scm_denominator (x);
  2997. SCM yd = scm_denominator (y);
  2998. scm_centered_divide (scm_product (scm_numerator (x), yd),
  2999. scm_product (scm_numerator (y), xd),
  3000. qp, &r1);
  3001. *rp = scm_divide (r1, scm_product (xd, yd));
  3002. }
  3003. static SCM scm_i_inexact_round_quotient (double x, double y);
  3004. static SCM scm_i_bigint_round_quotient (SCM x, SCM y);
  3005. static SCM scm_i_exact_rational_round_quotient (SCM x, SCM y);
  3006. SCM_PRIMITIVE_GENERIC (scm_round_quotient, "round-quotient", 2, 0, 0,
  3007. (SCM x, SCM y),
  3008. "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
  3009. "with ties going to the nearest even integer.\n"
  3010. "@lisp\n"
  3011. "(round-quotient 123 10) @result{} 12\n"
  3012. "(round-quotient 123 -10) @result{} -12\n"
  3013. "(round-quotient -123 10) @result{} -12\n"
  3014. "(round-quotient -123 -10) @result{} 12\n"
  3015. "(round-quotient 125 10) @result{} 12\n"
  3016. "(round-quotient 127 10) @result{} 13\n"
  3017. "(round-quotient 135 10) @result{} 14\n"
  3018. "(round-quotient -123.2 -63.5) @result{} 2.0\n"
  3019. "(round-quotient 16/3 -10/7) @result{} -4\n"
  3020. "@end lisp")
  3021. #define FUNC_NAME s_scm_round_quotient
  3022. {
  3023. if (SCM_LIKELY (SCM_I_INUMP (x)))
  3024. {
  3025. scm_t_inum xx = SCM_I_INUM (x);
  3026. if (SCM_LIKELY (SCM_I_INUMP (y)))
  3027. {
  3028. scm_t_inum yy = SCM_I_INUM (y);
  3029. if (SCM_UNLIKELY (yy == 0))
  3030. scm_num_overflow (s_scm_round_quotient);
  3031. else
  3032. {
  3033. scm_t_inum qq = xx / yy;
  3034. scm_t_inum rr = xx % yy;
  3035. scm_t_inum ay = yy;
  3036. scm_t_inum r2 = 2 * rr;
  3037. if (SCM_LIKELY (yy < 0))
  3038. {
  3039. ay = -ay;
  3040. r2 = -r2;
  3041. }
  3042. if (qq & 1L)
  3043. {
  3044. if (r2 >= ay)
  3045. qq++;
  3046. else if (r2 <= -ay)
  3047. qq--;
  3048. }
  3049. else
  3050. {
  3051. if (r2 > ay)
  3052. qq++;
  3053. else if (r2 < -ay)
  3054. qq--;
  3055. }
  3056. if (SCM_LIKELY (SCM_FIXABLE (qq)))
  3057. return SCM_I_MAKINUM (qq);
  3058. else
  3059. return scm_i_inum2big (qq);
  3060. }
  3061. }
  3062. else if (SCM_BIGP (y))
  3063. {
  3064. /* Pass a denormalized bignum version of x (even though it
  3065. can fit in a fixnum) to scm_i_bigint_round_quotient */
  3066. return scm_i_bigint_round_quotient (scm_i_long2big (xx), y);
  3067. }
  3068. else if (SCM_REALP (y))
  3069. return scm_i_inexact_round_quotient (xx, SCM_REAL_VALUE (y));
  3070. else if (SCM_FRACTIONP (y))
  3071. return scm_i_exact_rational_round_quotient (x, y);
  3072. else
  3073. return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
  3074. s_scm_round_quotient);
  3075. }
  3076. else if (SCM_BIGP (x))
  3077. {
  3078. if (SCM_LIKELY (SCM_I_INUMP (y)))
  3079. {
  3080. scm_t_inum yy = SCM_I_INUM (y);
  3081. if (SCM_UNLIKELY (yy == 0))
  3082. scm_num_overflow (s_scm_round_quotient);
  3083. else if (SCM_UNLIKELY (yy == 1))
  3084. return x;
  3085. else
  3086. {
  3087. SCM q = scm_i_mkbig ();
  3088. scm_t_inum rr;
  3089. int needs_adjustment;
  3090. if (yy > 0)
  3091. {
  3092. rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
  3093. SCM_I_BIG_MPZ (x), yy);
  3094. if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
  3095. needs_adjustment = (2*rr >= yy);
  3096. else
  3097. needs_adjustment = (2*rr > yy);
  3098. }
  3099. else
  3100. {
  3101. rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
  3102. SCM_I_BIG_MPZ (x), -yy);
  3103. mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
  3104. if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
  3105. needs_adjustment = (2*rr <= yy);
  3106. else
  3107. needs_adjustment = (2*rr < yy);
  3108. }
  3109. scm_remember_upto_here_1 (x);
  3110. if (needs_adjustment)
  3111. mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
  3112. return scm_i_normbig (q);
  3113. }
  3114. }
  3115. else if (SCM_BIGP (y))
  3116. return scm_i_bigint_round_quotient (x, y);
  3117. else if (SCM_REALP (y))
  3118. return scm_i_inexact_round_quotient
  3119. (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
  3120. else if (SCM_FRACTIONP (y))
  3121. return scm_i_exact_rational_round_quotient (x, y);
  3122. else
  3123. return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
  3124. s_scm_round_quotient);
  3125. }
  3126. else if (SCM_REALP (x))
  3127. {
  3128. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  3129. SCM_BIGP (y) || SCM_FRACTIONP (y))
  3130. return scm_i_inexact_round_quotient
  3131. (SCM_REAL_VALUE (x), scm_to_double (y));
  3132. else
  3133. return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
  3134. s_scm_round_quotient);
  3135. }
  3136. else if (SCM_FRACTIONP (x))
  3137. {
  3138. if (SCM_REALP (y))
  3139. return scm_i_inexact_round_quotient
  3140. (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
  3141. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  3142. return scm_i_exact_rational_round_quotient (x, y);
  3143. else
  3144. return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
  3145. s_scm_round_quotient);
  3146. }
  3147. else
  3148. return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG1,
  3149. s_scm_round_quotient);
  3150. }
  3151. #undef FUNC_NAME
  3152. static SCM
  3153. scm_i_inexact_round_quotient (double x, double y)
  3154. {
  3155. if (SCM_UNLIKELY (y == 0))
  3156. scm_num_overflow (s_scm_round_quotient); /* or return a NaN? */
  3157. else
  3158. return scm_from_double (scm_c_round (x / y));
  3159. }
  3160. /* Assumes that both x and y are bigints, though
  3161. x might be able to fit into a fixnum. */
  3162. static SCM
  3163. scm_i_bigint_round_quotient (SCM x, SCM y)
  3164. {
  3165. SCM q, r, r2;
  3166. int cmp, needs_adjustment;
  3167. /* Note that x might be small enough to fit into a
  3168. fixnum, so we must not let it escape into the wild */
  3169. q = scm_i_mkbig ();
  3170. r = scm_i_mkbig ();
  3171. r2 = scm_i_mkbig ();
  3172. mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
  3173. SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  3174. mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
  3175. scm_remember_upto_here_2 (x, r);
  3176. cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
  3177. if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
  3178. needs_adjustment = (cmp >= 0);
  3179. else
  3180. needs_adjustment = (cmp > 0);
  3181. scm_remember_upto_here_2 (r2, y);
  3182. if (needs_adjustment)
  3183. mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
  3184. return scm_i_normbig (q);
  3185. }
  3186. static SCM
  3187. scm_i_exact_rational_round_quotient (SCM x, SCM y)
  3188. {
  3189. return scm_round_quotient
  3190. (scm_product (scm_numerator (x), scm_denominator (y)),
  3191. scm_product (scm_numerator (y), scm_denominator (x)));
  3192. }
  3193. static SCM scm_i_inexact_round_remainder (double x, double y);
  3194. static SCM scm_i_bigint_round_remainder (SCM x, SCM y);
  3195. static SCM scm_i_exact_rational_round_remainder (SCM x, SCM y);
  3196. SCM_PRIMITIVE_GENERIC (scm_round_remainder, "round-remainder", 2, 0, 0,
  3197. (SCM x, SCM y),
  3198. "Return the real number @var{r} such that\n"
  3199. "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
  3200. "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
  3201. "nearest integer, with ties going to the nearest\n"
  3202. "even integer.\n"
  3203. "@lisp\n"
  3204. "(round-remainder 123 10) @result{} 3\n"
  3205. "(round-remainder 123 -10) @result{} 3\n"
  3206. "(round-remainder -123 10) @result{} -3\n"
  3207. "(round-remainder -123 -10) @result{} -3\n"
  3208. "(round-remainder 125 10) @result{} 5\n"
  3209. "(round-remainder 127 10) @result{} -3\n"
  3210. "(round-remainder 135 10) @result{} -5\n"
  3211. "(round-remainder -123.2 -63.5) @result{} 3.8\n"
  3212. "(round-remainder 16/3 -10/7) @result{} -8/21\n"
  3213. "@end lisp")
  3214. #define FUNC_NAME s_scm_round_remainder
  3215. {
  3216. if (SCM_LIKELY (SCM_I_INUMP (x)))
  3217. {
  3218. scm_t_inum xx = SCM_I_INUM (x);
  3219. if (SCM_LIKELY (SCM_I_INUMP (y)))
  3220. {
  3221. scm_t_inum yy = SCM_I_INUM (y);
  3222. if (SCM_UNLIKELY (yy == 0))
  3223. scm_num_overflow (s_scm_round_remainder);
  3224. else
  3225. {
  3226. scm_t_inum qq = xx / yy;
  3227. scm_t_inum rr = xx % yy;
  3228. scm_t_inum ay = yy;
  3229. scm_t_inum r2 = 2 * rr;
  3230. if (SCM_LIKELY (yy < 0))
  3231. {
  3232. ay = -ay;
  3233. r2 = -r2;
  3234. }
  3235. if (qq & 1L)
  3236. {
  3237. if (r2 >= ay)
  3238. rr -= yy;
  3239. else if (r2 <= -ay)
  3240. rr += yy;
  3241. }
  3242. else
  3243. {
  3244. if (r2 > ay)
  3245. rr -= yy;
  3246. else if (r2 < -ay)
  3247. rr += yy;
  3248. }
  3249. return SCM_I_MAKINUM (rr);
  3250. }
  3251. }
  3252. else if (SCM_BIGP (y))
  3253. {
  3254. /* Pass a denormalized bignum version of x (even though it
  3255. can fit in a fixnum) to scm_i_bigint_round_remainder */
  3256. return scm_i_bigint_round_remainder
  3257. (scm_i_long2big (xx), y);
  3258. }
  3259. else if (SCM_REALP (y))
  3260. return scm_i_inexact_round_remainder (xx, SCM_REAL_VALUE (y));
  3261. else if (SCM_FRACTIONP (y))
  3262. return scm_i_exact_rational_round_remainder (x, y);
  3263. else
  3264. return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
  3265. s_scm_round_remainder);
  3266. }
  3267. else if (SCM_BIGP (x))
  3268. {
  3269. if (SCM_LIKELY (SCM_I_INUMP (y)))
  3270. {
  3271. scm_t_inum yy = SCM_I_INUM (y);
  3272. if (SCM_UNLIKELY (yy == 0))
  3273. scm_num_overflow (s_scm_round_remainder);
  3274. else
  3275. {
  3276. SCM q = scm_i_mkbig ();
  3277. scm_t_inum rr;
  3278. int needs_adjustment;
  3279. if (yy > 0)
  3280. {
  3281. rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
  3282. SCM_I_BIG_MPZ (x), yy);
  3283. if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
  3284. needs_adjustment = (2*rr >= yy);
  3285. else
  3286. needs_adjustment = (2*rr > yy);
  3287. }
  3288. else
  3289. {
  3290. rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
  3291. SCM_I_BIG_MPZ (x), -yy);
  3292. if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
  3293. needs_adjustment = (2*rr <= yy);
  3294. else
  3295. needs_adjustment = (2*rr < yy);
  3296. }
  3297. scm_remember_upto_here_2 (x, q);
  3298. if (needs_adjustment)
  3299. rr -= yy;
  3300. return SCM_I_MAKINUM (rr);
  3301. }
  3302. }
  3303. else if (SCM_BIGP (y))
  3304. return scm_i_bigint_round_remainder (x, y);
  3305. else if (SCM_REALP (y))
  3306. return scm_i_inexact_round_remainder
  3307. (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
  3308. else if (SCM_FRACTIONP (y))
  3309. return scm_i_exact_rational_round_remainder (x, y);
  3310. else
  3311. return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
  3312. s_scm_round_remainder);
  3313. }
  3314. else if (SCM_REALP (x))
  3315. {
  3316. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  3317. SCM_BIGP (y) || SCM_FRACTIONP (y))
  3318. return scm_i_inexact_round_remainder
  3319. (SCM_REAL_VALUE (x), scm_to_double (y));
  3320. else
  3321. return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
  3322. s_scm_round_remainder);
  3323. }
  3324. else if (SCM_FRACTIONP (x))
  3325. {
  3326. if (SCM_REALP (y))
  3327. return scm_i_inexact_round_remainder
  3328. (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
  3329. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  3330. return scm_i_exact_rational_round_remainder (x, y);
  3331. else
  3332. return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
  3333. s_scm_round_remainder);
  3334. }
  3335. else
  3336. return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG1,
  3337. s_scm_round_remainder);
  3338. }
  3339. #undef FUNC_NAME
  3340. static SCM
  3341. scm_i_inexact_round_remainder (double x, double y)
  3342. {
  3343. /* Although it would be more efficient to use fmod here, we can't
  3344. because it would in some cases produce results inconsistent with
  3345. scm_i_inexact_round_quotient, such that x != r + q * y (not even
  3346. close). In particular, when x-y/2 is very close to a multiple of
  3347. y, then r might be either -abs(y/2) or abs(y/2), but those two
  3348. cases must correspond to different choices of q. If quotient
  3349. chooses one and remainder chooses the other, it would be bad. */
  3350. if (SCM_UNLIKELY (y == 0))
  3351. scm_num_overflow (s_scm_round_remainder); /* or return a NaN? */
  3352. else
  3353. {
  3354. double q = scm_c_round (x / y);
  3355. return scm_from_double (x - q * y);
  3356. }
  3357. }
  3358. /* Assumes that both x and y are bigints, though
  3359. x might be able to fit into a fixnum. */
  3360. static SCM
  3361. scm_i_bigint_round_remainder (SCM x, SCM y)
  3362. {
  3363. SCM q, r, r2;
  3364. int cmp, needs_adjustment;
  3365. /* Note that x might be small enough to fit into a
  3366. fixnum, so we must not let it escape into the wild */
  3367. q = scm_i_mkbig ();
  3368. r = scm_i_mkbig ();
  3369. r2 = scm_i_mkbig ();
  3370. mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
  3371. SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  3372. scm_remember_upto_here_1 (x);
  3373. mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
  3374. cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
  3375. if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
  3376. needs_adjustment = (cmp >= 0);
  3377. else
  3378. needs_adjustment = (cmp > 0);
  3379. scm_remember_upto_here_2 (q, r2);
  3380. if (needs_adjustment)
  3381. mpz_sub (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y));
  3382. scm_remember_upto_here_1 (y);
  3383. return scm_i_normbig (r);
  3384. }
  3385. static SCM
  3386. scm_i_exact_rational_round_remainder (SCM x, SCM y)
  3387. {
  3388. SCM xd = scm_denominator (x);
  3389. SCM yd = scm_denominator (y);
  3390. SCM r1 = scm_round_remainder (scm_product (scm_numerator (x), yd),
  3391. scm_product (scm_numerator (y), xd));
  3392. return scm_divide (r1, scm_product (xd, yd));
  3393. }
  3394. static void scm_i_inexact_round_divide (double x, double y, SCM *qp, SCM *rp);
  3395. static void scm_i_bigint_round_divide (SCM x, SCM y, SCM *qp, SCM *rp);
  3396. static void scm_i_exact_rational_round_divide (SCM x, SCM y, SCM *qp, SCM *rp);
  3397. SCM_PRIMITIVE_GENERIC (scm_i_round_divide, "round/", 2, 0, 0,
  3398. (SCM x, SCM y),
  3399. "Return the integer @var{q} and the real number @var{r}\n"
  3400. "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
  3401. "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
  3402. "nearest integer, with ties going to the nearest even integer.\n"
  3403. "@lisp\n"
  3404. "(round/ 123 10) @result{} 12 and 3\n"
  3405. "(round/ 123 -10) @result{} -12 and 3\n"
  3406. "(round/ -123 10) @result{} -12 and -3\n"
  3407. "(round/ -123 -10) @result{} 12 and -3\n"
  3408. "(round/ 125 10) @result{} 12 and 5\n"
  3409. "(round/ 127 10) @result{} 13 and -3\n"
  3410. "(round/ 135 10) @result{} 14 and -5\n"
  3411. "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
  3412. "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
  3413. "@end lisp")
  3414. #define FUNC_NAME s_scm_i_round_divide
  3415. {
  3416. SCM q, r;
  3417. scm_round_divide(x, y, &q, &r);
  3418. return scm_values (scm_list_2 (q, r));
  3419. }
  3420. #undef FUNC_NAME
  3421. #define s_scm_round_divide s_scm_i_round_divide
  3422. #define g_scm_round_divide g_scm_i_round_divide
  3423. void
  3424. scm_round_divide (SCM x, SCM y, SCM *qp, SCM *rp)
  3425. {
  3426. if (SCM_LIKELY (SCM_I_INUMP (x)))
  3427. {
  3428. scm_t_inum xx = SCM_I_INUM (x);
  3429. if (SCM_LIKELY (SCM_I_INUMP (y)))
  3430. {
  3431. scm_t_inum yy = SCM_I_INUM (y);
  3432. if (SCM_UNLIKELY (yy == 0))
  3433. scm_num_overflow (s_scm_round_divide);
  3434. else
  3435. {
  3436. scm_t_inum qq = xx / yy;
  3437. scm_t_inum rr = xx % yy;
  3438. scm_t_inum ay = yy;
  3439. scm_t_inum r2 = 2 * rr;
  3440. if (SCM_LIKELY (yy < 0))
  3441. {
  3442. ay = -ay;
  3443. r2 = -r2;
  3444. }
  3445. if (qq & 1L)
  3446. {
  3447. if (r2 >= ay)
  3448. { qq++; rr -= yy; }
  3449. else if (r2 <= -ay)
  3450. { qq--; rr += yy; }
  3451. }
  3452. else
  3453. {
  3454. if (r2 > ay)
  3455. { qq++; rr -= yy; }
  3456. else if (r2 < -ay)
  3457. { qq--; rr += yy; }
  3458. }
  3459. if (SCM_LIKELY (SCM_FIXABLE (qq)))
  3460. *qp = SCM_I_MAKINUM (qq);
  3461. else
  3462. *qp = scm_i_inum2big (qq);
  3463. *rp = SCM_I_MAKINUM (rr);
  3464. }
  3465. return;
  3466. }
  3467. else if (SCM_BIGP (y))
  3468. {
  3469. /* Pass a denormalized bignum version of x (even though it
  3470. can fit in a fixnum) to scm_i_bigint_round_divide */
  3471. return scm_i_bigint_round_divide
  3472. (scm_i_long2big (SCM_I_INUM (x)), y, qp, rp);
  3473. }
  3474. else if (SCM_REALP (y))
  3475. return scm_i_inexact_round_divide (xx, SCM_REAL_VALUE (y), qp, rp);
  3476. else if (SCM_FRACTIONP (y))
  3477. return scm_i_exact_rational_round_divide (x, y, qp, rp);
  3478. else
  3479. return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
  3480. s_scm_round_divide, qp, rp);
  3481. }
  3482. else if (SCM_BIGP (x))
  3483. {
  3484. if (SCM_LIKELY (SCM_I_INUMP (y)))
  3485. {
  3486. scm_t_inum yy = SCM_I_INUM (y);
  3487. if (SCM_UNLIKELY (yy == 0))
  3488. scm_num_overflow (s_scm_round_divide);
  3489. else
  3490. {
  3491. SCM q = scm_i_mkbig ();
  3492. scm_t_inum rr;
  3493. int needs_adjustment;
  3494. if (yy > 0)
  3495. {
  3496. rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
  3497. SCM_I_BIG_MPZ (x), yy);
  3498. if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
  3499. needs_adjustment = (2*rr >= yy);
  3500. else
  3501. needs_adjustment = (2*rr > yy);
  3502. }
  3503. else
  3504. {
  3505. rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
  3506. SCM_I_BIG_MPZ (x), -yy);
  3507. mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
  3508. if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
  3509. needs_adjustment = (2*rr <= yy);
  3510. else
  3511. needs_adjustment = (2*rr < yy);
  3512. }
  3513. scm_remember_upto_here_1 (x);
  3514. if (needs_adjustment)
  3515. {
  3516. mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
  3517. rr -= yy;
  3518. }
  3519. *qp = scm_i_normbig (q);
  3520. *rp = SCM_I_MAKINUM (rr);
  3521. }
  3522. return;
  3523. }
  3524. else if (SCM_BIGP (y))
  3525. return scm_i_bigint_round_divide (x, y, qp, rp);
  3526. else if (SCM_REALP (y))
  3527. return scm_i_inexact_round_divide
  3528. (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
  3529. else if (SCM_FRACTIONP (y))
  3530. return scm_i_exact_rational_round_divide (x, y, qp, rp);
  3531. else
  3532. return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
  3533. s_scm_round_divide, qp, rp);
  3534. }
  3535. else if (SCM_REALP (x))
  3536. {
  3537. if (SCM_REALP (y) || SCM_I_INUMP (y) ||
  3538. SCM_BIGP (y) || SCM_FRACTIONP (y))
  3539. return scm_i_inexact_round_divide
  3540. (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
  3541. else
  3542. return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
  3543. s_scm_round_divide, qp, rp);
  3544. }
  3545. else if (SCM_FRACTIONP (x))
  3546. {
  3547. if (SCM_REALP (y))
  3548. return scm_i_inexact_round_divide
  3549. (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
  3550. else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
  3551. return scm_i_exact_rational_round_divide (x, y, qp, rp);
  3552. else
  3553. return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
  3554. s_scm_round_divide, qp, rp);
  3555. }
  3556. else
  3557. return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG1,
  3558. s_scm_round_divide, qp, rp);
  3559. }
  3560. static void
  3561. scm_i_inexact_round_divide (double x, double y, SCM *qp, SCM *rp)
  3562. {
  3563. if (SCM_UNLIKELY (y == 0))
  3564. scm_num_overflow (s_scm_round_divide); /* or return a NaN? */
  3565. else
  3566. {
  3567. double q = scm_c_round (x / y);
  3568. double r = x - q * y;
  3569. *qp = scm_from_double (q);
  3570. *rp = scm_from_double (r);
  3571. }
  3572. }
  3573. /* Assumes that both x and y are bigints, though
  3574. x might be able to fit into a fixnum. */
  3575. static void
  3576. scm_i_bigint_round_divide (SCM x, SCM y, SCM *qp, SCM *rp)
  3577. {
  3578. SCM q, r, r2;
  3579. int cmp, needs_adjustment;
  3580. /* Note that x might be small enough to fit into a
  3581. fixnum, so we must not let it escape into the wild */
  3582. q = scm_i_mkbig ();
  3583. r = scm_i_mkbig ();
  3584. r2 = scm_i_mkbig ();
  3585. mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
  3586. SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  3587. scm_remember_upto_here_1 (x);
  3588. mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
  3589. cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
  3590. if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
  3591. needs_adjustment = (cmp >= 0);
  3592. else
  3593. needs_adjustment = (cmp > 0);
  3594. if (needs_adjustment)
  3595. {
  3596. mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
  3597. mpz_sub (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y));
  3598. }
  3599. scm_remember_upto_here_2 (r2, y);
  3600. *qp = scm_i_normbig (q);
  3601. *rp = scm_i_normbig (r);
  3602. }
  3603. static void
  3604. scm_i_exact_rational_round_divide (SCM x, SCM y, SCM *qp, SCM *rp)
  3605. {
  3606. SCM r1;
  3607. SCM xd = scm_denominator (x);
  3608. SCM yd = scm_denominator (y);
  3609. scm_round_divide (scm_product (scm_numerator (x), yd),
  3610. scm_product (scm_numerator (y), xd),
  3611. qp, &r1);
  3612. *rp = scm_divide (r1, scm_product (xd, yd));
  3613. }
  3614. SCM_PRIMITIVE_GENERIC (scm_i_gcd, "gcd", 0, 2, 1,
  3615. (SCM x, SCM y, SCM rest),
  3616. "Return the greatest common divisor of all parameter values.\n"
  3617. "If called without arguments, 0 is returned.")
  3618. #define FUNC_NAME s_scm_i_gcd
  3619. {
  3620. while (!scm_is_null (rest))
  3621. { x = scm_gcd (x, y);
  3622. y = scm_car (rest);
  3623. rest = scm_cdr (rest);
  3624. }
  3625. return scm_gcd (x, y);
  3626. }
  3627. #undef FUNC_NAME
  3628. #define s_gcd s_scm_i_gcd
  3629. #define g_gcd g_scm_i_gcd
  3630. SCM
  3631. scm_gcd (SCM x, SCM y)
  3632. {
  3633. if (SCM_UNBNDP (y))
  3634. return SCM_UNBNDP (x) ? SCM_INUM0 : scm_abs (x);
  3635. if (SCM_I_INUMP (x))
  3636. {
  3637. if (SCM_I_INUMP (y))
  3638. {
  3639. scm_t_inum xx = SCM_I_INUM (x);
  3640. scm_t_inum yy = SCM_I_INUM (y);
  3641. scm_t_inum u = xx < 0 ? -xx : xx;
  3642. scm_t_inum v = yy < 0 ? -yy : yy;
  3643. scm_t_inum result;
  3644. if (xx == 0)
  3645. result = v;
  3646. else if (yy == 0)
  3647. result = u;
  3648. else
  3649. {
  3650. scm_t_inum k = 1;
  3651. scm_t_inum t;
  3652. /* Determine a common factor 2^k */
  3653. while (!(1 & (u | v)))
  3654. {
  3655. k <<= 1;
  3656. u >>= 1;
  3657. v >>= 1;
  3658. }
  3659. /* Now, any factor 2^n can be eliminated */
  3660. if (u & 1)
  3661. t = -v;
  3662. else
  3663. {
  3664. t = u;
  3665. b3:
  3666. t = SCM_SRS (t, 1);
  3667. }
  3668. if (!(1 & t))
  3669. goto b3;
  3670. if (t > 0)
  3671. u = t;
  3672. else
  3673. v = -t;
  3674. t = u - v;
  3675. if (t != 0)
  3676. goto b3;
  3677. result = u * k;
  3678. }
  3679. return (SCM_POSFIXABLE (result)
  3680. ? SCM_I_MAKINUM (result)
  3681. : scm_i_inum2big (result));
  3682. }
  3683. else if (SCM_BIGP (y))
  3684. {
  3685. SCM_SWAP (x, y);
  3686. goto big_inum;
  3687. }
  3688. else
  3689. return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
  3690. }
  3691. else if (SCM_BIGP (x))
  3692. {
  3693. if (SCM_I_INUMP (y))
  3694. {
  3695. scm_t_bits result;
  3696. scm_t_inum yy;
  3697. big_inum:
  3698. yy = SCM_I_INUM (y);
  3699. if (yy == 0)
  3700. return scm_abs (x);
  3701. if (yy < 0)
  3702. yy = -yy;
  3703. result = mpz_gcd_ui (NULL, SCM_I_BIG_MPZ (x), yy);
  3704. scm_remember_upto_here_1 (x);
  3705. return (SCM_POSFIXABLE (result)
  3706. ? SCM_I_MAKINUM (result)
  3707. : scm_from_unsigned_integer (result));
  3708. }
  3709. else if (SCM_BIGP (y))
  3710. {
  3711. SCM result = scm_i_mkbig ();
  3712. mpz_gcd (SCM_I_BIG_MPZ (result),
  3713. SCM_I_BIG_MPZ (x),
  3714. SCM_I_BIG_MPZ (y));
  3715. scm_remember_upto_here_2 (x, y);
  3716. return scm_i_normbig (result);
  3717. }
  3718. else
  3719. return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
  3720. }
  3721. else
  3722. return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
  3723. }
  3724. SCM_PRIMITIVE_GENERIC (scm_i_lcm, "lcm", 0, 2, 1,
  3725. (SCM x, SCM y, SCM rest),
  3726. "Return the least common multiple of the arguments.\n"
  3727. "If called without arguments, 1 is returned.")
  3728. #define FUNC_NAME s_scm_i_lcm
  3729. {
  3730. while (!scm_is_null (rest))
  3731. { x = scm_lcm (x, y);
  3732. y = scm_car (rest);
  3733. rest = scm_cdr (rest);
  3734. }
  3735. return scm_lcm (x, y);
  3736. }
  3737. #undef FUNC_NAME
  3738. #define s_lcm s_scm_i_lcm
  3739. #define g_lcm g_scm_i_lcm
  3740. SCM
  3741. scm_lcm (SCM n1, SCM n2)
  3742. {
  3743. if (SCM_UNBNDP (n2))
  3744. {
  3745. if (SCM_UNBNDP (n1))
  3746. return SCM_I_MAKINUM (1L);
  3747. n2 = SCM_I_MAKINUM (1L);
  3748. }
  3749. if (SCM_UNLIKELY (!(SCM_I_INUMP (n1) || SCM_BIGP (n1))))
  3750. return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm);
  3751. if (SCM_UNLIKELY (!(SCM_I_INUMP (n2) || SCM_BIGP (n2))))
  3752. return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
  3753. if (SCM_I_INUMP (n1))
  3754. {
  3755. if (SCM_I_INUMP (n2))
  3756. {
  3757. SCM d = scm_gcd (n1, n2);
  3758. if (scm_is_eq (d, SCM_INUM0))
  3759. return d;
  3760. else
  3761. return scm_abs (scm_product (n1, scm_quotient (n2, d)));
  3762. }
  3763. else
  3764. {
  3765. /* inum n1, big n2 */
  3766. inumbig:
  3767. {
  3768. SCM result = scm_i_mkbig ();
  3769. scm_t_inum nn1 = SCM_I_INUM (n1);
  3770. if (nn1 == 0) return SCM_INUM0;
  3771. if (nn1 < 0) nn1 = - nn1;
  3772. mpz_lcm_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n2), nn1);
  3773. scm_remember_upto_here_1 (n2);
  3774. return result;
  3775. }
  3776. }
  3777. }
  3778. else
  3779. {
  3780. /* big n1 */
  3781. if (SCM_I_INUMP (n2))
  3782. {
  3783. SCM_SWAP (n1, n2);
  3784. goto inumbig;
  3785. }
  3786. else
  3787. {
  3788. SCM result = scm_i_mkbig ();
  3789. mpz_lcm(SCM_I_BIG_MPZ (result),
  3790. SCM_I_BIG_MPZ (n1),
  3791. SCM_I_BIG_MPZ (n2));
  3792. scm_remember_upto_here_2(n1, n2);
  3793. /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
  3794. return result;
  3795. }
  3796. }
  3797. }
  3798. /* Emulating 2's complement bignums with sign magnitude arithmetic:
  3799. Logand:
  3800. X Y Result Method:
  3801. (len)
  3802. + + + x (map digit:logand X Y)
  3803. + - + x (map digit:logand X (lognot (+ -1 Y)))
  3804. - + + y (map digit:logand (lognot (+ -1 X)) Y)
  3805. - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
  3806. Logior:
  3807. X Y Result Method:
  3808. + + + (map digit:logior X Y)
  3809. + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
  3810. - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
  3811. - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
  3812. Logxor:
  3813. X Y Result Method:
  3814. + + + (map digit:logxor X Y)
  3815. + - - (+ 1 (map digit:logxor X (+ -1 Y)))
  3816. - + - (+ 1 (map digit:logxor (+ -1 X) Y))
  3817. - - + (map digit:logxor (+ -1 X) (+ -1 Y))
  3818. Logtest:
  3819. X Y Result
  3820. + + (any digit:logand X Y)
  3821. + - (any digit:logand X (lognot (+ -1 Y)))
  3822. - + (any digit:logand (lognot (+ -1 X)) Y)
  3823. - - #t
  3824. */
  3825. SCM_DEFINE (scm_i_logand, "logand", 0, 2, 1,
  3826. (SCM x, SCM y, SCM rest),
  3827. "Return the bitwise AND of the integer arguments.\n\n"
  3828. "@lisp\n"
  3829. "(logand) @result{} -1\n"
  3830. "(logand 7) @result{} 7\n"
  3831. "(logand #b111 #b011 #b001) @result{} 1\n"
  3832. "@end lisp")
  3833. #define FUNC_NAME s_scm_i_logand
  3834. {
  3835. while (!scm_is_null (rest))
  3836. { x = scm_logand (x, y);
  3837. y = scm_car (rest);
  3838. rest = scm_cdr (rest);
  3839. }
  3840. return scm_logand (x, y);
  3841. }
  3842. #undef FUNC_NAME
  3843. #define s_scm_logand s_scm_i_logand
  3844. SCM scm_logand (SCM n1, SCM n2)
  3845. #define FUNC_NAME s_scm_logand
  3846. {
  3847. scm_t_inum nn1;
  3848. if (SCM_UNBNDP (n2))
  3849. {
  3850. if (SCM_UNBNDP (n1))
  3851. return SCM_I_MAKINUM (-1);
  3852. else if (!SCM_NUMBERP (n1))
  3853. SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
  3854. else if (SCM_NUMBERP (n1))
  3855. return n1;
  3856. else
  3857. SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
  3858. }
  3859. if (SCM_I_INUMP (n1))
  3860. {
  3861. nn1 = SCM_I_INUM (n1);
  3862. if (SCM_I_INUMP (n2))
  3863. {
  3864. scm_t_inum nn2 = SCM_I_INUM (n2);
  3865. return SCM_I_MAKINUM (nn1 & nn2);
  3866. }
  3867. else if SCM_BIGP (n2)
  3868. {
  3869. intbig:
  3870. if (nn1 == 0)
  3871. return SCM_INUM0;
  3872. {
  3873. SCM result_z = scm_i_mkbig ();
  3874. mpz_t nn1_z;
  3875. mpz_init_set_si (nn1_z, nn1);
  3876. mpz_and (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
  3877. scm_remember_upto_here_1 (n2);
  3878. mpz_clear (nn1_z);
  3879. return scm_i_normbig (result_z);
  3880. }
  3881. }
  3882. else
  3883. SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
  3884. }
  3885. else if (SCM_BIGP (n1))
  3886. {
  3887. if (SCM_I_INUMP (n2))
  3888. {
  3889. SCM_SWAP (n1, n2);
  3890. nn1 = SCM_I_INUM (n1);
  3891. goto intbig;
  3892. }
  3893. else if (SCM_BIGP (n2))
  3894. {
  3895. SCM result_z = scm_i_mkbig ();
  3896. mpz_and (SCM_I_BIG_MPZ (result_z),
  3897. SCM_I_BIG_MPZ (n1),
  3898. SCM_I_BIG_MPZ (n2));
  3899. scm_remember_upto_here_2 (n1, n2);
  3900. return scm_i_normbig (result_z);
  3901. }
  3902. else
  3903. SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
  3904. }
  3905. else
  3906. SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
  3907. }
  3908. #undef FUNC_NAME
  3909. SCM_DEFINE (scm_i_logior, "logior", 0, 2, 1,
  3910. (SCM x, SCM y, SCM rest),
  3911. "Return the bitwise OR of the integer arguments.\n\n"
  3912. "@lisp\n"
  3913. "(logior) @result{} 0\n"
  3914. "(logior 7) @result{} 7\n"
  3915. "(logior #b000 #b001 #b011) @result{} 3\n"
  3916. "@end lisp")
  3917. #define FUNC_NAME s_scm_i_logior
  3918. {
  3919. while (!scm_is_null (rest))
  3920. { x = scm_logior (x, y);
  3921. y = scm_car (rest);
  3922. rest = scm_cdr (rest);
  3923. }
  3924. return scm_logior (x, y);
  3925. }
  3926. #undef FUNC_NAME
  3927. #define s_scm_logior s_scm_i_logior
  3928. SCM scm_logior (SCM n1, SCM n2)
  3929. #define FUNC_NAME s_scm_logior
  3930. {
  3931. scm_t_inum nn1;
  3932. if (SCM_UNBNDP (n2))
  3933. {
  3934. if (SCM_UNBNDP (n1))
  3935. return SCM_INUM0;
  3936. else if (SCM_NUMBERP (n1))
  3937. return n1;
  3938. else
  3939. SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
  3940. }
  3941. if (SCM_I_INUMP (n1))
  3942. {
  3943. nn1 = SCM_I_INUM (n1);
  3944. if (SCM_I_INUMP (n2))
  3945. {
  3946. long nn2 = SCM_I_INUM (n2);
  3947. return SCM_I_MAKINUM (nn1 | nn2);
  3948. }
  3949. else if (SCM_BIGP (n2))
  3950. {
  3951. intbig:
  3952. if (nn1 == 0)
  3953. return n2;
  3954. {
  3955. SCM result_z = scm_i_mkbig ();
  3956. mpz_t nn1_z;
  3957. mpz_init_set_si (nn1_z, nn1);
  3958. mpz_ior (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
  3959. scm_remember_upto_here_1 (n2);
  3960. mpz_clear (nn1_z);
  3961. return scm_i_normbig (result_z);
  3962. }
  3963. }
  3964. else
  3965. SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
  3966. }
  3967. else if (SCM_BIGP (n1))
  3968. {
  3969. if (SCM_I_INUMP (n2))
  3970. {
  3971. SCM_SWAP (n1, n2);
  3972. nn1 = SCM_I_INUM (n1);
  3973. goto intbig;
  3974. }
  3975. else if (SCM_BIGP (n2))
  3976. {
  3977. SCM result_z = scm_i_mkbig ();
  3978. mpz_ior (SCM_I_BIG_MPZ (result_z),
  3979. SCM_I_BIG_MPZ (n1),
  3980. SCM_I_BIG_MPZ (n2));
  3981. scm_remember_upto_here_2 (n1, n2);
  3982. return scm_i_normbig (result_z);
  3983. }
  3984. else
  3985. SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
  3986. }
  3987. else
  3988. SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
  3989. }
  3990. #undef FUNC_NAME
  3991. SCM_DEFINE (scm_i_logxor, "logxor", 0, 2, 1,
  3992. (SCM x, SCM y, SCM rest),
  3993. "Return the bitwise XOR of the integer arguments. A bit is\n"
  3994. "set in the result if it is set in an odd number of arguments.\n"
  3995. "@lisp\n"
  3996. "(logxor) @result{} 0\n"
  3997. "(logxor 7) @result{} 7\n"
  3998. "(logxor #b000 #b001 #b011) @result{} 2\n"
  3999. "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
  4000. "@end lisp")
  4001. #define FUNC_NAME s_scm_i_logxor
  4002. {
  4003. while (!scm_is_null (rest))
  4004. { x = scm_logxor (x, y);
  4005. y = scm_car (rest);
  4006. rest = scm_cdr (rest);
  4007. }
  4008. return scm_logxor (x, y);
  4009. }
  4010. #undef FUNC_NAME
  4011. #define s_scm_logxor s_scm_i_logxor
  4012. SCM scm_logxor (SCM n1, SCM n2)
  4013. #define FUNC_NAME s_scm_logxor
  4014. {
  4015. scm_t_inum nn1;
  4016. if (SCM_UNBNDP (n2))
  4017. {
  4018. if (SCM_UNBNDP (n1))
  4019. return SCM_INUM0;
  4020. else if (SCM_NUMBERP (n1))
  4021. return n1;
  4022. else
  4023. SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
  4024. }
  4025. if (SCM_I_INUMP (n1))
  4026. {
  4027. nn1 = SCM_I_INUM (n1);
  4028. if (SCM_I_INUMP (n2))
  4029. {
  4030. scm_t_inum nn2 = SCM_I_INUM (n2);
  4031. return SCM_I_MAKINUM (nn1 ^ nn2);
  4032. }
  4033. else if (SCM_BIGP (n2))
  4034. {
  4035. intbig:
  4036. {
  4037. SCM result_z = scm_i_mkbig ();
  4038. mpz_t nn1_z;
  4039. mpz_init_set_si (nn1_z, nn1);
  4040. mpz_xor (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
  4041. scm_remember_upto_here_1 (n2);
  4042. mpz_clear (nn1_z);
  4043. return scm_i_normbig (result_z);
  4044. }
  4045. }
  4046. else
  4047. SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
  4048. }
  4049. else if (SCM_BIGP (n1))
  4050. {
  4051. if (SCM_I_INUMP (n2))
  4052. {
  4053. SCM_SWAP (n1, n2);
  4054. nn1 = SCM_I_INUM (n1);
  4055. goto intbig;
  4056. }
  4057. else if (SCM_BIGP (n2))
  4058. {
  4059. SCM result_z = scm_i_mkbig ();
  4060. mpz_xor (SCM_I_BIG_MPZ (result_z),
  4061. SCM_I_BIG_MPZ (n1),
  4062. SCM_I_BIG_MPZ (n2));
  4063. scm_remember_upto_here_2 (n1, n2);
  4064. return scm_i_normbig (result_z);
  4065. }
  4066. else
  4067. SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
  4068. }
  4069. else
  4070. SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
  4071. }
  4072. #undef FUNC_NAME
  4073. SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0,
  4074. (SCM j, SCM k),
  4075. "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
  4076. "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
  4077. "without actually calculating the @code{logand}, just testing\n"
  4078. "for non-zero.\n"
  4079. "\n"
  4080. "@lisp\n"
  4081. "(logtest #b0100 #b1011) @result{} #f\n"
  4082. "(logtest #b0100 #b0111) @result{} #t\n"
  4083. "@end lisp")
  4084. #define FUNC_NAME s_scm_logtest
  4085. {
  4086. scm_t_inum nj;
  4087. if (SCM_I_INUMP (j))
  4088. {
  4089. nj = SCM_I_INUM (j);
  4090. if (SCM_I_INUMP (k))
  4091. {
  4092. scm_t_inum nk = SCM_I_INUM (k);
  4093. return scm_from_bool (nj & nk);
  4094. }
  4095. else if (SCM_BIGP (k))
  4096. {
  4097. intbig:
  4098. if (nj == 0)
  4099. return SCM_BOOL_F;
  4100. {
  4101. SCM result;
  4102. mpz_t nj_z;
  4103. mpz_init_set_si (nj_z, nj);
  4104. mpz_and (nj_z, nj_z, SCM_I_BIG_MPZ (k));
  4105. scm_remember_upto_here_1 (k);
  4106. result = scm_from_bool (mpz_sgn (nj_z) != 0);
  4107. mpz_clear (nj_z);
  4108. return result;
  4109. }
  4110. }
  4111. else
  4112. SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
  4113. }
  4114. else if (SCM_BIGP (j))
  4115. {
  4116. if (SCM_I_INUMP (k))
  4117. {
  4118. SCM_SWAP (j, k);
  4119. nj = SCM_I_INUM (j);
  4120. goto intbig;
  4121. }
  4122. else if (SCM_BIGP (k))
  4123. {
  4124. SCM result;
  4125. mpz_t result_z;
  4126. mpz_init (result_z);
  4127. mpz_and (result_z,
  4128. SCM_I_BIG_MPZ (j),
  4129. SCM_I_BIG_MPZ (k));
  4130. scm_remember_upto_here_2 (j, k);
  4131. result = scm_from_bool (mpz_sgn (result_z) != 0);
  4132. mpz_clear (result_z);
  4133. return result;
  4134. }
  4135. else
  4136. SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
  4137. }
  4138. else
  4139. SCM_WRONG_TYPE_ARG (SCM_ARG1, j);
  4140. }
  4141. #undef FUNC_NAME
  4142. SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0,
  4143. (SCM index, SCM j),
  4144. "Test whether bit number @var{index} in @var{j} is set.\n"
  4145. "@var{index} starts from 0 for the least significant bit.\n"
  4146. "\n"
  4147. "@lisp\n"
  4148. "(logbit? 0 #b1101) @result{} #t\n"
  4149. "(logbit? 1 #b1101) @result{} #f\n"
  4150. "(logbit? 2 #b1101) @result{} #t\n"
  4151. "(logbit? 3 #b1101) @result{} #t\n"
  4152. "(logbit? 4 #b1101) @result{} #f\n"
  4153. "@end lisp")
  4154. #define FUNC_NAME s_scm_logbit_p
  4155. {
  4156. unsigned long int iindex;
  4157. iindex = scm_to_ulong (index);
  4158. if (SCM_I_INUMP (j))
  4159. {
  4160. /* bits above what's in an inum follow the sign bit */
  4161. iindex = min (iindex, SCM_LONG_BIT - 1);
  4162. return scm_from_bool ((1L << iindex) & SCM_I_INUM (j));
  4163. }
  4164. else if (SCM_BIGP (j))
  4165. {
  4166. int val = mpz_tstbit (SCM_I_BIG_MPZ (j), iindex);
  4167. scm_remember_upto_here_1 (j);
  4168. return scm_from_bool (val);
  4169. }
  4170. else
  4171. SCM_WRONG_TYPE_ARG (SCM_ARG2, j);
  4172. }
  4173. #undef FUNC_NAME
  4174. SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0,
  4175. (SCM n),
  4176. "Return the integer which is the ones-complement of the integer\n"
  4177. "argument.\n"
  4178. "\n"
  4179. "@lisp\n"
  4180. "(number->string (lognot #b10000000) 2)\n"
  4181. " @result{} \"-10000001\"\n"
  4182. "(number->string (lognot #b0) 2)\n"
  4183. " @result{} \"-1\"\n"
  4184. "@end lisp")
  4185. #define FUNC_NAME s_scm_lognot
  4186. {
  4187. if (SCM_I_INUMP (n)) {
  4188. /* No overflow here, just need to toggle all the bits making up the inum.
  4189. Enhancement: No need to strip the tag and add it back, could just xor
  4190. a block of 1 bits, if that worked with the various debug versions of
  4191. the SCM typedef. */
  4192. return SCM_I_MAKINUM (~ SCM_I_INUM (n));
  4193. } else if (SCM_BIGP (n)) {
  4194. SCM result = scm_i_mkbig ();
  4195. mpz_com (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n));
  4196. scm_remember_upto_here_1 (n);
  4197. return result;
  4198. } else {
  4199. SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
  4200. }
  4201. }
  4202. #undef FUNC_NAME
  4203. /* returns 0 if IN is not an integer. OUT must already be
  4204. initialized. */
  4205. static int
  4206. coerce_to_big (SCM in, mpz_t out)
  4207. {
  4208. if (SCM_BIGP (in))
  4209. mpz_set (out, SCM_I_BIG_MPZ (in));
  4210. else if (SCM_I_INUMP (in))
  4211. mpz_set_si (out, SCM_I_INUM (in));
  4212. else
  4213. return 0;
  4214. return 1;
  4215. }
  4216. SCM_DEFINE (scm_modulo_expt, "modulo-expt", 3, 0, 0,
  4217. (SCM n, SCM k, SCM m),
  4218. "Return @var{n} raised to the integer exponent\n"
  4219. "@var{k}, modulo @var{m}.\n"
  4220. "\n"
  4221. "@lisp\n"
  4222. "(modulo-expt 2 3 5)\n"
  4223. " @result{} 3\n"
  4224. "@end lisp")
  4225. #define FUNC_NAME s_scm_modulo_expt
  4226. {
  4227. mpz_t n_tmp;
  4228. mpz_t k_tmp;
  4229. mpz_t m_tmp;
  4230. /* There are two classes of error we might encounter --
  4231. 1) Math errors, which we'll report by calling scm_num_overflow,
  4232. and
  4233. 2) wrong-type errors, which of course we'll report by calling
  4234. SCM_WRONG_TYPE_ARG.
  4235. We don't report those errors immediately, however; instead we do
  4236. some cleanup first. These variables tell us which error (if
  4237. any) we should report after cleaning up.
  4238. */
  4239. int report_overflow = 0;
  4240. int position_of_wrong_type = 0;
  4241. SCM value_of_wrong_type = SCM_INUM0;
  4242. SCM result = SCM_UNDEFINED;
  4243. mpz_init (n_tmp);
  4244. mpz_init (k_tmp);
  4245. mpz_init (m_tmp);
  4246. if (scm_is_eq (m, SCM_INUM0))
  4247. {
  4248. report_overflow = 1;
  4249. goto cleanup;
  4250. }
  4251. if (!coerce_to_big (n, n_tmp))
  4252. {
  4253. value_of_wrong_type = n;
  4254. position_of_wrong_type = 1;
  4255. goto cleanup;
  4256. }
  4257. if (!coerce_to_big (k, k_tmp))
  4258. {
  4259. value_of_wrong_type = k;
  4260. position_of_wrong_type = 2;
  4261. goto cleanup;
  4262. }
  4263. if (!coerce_to_big (m, m_tmp))
  4264. {
  4265. value_of_wrong_type = m;
  4266. position_of_wrong_type = 3;
  4267. goto cleanup;
  4268. }
  4269. /* if the exponent K is negative, and we simply call mpz_powm, we
  4270. will get a divide-by-zero exception when an inverse 1/n mod m
  4271. doesn't exist (or is not unique). Since exceptions are hard to
  4272. handle, we'll attempt the inversion "by hand" -- that way, we get
  4273. a simple failure code, which is easy to handle. */
  4274. if (-1 == mpz_sgn (k_tmp))
  4275. {
  4276. if (!mpz_invert (n_tmp, n_tmp, m_tmp))
  4277. {
  4278. report_overflow = 1;
  4279. goto cleanup;
  4280. }
  4281. mpz_neg (k_tmp, k_tmp);
  4282. }
  4283. result = scm_i_mkbig ();
  4284. mpz_powm (SCM_I_BIG_MPZ (result),
  4285. n_tmp,
  4286. k_tmp,
  4287. m_tmp);
  4288. if (mpz_sgn (m_tmp) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)
  4289. mpz_add (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), m_tmp);
  4290. cleanup:
  4291. mpz_clear (m_tmp);
  4292. mpz_clear (k_tmp);
  4293. mpz_clear (n_tmp);
  4294. if (report_overflow)
  4295. scm_num_overflow (FUNC_NAME);
  4296. if (position_of_wrong_type)
  4297. SCM_WRONG_TYPE_ARG (position_of_wrong_type,
  4298. value_of_wrong_type);
  4299. return scm_i_normbig (result);
  4300. }
  4301. #undef FUNC_NAME
  4302. SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
  4303. (SCM n, SCM k),
  4304. "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
  4305. "exact integer, @var{n} can be any number.\n"
  4306. "\n"
  4307. "Negative @var{k} is supported, and results in\n"
  4308. "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
  4309. "@math{@var{n}^0} is 1, as usual, and that\n"
  4310. "includes @math{0^0} is 1.\n"
  4311. "\n"
  4312. "@lisp\n"
  4313. "(integer-expt 2 5) @result{} 32\n"
  4314. "(integer-expt -3 3) @result{} -27\n"
  4315. "(integer-expt 5 -3) @result{} 1/125\n"
  4316. "(integer-expt 0 0) @result{} 1\n"
  4317. "@end lisp")
  4318. #define FUNC_NAME s_scm_integer_expt
  4319. {
  4320. scm_t_inum i2 = 0;
  4321. SCM z_i2 = SCM_BOOL_F;
  4322. int i2_is_big = 0;
  4323. SCM acc = SCM_I_MAKINUM (1L);
  4324. /* Specifically refrain from checking the type of the first argument.
  4325. This allows us to exponentiate any object that can be multiplied.
  4326. If we must raise to a negative power, we must also be able to
  4327. take its reciprocal. */
  4328. if (!SCM_LIKELY (SCM_I_INUMP (k)) && !SCM_LIKELY (SCM_BIGP (k)))
  4329. SCM_WRONG_TYPE_ARG (2, k);
  4330. if (SCM_UNLIKELY (scm_is_eq (k, SCM_INUM0)))
  4331. return SCM_INUM1; /* n^(exact0) is exact 1, regardless of n */
  4332. else if (SCM_UNLIKELY (scm_is_eq (n, SCM_I_MAKINUM (-1L))))
  4333. return scm_is_false (scm_even_p (k)) ? n : SCM_INUM1;
  4334. /* The next check is necessary only because R6RS specifies different
  4335. behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
  4336. we simply skip this case and move on. */
  4337. else if (SCM_NUMBERP (n) && scm_is_true (scm_zero_p (n)))
  4338. {
  4339. /* k cannot be 0 at this point, because we
  4340. have already checked for that case above */
  4341. if (scm_is_true (scm_positive_p (k)))
  4342. return n;
  4343. else /* return NaN for (0 ^ k) for negative k per R6RS */
  4344. return scm_nan ();
  4345. }
  4346. if (SCM_I_INUMP (k))
  4347. i2 = SCM_I_INUM (k);
  4348. else if (SCM_BIGP (k))
  4349. {
  4350. z_i2 = scm_i_clonebig (k, 1);
  4351. scm_remember_upto_here_1 (k);
  4352. i2_is_big = 1;
  4353. }
  4354. else
  4355. SCM_WRONG_TYPE_ARG (2, k);
  4356. if (i2_is_big)
  4357. {
  4358. if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == -1)
  4359. {
  4360. mpz_neg (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2));
  4361. n = scm_divide (n, SCM_UNDEFINED);
  4362. }
  4363. while (1)
  4364. {
  4365. if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == 0)
  4366. {
  4367. return acc;
  4368. }
  4369. if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2), 1) == 0)
  4370. {
  4371. return scm_product (acc, n);
  4372. }
  4373. if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2), 0))
  4374. acc = scm_product (acc, n);
  4375. n = scm_product (n, n);
  4376. mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2), 1);
  4377. }
  4378. }
  4379. else
  4380. {
  4381. if (i2 < 0)
  4382. {
  4383. i2 = -i2;
  4384. n = scm_divide (n, SCM_UNDEFINED);
  4385. }
  4386. while (1)
  4387. {
  4388. if (0 == i2)
  4389. return acc;
  4390. if (1 == i2)
  4391. return scm_product (acc, n);
  4392. if (i2 & 1)
  4393. acc = scm_product (acc, n);
  4394. n = scm_product (n, n);
  4395. i2 >>= 1;
  4396. }
  4397. }
  4398. }
  4399. #undef FUNC_NAME
  4400. SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
  4401. (SCM n, SCM cnt),
  4402. "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
  4403. "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
  4404. "\n"
  4405. "This is effectively a multiplication by 2^@var{cnt}, and when\n"
  4406. "@var{cnt} is negative it's a division, rounded towards negative\n"
  4407. "infinity. (Note that this is not the same rounding as\n"
  4408. "@code{quotient} does.)\n"
  4409. "\n"
  4410. "With @var{n} viewed as an infinite precision twos complement,\n"
  4411. "@code{ash} means a left shift introducing zero bits, or a right\n"
  4412. "shift dropping bits.\n"
  4413. "\n"
  4414. "@lisp\n"
  4415. "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
  4416. "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
  4417. "\n"
  4418. ";; -23 is bits ...11101001, -6 is bits ...111010\n"
  4419. "(ash -23 -2) @result{} -6\n"
  4420. "@end lisp")
  4421. #define FUNC_NAME s_scm_ash
  4422. {
  4423. long bits_to_shift;
  4424. bits_to_shift = scm_to_long (cnt);
  4425. if (SCM_I_INUMP (n))
  4426. {
  4427. scm_t_inum nn = SCM_I_INUM (n);
  4428. if (bits_to_shift > 0)
  4429. {
  4430. /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
  4431. overflow a non-zero fixnum. For smaller shifts we check the
  4432. bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
  4433. all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
  4434. Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
  4435. bits_to_shift)". */
  4436. if (nn == 0)
  4437. return n;
  4438. if (bits_to_shift < SCM_I_FIXNUM_BIT-1
  4439. && ((scm_t_bits)
  4440. (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
  4441. <= 1))
  4442. {
  4443. return SCM_I_MAKINUM (nn << bits_to_shift);
  4444. }
  4445. else
  4446. {
  4447. SCM result = scm_i_inum2big (nn);
  4448. mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
  4449. bits_to_shift);
  4450. return result;
  4451. }
  4452. }
  4453. else
  4454. {
  4455. bits_to_shift = -bits_to_shift;
  4456. if (bits_to_shift >= SCM_LONG_BIT)
  4457. return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM(-1));
  4458. else
  4459. return SCM_I_MAKINUM (SCM_SRS (nn, bits_to_shift));
  4460. }
  4461. }
  4462. else if (SCM_BIGP (n))
  4463. {
  4464. SCM result;
  4465. if (bits_to_shift == 0)
  4466. return n;
  4467. result = scm_i_mkbig ();
  4468. if (bits_to_shift >= 0)
  4469. {
  4470. mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
  4471. bits_to_shift);
  4472. return result;
  4473. }
  4474. else
  4475. {
  4476. /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
  4477. we have to allocate a bignum even if the result is going to be a
  4478. fixnum. */
  4479. mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
  4480. -bits_to_shift);
  4481. return scm_i_normbig (result);
  4482. }
  4483. }
  4484. else
  4485. {
  4486. SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
  4487. }
  4488. }
  4489. #undef FUNC_NAME
  4490. SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
  4491. (SCM n, SCM start, SCM end),
  4492. "Return the integer composed of the @var{start} (inclusive)\n"
  4493. "through @var{end} (exclusive) bits of @var{n}. The\n"
  4494. "@var{start}th bit becomes the 0-th bit in the result.\n"
  4495. "\n"
  4496. "@lisp\n"
  4497. "(number->string (bit-extract #b1101101010 0 4) 2)\n"
  4498. " @result{} \"1010\"\n"
  4499. "(number->string (bit-extract #b1101101010 4 9) 2)\n"
  4500. " @result{} \"10110\"\n"
  4501. "@end lisp")
  4502. #define FUNC_NAME s_scm_bit_extract
  4503. {
  4504. unsigned long int istart, iend, bits;
  4505. istart = scm_to_ulong (start);
  4506. iend = scm_to_ulong (end);
  4507. SCM_ASSERT_RANGE (3, end, (iend >= istart));
  4508. /* how many bits to keep */
  4509. bits = iend - istart;
  4510. if (SCM_I_INUMP (n))
  4511. {
  4512. scm_t_inum in = SCM_I_INUM (n);
  4513. /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
  4514. SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
  4515. in = SCM_SRS (in, min (istart, SCM_I_FIXNUM_BIT-1));
  4516. if (in < 0 && bits >= SCM_I_FIXNUM_BIT)
  4517. {
  4518. /* Since we emulate two's complement encoded numbers, this
  4519. * special case requires us to produce a result that has
  4520. * more bits than can be stored in a fixnum.
  4521. */
  4522. SCM result = scm_i_inum2big (in);
  4523. mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
  4524. bits);
  4525. return result;
  4526. }
  4527. /* mask down to requisite bits */
  4528. bits = min (bits, SCM_I_FIXNUM_BIT);
  4529. return SCM_I_MAKINUM (in & ((1L << bits) - 1));
  4530. }
  4531. else if (SCM_BIGP (n))
  4532. {
  4533. SCM result;
  4534. if (bits == 1)
  4535. {
  4536. result = SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n), istart));
  4537. }
  4538. else
  4539. {
  4540. /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
  4541. bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
  4542. such bits into a ulong. */
  4543. result = scm_i_mkbig ();
  4544. mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result), SCM_I_BIG_MPZ(n), istart);
  4545. mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result), SCM_I_BIG_MPZ(result), bits);
  4546. result = scm_i_normbig (result);
  4547. }
  4548. scm_remember_upto_here_1 (n);
  4549. return result;
  4550. }
  4551. else
  4552. SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
  4553. }
  4554. #undef FUNC_NAME
  4555. static const char scm_logtab[] = {
  4556. 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
  4557. };
  4558. SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0,
  4559. (SCM n),
  4560. "Return the number of bits in integer @var{n}. If integer is\n"
  4561. "positive, the 1-bits in its binary representation are counted.\n"
  4562. "If negative, the 0-bits in its two's-complement binary\n"
  4563. "representation are counted. If 0, 0 is returned.\n"
  4564. "\n"
  4565. "@lisp\n"
  4566. "(logcount #b10101010)\n"
  4567. " @result{} 4\n"
  4568. "(logcount 0)\n"
  4569. " @result{} 0\n"
  4570. "(logcount -2)\n"
  4571. " @result{} 1\n"
  4572. "@end lisp")
  4573. #define FUNC_NAME s_scm_logcount
  4574. {
  4575. if (SCM_I_INUMP (n))
  4576. {
  4577. unsigned long c = 0;
  4578. scm_t_inum nn = SCM_I_INUM (n);
  4579. if (nn < 0)
  4580. nn = -1 - nn;
  4581. while (nn)
  4582. {
  4583. c += scm_logtab[15 & nn];
  4584. nn >>= 4;
  4585. }
  4586. return SCM_I_MAKINUM (c);
  4587. }
  4588. else if (SCM_BIGP (n))
  4589. {
  4590. unsigned long count;
  4591. if (mpz_sgn (SCM_I_BIG_MPZ (n)) >= 0)
  4592. count = mpz_popcount (SCM_I_BIG_MPZ (n));
  4593. else
  4594. count = mpz_hamdist (SCM_I_BIG_MPZ (n), z_negative_one);
  4595. scm_remember_upto_here_1 (n);
  4596. return SCM_I_MAKINUM (count);
  4597. }
  4598. else
  4599. SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
  4600. }
  4601. #undef FUNC_NAME
  4602. static const char scm_ilentab[] = {
  4603. 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
  4604. };
  4605. SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0,
  4606. (SCM n),
  4607. "Return the number of bits necessary to represent @var{n}.\n"
  4608. "\n"
  4609. "@lisp\n"
  4610. "(integer-length #b10101010)\n"
  4611. " @result{} 8\n"
  4612. "(integer-length 0)\n"
  4613. " @result{} 0\n"
  4614. "(integer-length #b1111)\n"
  4615. " @result{} 4\n"
  4616. "@end lisp")
  4617. #define FUNC_NAME s_scm_integer_length
  4618. {
  4619. if (SCM_I_INUMP (n))
  4620. {
  4621. unsigned long c = 0;
  4622. unsigned int l = 4;
  4623. scm_t_inum nn = SCM_I_INUM (n);
  4624. if (nn < 0)
  4625. nn = -1 - nn;
  4626. while (nn)
  4627. {
  4628. c += 4;
  4629. l = scm_ilentab [15 & nn];
  4630. nn >>= 4;
  4631. }
  4632. return SCM_I_MAKINUM (c - 4 + l);
  4633. }
  4634. else if (SCM_BIGP (n))
  4635. {
  4636. /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
  4637. want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
  4638. 1 too big, so check for that and adjust. */
  4639. size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2);
  4640. if (mpz_sgn (SCM_I_BIG_MPZ (n)) < 0
  4641. && mpz_scan0 (SCM_I_BIG_MPZ (n), /* no 0 bits above the lowest 1 */
  4642. mpz_scan1 (SCM_I_BIG_MPZ (n), 0)) == ULONG_MAX)
  4643. size--;
  4644. scm_remember_upto_here_1 (n);
  4645. return SCM_I_MAKINUM (size);
  4646. }
  4647. else
  4648. SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
  4649. }
  4650. #undef FUNC_NAME
  4651. /*** NUMBERS -> STRINGS ***/
  4652. #define SCM_MAX_DBL_PREC 60
  4653. #define SCM_MAX_DBL_RADIX 36
  4654. /* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
  4655. static int scm_dblprec[SCM_MAX_DBL_RADIX - 1];
  4656. static double fx_per_radix[SCM_MAX_DBL_RADIX - 1][SCM_MAX_DBL_PREC];
  4657. static
  4658. void init_dblprec(int *prec, int radix) {
  4659. /* determine floating point precision by adding successively
  4660. smaller increments to 1.0 until it is considered == 1.0 */
  4661. double f = ((double)1.0)/radix;
  4662. double fsum = 1.0 + f;
  4663. *prec = 0;
  4664. while (fsum != 1.0)
  4665. {
  4666. if (++(*prec) > SCM_MAX_DBL_PREC)
  4667. fsum = 1.0;
  4668. else
  4669. {
  4670. f /= radix;
  4671. fsum = f + 1.0;
  4672. }
  4673. }
  4674. (*prec) -= 1;
  4675. }
  4676. static
  4677. void init_fx_radix(double *fx_list, int radix)
  4678. {
  4679. /* initialize a per-radix list of tolerances. When added
  4680. to a number < 1.0, we can determine if we should raund
  4681. up and quit converting a number to a string. */
  4682. int i;
  4683. fx_list[0] = 0.0;
  4684. fx_list[1] = 0.5;
  4685. for( i = 2 ; i < SCM_MAX_DBL_PREC; ++i )
  4686. fx_list[i] = (fx_list[i-1] / radix);
  4687. }
  4688. /* use this array as a way to generate a single digit */
  4689. static const char number_chars[] = "0123456789abcdefghijklmnopqrstuvwxyz";
  4690. static size_t
  4691. idbl2str (double f, char *a, int radix)
  4692. {
  4693. int efmt, dpt, d, i, wp;
  4694. double *fx;
  4695. #ifdef DBL_MIN_10_EXP
  4696. double f_cpy;
  4697. int exp_cpy;
  4698. #endif /* DBL_MIN_10_EXP */
  4699. size_t ch = 0;
  4700. int exp = 0;
  4701. if(radix < 2 ||
  4702. radix > SCM_MAX_DBL_RADIX)
  4703. {
  4704. /* revert to existing behavior */
  4705. radix = 10;
  4706. }
  4707. wp = scm_dblprec[radix-2];
  4708. fx = fx_per_radix[radix-2];
  4709. if (f == 0.0)
  4710. {
  4711. #ifdef HAVE_COPYSIGN
  4712. double sgn = copysign (1.0, f);
  4713. if (sgn < 0.0)
  4714. a[ch++] = '-';
  4715. #endif
  4716. goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
  4717. }
  4718. if (isinf (f))
  4719. {
  4720. if (f < 0)
  4721. strcpy (a, "-inf.0");
  4722. else
  4723. strcpy (a, "+inf.0");
  4724. return ch+6;
  4725. }
  4726. else if (isnan (f))
  4727. {
  4728. strcpy (a, "+nan.0");
  4729. return ch+6;
  4730. }
  4731. if (f < 0.0)
  4732. {
  4733. f = -f;
  4734. a[ch++] = '-';
  4735. }
  4736. #ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
  4737. make-uniform-vector, from causing infinite loops. */
  4738. /* just do the checking...if it passes, we do the conversion for our
  4739. radix again below */
  4740. f_cpy = f;
  4741. exp_cpy = exp;
  4742. while (f_cpy < 1.0)
  4743. {
  4744. f_cpy *= 10.0;
  4745. if (exp_cpy-- < DBL_MIN_10_EXP)
  4746. {
  4747. a[ch++] = '#';
  4748. a[ch++] = '.';
  4749. a[ch++] = '#';
  4750. return ch;
  4751. }
  4752. }
  4753. while (f_cpy > 10.0)
  4754. {
  4755. f_cpy *= 0.10;
  4756. if (exp_cpy++ > DBL_MAX_10_EXP)
  4757. {
  4758. a[ch++] = '#';
  4759. a[ch++] = '.';
  4760. a[ch++] = '#';
  4761. return ch;
  4762. }
  4763. }
  4764. #endif
  4765. while (f < 1.0)
  4766. {
  4767. f *= radix;
  4768. exp--;
  4769. }
  4770. while (f > radix)
  4771. {
  4772. f /= radix;
  4773. exp++;
  4774. }
  4775. if (f + fx[wp] >= radix)
  4776. {
  4777. f = 1.0;
  4778. exp++;
  4779. }
  4780. zero:
  4781. efmt = (exp < -3) || (exp > wp + 2);
  4782. if (!efmt)
  4783. {
  4784. if (exp < 0)
  4785. {
  4786. a[ch++] = '0';
  4787. a[ch++] = '.';
  4788. dpt = exp;
  4789. while (++dpt)
  4790. a[ch++] = '0';
  4791. }
  4792. else
  4793. dpt = exp + 1;
  4794. }
  4795. else
  4796. dpt = 1;
  4797. do
  4798. {
  4799. d = f;
  4800. f -= d;
  4801. a[ch++] = number_chars[d];
  4802. if (f < fx[wp])
  4803. break;
  4804. if (f + fx[wp] >= 1.0)
  4805. {
  4806. a[ch - 1] = number_chars[d+1];
  4807. break;
  4808. }
  4809. f *= radix;
  4810. if (!(--dpt))
  4811. a[ch++] = '.';
  4812. }
  4813. while (wp--);
  4814. if (dpt > 0)
  4815. {
  4816. if ((dpt > 4) && (exp > 6))
  4817. {
  4818. d = (a[0] == '-' ? 2 : 1);
  4819. for (i = ch++; i > d; i--)
  4820. a[i] = a[i - 1];
  4821. a[d] = '.';
  4822. efmt = 1;
  4823. }
  4824. else
  4825. {
  4826. while (--dpt)
  4827. a[ch++] = '0';
  4828. a[ch++] = '.';
  4829. }
  4830. }
  4831. if (a[ch - 1] == '.')
  4832. a[ch++] = '0'; /* trailing zero */
  4833. if (efmt && exp)
  4834. {
  4835. a[ch++] = 'e';
  4836. if (exp < 0)
  4837. {
  4838. exp = -exp;
  4839. a[ch++] = '-';
  4840. }
  4841. for (i = radix; i <= exp; i *= radix);
  4842. for (i /= radix; i; i /= radix)
  4843. {
  4844. a[ch++] = number_chars[exp / i];
  4845. exp %= i;
  4846. }
  4847. }
  4848. return ch;
  4849. }
  4850. static size_t
  4851. icmplx2str (double real, double imag, char *str, int radix)
  4852. {
  4853. size_t i;
  4854. double sgn;
  4855. i = idbl2str (real, str, radix);
  4856. #ifdef HAVE_COPYSIGN
  4857. sgn = copysign (1.0, imag);
  4858. #else
  4859. sgn = imag;
  4860. #endif
  4861. /* Don't output a '+' for negative numbers or for Inf and
  4862. NaN. They will provide their own sign. */
  4863. if (sgn >= 0 && DOUBLE_IS_FINITE (imag))
  4864. str[i++] = '+';
  4865. i += idbl2str (imag, &str[i], radix);
  4866. str[i++] = 'i';
  4867. return i;
  4868. }
  4869. static size_t
  4870. iflo2str (SCM flt, char *str, int radix)
  4871. {
  4872. size_t i;
  4873. if (SCM_REALP (flt))
  4874. i = idbl2str (SCM_REAL_VALUE (flt), str, radix);
  4875. else
  4876. i = icmplx2str (SCM_COMPLEX_REAL (flt), SCM_COMPLEX_IMAG (flt),
  4877. str, radix);
  4878. return i;
  4879. }
  4880. /* convert a scm_t_intmax to a string (unterminated). returns the number of
  4881. characters in the result.
  4882. rad is output base
  4883. p is destination: worst case (base 2) is SCM_INTBUFLEN */
  4884. size_t
  4885. scm_iint2str (scm_t_intmax num, int rad, char *p)
  4886. {
  4887. if (num < 0)
  4888. {
  4889. *p++ = '-';
  4890. return scm_iuint2str (-num, rad, p) + 1;
  4891. }
  4892. else
  4893. return scm_iuint2str (num, rad, p);
  4894. }
  4895. /* convert a scm_t_intmax to a string (unterminated). returns the number of
  4896. characters in the result.
  4897. rad is output base
  4898. p is destination: worst case (base 2) is SCM_INTBUFLEN */
  4899. size_t
  4900. scm_iuint2str (scm_t_uintmax num, int rad, char *p)
  4901. {
  4902. size_t j = 1;
  4903. size_t i;
  4904. scm_t_uintmax n = num;
  4905. if (rad < 2 || rad > 36)
  4906. scm_out_of_range ("scm_iuint2str", scm_from_int (rad));
  4907. for (n /= rad; n > 0; n /= rad)
  4908. j++;
  4909. i = j;
  4910. n = num;
  4911. while (i--)
  4912. {
  4913. int d = n % rad;
  4914. n /= rad;
  4915. p[i] = number_chars[d];
  4916. }
  4917. return j;
  4918. }
  4919. SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
  4920. (SCM n, SCM radix),
  4921. "Return a string holding the external representation of the\n"
  4922. "number @var{n} in the given @var{radix}. If @var{n} is\n"
  4923. "inexact, a radix of 10 will be used.")
  4924. #define FUNC_NAME s_scm_number_to_string
  4925. {
  4926. int base;
  4927. if (SCM_UNBNDP (radix))
  4928. base = 10;
  4929. else
  4930. base = scm_to_signed_integer (radix, 2, 36);
  4931. if (SCM_I_INUMP (n))
  4932. {
  4933. char num_buf [SCM_INTBUFLEN];
  4934. size_t length = scm_iint2str (SCM_I_INUM (n), base, num_buf);
  4935. return scm_from_locale_stringn (num_buf, length);
  4936. }
  4937. else if (SCM_BIGP (n))
  4938. {
  4939. char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n));
  4940. size_t len = strlen (str);
  4941. void (*freefunc) (void *, size_t);
  4942. SCM ret;
  4943. mp_get_memory_functions (NULL, NULL, &freefunc);
  4944. scm_remember_upto_here_1 (n);
  4945. ret = scm_from_latin1_stringn (str, len);
  4946. freefunc (str, len + 1);
  4947. return ret;
  4948. }
  4949. else if (SCM_FRACTIONP (n))
  4950. {
  4951. return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n), radix),
  4952. scm_from_locale_string ("/"),
  4953. scm_number_to_string (SCM_FRACTION_DENOMINATOR (n), radix)));
  4954. }
  4955. else if (SCM_INEXACTP (n))
  4956. {
  4957. char num_buf [FLOBUFLEN];
  4958. return scm_from_locale_stringn (num_buf, iflo2str (n, num_buf, base));
  4959. }
  4960. else
  4961. SCM_WRONG_TYPE_ARG (1, n);
  4962. }
  4963. #undef FUNC_NAME
  4964. /* These print routines used to be stubbed here so that scm_repl.c
  4965. wouldn't need SCM_BIGDIG conditionals (pre GMP) */
  4966. int
  4967. scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
  4968. {
  4969. char num_buf[FLOBUFLEN];
  4970. scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port);
  4971. return !0;
  4972. }
  4973. void
  4974. scm_i_print_double (double val, SCM port)
  4975. {
  4976. char num_buf[FLOBUFLEN];
  4977. scm_lfwrite_unlocked (num_buf, idbl2str (val, num_buf, 10), port);
  4978. }
  4979. int
  4980. scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
  4981. {
  4982. char num_buf[FLOBUFLEN];
  4983. scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port);
  4984. return !0;
  4985. }
  4986. void
  4987. scm_i_print_complex (double real, double imag, SCM port)
  4988. {
  4989. char num_buf[FLOBUFLEN];
  4990. scm_lfwrite_unlocked (num_buf, icmplx2str (real, imag, num_buf, 10), port);
  4991. }
  4992. int
  4993. scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
  4994. {
  4995. SCM str;
  4996. str = scm_number_to_string (sexp, SCM_UNDEFINED);
  4997. scm_display (str, port);
  4998. scm_remember_upto_here_1 (str);
  4999. return !0;
  5000. }
  5001. int
  5002. scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
  5003. {
  5004. char *str = mpz_get_str (NULL, 10, SCM_I_BIG_MPZ (exp));
  5005. size_t len = strlen (str);
  5006. void (*freefunc) (void *, size_t);
  5007. mp_get_memory_functions (NULL, NULL, &freefunc);
  5008. scm_remember_upto_here_1 (exp);
  5009. scm_lfwrite_unlocked (str, len, port);
  5010. freefunc (str, len + 1);
  5011. return !0;
  5012. }
  5013. /*** END nums->strs ***/
  5014. /*** STRINGS -> NUMBERS ***/
  5015. /* The following functions implement the conversion from strings to numbers.
  5016. * The implementation somehow follows the grammar for numbers as it is given
  5017. * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
  5018. * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
  5019. * points should be noted about the implementation:
  5020. *
  5021. * * Each function keeps a local index variable 'idx' that points at the
  5022. * current position within the parsed string. The global index is only
  5023. * updated if the function could parse the corresponding syntactic unit
  5024. * successfully.
  5025. *
  5026. * * Similarly, the functions keep track of indicators of inexactness ('#',
  5027. * '.' or exponents) using local variables ('hash_seen', 'x').
  5028. *
  5029. * * Sequences of digits are parsed into temporary variables holding fixnums.
  5030. * Only if these fixnums would overflow, the result variables are updated
  5031. * using the standard functions scm_add, scm_product, scm_divide etc. Then,
  5032. * the temporary variables holding the fixnums are cleared, and the process
  5033. * starts over again. If for example fixnums were able to store five decimal
  5034. * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
  5035. * and the result was computed as 12345 * 100000 + 67890. In other words,
  5036. * only every five digits two bignum operations were performed.
  5037. *
  5038. * Notes on the handling of exactness specifiers:
  5039. *
  5040. * When parsing non-real complex numbers, we apply exactness specifiers on
  5041. * per-component basis, as is done in PLT Scheme. For complex numbers
  5042. * written in rectangular form, exactness specifiers are applied to the
  5043. * real and imaginary parts before calling scm_make_rectangular. For
  5044. * complex numbers written in polar form, exactness specifiers are applied
  5045. * to the magnitude and angle before calling scm_make_polar.
  5046. *
  5047. * There are two kinds of exactness specifiers: forced and implicit. A
  5048. * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
  5049. * the entire number, and applies to both components of a complex number.
  5050. * "#e" causes each component to be made exact, and "#i" causes each
  5051. * component to be made inexact. If no forced exactness specifier is
  5052. * present, then the exactness of each component is determined
  5053. * independently by the presence or absence of a decimal point or hash mark
  5054. * within that component. If a decimal point or hash mark is present, the
  5055. * component is made inexact, otherwise it is made exact.
  5056. *
  5057. * After the exactness specifiers have been applied to each component, they
  5058. * are passed to either scm_make_rectangular or scm_make_polar to produce
  5059. * the final result. Note that this will result in a real number if the
  5060. * imaginary part, magnitude, or angle is an exact 0.
  5061. *
  5062. * For example, (string->number "#i5.0+0i") does the equivalent of:
  5063. *
  5064. * (make-rectangular (exact->inexact 5) (exact->inexact 0))
  5065. */
  5066. enum t_exactness {NO_EXACTNESS, INEXACT, EXACT};
  5067. /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
  5068. /* Caller is responsible for checking that the return value is in range
  5069. for the given radix, which should be <= 36. */
  5070. static unsigned int
  5071. char_decimal_value (scm_t_uint32 c)
  5072. {
  5073. /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
  5074. that's certainly above any valid decimal, so we take advantage of
  5075. that to elide some tests. */
  5076. unsigned int d = (unsigned int) uc_decimal_value (c);
  5077. /* If that failed, try extended hexadecimals, then. Only accept ascii
  5078. hexadecimals. */
  5079. if (d >= 10U)
  5080. {
  5081. c = uc_tolower (c);
  5082. if (c >= (scm_t_uint32) 'a')
  5083. d = c - (scm_t_uint32)'a' + 10U;
  5084. }
  5085. return d;
  5086. }
  5087. /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
  5088. in base RADIX. Upon success, return the unsigned integer and update
  5089. *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
  5090. static SCM
  5091. mem2uinteger (SCM mem, unsigned int *p_idx,
  5092. unsigned int radix, enum t_exactness *p_exactness)
  5093. {
  5094. unsigned int idx = *p_idx;
  5095. unsigned int hash_seen = 0;
  5096. scm_t_bits shift = 1;
  5097. scm_t_bits add = 0;
  5098. unsigned int digit_value;
  5099. SCM result;
  5100. char c;
  5101. size_t len = scm_i_string_length (mem);
  5102. if (idx == len)
  5103. return SCM_BOOL_F;
  5104. c = scm_i_string_ref (mem, idx);
  5105. digit_value = char_decimal_value (c);
  5106. if (digit_value >= radix)
  5107. return SCM_BOOL_F;
  5108. idx++;
  5109. result = SCM_I_MAKINUM (digit_value);
  5110. while (idx != len)
  5111. {
  5112. scm_t_wchar c = scm_i_string_ref (mem, idx);
  5113. if (c == '#')
  5114. {
  5115. hash_seen = 1;
  5116. digit_value = 0;
  5117. }
  5118. else if (hash_seen)
  5119. break;
  5120. else
  5121. {
  5122. digit_value = char_decimal_value (c);
  5123. /* This check catches non-decimals in addition to out-of-range
  5124. decimals. */
  5125. if (digit_value >= radix)
  5126. break;
  5127. }
  5128. idx++;
  5129. if (SCM_MOST_POSITIVE_FIXNUM / radix < shift)
  5130. {
  5131. result = scm_product (result, SCM_I_MAKINUM (shift));
  5132. if (add > 0)
  5133. result = scm_sum (result, SCM_I_MAKINUM (add));
  5134. shift = radix;
  5135. add = digit_value;
  5136. }
  5137. else
  5138. {
  5139. shift = shift * radix;
  5140. add = add * radix + digit_value;
  5141. }
  5142. };
  5143. if (shift > 1)
  5144. result = scm_product (result, SCM_I_MAKINUM (shift));
  5145. if (add > 0)
  5146. result = scm_sum (result, SCM_I_MAKINUM (add));
  5147. *p_idx = idx;
  5148. if (hash_seen)
  5149. *p_exactness = INEXACT;
  5150. return result;
  5151. }
  5152. /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
  5153. * covers the parts of the rules that start at a potential point. The value
  5154. * of the digits up to the point have been parsed by the caller and are given
  5155. * in variable result. The content of *p_exactness indicates, whether a hash
  5156. * has already been seen in the digits before the point.
  5157. */
  5158. #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
  5159. static SCM
  5160. mem2decimal_from_point (SCM result, SCM mem,
  5161. unsigned int *p_idx, enum t_exactness *p_exactness)
  5162. {
  5163. unsigned int idx = *p_idx;
  5164. enum t_exactness x = *p_exactness;
  5165. size_t len = scm_i_string_length (mem);
  5166. if (idx == len)
  5167. return result;
  5168. if (scm_i_string_ref (mem, idx) == '.')
  5169. {
  5170. scm_t_bits shift = 1;
  5171. scm_t_bits add = 0;
  5172. unsigned int digit_value;
  5173. SCM big_shift = SCM_INUM1;
  5174. idx++;
  5175. while (idx != len)
  5176. {
  5177. scm_t_wchar c = scm_i_string_ref (mem, idx);
  5178. if (uc_is_property_decimal_digit ((scm_t_uint32) c))
  5179. {
  5180. if (x == INEXACT)
  5181. return SCM_BOOL_F;
  5182. else
  5183. digit_value = DIGIT2UINT (c);
  5184. }
  5185. else if (c == '#')
  5186. {
  5187. x = INEXACT;
  5188. digit_value = 0;
  5189. }
  5190. else
  5191. break;
  5192. idx++;
  5193. if (SCM_MOST_POSITIVE_FIXNUM / 10 < shift)
  5194. {
  5195. big_shift = scm_product (big_shift, SCM_I_MAKINUM (shift));
  5196. result = scm_product (result, SCM_I_MAKINUM (shift));
  5197. if (add > 0)
  5198. result = scm_sum (result, SCM_I_MAKINUM (add));
  5199. shift = 10;
  5200. add = digit_value;
  5201. }
  5202. else
  5203. {
  5204. shift = shift * 10;
  5205. add = add * 10 + digit_value;
  5206. }
  5207. };
  5208. if (add > 0)
  5209. {
  5210. big_shift = scm_product (big_shift, SCM_I_MAKINUM (shift));
  5211. result = scm_product (result, SCM_I_MAKINUM (shift));
  5212. result = scm_sum (result, SCM_I_MAKINUM (add));
  5213. }
  5214. result = scm_divide (result, big_shift);
  5215. /* We've seen a decimal point, thus the value is implicitly inexact. */
  5216. x = INEXACT;
  5217. }
  5218. if (idx != len)
  5219. {
  5220. int sign = 1;
  5221. unsigned int start;
  5222. scm_t_wchar c;
  5223. int exponent;
  5224. SCM e;
  5225. /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
  5226. switch (scm_i_string_ref (mem, idx))
  5227. {
  5228. case 'd': case 'D':
  5229. case 'e': case 'E':
  5230. case 'f': case 'F':
  5231. case 'l': case 'L':
  5232. case 's': case 'S':
  5233. idx++;
  5234. if (idx == len)
  5235. return SCM_BOOL_F;
  5236. start = idx;
  5237. c = scm_i_string_ref (mem, idx);
  5238. if (c == '-')
  5239. {
  5240. idx++;
  5241. if (idx == len)
  5242. return SCM_BOOL_F;
  5243. sign = -1;
  5244. c = scm_i_string_ref (mem, idx);
  5245. }
  5246. else if (c == '+')
  5247. {
  5248. idx++;
  5249. if (idx == len)
  5250. return SCM_BOOL_F;
  5251. sign = 1;
  5252. c = scm_i_string_ref (mem, idx);
  5253. }
  5254. else
  5255. sign = 1;
  5256. if (!uc_is_property_decimal_digit ((scm_t_uint32) c))
  5257. return SCM_BOOL_F;
  5258. idx++;
  5259. exponent = DIGIT2UINT (c);
  5260. while (idx != len)
  5261. {
  5262. scm_t_wchar c = scm_i_string_ref (mem, idx);
  5263. if (uc_is_property_decimal_digit ((scm_t_uint32) c))
  5264. {
  5265. idx++;
  5266. if (exponent <= SCM_MAXEXP)
  5267. exponent = exponent * 10 + DIGIT2UINT (c);
  5268. }
  5269. else
  5270. break;
  5271. }
  5272. if (exponent > SCM_MAXEXP)
  5273. {
  5274. size_t exp_len = idx - start;
  5275. SCM exp_string = scm_i_substring_copy (mem, start, start + exp_len);
  5276. SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED);
  5277. scm_out_of_range ("string->number", exp_num);
  5278. }
  5279. e = scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent));
  5280. if (sign == 1)
  5281. result = scm_product (result, e);
  5282. else
  5283. result = scm_divide (result, e);
  5284. /* We've seen an exponent, thus the value is implicitly inexact. */
  5285. x = INEXACT;
  5286. break;
  5287. default:
  5288. break;
  5289. }
  5290. }
  5291. *p_idx = idx;
  5292. if (x == INEXACT)
  5293. *p_exactness = x;
  5294. return result;
  5295. }
  5296. /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
  5297. static SCM
  5298. mem2ureal (SCM mem, unsigned int *p_idx,
  5299. unsigned int radix, enum t_exactness forced_x)
  5300. {
  5301. unsigned int idx = *p_idx;
  5302. SCM result;
  5303. size_t len = scm_i_string_length (mem);
  5304. /* Start off believing that the number will be exact. This changes
  5305. to INEXACT if we see a decimal point or a hash. */
  5306. enum t_exactness implicit_x = EXACT;
  5307. if (idx == len)
  5308. return SCM_BOOL_F;
  5309. if (idx+5 <= len && !scm_i_string_strcmp (mem, idx, "inf.0"))
  5310. {
  5311. *p_idx = idx+5;
  5312. return scm_inf ();
  5313. }
  5314. if (idx+4 < len && !scm_i_string_strcmp (mem, idx, "nan."))
  5315. {
  5316. /* Cobble up the fractional part. We might want to set the
  5317. NaN's mantissa from it. */
  5318. idx += 4;
  5319. if (!scm_is_eq (mem2uinteger (mem, &idx, 10, &implicit_x), SCM_INUM0))
  5320. {
  5321. #if SCM_ENABLE_DEPRECATED == 1
  5322. scm_c_issue_deprecation_warning
  5323. ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
  5324. #else
  5325. return SCM_BOOL_F;
  5326. #endif
  5327. }
  5328. *p_idx = idx;
  5329. return scm_nan ();
  5330. }
  5331. if (scm_i_string_ref (mem, idx) == '.')
  5332. {
  5333. if (radix != 10)
  5334. return SCM_BOOL_F;
  5335. else if (idx + 1 == len)
  5336. return SCM_BOOL_F;
  5337. else if (!uc_is_property_decimal_digit ((scm_t_uint32) scm_i_string_ref (mem, idx+1)))
  5338. return SCM_BOOL_F;
  5339. else
  5340. result = mem2decimal_from_point (SCM_INUM0, mem,
  5341. p_idx, &implicit_x);
  5342. }
  5343. else
  5344. {
  5345. SCM uinteger;
  5346. uinteger = mem2uinteger (mem, &idx, radix, &implicit_x);
  5347. if (scm_is_false (uinteger))
  5348. return SCM_BOOL_F;
  5349. if (idx == len)
  5350. result = uinteger;
  5351. else if (scm_i_string_ref (mem, idx) == '/')
  5352. {
  5353. SCM divisor;
  5354. idx++;
  5355. if (idx == len)
  5356. return SCM_BOOL_F;
  5357. divisor = mem2uinteger (mem, &idx, radix, &implicit_x);
  5358. if (scm_is_false (divisor))
  5359. return SCM_BOOL_F;
  5360. /* both are int/big here, I assume */
  5361. result = scm_i_make_ratio (uinteger, divisor);
  5362. }
  5363. else if (radix == 10)
  5364. {
  5365. result = mem2decimal_from_point (uinteger, mem, &idx, &implicit_x);
  5366. if (scm_is_false (result))
  5367. return SCM_BOOL_F;
  5368. }
  5369. else
  5370. result = uinteger;
  5371. *p_idx = idx;
  5372. }
  5373. switch (forced_x)
  5374. {
  5375. case EXACT:
  5376. if (SCM_INEXACTP (result))
  5377. return scm_inexact_to_exact (result);
  5378. else
  5379. return result;
  5380. case INEXACT:
  5381. if (SCM_INEXACTP (result))
  5382. return result;
  5383. else
  5384. return scm_exact_to_inexact (result);
  5385. case NO_EXACTNESS:
  5386. if (implicit_x == INEXACT)
  5387. {
  5388. if (SCM_INEXACTP (result))
  5389. return result;
  5390. else
  5391. return scm_exact_to_inexact (result);
  5392. }
  5393. else
  5394. return result;
  5395. }
  5396. /* We should never get here */
  5397. scm_syserror ("mem2ureal");
  5398. }
  5399. /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
  5400. static SCM
  5401. mem2complex (SCM mem, unsigned int idx,
  5402. unsigned int radix, enum t_exactness forced_x)
  5403. {
  5404. scm_t_wchar c;
  5405. int sign = 0;
  5406. SCM ureal;
  5407. size_t len = scm_i_string_length (mem);
  5408. if (idx == len)
  5409. return SCM_BOOL_F;
  5410. c = scm_i_string_ref (mem, idx);
  5411. if (c == '+')
  5412. {
  5413. idx++;
  5414. sign = 1;
  5415. }
  5416. else if (c == '-')
  5417. {
  5418. idx++;
  5419. sign = -1;
  5420. }
  5421. if (idx == len)
  5422. return SCM_BOOL_F;
  5423. ureal = mem2ureal (mem, &idx, radix, forced_x);
  5424. if (scm_is_false (ureal))
  5425. {
  5426. /* input must be either +i or -i */
  5427. if (sign == 0)
  5428. return SCM_BOOL_F;
  5429. if (scm_i_string_ref (mem, idx) == 'i'
  5430. || scm_i_string_ref (mem, idx) == 'I')
  5431. {
  5432. idx++;
  5433. if (idx != len)
  5434. return SCM_BOOL_F;
  5435. return scm_make_rectangular (SCM_INUM0, SCM_I_MAKINUM (sign));
  5436. }
  5437. else
  5438. return SCM_BOOL_F;
  5439. }
  5440. else
  5441. {
  5442. if (sign == -1 && scm_is_false (scm_nan_p (ureal)))
  5443. ureal = scm_difference (ureal, SCM_UNDEFINED);
  5444. if (idx == len)
  5445. return ureal;
  5446. c = scm_i_string_ref (mem, idx);
  5447. switch (c)
  5448. {
  5449. case 'i': case 'I':
  5450. /* either +<ureal>i or -<ureal>i */
  5451. idx++;
  5452. if (sign == 0)
  5453. return SCM_BOOL_F;
  5454. if (idx != len)
  5455. return SCM_BOOL_F;
  5456. return scm_make_rectangular (SCM_INUM0, ureal);
  5457. case '@':
  5458. /* polar input: <real>@<real>. */
  5459. idx++;
  5460. if (idx == len)
  5461. return SCM_BOOL_F;
  5462. else
  5463. {
  5464. int sign;
  5465. SCM angle;
  5466. SCM result;
  5467. c = scm_i_string_ref (mem, idx);
  5468. if (c == '+')
  5469. {
  5470. idx++;
  5471. if (idx == len)
  5472. return SCM_BOOL_F;
  5473. sign = 1;
  5474. }
  5475. else if (c == '-')
  5476. {
  5477. idx++;
  5478. if (idx == len)
  5479. return SCM_BOOL_F;
  5480. sign = -1;
  5481. }
  5482. else
  5483. sign = 1;
  5484. angle = mem2ureal (mem, &idx, radix, forced_x);
  5485. if (scm_is_false (angle))
  5486. return SCM_BOOL_F;
  5487. if (idx != len)
  5488. return SCM_BOOL_F;
  5489. if (sign == -1 && scm_is_false (scm_nan_p (ureal)))
  5490. angle = scm_difference (angle, SCM_UNDEFINED);
  5491. result = scm_make_polar (ureal, angle);
  5492. return result;
  5493. }
  5494. case '+':
  5495. case '-':
  5496. /* expecting input matching <real>[+-]<ureal>?i */
  5497. idx++;
  5498. if (idx == len)
  5499. return SCM_BOOL_F;
  5500. else
  5501. {
  5502. int sign = (c == '+') ? 1 : -1;
  5503. SCM imag = mem2ureal (mem, &idx, radix, forced_x);
  5504. if (scm_is_false (imag))
  5505. imag = SCM_I_MAKINUM (sign);
  5506. else if (sign == -1 && scm_is_false (scm_nan_p (imag)))
  5507. imag = scm_difference (imag, SCM_UNDEFINED);
  5508. if (idx == len)
  5509. return SCM_BOOL_F;
  5510. if (scm_i_string_ref (mem, idx) != 'i'
  5511. && scm_i_string_ref (mem, idx) != 'I')
  5512. return SCM_BOOL_F;
  5513. idx++;
  5514. if (idx != len)
  5515. return SCM_BOOL_F;
  5516. return scm_make_rectangular (ureal, imag);
  5517. }
  5518. default:
  5519. return SCM_BOOL_F;
  5520. }
  5521. }
  5522. }
  5523. /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
  5524. enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16};
  5525. SCM
  5526. scm_i_string_to_number (SCM mem, unsigned int default_radix)
  5527. {
  5528. unsigned int idx = 0;
  5529. unsigned int radix = NO_RADIX;
  5530. enum t_exactness forced_x = NO_EXACTNESS;
  5531. size_t len = scm_i_string_length (mem);
  5532. /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
  5533. while (idx + 2 < len && scm_i_string_ref (mem, idx) == '#')
  5534. {
  5535. switch (scm_i_string_ref (mem, idx + 1))
  5536. {
  5537. case 'b': case 'B':
  5538. if (radix != NO_RADIX)
  5539. return SCM_BOOL_F;
  5540. radix = DUAL;
  5541. break;
  5542. case 'd': case 'D':
  5543. if (radix != NO_RADIX)
  5544. return SCM_BOOL_F;
  5545. radix = DEC;
  5546. break;
  5547. case 'i': case 'I':
  5548. if (forced_x != NO_EXACTNESS)
  5549. return SCM_BOOL_F;
  5550. forced_x = INEXACT;
  5551. break;
  5552. case 'e': case 'E':
  5553. if (forced_x != NO_EXACTNESS)
  5554. return SCM_BOOL_F;
  5555. forced_x = EXACT;
  5556. break;
  5557. case 'o': case 'O':
  5558. if (radix != NO_RADIX)
  5559. return SCM_BOOL_F;
  5560. radix = OCT;
  5561. break;
  5562. case 'x': case 'X':
  5563. if (radix != NO_RADIX)
  5564. return SCM_BOOL_F;
  5565. radix = HEX;
  5566. break;
  5567. default:
  5568. return SCM_BOOL_F;
  5569. }
  5570. idx += 2;
  5571. }
  5572. /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
  5573. if (radix == NO_RADIX)
  5574. radix = default_radix;
  5575. return mem2complex (mem, idx, radix, forced_x);
  5576. }
  5577. SCM
  5578. scm_c_locale_stringn_to_number (const char* mem, size_t len,
  5579. unsigned int default_radix)
  5580. {
  5581. SCM str = scm_from_locale_stringn (mem, len);
  5582. return scm_i_string_to_number (str, default_radix);
  5583. }
  5584. SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
  5585. (SCM string, SCM radix),
  5586. "Return a number of the maximally precise representation\n"
  5587. "expressed by the given @var{string}. @var{radix} must be an\n"
  5588. "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
  5589. "is a default radix that may be overridden by an explicit radix\n"
  5590. "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
  5591. "supplied, then the default radix is 10. If string is not a\n"
  5592. "syntactically valid notation for a number, then\n"
  5593. "@code{string->number} returns @code{#f}.")
  5594. #define FUNC_NAME s_scm_string_to_number
  5595. {
  5596. SCM answer;
  5597. unsigned int base;
  5598. SCM_VALIDATE_STRING (1, string);
  5599. if (SCM_UNBNDP (radix))
  5600. base = 10;
  5601. else
  5602. base = scm_to_unsigned_integer (radix, 2, INT_MAX);
  5603. answer = scm_i_string_to_number (string, base);
  5604. scm_remember_upto_here_1 (string);
  5605. return answer;
  5606. }
  5607. #undef FUNC_NAME
  5608. /*** END strs->nums ***/
  5609. SCM_DEFINE (scm_number_p, "number?", 1, 0, 0,
  5610. (SCM x),
  5611. "Return @code{#t} if @var{x} is a number, @code{#f}\n"
  5612. "otherwise.")
  5613. #define FUNC_NAME s_scm_number_p
  5614. {
  5615. return scm_from_bool (SCM_NUMBERP (x));
  5616. }
  5617. #undef FUNC_NAME
  5618. SCM_DEFINE (scm_complex_p, "complex?", 1, 0, 0,
  5619. (SCM x),
  5620. "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
  5621. "otherwise. Note that the sets of real, rational and integer\n"
  5622. "values form subsets of the set of complex numbers, i. e. the\n"
  5623. "predicate will also be fulfilled if @var{x} is a real,\n"
  5624. "rational or integer number.")
  5625. #define FUNC_NAME s_scm_complex_p
  5626. {
  5627. /* all numbers are complex. */
  5628. return scm_number_p (x);
  5629. }
  5630. #undef FUNC_NAME
  5631. SCM_DEFINE (scm_real_p, "real?", 1, 0, 0,
  5632. (SCM x),
  5633. "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
  5634. "otherwise. Note that the set of integer values forms a subset of\n"
  5635. "the set of real numbers, i. e. the predicate will also be\n"
  5636. "fulfilled if @var{x} is an integer number.")
  5637. #define FUNC_NAME s_scm_real_p
  5638. {
  5639. return scm_from_bool
  5640. (SCM_I_INUMP (x) || SCM_REALP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x));
  5641. }
  5642. #undef FUNC_NAME
  5643. SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0,
  5644. (SCM x),
  5645. "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
  5646. "otherwise. Note that the set of integer values forms a subset of\n"
  5647. "the set of rational numbers, i. e. the predicate will also be\n"
  5648. "fulfilled if @var{x} is an integer number.")
  5649. #define FUNC_NAME s_scm_rational_p
  5650. {
  5651. if (SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))
  5652. return SCM_BOOL_T;
  5653. else if (SCM_REALP (x))
  5654. /* due to their limited precision, finite floating point numbers are
  5655. rational as well. (finite means neither infinity nor a NaN) */
  5656. return scm_from_bool (DOUBLE_IS_FINITE (SCM_REAL_VALUE (x)));
  5657. else
  5658. return SCM_BOOL_F;
  5659. }
  5660. #undef FUNC_NAME
  5661. SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
  5662. (SCM x),
  5663. "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
  5664. "else.")
  5665. #define FUNC_NAME s_scm_integer_p
  5666. {
  5667. if (SCM_I_INUMP (x) || SCM_BIGP (x))
  5668. return SCM_BOOL_T;
  5669. else if (SCM_REALP (x))
  5670. {
  5671. double val = SCM_REAL_VALUE (x);
  5672. return scm_from_bool (!isinf (val) && (val == floor (val)));
  5673. }
  5674. else
  5675. return SCM_BOOL_F;
  5676. }
  5677. #undef FUNC_NAME
  5678. SCM scm_i_num_eq_p (SCM, SCM, SCM);
  5679. SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1,
  5680. (SCM x, SCM y, SCM rest),
  5681. "Return @code{#t} if all parameters are numerically equal.")
  5682. #define FUNC_NAME s_scm_i_num_eq_p
  5683. {
  5684. if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
  5685. return SCM_BOOL_T;
  5686. while (!scm_is_null (rest))
  5687. {
  5688. if (scm_is_false (scm_num_eq_p (x, y)))
  5689. return SCM_BOOL_F;
  5690. x = y;
  5691. y = scm_car (rest);
  5692. rest = scm_cdr (rest);
  5693. }
  5694. return scm_num_eq_p (x, y);
  5695. }
  5696. #undef FUNC_NAME
  5697. SCM
  5698. scm_num_eq_p (SCM x, SCM y)
  5699. {
  5700. again:
  5701. if (SCM_I_INUMP (x))
  5702. {
  5703. scm_t_signed_bits xx = SCM_I_INUM (x);
  5704. if (SCM_I_INUMP (y))
  5705. {
  5706. scm_t_signed_bits yy = SCM_I_INUM (y);
  5707. return scm_from_bool (xx == yy);
  5708. }
  5709. else if (SCM_BIGP (y))
  5710. return SCM_BOOL_F;
  5711. else if (SCM_REALP (y))
  5712. {
  5713. /* On a 32-bit system an inum fits a double, we can cast the inum
  5714. to a double and compare.
  5715. But on a 64-bit system an inum is bigger than a double and
  5716. casting it to a double (call that dxx) will round. dxx is at
  5717. worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
  5718. an integer and fits a long. So we cast yy to a long and
  5719. compare with plain xx.
  5720. An alternative (for any size system actually) would be to check
  5721. yy is an integer (with floor) and is in range of an inum
  5722. (compare against appropriate powers of 2) then test
  5723. xx==(scm_t_signed_bits)yy. It's just a matter of which
  5724. casts/comparisons might be fastest or easiest for the cpu. */
  5725. double yy = SCM_REAL_VALUE (y);
  5726. return scm_from_bool ((double) xx == yy
  5727. && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
  5728. || xx == (scm_t_signed_bits) yy));
  5729. }
  5730. else if (SCM_COMPLEXP (y))
  5731. return scm_from_bool (((double) xx == SCM_COMPLEX_REAL (y))
  5732. && (0.0 == SCM_COMPLEX_IMAG (y)));
  5733. else if (SCM_FRACTIONP (y))
  5734. return SCM_BOOL_F;
  5735. else
  5736. return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
  5737. s_scm_i_num_eq_p);
  5738. }
  5739. else if (SCM_BIGP (x))
  5740. {
  5741. if (SCM_I_INUMP (y))
  5742. return SCM_BOOL_F;
  5743. else if (SCM_BIGP (y))
  5744. {
  5745. int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  5746. scm_remember_upto_here_2 (x, y);
  5747. return scm_from_bool (0 == cmp);
  5748. }
  5749. else if (SCM_REALP (y))
  5750. {
  5751. int cmp;
  5752. if (isnan (SCM_REAL_VALUE (y)))
  5753. return SCM_BOOL_F;
  5754. cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
  5755. scm_remember_upto_here_1 (x);
  5756. return scm_from_bool (0 == cmp);
  5757. }
  5758. else if (SCM_COMPLEXP (y))
  5759. {
  5760. int cmp;
  5761. if (0.0 != SCM_COMPLEX_IMAG (y))
  5762. return SCM_BOOL_F;
  5763. if (isnan (SCM_COMPLEX_REAL (y)))
  5764. return SCM_BOOL_F;
  5765. cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y));
  5766. scm_remember_upto_here_1 (x);
  5767. return scm_from_bool (0 == cmp);
  5768. }
  5769. else if (SCM_FRACTIONP (y))
  5770. return SCM_BOOL_F;
  5771. else
  5772. return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
  5773. s_scm_i_num_eq_p);
  5774. }
  5775. else if (SCM_REALP (x))
  5776. {
  5777. double xx = SCM_REAL_VALUE (x);
  5778. if (SCM_I_INUMP (y))
  5779. {
  5780. /* see comments with inum/real above */
  5781. scm_t_signed_bits yy = SCM_I_INUM (y);
  5782. return scm_from_bool (xx == (double) yy
  5783. && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
  5784. || (scm_t_signed_bits) xx == yy));
  5785. }
  5786. else if (SCM_BIGP (y))
  5787. {
  5788. int cmp;
  5789. if (isnan (SCM_REAL_VALUE (x)))
  5790. return SCM_BOOL_F;
  5791. cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
  5792. scm_remember_upto_here_1 (y);
  5793. return scm_from_bool (0 == cmp);
  5794. }
  5795. else if (SCM_REALP (y))
  5796. return scm_from_bool (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
  5797. else if (SCM_COMPLEXP (y))
  5798. return scm_from_bool ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y))
  5799. && (0.0 == SCM_COMPLEX_IMAG (y)));
  5800. else if (SCM_FRACTIONP (y))
  5801. {
  5802. double xx = SCM_REAL_VALUE (x);
  5803. if (isnan (xx))
  5804. return SCM_BOOL_F;
  5805. if (isinf (xx))
  5806. return scm_from_bool (xx < 0.0);
  5807. x = scm_inexact_to_exact (x); /* with x as frac or int */
  5808. goto again;
  5809. }
  5810. else
  5811. return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
  5812. s_scm_i_num_eq_p);
  5813. }
  5814. else if (SCM_COMPLEXP (x))
  5815. {
  5816. if (SCM_I_INUMP (y))
  5817. return scm_from_bool ((SCM_COMPLEX_REAL (x) == (double) SCM_I_INUM (y))
  5818. && (SCM_COMPLEX_IMAG (x) == 0.0));
  5819. else if (SCM_BIGP (y))
  5820. {
  5821. int cmp;
  5822. if (0.0 != SCM_COMPLEX_IMAG (x))
  5823. return SCM_BOOL_F;
  5824. if (isnan (SCM_COMPLEX_REAL (x)))
  5825. return SCM_BOOL_F;
  5826. cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x));
  5827. scm_remember_upto_here_1 (y);
  5828. return scm_from_bool (0 == cmp);
  5829. }
  5830. else if (SCM_REALP (y))
  5831. return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y))
  5832. && (SCM_COMPLEX_IMAG (x) == 0.0));
  5833. else if (SCM_COMPLEXP (y))
  5834. return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y))
  5835. && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)));
  5836. else if (SCM_FRACTIONP (y))
  5837. {
  5838. double xx;
  5839. if (SCM_COMPLEX_IMAG (x) != 0.0)
  5840. return SCM_BOOL_F;
  5841. xx = SCM_COMPLEX_REAL (x);
  5842. if (isnan (xx))
  5843. return SCM_BOOL_F;
  5844. if (isinf (xx))
  5845. return scm_from_bool (xx < 0.0);
  5846. x = scm_inexact_to_exact (x); /* with x as frac or int */
  5847. goto again;
  5848. }
  5849. else
  5850. return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
  5851. s_scm_i_num_eq_p);
  5852. }
  5853. else if (SCM_FRACTIONP (x))
  5854. {
  5855. if (SCM_I_INUMP (y))
  5856. return SCM_BOOL_F;
  5857. else if (SCM_BIGP (y))
  5858. return SCM_BOOL_F;
  5859. else if (SCM_REALP (y))
  5860. {
  5861. double yy = SCM_REAL_VALUE (y);
  5862. if (isnan (yy))
  5863. return SCM_BOOL_F;
  5864. if (isinf (yy))
  5865. return scm_from_bool (0.0 < yy);
  5866. y = scm_inexact_to_exact (y); /* with y as frac or int */
  5867. goto again;
  5868. }
  5869. else if (SCM_COMPLEXP (y))
  5870. {
  5871. double yy;
  5872. if (SCM_COMPLEX_IMAG (y) != 0.0)
  5873. return SCM_BOOL_F;
  5874. yy = SCM_COMPLEX_REAL (y);
  5875. if (isnan (yy))
  5876. return SCM_BOOL_F;
  5877. if (isinf (yy))
  5878. return scm_from_bool (0.0 < yy);
  5879. y = scm_inexact_to_exact (y); /* with y as frac or int */
  5880. goto again;
  5881. }
  5882. else if (SCM_FRACTIONP (y))
  5883. return scm_i_fraction_equalp (x, y);
  5884. else
  5885. return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
  5886. s_scm_i_num_eq_p);
  5887. }
  5888. else
  5889. return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1,
  5890. s_scm_i_num_eq_p);
  5891. }
  5892. /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
  5893. done are good for inums, but for bignums an answer can almost always be
  5894. had by just examining a few high bits of the operands, as done by GMP in
  5895. mpq_cmp. flonum/frac compares likewise, but with the slight complication
  5896. of the float exponent to take into account. */
  5897. SCM_INTERNAL SCM scm_i_num_less_p (SCM, SCM, SCM);
  5898. SCM_PRIMITIVE_GENERIC (scm_i_num_less_p, "<", 0, 2, 1,
  5899. (SCM x, SCM y, SCM rest),
  5900. "Return @code{#t} if the list of parameters is monotonically\n"
  5901. "increasing.")
  5902. #define FUNC_NAME s_scm_i_num_less_p
  5903. {
  5904. if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
  5905. return SCM_BOOL_T;
  5906. while (!scm_is_null (rest))
  5907. {
  5908. if (scm_is_false (scm_less_p (x, y)))
  5909. return SCM_BOOL_F;
  5910. x = y;
  5911. y = scm_car (rest);
  5912. rest = scm_cdr (rest);
  5913. }
  5914. return scm_less_p (x, y);
  5915. }
  5916. #undef FUNC_NAME
  5917. SCM
  5918. scm_less_p (SCM x, SCM y)
  5919. {
  5920. again:
  5921. if (SCM_I_INUMP (x))
  5922. {
  5923. scm_t_inum xx = SCM_I_INUM (x);
  5924. if (SCM_I_INUMP (y))
  5925. {
  5926. scm_t_inum yy = SCM_I_INUM (y);
  5927. return scm_from_bool (xx < yy);
  5928. }
  5929. else if (SCM_BIGP (y))
  5930. {
  5931. int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
  5932. scm_remember_upto_here_1 (y);
  5933. return scm_from_bool (sgn > 0);
  5934. }
  5935. else if (SCM_REALP (y))
  5936. return scm_from_bool ((double) xx < SCM_REAL_VALUE (y));
  5937. else if (SCM_FRACTIONP (y))
  5938. {
  5939. /* "x < a/b" becomes "x*b < a" */
  5940. int_frac:
  5941. x = scm_product (x, SCM_FRACTION_DENOMINATOR (y));
  5942. y = SCM_FRACTION_NUMERATOR (y);
  5943. goto again;
  5944. }
  5945. else
  5946. return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
  5947. s_scm_i_num_less_p);
  5948. }
  5949. else if (SCM_BIGP (x))
  5950. {
  5951. if (SCM_I_INUMP (y))
  5952. {
  5953. int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
  5954. scm_remember_upto_here_1 (x);
  5955. return scm_from_bool (sgn < 0);
  5956. }
  5957. else if (SCM_BIGP (y))
  5958. {
  5959. int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  5960. scm_remember_upto_here_2 (x, y);
  5961. return scm_from_bool (cmp < 0);
  5962. }
  5963. else if (SCM_REALP (y))
  5964. {
  5965. int cmp;
  5966. if (isnan (SCM_REAL_VALUE (y)))
  5967. return SCM_BOOL_F;
  5968. cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
  5969. scm_remember_upto_here_1 (x);
  5970. return scm_from_bool (cmp < 0);
  5971. }
  5972. else if (SCM_FRACTIONP (y))
  5973. goto int_frac;
  5974. else
  5975. return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
  5976. s_scm_i_num_less_p);
  5977. }
  5978. else if (SCM_REALP (x))
  5979. {
  5980. if (SCM_I_INUMP (y))
  5981. return scm_from_bool (SCM_REAL_VALUE (x) < (double) SCM_I_INUM (y));
  5982. else if (SCM_BIGP (y))
  5983. {
  5984. int cmp;
  5985. if (isnan (SCM_REAL_VALUE (x)))
  5986. return SCM_BOOL_F;
  5987. cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
  5988. scm_remember_upto_here_1 (y);
  5989. return scm_from_bool (cmp > 0);
  5990. }
  5991. else if (SCM_REALP (y))
  5992. return scm_from_bool (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y));
  5993. else if (SCM_FRACTIONP (y))
  5994. {
  5995. double xx = SCM_REAL_VALUE (x);
  5996. if (isnan (xx))
  5997. return SCM_BOOL_F;
  5998. if (isinf (xx))
  5999. return scm_from_bool (xx < 0.0);
  6000. x = scm_inexact_to_exact (x); /* with x as frac or int */
  6001. goto again;
  6002. }
  6003. else
  6004. return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
  6005. s_scm_i_num_less_p);
  6006. }
  6007. else if (SCM_FRACTIONP (x))
  6008. {
  6009. if (SCM_I_INUMP (y) || SCM_BIGP (y))
  6010. {
  6011. /* "a/b < y" becomes "a < y*b" */
  6012. y = scm_product (y, SCM_FRACTION_DENOMINATOR (x));
  6013. x = SCM_FRACTION_NUMERATOR (x);
  6014. goto again;
  6015. }
  6016. else if (SCM_REALP (y))
  6017. {
  6018. double yy = SCM_REAL_VALUE (y);
  6019. if (isnan (yy))
  6020. return SCM_BOOL_F;
  6021. if (isinf (yy))
  6022. return scm_from_bool (0.0 < yy);
  6023. y = scm_inexact_to_exact (y); /* with y as frac or int */
  6024. goto again;
  6025. }
  6026. else if (SCM_FRACTIONP (y))
  6027. {
  6028. /* "a/b < c/d" becomes "a*d < c*b" */
  6029. SCM new_x = scm_product (SCM_FRACTION_NUMERATOR (x),
  6030. SCM_FRACTION_DENOMINATOR (y));
  6031. SCM new_y = scm_product (SCM_FRACTION_NUMERATOR (y),
  6032. SCM_FRACTION_DENOMINATOR (x));
  6033. x = new_x;
  6034. y = new_y;
  6035. goto again;
  6036. }
  6037. else
  6038. return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
  6039. s_scm_i_num_less_p);
  6040. }
  6041. else
  6042. return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARG1,
  6043. s_scm_i_num_less_p);
  6044. }
  6045. SCM scm_i_num_gr_p (SCM, SCM, SCM);
  6046. SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p, ">", 0, 2, 1,
  6047. (SCM x, SCM y, SCM rest),
  6048. "Return @code{#t} if the list of parameters is monotonically\n"
  6049. "decreasing.")
  6050. #define FUNC_NAME s_scm_i_num_gr_p
  6051. {
  6052. if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
  6053. return SCM_BOOL_T;
  6054. while (!scm_is_null (rest))
  6055. {
  6056. if (scm_is_false (scm_gr_p (x, y)))
  6057. return SCM_BOOL_F;
  6058. x = y;
  6059. y = scm_car (rest);
  6060. rest = scm_cdr (rest);
  6061. }
  6062. return scm_gr_p (x, y);
  6063. }
  6064. #undef FUNC_NAME
  6065. #define FUNC_NAME s_scm_i_num_gr_p
  6066. SCM
  6067. scm_gr_p (SCM x, SCM y)
  6068. {
  6069. if (!SCM_NUMBERP (x))
  6070. return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME);
  6071. else if (!SCM_NUMBERP (y))
  6072. return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
  6073. else
  6074. return scm_less_p (y, x);
  6075. }
  6076. #undef FUNC_NAME
  6077. SCM scm_i_num_leq_p (SCM, SCM, SCM);
  6078. SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p, "<=", 0, 2, 1,
  6079. (SCM x, SCM y, SCM rest),
  6080. "Return @code{#t} if the list of parameters is monotonically\n"
  6081. "non-decreasing.")
  6082. #define FUNC_NAME s_scm_i_num_leq_p
  6083. {
  6084. if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
  6085. return SCM_BOOL_T;
  6086. while (!scm_is_null (rest))
  6087. {
  6088. if (scm_is_false (scm_leq_p (x, y)))
  6089. return SCM_BOOL_F;
  6090. x = y;
  6091. y = scm_car (rest);
  6092. rest = scm_cdr (rest);
  6093. }
  6094. return scm_leq_p (x, y);
  6095. }
  6096. #undef FUNC_NAME
  6097. #define FUNC_NAME s_scm_i_num_leq_p
  6098. SCM
  6099. scm_leq_p (SCM x, SCM y)
  6100. {
  6101. if (!SCM_NUMBERP (x))
  6102. return scm_wta_dispatch_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME);
  6103. else if (!SCM_NUMBERP (y))
  6104. return scm_wta_dispatch_2 (g_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME);
  6105. else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
  6106. return SCM_BOOL_F;
  6107. else
  6108. return scm_not (scm_less_p (y, x));
  6109. }
  6110. #undef FUNC_NAME
  6111. SCM scm_i_num_geq_p (SCM, SCM, SCM);
  6112. SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p, ">=", 0, 2, 1,
  6113. (SCM x, SCM y, SCM rest),
  6114. "Return @code{#t} if the list of parameters is monotonically\n"
  6115. "non-increasing.")
  6116. #define FUNC_NAME s_scm_i_num_geq_p
  6117. {
  6118. if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
  6119. return SCM_BOOL_T;
  6120. while (!scm_is_null (rest))
  6121. {
  6122. if (scm_is_false (scm_geq_p (x, y)))
  6123. return SCM_BOOL_F;
  6124. x = y;
  6125. y = scm_car (rest);
  6126. rest = scm_cdr (rest);
  6127. }
  6128. return scm_geq_p (x, y);
  6129. }
  6130. #undef FUNC_NAME
  6131. #define FUNC_NAME s_scm_i_num_geq_p
  6132. SCM
  6133. scm_geq_p (SCM x, SCM y)
  6134. {
  6135. if (!SCM_NUMBERP (x))
  6136. return scm_wta_dispatch_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME);
  6137. else if (!SCM_NUMBERP (y))
  6138. return scm_wta_dispatch_2 (g_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME);
  6139. else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
  6140. return SCM_BOOL_F;
  6141. else
  6142. return scm_not (scm_less_p (x, y));
  6143. }
  6144. #undef FUNC_NAME
  6145. SCM_PRIMITIVE_GENERIC (scm_zero_p, "zero?", 1, 0, 0,
  6146. (SCM z),
  6147. "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
  6148. "zero.")
  6149. #define FUNC_NAME s_scm_zero_p
  6150. {
  6151. if (SCM_I_INUMP (z))
  6152. return scm_from_bool (scm_is_eq (z, SCM_INUM0));
  6153. else if (SCM_BIGP (z))
  6154. return SCM_BOOL_F;
  6155. else if (SCM_REALP (z))
  6156. return scm_from_bool (SCM_REAL_VALUE (z) == 0.0);
  6157. else if (SCM_COMPLEXP (z))
  6158. return scm_from_bool (SCM_COMPLEX_REAL (z) == 0.0
  6159. && SCM_COMPLEX_IMAG (z) == 0.0);
  6160. else if (SCM_FRACTIONP (z))
  6161. return SCM_BOOL_F;
  6162. else
  6163. return scm_wta_dispatch_1 (g_scm_zero_p, z, SCM_ARG1, s_scm_zero_p);
  6164. }
  6165. #undef FUNC_NAME
  6166. SCM_PRIMITIVE_GENERIC (scm_positive_p, "positive?", 1, 0, 0,
  6167. (SCM x),
  6168. "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
  6169. "zero.")
  6170. #define FUNC_NAME s_scm_positive_p
  6171. {
  6172. if (SCM_I_INUMP (x))
  6173. return scm_from_bool (SCM_I_INUM (x) > 0);
  6174. else if (SCM_BIGP (x))
  6175. {
  6176. int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
  6177. scm_remember_upto_here_1 (x);
  6178. return scm_from_bool (sgn > 0);
  6179. }
  6180. else if (SCM_REALP (x))
  6181. return scm_from_bool(SCM_REAL_VALUE (x) > 0.0);
  6182. else if (SCM_FRACTIONP (x))
  6183. return scm_positive_p (SCM_FRACTION_NUMERATOR (x));
  6184. else
  6185. return scm_wta_dispatch_1 (g_scm_positive_p, x, SCM_ARG1, s_scm_positive_p);
  6186. }
  6187. #undef FUNC_NAME
  6188. SCM_PRIMITIVE_GENERIC (scm_negative_p, "negative?", 1, 0, 0,
  6189. (SCM x),
  6190. "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
  6191. "zero.")
  6192. #define FUNC_NAME s_scm_negative_p
  6193. {
  6194. if (SCM_I_INUMP (x))
  6195. return scm_from_bool (SCM_I_INUM (x) < 0);
  6196. else if (SCM_BIGP (x))
  6197. {
  6198. int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
  6199. scm_remember_upto_here_1 (x);
  6200. return scm_from_bool (sgn < 0);
  6201. }
  6202. else if (SCM_REALP (x))
  6203. return scm_from_bool(SCM_REAL_VALUE (x) < 0.0);
  6204. else if (SCM_FRACTIONP (x))
  6205. return scm_negative_p (SCM_FRACTION_NUMERATOR (x));
  6206. else
  6207. return scm_wta_dispatch_1 (g_scm_negative_p, x, SCM_ARG1, s_scm_negative_p);
  6208. }
  6209. #undef FUNC_NAME
  6210. /* scm_min and scm_max return an inexact when either argument is inexact, as
  6211. required by r5rs. On that basis, for exact/inexact combinations the
  6212. exact is converted to inexact to compare and possibly return. This is
  6213. unlike scm_less_p above which takes some trouble to preserve all bits in
  6214. its test, such trouble is not required for min and max. */
  6215. SCM_PRIMITIVE_GENERIC (scm_i_max, "max", 0, 2, 1,
  6216. (SCM x, SCM y, SCM rest),
  6217. "Return the maximum of all parameter values.")
  6218. #define FUNC_NAME s_scm_i_max
  6219. {
  6220. while (!scm_is_null (rest))
  6221. { x = scm_max (x, y);
  6222. y = scm_car (rest);
  6223. rest = scm_cdr (rest);
  6224. }
  6225. return scm_max (x, y);
  6226. }
  6227. #undef FUNC_NAME
  6228. #define s_max s_scm_i_max
  6229. #define g_max g_scm_i_max
  6230. SCM
  6231. scm_max (SCM x, SCM y)
  6232. {
  6233. if (SCM_UNBNDP (y))
  6234. {
  6235. if (SCM_UNBNDP (x))
  6236. return scm_wta_dispatch_0 (g_max, s_max);
  6237. else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
  6238. return x;
  6239. else
  6240. return scm_wta_dispatch_1 (g_max, x, SCM_ARG1, s_max);
  6241. }
  6242. if (SCM_I_INUMP (x))
  6243. {
  6244. scm_t_inum xx = SCM_I_INUM (x);
  6245. if (SCM_I_INUMP (y))
  6246. {
  6247. scm_t_inum yy = SCM_I_INUM (y);
  6248. return (xx < yy) ? y : x;
  6249. }
  6250. else if (SCM_BIGP (y))
  6251. {
  6252. int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
  6253. scm_remember_upto_here_1 (y);
  6254. return (sgn < 0) ? x : y;
  6255. }
  6256. else if (SCM_REALP (y))
  6257. {
  6258. double xxd = xx;
  6259. double yyd = SCM_REAL_VALUE (y);
  6260. if (xxd > yyd)
  6261. return scm_from_double (xxd);
  6262. /* If y is a NaN, then "==" is false and we return the NaN */
  6263. else if (SCM_LIKELY (!(xxd == yyd)))
  6264. return y;
  6265. /* Handle signed zeroes properly */
  6266. else if (xx == 0)
  6267. return flo0;
  6268. else
  6269. return y;
  6270. }
  6271. else if (SCM_FRACTIONP (y))
  6272. {
  6273. use_less:
  6274. return (scm_is_false (scm_less_p (x, y)) ? x : y);
  6275. }
  6276. else
  6277. return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
  6278. }
  6279. else if (SCM_BIGP (x))
  6280. {
  6281. if (SCM_I_INUMP (y))
  6282. {
  6283. int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
  6284. scm_remember_upto_here_1 (x);
  6285. return (sgn < 0) ? y : x;
  6286. }
  6287. else if (SCM_BIGP (y))
  6288. {
  6289. int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  6290. scm_remember_upto_here_2 (x, y);
  6291. return (cmp > 0) ? x : y;
  6292. }
  6293. else if (SCM_REALP (y))
  6294. {
  6295. /* if y==NaN then xx>yy is false, so we return the NaN y */
  6296. double xx, yy;
  6297. big_real:
  6298. xx = scm_i_big2dbl (x);
  6299. yy = SCM_REAL_VALUE (y);
  6300. return (xx > yy ? scm_from_double (xx) : y);
  6301. }
  6302. else if (SCM_FRACTIONP (y))
  6303. {
  6304. goto use_less;
  6305. }
  6306. else
  6307. return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
  6308. }
  6309. else if (SCM_REALP (x))
  6310. {
  6311. if (SCM_I_INUMP (y))
  6312. {
  6313. scm_t_inum yy = SCM_I_INUM (y);
  6314. double xxd = SCM_REAL_VALUE (x);
  6315. double yyd = yy;
  6316. if (yyd > xxd)
  6317. return scm_from_double (yyd);
  6318. /* If x is a NaN, then "==" is false and we return the NaN */
  6319. else if (SCM_LIKELY (!(xxd == yyd)))
  6320. return x;
  6321. /* Handle signed zeroes properly */
  6322. else if (yy == 0)
  6323. return flo0;
  6324. else
  6325. return x;
  6326. }
  6327. else if (SCM_BIGP (y))
  6328. {
  6329. SCM_SWAP (x, y);
  6330. goto big_real;
  6331. }
  6332. else if (SCM_REALP (y))
  6333. {
  6334. double xx = SCM_REAL_VALUE (x);
  6335. double yy = SCM_REAL_VALUE (y);
  6336. /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
  6337. if (xx > yy)
  6338. return x;
  6339. else if (SCM_LIKELY (xx < yy))
  6340. return y;
  6341. /* If neither (xx > yy) nor (xx < yy), then
  6342. either they're equal or one is a NaN */
  6343. else if (SCM_UNLIKELY (isnan (xx)))
  6344. return DOUBLE_IS_POSITIVE_INFINITY (yy) ? y : x;
  6345. else if (SCM_UNLIKELY (isnan (yy)))
  6346. return DOUBLE_IS_POSITIVE_INFINITY (xx) ? x : y;
  6347. /* xx == yy, but handle signed zeroes properly */
  6348. else if (double_is_non_negative_zero (yy))
  6349. return y;
  6350. else
  6351. return x;
  6352. }
  6353. else if (SCM_FRACTIONP (y))
  6354. {
  6355. double yy = scm_i_fraction2double (y);
  6356. double xx = SCM_REAL_VALUE (x);
  6357. return (xx < yy) ? scm_from_double (yy) : x;
  6358. }
  6359. else
  6360. return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
  6361. }
  6362. else if (SCM_FRACTIONP (x))
  6363. {
  6364. if (SCM_I_INUMP (y))
  6365. {
  6366. goto use_less;
  6367. }
  6368. else if (SCM_BIGP (y))
  6369. {
  6370. goto use_less;
  6371. }
  6372. else if (SCM_REALP (y))
  6373. {
  6374. double xx = scm_i_fraction2double (x);
  6375. /* if y==NaN then ">" is false, so we return the NaN y */
  6376. return (xx > SCM_REAL_VALUE (y)) ? scm_from_double (xx) : y;
  6377. }
  6378. else if (SCM_FRACTIONP (y))
  6379. {
  6380. goto use_less;
  6381. }
  6382. else
  6383. return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
  6384. }
  6385. else
  6386. return scm_wta_dispatch_2 (g_max, x, y, SCM_ARG1, s_max);
  6387. }
  6388. SCM_PRIMITIVE_GENERIC (scm_i_min, "min", 0, 2, 1,
  6389. (SCM x, SCM y, SCM rest),
  6390. "Return the minimum of all parameter values.")
  6391. #define FUNC_NAME s_scm_i_min
  6392. {
  6393. while (!scm_is_null (rest))
  6394. { x = scm_min (x, y);
  6395. y = scm_car (rest);
  6396. rest = scm_cdr (rest);
  6397. }
  6398. return scm_min (x, y);
  6399. }
  6400. #undef FUNC_NAME
  6401. #define s_min s_scm_i_min
  6402. #define g_min g_scm_i_min
  6403. SCM
  6404. scm_min (SCM x, SCM y)
  6405. {
  6406. if (SCM_UNBNDP (y))
  6407. {
  6408. if (SCM_UNBNDP (x))
  6409. return scm_wta_dispatch_0 (g_min, s_min);
  6410. else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
  6411. return x;
  6412. else
  6413. return scm_wta_dispatch_1 (g_min, x, SCM_ARG1, s_min);
  6414. }
  6415. if (SCM_I_INUMP (x))
  6416. {
  6417. scm_t_inum xx = SCM_I_INUM (x);
  6418. if (SCM_I_INUMP (y))
  6419. {
  6420. scm_t_inum yy = SCM_I_INUM (y);
  6421. return (xx < yy) ? x : y;
  6422. }
  6423. else if (SCM_BIGP (y))
  6424. {
  6425. int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
  6426. scm_remember_upto_here_1 (y);
  6427. return (sgn < 0) ? y : x;
  6428. }
  6429. else if (SCM_REALP (y))
  6430. {
  6431. double z = xx;
  6432. /* if y==NaN then "<" is false and we return NaN */
  6433. return (z < SCM_REAL_VALUE (y)) ? scm_from_double (z) : y;
  6434. }
  6435. else if (SCM_FRACTIONP (y))
  6436. {
  6437. use_less:
  6438. return (scm_is_false (scm_less_p (x, y)) ? y : x);
  6439. }
  6440. else
  6441. return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
  6442. }
  6443. else if (SCM_BIGP (x))
  6444. {
  6445. if (SCM_I_INUMP (y))
  6446. {
  6447. int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
  6448. scm_remember_upto_here_1 (x);
  6449. return (sgn < 0) ? x : y;
  6450. }
  6451. else if (SCM_BIGP (y))
  6452. {
  6453. int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
  6454. scm_remember_upto_here_2 (x, y);
  6455. return (cmp > 0) ? y : x;
  6456. }
  6457. else if (SCM_REALP (y))
  6458. {
  6459. /* if y==NaN then xx<yy is false, so we return the NaN y */
  6460. double xx, yy;
  6461. big_real:
  6462. xx = scm_i_big2dbl (x);
  6463. yy = SCM_REAL_VALUE (y);
  6464. return (xx < yy ? scm_from_double (xx) : y);
  6465. }
  6466. else if (SCM_FRACTIONP (y))
  6467. {
  6468. goto use_less;
  6469. }
  6470. else
  6471. return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
  6472. }
  6473. else if (SCM_REALP (x))
  6474. {
  6475. if (SCM_I_INUMP (y))
  6476. {
  6477. double z = SCM_I_INUM (y);
  6478. /* if x==NaN then "<" is false and we return NaN */
  6479. return (z < SCM_REAL_VALUE (x)) ? scm_from_double (z) : x;
  6480. }
  6481. else if (SCM_BIGP (y))
  6482. {
  6483. SCM_SWAP (x, y);
  6484. goto big_real;
  6485. }
  6486. else if (SCM_REALP (y))
  6487. {
  6488. double xx = SCM_REAL_VALUE (x);
  6489. double yy = SCM_REAL_VALUE (y);
  6490. /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
  6491. if (xx < yy)
  6492. return x;
  6493. else if (SCM_LIKELY (xx > yy))
  6494. return y;
  6495. /* If neither (xx < yy) nor (xx > yy), then
  6496. either they're equal or one is a NaN */
  6497. else if (SCM_UNLIKELY (isnan (xx)))
  6498. return DOUBLE_IS_NEGATIVE_INFINITY (yy) ? y : x;
  6499. else if (SCM_UNLIKELY (isnan (yy)))
  6500. return DOUBLE_IS_NEGATIVE_INFINITY (xx) ? x : y;
  6501. /* xx == yy, but handle signed zeroes properly */
  6502. else if (double_is_non_negative_zero (xx))
  6503. return y;
  6504. else
  6505. return x;
  6506. }
  6507. else if (SCM_FRACTIONP (y))
  6508. {
  6509. double yy = scm_i_fraction2double (y);
  6510. double xx = SCM_REAL_VALUE (x);
  6511. return (yy < xx) ? scm_from_double (yy) : x;
  6512. }
  6513. else
  6514. return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
  6515. }
  6516. else if (SCM_FRACTIONP (x))
  6517. {
  6518. if (SCM_I_INUMP (y))
  6519. {
  6520. goto use_less;
  6521. }
  6522. else if (SCM_BIGP (y))
  6523. {
  6524. goto use_less;
  6525. }
  6526. else if (SCM_REALP (y))
  6527. {
  6528. double xx = scm_i_fraction2double (x);
  6529. /* if y==NaN then "<" is false, so we return the NaN y */
  6530. return (xx < SCM_REAL_VALUE (y)) ? scm_from_double (xx) : y;
  6531. }
  6532. else if (SCM_FRACTIONP (y))
  6533. {
  6534. goto use_less;
  6535. }
  6536. else
  6537. return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
  6538. }
  6539. else
  6540. return scm_wta_dispatch_2 (g_min, x, y, SCM_ARG1, s_min);
  6541. }
  6542. SCM_PRIMITIVE_GENERIC (scm_i_sum, "+", 0, 2, 1,
  6543. (SCM x, SCM y, SCM rest),
  6544. "Return the sum of all parameter values. Return 0 if called without\n"
  6545. "any parameters." )
  6546. #define FUNC_NAME s_scm_i_sum
  6547. {
  6548. while (!scm_is_null (rest))
  6549. { x = scm_sum (x, y);
  6550. y = scm_car (rest);
  6551. rest = scm_cdr (rest);
  6552. }
  6553. return scm_sum (x, y);
  6554. }
  6555. #undef FUNC_NAME
  6556. #define s_sum s_scm_i_sum
  6557. #define g_sum g_scm_i_sum
  6558. SCM
  6559. scm_sum (SCM x, SCM y)
  6560. {
  6561. if (SCM_UNLIKELY (SCM_UNBNDP (y)))
  6562. {
  6563. if (SCM_NUMBERP (x)) return x;
  6564. if (SCM_UNBNDP (x)) return SCM_INUM0;
  6565. return scm_wta_dispatch_1 (g_sum, x, SCM_ARG1, s_sum);
  6566. }
  6567. if (SCM_LIKELY (SCM_I_INUMP (x)))
  6568. {
  6569. if (SCM_LIKELY (SCM_I_INUMP (y)))
  6570. {
  6571. scm_t_inum xx = SCM_I_INUM (x);
  6572. scm_t_inum yy = SCM_I_INUM (y);
  6573. scm_t_inum z = xx + yy;
  6574. return SCM_FIXABLE (z) ? SCM_I_MAKINUM (z) : scm_i_inum2big (z);
  6575. }
  6576. else if (SCM_BIGP (y))
  6577. {
  6578. SCM_SWAP (x, y);
  6579. goto add_big_inum;
  6580. }
  6581. else if (SCM_REALP (y))
  6582. {
  6583. scm_t_inum xx = SCM_I_INUM (x);
  6584. return scm_from_double (xx + SCM_REAL_VALUE (y));
  6585. }
  6586. else if (SCM_COMPLEXP (y))
  6587. {
  6588. scm_t_inum xx = SCM_I_INUM (x);
  6589. return scm_c_make_rectangular (xx + SCM_COMPLEX_REAL (y),
  6590. SCM_COMPLEX_IMAG (y));
  6591. }
  6592. else if (SCM_FRACTIONP (y))
  6593. return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y),
  6594. scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
  6595. SCM_FRACTION_DENOMINATOR (y));
  6596. else
  6597. return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
  6598. } else if (SCM_BIGP (x))
  6599. {
  6600. if (SCM_I_INUMP (y))
  6601. {
  6602. scm_t_inum inum;
  6603. int bigsgn;
  6604. add_big_inum:
  6605. inum = SCM_I_INUM (y);
  6606. if (inum == 0)
  6607. return x;
  6608. bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x));
  6609. if (inum < 0)
  6610. {
  6611. SCM result = scm_i_mkbig ();
  6612. mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum);
  6613. scm_remember_upto_here_1 (x);
  6614. /* we know the result will have to be a bignum */
  6615. if (bigsgn == -1)
  6616. return result;
  6617. return scm_i_normbig (result);
  6618. }
  6619. else
  6620. {
  6621. SCM result = scm_i_mkbig ();
  6622. mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum);
  6623. scm_remember_upto_here_1 (x);
  6624. /* we know the result will have to be a bignum */
  6625. if (bigsgn == 1)
  6626. return result;
  6627. return scm_i_normbig (result);
  6628. }
  6629. }
  6630. else if (SCM_BIGP (y))
  6631. {
  6632. SCM result = scm_i_mkbig ();
  6633. int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
  6634. int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
  6635. mpz_add (SCM_I_BIG_MPZ (result),
  6636. SCM_I_BIG_MPZ (x),
  6637. SCM_I_BIG_MPZ (y));
  6638. scm_remember_upto_here_2 (x, y);
  6639. /* we know the result will have to be a bignum */
  6640. if (sgn_x == sgn_y)
  6641. return result;
  6642. return scm_i_normbig (result);
  6643. }
  6644. else if (SCM_REALP (y))
  6645. {
  6646. double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y);
  6647. scm_remember_upto_here_1 (x);
  6648. return scm_from_double (result);
  6649. }
  6650. else if (SCM_COMPLEXP (y))
  6651. {
  6652. double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
  6653. + SCM_COMPLEX_REAL (y));
  6654. scm_remember_upto_here_1 (x);
  6655. return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (y));
  6656. }
  6657. else if (SCM_FRACTIONP (y))
  6658. return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y),
  6659. scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
  6660. SCM_FRACTION_DENOMINATOR (y));
  6661. else
  6662. return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
  6663. }
  6664. else if (SCM_REALP (x))
  6665. {
  6666. if (SCM_I_INUMP (y))
  6667. return scm_from_double (SCM_REAL_VALUE (x) + SCM_I_INUM (y));
  6668. else if (SCM_BIGP (y))
  6669. {
  6670. double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x);
  6671. scm_remember_upto_here_1 (y);
  6672. return scm_from_double (result);
  6673. }
  6674. else if (SCM_REALP (y))
  6675. return scm_from_double (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y));
  6676. else if (SCM_COMPLEXP (y))
  6677. return scm_c_make_rectangular (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y),
  6678. SCM_COMPLEX_IMAG (y));
  6679. else if (SCM_FRACTIONP (y))
  6680. return scm_from_double (SCM_REAL_VALUE (x) + scm_i_fraction2double (y));
  6681. else
  6682. return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
  6683. }
  6684. else if (SCM_COMPLEXP (x))
  6685. {
  6686. if (SCM_I_INUMP (y))
  6687. return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + SCM_I_INUM (y),
  6688. SCM_COMPLEX_IMAG (x));
  6689. else if (SCM_BIGP (y))
  6690. {
  6691. double real_part = (mpz_get_d (SCM_I_BIG_MPZ (y))
  6692. + SCM_COMPLEX_REAL (x));
  6693. scm_remember_upto_here_1 (y);
  6694. return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (x));
  6695. }
  6696. else if (SCM_REALP (y))
  6697. return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y),
  6698. SCM_COMPLEX_IMAG (x));
  6699. else if (SCM_COMPLEXP (y))
  6700. return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + SCM_COMPLEX_REAL (y),
  6701. SCM_COMPLEX_IMAG (x) + SCM_COMPLEX_IMAG (y));
  6702. else if (SCM_FRACTIONP (y))
  6703. return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + scm_i_fraction2double (y),
  6704. SCM_COMPLEX_IMAG (x));
  6705. else
  6706. return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
  6707. }
  6708. else if (SCM_FRACTIONP (x))
  6709. {
  6710. if (SCM_I_INUMP (y))
  6711. return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x),
  6712. scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
  6713. SCM_FRACTION_DENOMINATOR (x));
  6714. else if (SCM_BIGP (y))
  6715. return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x),
  6716. scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
  6717. SCM_FRACTION_DENOMINATOR (x));
  6718. else if (SCM_REALP (y))
  6719. return scm_from_double (SCM_REAL_VALUE (y) + scm_i_fraction2double (x));
  6720. else if (SCM_COMPLEXP (y))
  6721. return scm_c_make_rectangular (SCM_COMPLEX_REAL (y) + scm_i_fraction2double (x),
  6722. SCM_COMPLEX_IMAG (y));
  6723. else if (SCM_FRACTIONP (y))
  6724. /* a/b + c/d = (ad + bc) / bd */
  6725. return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
  6726. scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
  6727. scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
  6728. else
  6729. return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
  6730. }
  6731. else
  6732. return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARG1, s_sum);
  6733. }
  6734. SCM_DEFINE (scm_oneplus, "1+", 1, 0, 0,
  6735. (SCM x),
  6736. "Return @math{@var{x}+1}.")
  6737. #define FUNC_NAME s_scm_oneplus
  6738. {
  6739. return scm_sum (x, SCM_INUM1);
  6740. }
  6741. #undef FUNC_NAME
  6742. SCM_PRIMITIVE_GENERIC (scm_i_difference, "-", 0, 2, 1,
  6743. (SCM x, SCM y, SCM rest),
  6744. "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
  6745. "the sum of all but the first argument are subtracted from the first\n"
  6746. "argument.")
  6747. #define FUNC_NAME s_scm_i_difference
  6748. {
  6749. while (!scm_is_null (rest))
  6750. { x = scm_difference (x, y);
  6751. y = scm_car (rest);
  6752. rest = scm_cdr (rest);
  6753. }
  6754. return scm_difference (x, y);
  6755. }
  6756. #undef FUNC_NAME
  6757. #define s_difference s_scm_i_difference
  6758. #define g_difference g_scm_i_difference
  6759. SCM
  6760. scm_difference (SCM x, SCM y)
  6761. #define FUNC_NAME s_difference
  6762. {
  6763. if (SCM_UNLIKELY (SCM_UNBNDP (y)))
  6764. {
  6765. if (SCM_UNBNDP (x))
  6766. return scm_wta_dispatch_0 (g_difference, s_difference);
  6767. else
  6768. if (SCM_I_INUMP (x))
  6769. {
  6770. scm_t_inum xx = -SCM_I_INUM (x);
  6771. if (SCM_FIXABLE (xx))
  6772. return SCM_I_MAKINUM (xx);
  6773. else
  6774. return scm_i_inum2big (xx);
  6775. }
  6776. else if (SCM_BIGP (x))
  6777. /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
  6778. bignum, but negating that gives a fixnum. */
  6779. return scm_i_normbig (scm_i_clonebig (x, 0));
  6780. else if (SCM_REALP (x))
  6781. return scm_from_double (-SCM_REAL_VALUE (x));
  6782. else if (SCM_COMPLEXP (x))
  6783. return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x),
  6784. -SCM_COMPLEX_IMAG (x));
  6785. else if (SCM_FRACTIONP (x))
  6786. return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
  6787. SCM_FRACTION_DENOMINATOR (x));
  6788. else
  6789. return scm_wta_dispatch_1 (g_difference, x, SCM_ARG1, s_difference);
  6790. }
  6791. if (SCM_LIKELY (SCM_I_INUMP (x)))
  6792. {
  6793. if (SCM_LIKELY (SCM_I_INUMP (y)))
  6794. {
  6795. scm_t_inum xx = SCM_I_INUM (x);
  6796. scm_t_inum yy = SCM_I_INUM (y);
  6797. scm_t_inum z = xx - yy;
  6798. if (SCM_FIXABLE (z))
  6799. return SCM_I_MAKINUM (z);
  6800. else
  6801. return scm_i_inum2big (z);
  6802. }
  6803. else if (SCM_BIGP (y))
  6804. {
  6805. /* inum-x - big-y */
  6806. scm_t_inum xx = SCM_I_INUM (x);
  6807. if (xx == 0)
  6808. {
  6809. /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
  6810. bignum, but negating that gives a fixnum. */
  6811. return scm_i_normbig (scm_i_clonebig (y, 0));
  6812. }
  6813. else
  6814. {
  6815. int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
  6816. SCM result = scm_i_mkbig ();
  6817. if (xx >= 0)
  6818. mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y));
  6819. else
  6820. {
  6821. /* x - y == -(y + -x) */
  6822. mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), -xx);
  6823. mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
  6824. }
  6825. scm_remember_upto_here_1 (y);
  6826. if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0))
  6827. /* we know the result will have to be a bignum */
  6828. return result;
  6829. else
  6830. return scm_i_normbig (result);
  6831. }
  6832. }
  6833. else if (SCM_REALP (y))
  6834. {
  6835. scm_t_inum xx = SCM_I_INUM (x);
  6836. /*
  6837. * We need to handle x == exact 0
  6838. * specially because R6RS states that:
  6839. * (- 0.0) ==> -0.0 and
  6840. * (- 0.0 0.0) ==> 0.0
  6841. * and the scheme compiler changes
  6842. * (- 0.0) into (- 0 0.0)
  6843. * So we need to treat (- 0 0.0) like (- 0.0).
  6844. * At the C level, (-x) is different than (0.0 - x).
  6845. * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
  6846. */
  6847. if (xx == 0)
  6848. return scm_from_double (- SCM_REAL_VALUE (y));
  6849. else
  6850. return scm_from_double (xx - SCM_REAL_VALUE (y));
  6851. }
  6852. else if (SCM_COMPLEXP (y))
  6853. {
  6854. scm_t_inum xx = SCM_I_INUM (x);
  6855. /* We need to handle x == exact 0 specially.
  6856. See the comment above (for SCM_REALP (y)) */
  6857. if (xx == 0)
  6858. return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y),
  6859. - SCM_COMPLEX_IMAG (y));
  6860. else
  6861. return scm_c_make_rectangular (xx - SCM_COMPLEX_REAL (y),
  6862. - SCM_COMPLEX_IMAG (y));
  6863. }
  6864. else if (SCM_FRACTIONP (y))
  6865. /* a - b/c = (ac - b) / c */
  6866. return scm_i_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
  6867. SCM_FRACTION_NUMERATOR (y)),
  6868. SCM_FRACTION_DENOMINATOR (y));
  6869. else
  6870. return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
  6871. }
  6872. else if (SCM_BIGP (x))
  6873. {
  6874. if (SCM_I_INUMP (y))
  6875. {
  6876. /* big-x - inum-y */
  6877. scm_t_inum yy = SCM_I_INUM (y);
  6878. int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
  6879. scm_remember_upto_here_1 (x);
  6880. if (sgn_x == 0)
  6881. return (SCM_FIXABLE (-yy) ?
  6882. SCM_I_MAKINUM (-yy) : scm_from_inum (-yy));
  6883. else
  6884. {
  6885. SCM result = scm_i_mkbig ();
  6886. if (yy >= 0)
  6887. mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
  6888. else
  6889. mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), -yy);
  6890. scm_remember_upto_here_1 (x);
  6891. if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0))
  6892. /* we know the result will have to be a bignum */
  6893. return result;
  6894. else
  6895. return scm_i_normbig (result);
  6896. }
  6897. }
  6898. else if (SCM_BIGP (y))
  6899. {
  6900. int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
  6901. int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
  6902. SCM result = scm_i_mkbig ();
  6903. mpz_sub (SCM_I_BIG_MPZ (result),
  6904. SCM_I_BIG_MPZ (x),
  6905. SCM_I_BIG_MPZ (y));
  6906. scm_remember_upto_here_2 (x, y);
  6907. /* we know the result will have to be a bignum */
  6908. if ((sgn_x == 1) && (sgn_y == -1))
  6909. return result;
  6910. if ((sgn_x == -1) && (sgn_y == 1))
  6911. return result;
  6912. return scm_i_normbig (result);
  6913. }
  6914. else if (SCM_REALP (y))
  6915. {
  6916. double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y);
  6917. scm_remember_upto_here_1 (x);
  6918. return scm_from_double (result);
  6919. }
  6920. else if (SCM_COMPLEXP (y))
  6921. {
  6922. double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
  6923. - SCM_COMPLEX_REAL (y));
  6924. scm_remember_upto_here_1 (x);
  6925. return scm_c_make_rectangular (real_part, - SCM_COMPLEX_IMAG (y));
  6926. }
  6927. else if (SCM_FRACTIONP (y))
  6928. return scm_i_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
  6929. SCM_FRACTION_NUMERATOR (y)),
  6930. SCM_FRACTION_DENOMINATOR (y));
  6931. else
  6932. return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
  6933. }
  6934. else if (SCM_REALP (x))
  6935. {
  6936. if (SCM_I_INUMP (y))
  6937. return scm_from_double (SCM_REAL_VALUE (x) - SCM_I_INUM (y));
  6938. else if (SCM_BIGP (y))
  6939. {
  6940. double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y));
  6941. scm_remember_upto_here_1 (x);
  6942. return scm_from_double (result);
  6943. }
  6944. else if (SCM_REALP (y))
  6945. return scm_from_double (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y));
  6946. else if (SCM_COMPLEXP (y))
  6947. return scm_c_make_rectangular (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y),
  6948. -SCM_COMPLEX_IMAG (y));
  6949. else if (SCM_FRACTIONP (y))
  6950. return scm_from_double (SCM_REAL_VALUE (x) - scm_i_fraction2double (y));
  6951. else
  6952. return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
  6953. }
  6954. else if (SCM_COMPLEXP (x))
  6955. {
  6956. if (SCM_I_INUMP (y))
  6957. return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_I_INUM (y),
  6958. SCM_COMPLEX_IMAG (x));
  6959. else if (SCM_BIGP (y))
  6960. {
  6961. double real_part = (SCM_COMPLEX_REAL (x)
  6962. - mpz_get_d (SCM_I_BIG_MPZ (y)));
  6963. scm_remember_upto_here_1 (x);
  6964. return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (y));
  6965. }
  6966. else if (SCM_REALP (y))
  6967. return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y),
  6968. SCM_COMPLEX_IMAG (x));
  6969. else if (SCM_COMPLEXP (y))
  6970. return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y),
  6971. SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y));
  6972. else if (SCM_FRACTIONP (y))
  6973. return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - scm_i_fraction2double (y),
  6974. SCM_COMPLEX_IMAG (x));
  6975. else
  6976. return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
  6977. }
  6978. else if (SCM_FRACTIONP (x))
  6979. {
  6980. if (SCM_I_INUMP (y))
  6981. /* a/b - c = (a - cb) / b */
  6982. return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
  6983. scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
  6984. SCM_FRACTION_DENOMINATOR (x));
  6985. else if (SCM_BIGP (y))
  6986. return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
  6987. scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
  6988. SCM_FRACTION_DENOMINATOR (x));
  6989. else if (SCM_REALP (y))
  6990. return scm_from_double (scm_i_fraction2double (x) - SCM_REAL_VALUE (y));
  6991. else if (SCM_COMPLEXP (y))
  6992. return scm_c_make_rectangular (scm_i_fraction2double (x) - SCM_COMPLEX_REAL (y),
  6993. -SCM_COMPLEX_IMAG (y));
  6994. else if (SCM_FRACTIONP (y))
  6995. /* a/b - c/d = (ad - bc) / bd */
  6996. return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
  6997. scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
  6998. scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
  6999. else
  7000. return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
  7001. }
  7002. else
  7003. return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARG1, s_difference);
  7004. }
  7005. #undef FUNC_NAME
  7006. SCM_DEFINE (scm_oneminus, "1-", 1, 0, 0,
  7007. (SCM x),
  7008. "Return @math{@var{x}-1}.")
  7009. #define FUNC_NAME s_scm_oneminus
  7010. {
  7011. return scm_difference (x, SCM_INUM1);
  7012. }
  7013. #undef FUNC_NAME
  7014. SCM_PRIMITIVE_GENERIC (scm_i_product, "*", 0, 2, 1,
  7015. (SCM x, SCM y, SCM rest),
  7016. "Return the product of all arguments. If called without arguments,\n"
  7017. "1 is returned.")
  7018. #define FUNC_NAME s_scm_i_product
  7019. {
  7020. while (!scm_is_null (rest))
  7021. { x = scm_product (x, y);
  7022. y = scm_car (rest);
  7023. rest = scm_cdr (rest);
  7024. }
  7025. return scm_product (x, y);
  7026. }
  7027. #undef FUNC_NAME
  7028. #define s_product s_scm_i_product
  7029. #define g_product g_scm_i_product
  7030. SCM
  7031. scm_product (SCM x, SCM y)
  7032. {
  7033. if (SCM_UNLIKELY (SCM_UNBNDP (y)))
  7034. {
  7035. if (SCM_UNBNDP (x))
  7036. return SCM_I_MAKINUM (1L);
  7037. else if (SCM_NUMBERP (x))
  7038. return x;
  7039. else
  7040. return scm_wta_dispatch_1 (g_product, x, SCM_ARG1, s_product);
  7041. }
  7042. if (SCM_LIKELY (SCM_I_INUMP (x)))
  7043. {
  7044. scm_t_inum xx;
  7045. xinum:
  7046. xx = SCM_I_INUM (x);
  7047. switch (xx)
  7048. {
  7049. case 1:
  7050. /* exact1 is the universal multiplicative identity */
  7051. return y;
  7052. break;
  7053. case 0:
  7054. /* exact0 times a fixnum is exact0: optimize this case */
  7055. if (SCM_LIKELY (SCM_I_INUMP (y)))
  7056. return SCM_INUM0;
  7057. /* if the other argument is inexact, the result is inexact,
  7058. and we must do the multiplication in order to handle
  7059. infinities and NaNs properly. */
  7060. else if (SCM_REALP (y))
  7061. return scm_from_double (0.0 * SCM_REAL_VALUE (y));
  7062. else if (SCM_COMPLEXP (y))
  7063. return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y),
  7064. 0.0 * SCM_COMPLEX_IMAG (y));
  7065. /* we've already handled inexact numbers,
  7066. so y must be exact, and we return exact0 */
  7067. else if (SCM_NUMP (y))
  7068. return SCM_INUM0;
  7069. else
  7070. return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
  7071. break;
  7072. case -1:
  7073. /*
  7074. * This case is important for more than just optimization.
  7075. * It handles the case of negating
  7076. * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum),
  7077. * which is a bignum that must be changed back into a fixnum.
  7078. * Failure to do so will cause the following to return #f:
  7079. * (= most-negative-fixnum (* -1 (- most-negative-fixnum)))
  7080. */
  7081. return scm_difference(y, SCM_UNDEFINED);
  7082. break;
  7083. }
  7084. if (SCM_LIKELY (SCM_I_INUMP (y)))
  7085. {
  7086. scm_t_inum yy = SCM_I_INUM (y);
  7087. scm_t_inum kk = xx * yy;
  7088. SCM k = SCM_I_MAKINUM (kk);
  7089. if ((kk == SCM_I_INUM (k)) && (kk / xx == yy))
  7090. return k;
  7091. else
  7092. {
  7093. SCM result = scm_i_inum2big (xx);
  7094. mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy);
  7095. return scm_i_normbig (result);
  7096. }
  7097. }
  7098. else if (SCM_BIGP (y))
  7099. {
  7100. SCM result = scm_i_mkbig ();
  7101. mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx);
  7102. scm_remember_upto_here_1 (y);
  7103. return result;
  7104. }
  7105. else if (SCM_REALP (y))
  7106. return scm_from_double (xx * SCM_REAL_VALUE (y));
  7107. else if (SCM_COMPLEXP (y))
  7108. return scm_c_make_rectangular (xx * SCM_COMPLEX_REAL (y),
  7109. xx * SCM_COMPLEX_IMAG (y));
  7110. else if (SCM_FRACTIONP (y))
  7111. return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
  7112. SCM_FRACTION_DENOMINATOR (y));
  7113. else
  7114. return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
  7115. }
  7116. else if (SCM_BIGP (x))
  7117. {
  7118. if (SCM_I_INUMP (y))
  7119. {
  7120. SCM_SWAP (x, y);
  7121. goto xinum;
  7122. }
  7123. else if (SCM_BIGP (y))
  7124. {
  7125. SCM result = scm_i_mkbig ();
  7126. mpz_mul (SCM_I_BIG_MPZ (result),
  7127. SCM_I_BIG_MPZ (x),
  7128. SCM_I_BIG_MPZ (y));
  7129. scm_remember_upto_here_2 (x, y);
  7130. return result;
  7131. }
  7132. else if (SCM_REALP (y))
  7133. {
  7134. double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y);
  7135. scm_remember_upto_here_1 (x);
  7136. return scm_from_double (result);
  7137. }
  7138. else if (SCM_COMPLEXP (y))
  7139. {
  7140. double z = mpz_get_d (SCM_I_BIG_MPZ (x));
  7141. scm_remember_upto_here_1 (x);
  7142. return scm_c_make_rectangular (z * SCM_COMPLEX_REAL (y),
  7143. z * SCM_COMPLEX_IMAG (y));
  7144. }
  7145. else if (SCM_FRACTIONP (y))
  7146. return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
  7147. SCM_FRACTION_DENOMINATOR (y));
  7148. else
  7149. return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
  7150. }
  7151. else if (SCM_REALP (x))
  7152. {
  7153. if (SCM_I_INUMP (y))
  7154. {
  7155. SCM_SWAP (x, y);
  7156. goto xinum;
  7157. }
  7158. else if (SCM_BIGP (y))
  7159. {
  7160. double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);
  7161. scm_remember_upto_here_1 (y);
  7162. return scm_from_double (result);
  7163. }
  7164. else if (SCM_REALP (y))
  7165. return scm_from_double (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));
  7166. else if (SCM_COMPLEXP (y))
  7167. return scm_c_make_rectangular (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y),
  7168. SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y));
  7169. else if (SCM_FRACTIONP (y))
  7170. return scm_from_double (SCM_REAL_VALUE (x) * scm_i_fraction2double (y));
  7171. else
  7172. return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
  7173. }
  7174. else if (SCM_COMPLEXP (x))
  7175. {
  7176. if (SCM_I_INUMP (y))
  7177. {
  7178. SCM_SWAP (x, y);
  7179. goto xinum;
  7180. }
  7181. else if (SCM_BIGP (y))
  7182. {
  7183. double z = mpz_get_d (SCM_I_BIG_MPZ (y));
  7184. scm_remember_upto_here_1 (y);
  7185. return scm_c_make_rectangular (z * SCM_COMPLEX_REAL (x),
  7186. z * SCM_COMPLEX_IMAG (x));
  7187. }
  7188. else if (SCM_REALP (y))
  7189. return scm_c_make_rectangular (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x),
  7190. SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x));
  7191. else if (SCM_COMPLEXP (y))
  7192. {
  7193. return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y)
  7194. - SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y),
  7195. SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y)
  7196. + SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y));
  7197. }
  7198. else if (SCM_FRACTIONP (y))
  7199. {
  7200. double yy = scm_i_fraction2double (y);
  7201. return scm_c_make_rectangular (yy * SCM_COMPLEX_REAL (x),
  7202. yy * SCM_COMPLEX_IMAG (x));
  7203. }
  7204. else
  7205. return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
  7206. }
  7207. else if (SCM_FRACTIONP (x))
  7208. {
  7209. if (SCM_I_INUMP (y))
  7210. return scm_i_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
  7211. SCM_FRACTION_DENOMINATOR (x));
  7212. else if (SCM_BIGP (y))
  7213. return scm_i_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
  7214. SCM_FRACTION_DENOMINATOR (x));
  7215. else if (SCM_REALP (y))
  7216. return scm_from_double (scm_i_fraction2double (x) * SCM_REAL_VALUE (y));
  7217. else if (SCM_COMPLEXP (y))
  7218. {
  7219. double xx = scm_i_fraction2double (x);
  7220. return scm_c_make_rectangular (xx * SCM_COMPLEX_REAL (y),
  7221. xx * SCM_COMPLEX_IMAG (y));
  7222. }
  7223. else if (SCM_FRACTIONP (y))
  7224. /* a/b * c/d = ac / bd */
  7225. return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x),
  7226. SCM_FRACTION_NUMERATOR (y)),
  7227. scm_product (SCM_FRACTION_DENOMINATOR (x),
  7228. SCM_FRACTION_DENOMINATOR (y)));
  7229. else
  7230. return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
  7231. }
  7232. else
  7233. return scm_wta_dispatch_2 (g_product, x, y, SCM_ARG1, s_product);
  7234. }
  7235. #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
  7236. || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
  7237. #define ALLOW_DIVIDE_BY_ZERO
  7238. /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
  7239. #endif
  7240. /* The code below for complex division is adapted from the GNU
  7241. libstdc++, which adapted it from f2c's libF77, and is subject to
  7242. this copyright: */
  7243. /****************************************************************
  7244. Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
  7245. Permission to use, copy, modify, and distribute this software
  7246. and its documentation for any purpose and without fee is hereby
  7247. granted, provided that the above copyright notice appear in all
  7248. copies and that both that the copyright notice and this
  7249. permission notice and warranty disclaimer appear in supporting
  7250. documentation, and that the names of AT&T Bell Laboratories or
  7251. Bellcore or any of their entities not be used in advertising or
  7252. publicity pertaining to distribution of the software without
  7253. specific, written prior permission.
  7254. AT&T and Bellcore disclaim all warranties with regard to this
  7255. software, including all implied warranties of merchantability
  7256. and fitness. In no event shall AT&T or Bellcore be liable for
  7257. any special, indirect or consequential damages or any damages
  7258. whatsoever resulting from loss of use, data or profits, whether
  7259. in an action of contract, negligence or other tortious action,
  7260. arising out of or in connection with the use or performance of
  7261. this software.
  7262. ****************************************************************/
  7263. SCM_PRIMITIVE_GENERIC (scm_i_divide, "/", 0, 2, 1,
  7264. (SCM x, SCM y, SCM rest),
  7265. "Divide the first argument by the product of the remaining\n"
  7266. "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
  7267. "returned.")
  7268. #define FUNC_NAME s_scm_i_divide
  7269. {
  7270. while (!scm_is_null (rest))
  7271. { x = scm_divide (x, y);
  7272. y = scm_car (rest);
  7273. rest = scm_cdr (rest);
  7274. }
  7275. return scm_divide (x, y);
  7276. }
  7277. #undef FUNC_NAME
  7278. #define s_divide s_scm_i_divide
  7279. #define g_divide g_scm_i_divide
  7280. static SCM
  7281. do_divide (SCM x, SCM y, int inexact)
  7282. #define FUNC_NAME s_divide
  7283. {
  7284. double a;
  7285. if (SCM_UNLIKELY (SCM_UNBNDP (y)))
  7286. {
  7287. if (SCM_UNBNDP (x))
  7288. return scm_wta_dispatch_0 (g_divide, s_divide);
  7289. else if (SCM_I_INUMP (x))
  7290. {
  7291. scm_t_inum xx = SCM_I_INUM (x);
  7292. if (xx == 1 || xx == -1)
  7293. return x;
  7294. #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
  7295. else if (xx == 0)
  7296. scm_num_overflow (s_divide);
  7297. #endif
  7298. else
  7299. {
  7300. if (inexact)
  7301. return scm_from_double (1.0 / (double) xx);
  7302. else return scm_i_make_ratio (SCM_INUM1, x);
  7303. }
  7304. }
  7305. else if (SCM_BIGP (x))
  7306. {
  7307. if (inexact)
  7308. return scm_from_double (1.0 / scm_i_big2dbl (x));
  7309. else return scm_i_make_ratio (SCM_INUM1, x);
  7310. }
  7311. else if (SCM_REALP (x))
  7312. {
  7313. double xx = SCM_REAL_VALUE (x);
  7314. #ifndef ALLOW_DIVIDE_BY_ZERO
  7315. if (xx == 0.0)
  7316. scm_num_overflow (s_divide);
  7317. else
  7318. #endif
  7319. return scm_from_double (1.0 / xx);
  7320. }
  7321. else if (SCM_COMPLEXP (x))
  7322. {
  7323. double r = SCM_COMPLEX_REAL (x);
  7324. double i = SCM_COMPLEX_IMAG (x);
  7325. if (fabs(r) <= fabs(i))
  7326. {
  7327. double t = r / i;
  7328. double d = i * (1.0 + t * t);
  7329. return scm_c_make_rectangular (t / d, -1.0 / d);
  7330. }
  7331. else
  7332. {
  7333. double t = i / r;
  7334. double d = r * (1.0 + t * t);
  7335. return scm_c_make_rectangular (1.0 / d, -t / d);
  7336. }
  7337. }
  7338. else if (SCM_FRACTIONP (x))
  7339. return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x),
  7340. SCM_FRACTION_NUMERATOR (x));
  7341. else
  7342. return scm_wta_dispatch_1 (g_divide, x, SCM_ARG1, s_divide);
  7343. }
  7344. if (SCM_LIKELY (SCM_I_INUMP (x)))
  7345. {
  7346. scm_t_inum xx = SCM_I_INUM (x);
  7347. if (SCM_LIKELY (SCM_I_INUMP (y)))
  7348. {
  7349. scm_t_inum yy = SCM_I_INUM (y);
  7350. if (yy == 0)
  7351. {
  7352. #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
  7353. scm_num_overflow (s_divide);
  7354. #else
  7355. return scm_from_double ((double) xx / (double) yy);
  7356. #endif
  7357. }
  7358. else if (xx % yy != 0)
  7359. {
  7360. if (inexact)
  7361. return scm_from_double ((double) xx / (double) yy);
  7362. else return scm_i_make_ratio (x, y);
  7363. }
  7364. else
  7365. {
  7366. scm_t_inum z = xx / yy;
  7367. if (SCM_FIXABLE (z))
  7368. return SCM_I_MAKINUM (z);
  7369. else
  7370. return scm_i_inum2big (z);
  7371. }
  7372. }
  7373. else if (SCM_BIGP (y))
  7374. {
  7375. if (inexact)
  7376. return scm_from_double ((double) xx / scm_i_big2dbl (y));
  7377. else return scm_i_make_ratio (x, y);
  7378. }
  7379. else if (SCM_REALP (y))
  7380. {
  7381. double yy = SCM_REAL_VALUE (y);
  7382. #ifndef ALLOW_DIVIDE_BY_ZERO
  7383. if (yy == 0.0)
  7384. scm_num_overflow (s_divide);
  7385. else
  7386. #endif
  7387. return scm_from_double ((double) xx / yy);
  7388. }
  7389. else if (SCM_COMPLEXP (y))
  7390. {
  7391. a = xx;
  7392. complex_div: /* y _must_ be a complex number */
  7393. {
  7394. double r = SCM_COMPLEX_REAL (y);
  7395. double i = SCM_COMPLEX_IMAG (y);
  7396. if (fabs(r) <= fabs(i))
  7397. {
  7398. double t = r / i;
  7399. double d = i * (1.0 + t * t);
  7400. return scm_c_make_rectangular ((a * t) / d, -a / d);
  7401. }
  7402. else
  7403. {
  7404. double t = i / r;
  7405. double d = r * (1.0 + t * t);
  7406. return scm_c_make_rectangular (a / d, -(a * t) / d);
  7407. }
  7408. }
  7409. }
  7410. else if (SCM_FRACTIONP (y))
  7411. /* a / b/c = ac / b */
  7412. return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
  7413. SCM_FRACTION_NUMERATOR (y));
  7414. else
  7415. return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
  7416. }
  7417. else if (SCM_BIGP (x))
  7418. {
  7419. if (SCM_I_INUMP (y))
  7420. {
  7421. scm_t_inum yy = SCM_I_INUM (y);
  7422. if (yy == 0)
  7423. {
  7424. #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
  7425. scm_num_overflow (s_divide);
  7426. #else
  7427. int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
  7428. scm_remember_upto_here_1 (x);
  7429. return (sgn == 0) ? scm_nan () : scm_inf ();
  7430. #endif
  7431. }
  7432. else if (yy == 1)
  7433. return x;
  7434. else
  7435. {
  7436. /* FIXME: HMM, what are the relative performance issues here?
  7437. We need to test. Is it faster on average to test
  7438. divisible_p, then perform whichever operation, or is it
  7439. faster to perform the integer div opportunistically and
  7440. switch to real if there's a remainder? For now we take the
  7441. middle ground: test, then if divisible, use the faster div
  7442. func. */
  7443. scm_t_inum abs_yy = yy < 0 ? -yy : yy;
  7444. int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy);
  7445. if (divisible_p)
  7446. {
  7447. SCM result = scm_i_mkbig ();
  7448. mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy);
  7449. scm_remember_upto_here_1 (x);
  7450. if (yy < 0)
  7451. mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
  7452. return scm_i_normbig (result);
  7453. }
  7454. else
  7455. {
  7456. if (inexact)
  7457. return scm_from_double (scm_i_big2dbl (x) / (double) yy);
  7458. else return scm_i_make_ratio (x, y);
  7459. }
  7460. }
  7461. }
  7462. else if (SCM_BIGP (y))
  7463. {
  7464. /* big_x / big_y */
  7465. if (inexact)
  7466. {
  7467. /* It's easily possible for the ratio x/y to fit a double
  7468. but one or both x and y be too big to fit a double,
  7469. hence the use of mpq_get_d rather than converting and
  7470. dividing. */
  7471. mpq_t q;
  7472. *mpq_numref(q) = *SCM_I_BIG_MPZ (x);
  7473. *mpq_denref(q) = *SCM_I_BIG_MPZ (y);
  7474. return scm_from_double (mpq_get_d (q));
  7475. }
  7476. else
  7477. {
  7478. int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
  7479. SCM_I_BIG_MPZ (y));
  7480. if (divisible_p)
  7481. {
  7482. SCM result = scm_i_mkbig ();
  7483. mpz_divexact (SCM_I_BIG_MPZ (result),
  7484. SCM_I_BIG_MPZ (x),
  7485. SCM_I_BIG_MPZ (y));
  7486. scm_remember_upto_here_2 (x, y);
  7487. return scm_i_normbig (result);
  7488. }
  7489. else
  7490. return scm_i_make_ratio (x, y);
  7491. }
  7492. }
  7493. else if (SCM_REALP (y))
  7494. {
  7495. double yy = SCM_REAL_VALUE (y);
  7496. #ifndef ALLOW_DIVIDE_BY_ZERO
  7497. if (yy == 0.0)
  7498. scm_num_overflow (s_divide);
  7499. else
  7500. #endif
  7501. return scm_from_double (scm_i_big2dbl (x) / yy);
  7502. }
  7503. else if (SCM_COMPLEXP (y))
  7504. {
  7505. a = scm_i_big2dbl (x);
  7506. goto complex_div;
  7507. }
  7508. else if (SCM_FRACTIONP (y))
  7509. return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
  7510. SCM_FRACTION_NUMERATOR (y));
  7511. else
  7512. return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
  7513. }
  7514. else if (SCM_REALP (x))
  7515. {
  7516. double rx = SCM_REAL_VALUE (x);
  7517. if (SCM_I_INUMP (y))
  7518. {
  7519. scm_t_inum yy = SCM_I_INUM (y);
  7520. #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
  7521. if (yy == 0)
  7522. scm_num_overflow (s_divide);
  7523. else
  7524. #endif
  7525. return scm_from_double (rx / (double) yy);
  7526. }
  7527. else if (SCM_BIGP (y))
  7528. {
  7529. double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
  7530. scm_remember_upto_here_1 (y);
  7531. return scm_from_double (rx / dby);
  7532. }
  7533. else if (SCM_REALP (y))
  7534. {
  7535. double yy = SCM_REAL_VALUE (y);
  7536. #ifndef ALLOW_DIVIDE_BY_ZERO
  7537. if (yy == 0.0)
  7538. scm_num_overflow (s_divide);
  7539. else
  7540. #endif
  7541. return scm_from_double (rx / yy);
  7542. }
  7543. else if (SCM_COMPLEXP (y))
  7544. {
  7545. a = rx;
  7546. goto complex_div;
  7547. }
  7548. else if (SCM_FRACTIONP (y))
  7549. return scm_from_double (rx / scm_i_fraction2double (y));
  7550. else
  7551. return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
  7552. }
  7553. else if (SCM_COMPLEXP (x))
  7554. {
  7555. double rx = SCM_COMPLEX_REAL (x);
  7556. double ix = SCM_COMPLEX_IMAG (x);
  7557. if (SCM_I_INUMP (y))
  7558. {
  7559. scm_t_inum yy = SCM_I_INUM (y);
  7560. #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
  7561. if (yy == 0)
  7562. scm_num_overflow (s_divide);
  7563. else
  7564. #endif
  7565. {
  7566. double d = yy;
  7567. return scm_c_make_rectangular (rx / d, ix / d);
  7568. }
  7569. }
  7570. else if (SCM_BIGP (y))
  7571. {
  7572. double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
  7573. scm_remember_upto_here_1 (y);
  7574. return scm_c_make_rectangular (rx / dby, ix / dby);
  7575. }
  7576. else if (SCM_REALP (y))
  7577. {
  7578. double yy = SCM_REAL_VALUE (y);
  7579. #ifndef ALLOW_DIVIDE_BY_ZERO
  7580. if (yy == 0.0)
  7581. scm_num_overflow (s_divide);
  7582. else
  7583. #endif
  7584. return scm_c_make_rectangular (rx / yy, ix / yy);
  7585. }
  7586. else if (SCM_COMPLEXP (y))
  7587. {
  7588. double ry = SCM_COMPLEX_REAL (y);
  7589. double iy = SCM_COMPLEX_IMAG (y);
  7590. if (fabs(ry) <= fabs(iy))
  7591. {
  7592. double t = ry / iy;
  7593. double d = iy * (1.0 + t * t);
  7594. return scm_c_make_rectangular ((rx * t + ix) / d, (ix * t - rx) / d);
  7595. }
  7596. else
  7597. {
  7598. double t = iy / ry;
  7599. double d = ry * (1.0 + t * t);
  7600. return scm_c_make_rectangular ((rx + ix * t) / d, (ix - rx * t) / d);
  7601. }
  7602. }
  7603. else if (SCM_FRACTIONP (y))
  7604. {
  7605. double yy = scm_i_fraction2double (y);
  7606. return scm_c_make_rectangular (rx / yy, ix / yy);
  7607. }
  7608. else
  7609. return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
  7610. }
  7611. else if (SCM_FRACTIONP (x))
  7612. {
  7613. if (SCM_I_INUMP (y))
  7614. {
  7615. scm_t_inum yy = SCM_I_INUM (y);
  7616. #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
  7617. if (yy == 0)
  7618. scm_num_overflow (s_divide);
  7619. else
  7620. #endif
  7621. return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x),
  7622. scm_product (SCM_FRACTION_DENOMINATOR (x), y));
  7623. }
  7624. else if (SCM_BIGP (y))
  7625. {
  7626. return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x),
  7627. scm_product (SCM_FRACTION_DENOMINATOR (x), y));
  7628. }
  7629. else if (SCM_REALP (y))
  7630. {
  7631. double yy = SCM_REAL_VALUE (y);
  7632. #ifndef ALLOW_DIVIDE_BY_ZERO
  7633. if (yy == 0.0)
  7634. scm_num_overflow (s_divide);
  7635. else
  7636. #endif
  7637. return scm_from_double (scm_i_fraction2double (x) / yy);
  7638. }
  7639. else if (SCM_COMPLEXP (y))
  7640. {
  7641. a = scm_i_fraction2double (x);
  7642. goto complex_div;
  7643. }
  7644. else if (SCM_FRACTIONP (y))
  7645. return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
  7646. scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x)));
  7647. else
  7648. return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
  7649. }
  7650. else
  7651. return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARG1, s_divide);
  7652. }
  7653. SCM
  7654. scm_divide (SCM x, SCM y)
  7655. {
  7656. return do_divide (x, y, 0);
  7657. }
  7658. static SCM scm_divide2real (SCM x, SCM y)
  7659. {
  7660. return do_divide (x, y, 1);
  7661. }
  7662. #undef FUNC_NAME
  7663. double
  7664. scm_c_truncate (double x)
  7665. {
  7666. return trunc (x);
  7667. }
  7668. /* scm_c_round is done using floor(x+0.5) to round to nearest and with
  7669. half-way case (ie. when x is an integer plus 0.5) going upwards.
  7670. Then half-way cases are identified and adjusted down if the
  7671. round-upwards didn't give the desired even integer.
  7672. "plus_half == result" identifies a half-way case. If plus_half, which is
  7673. x + 0.5, is an integer then x must be an integer plus 0.5.
  7674. An odd "result" value is identified with result/2 != floor(result/2).
  7675. This is done with plus_half, since that value is ready for use sooner in
  7676. a pipelined cpu, and we're already requiring plus_half == result.
  7677. Note however that we need to be careful when x is big and already an
  7678. integer. In that case "x+0.5" may round to an adjacent integer, causing
  7679. us to return such a value, incorrectly. For instance if the hardware is
  7680. in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
  7681. (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
  7682. returned. Or if the hardware is in round-upwards mode, then other bigger
  7683. values like say x == 2^128 will see x+0.5 rounding up to the next higher
  7684. representable value, 2^128+2^76 (or whatever), again incorrect.
  7685. These bad roundings of x+0.5 are avoided by testing at the start whether
  7686. x is already an integer. If it is then clearly that's the desired result
  7687. already. And if it's not then the exponent must be small enough to allow
  7688. an 0.5 to be represented, and hence added without a bad rounding. */
  7689. double
  7690. scm_c_round (double x)
  7691. {
  7692. double plus_half, result;
  7693. if (x == floor (x))
  7694. return x;
  7695. plus_half = x + 0.5;
  7696. result = floor (plus_half);
  7697. /* Adjust so that the rounding is towards even. */
  7698. return ((plus_half == result && plus_half / 2 != floor (plus_half / 2))
  7699. ? result - 1
  7700. : result);
  7701. }
  7702. SCM_PRIMITIVE_GENERIC (scm_truncate_number, "truncate", 1, 0, 0,
  7703. (SCM x),
  7704. "Round the number @var{x} towards zero.")
  7705. #define FUNC_NAME s_scm_truncate_number
  7706. {
  7707. if (SCM_I_INUMP (x) || SCM_BIGP (x))
  7708. return x;
  7709. else if (SCM_REALP (x))
  7710. return scm_from_double (trunc (SCM_REAL_VALUE (x)));
  7711. else if (SCM_FRACTIONP (x))
  7712. return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x),
  7713. SCM_FRACTION_DENOMINATOR (x));
  7714. else
  7715. return scm_wta_dispatch_1 (g_scm_truncate_number, x, SCM_ARG1,
  7716. s_scm_truncate_number);
  7717. }
  7718. #undef FUNC_NAME
  7719. SCM_PRIMITIVE_GENERIC (scm_round_number, "round", 1, 0, 0,
  7720. (SCM x),
  7721. "Round the number @var{x} towards the nearest integer. "
  7722. "When it is exactly halfway between two integers, "
  7723. "round towards the even one.")
  7724. #define FUNC_NAME s_scm_round_number
  7725. {
  7726. if (SCM_I_INUMP (x) || SCM_BIGP (x))
  7727. return x;
  7728. else if (SCM_REALP (x))
  7729. return scm_from_double (scm_c_round (SCM_REAL_VALUE (x)));
  7730. else if (SCM_FRACTIONP (x))
  7731. return scm_round_quotient (SCM_FRACTION_NUMERATOR (x),
  7732. SCM_FRACTION_DENOMINATOR (x));
  7733. else
  7734. return scm_wta_dispatch_1 (g_scm_round_number, x, SCM_ARG1,
  7735. s_scm_round_number);
  7736. }
  7737. #undef FUNC_NAME
  7738. SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0,
  7739. (SCM x),
  7740. "Round the number @var{x} towards minus infinity.")
  7741. #define FUNC_NAME s_scm_floor
  7742. {
  7743. if (SCM_I_INUMP (x) || SCM_BIGP (x))
  7744. return x;
  7745. else if (SCM_REALP (x))
  7746. return scm_from_double (floor (SCM_REAL_VALUE (x)));
  7747. else if (SCM_FRACTIONP (x))
  7748. return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x),
  7749. SCM_FRACTION_DENOMINATOR (x));
  7750. else
  7751. return scm_wta_dispatch_1 (g_scm_floor, x, 1, s_scm_floor);
  7752. }
  7753. #undef FUNC_NAME
  7754. SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0,
  7755. (SCM x),
  7756. "Round the number @var{x} towards infinity.")
  7757. #define FUNC_NAME s_scm_ceiling
  7758. {
  7759. if (SCM_I_INUMP (x) || SCM_BIGP (x))
  7760. return x;
  7761. else if (SCM_REALP (x))
  7762. return scm_from_double (ceil (SCM_REAL_VALUE (x)));
  7763. else if (SCM_FRACTIONP (x))
  7764. return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x),
  7765. SCM_FRACTION_DENOMINATOR (x));
  7766. else
  7767. return scm_wta_dispatch_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
  7768. }
  7769. #undef FUNC_NAME
  7770. SCM_PRIMITIVE_GENERIC (scm_expt, "expt", 2, 0, 0,
  7771. (SCM x, SCM y),
  7772. "Return @var{x} raised to the power of @var{y}.")
  7773. #define FUNC_NAME s_scm_expt
  7774. {
  7775. if (scm_is_integer (y))
  7776. {
  7777. if (scm_is_true (scm_exact_p (y)))
  7778. return scm_integer_expt (x, y);
  7779. else
  7780. {
  7781. /* Here we handle the case where the exponent is an inexact
  7782. integer. We make the exponent exact in order to use
  7783. scm_integer_expt, and thus avoid the spurious imaginary
  7784. parts that may result from round-off errors in the general
  7785. e^(y log x) method below (for example when squaring a large
  7786. negative number). In this case, we must return an inexact
  7787. result for correctness. We also make the base inexact so
  7788. that scm_integer_expt will use fast inexact arithmetic
  7789. internally. Note that making the base inexact is not
  7790. sufficient to guarantee an inexact result, because
  7791. scm_integer_expt will return an exact 1 when the exponent
  7792. is 0, even if the base is inexact. */
  7793. return scm_exact_to_inexact
  7794. (scm_integer_expt (scm_exact_to_inexact (x),
  7795. scm_inexact_to_exact (y)));
  7796. }
  7797. }
  7798. else if (scm_is_real (x) && scm_is_real (y) && scm_to_double (x) >= 0.0)
  7799. {
  7800. return scm_from_double (pow (scm_to_double (x), scm_to_double (y)));
  7801. }
  7802. else if (scm_is_complex (x) && scm_is_complex (y))
  7803. return scm_exp (scm_product (scm_log (x), y));
  7804. else if (scm_is_complex (x))
  7805. return scm_wta_dispatch_2 (g_scm_expt, x, y, SCM_ARG2, s_scm_expt);
  7806. else
  7807. return scm_wta_dispatch_2 (g_scm_expt, x, y, SCM_ARG1, s_scm_expt);
  7808. }
  7809. #undef FUNC_NAME
  7810. /* sin/cos/tan/asin/acos/atan
  7811. sinh/cosh/tanh/asinh/acosh/atanh
  7812. Derived from "Transcen.scm", Complex trancendental functions for SCM.
  7813. Written by Jerry D. Hedden, (C) FSF.
  7814. See the file `COPYING' for terms applying to this program. */
  7815. SCM_PRIMITIVE_GENERIC (scm_sin, "sin", 1, 0, 0,
  7816. (SCM z),
  7817. "Compute the sine of @var{z}.")
  7818. #define FUNC_NAME s_scm_sin
  7819. {
  7820. if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
  7821. return z; /* sin(exact0) = exact0 */
  7822. else if (scm_is_real (z))
  7823. return scm_from_double (sin (scm_to_double (z)));
  7824. else if (SCM_COMPLEXP (z))
  7825. { double x, y;
  7826. x = SCM_COMPLEX_REAL (z);
  7827. y = SCM_COMPLEX_IMAG (z);
  7828. return scm_c_make_rectangular (sin (x) * cosh (y),
  7829. cos (x) * sinh (y));
  7830. }
  7831. else
  7832. return scm_wta_dispatch_1 (g_scm_sin, z, 1, s_scm_sin);
  7833. }
  7834. #undef FUNC_NAME
  7835. SCM_PRIMITIVE_GENERIC (scm_cos, "cos", 1, 0, 0,
  7836. (SCM z),
  7837. "Compute the cosine of @var{z}.")
  7838. #define FUNC_NAME s_scm_cos
  7839. {
  7840. if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
  7841. return SCM_INUM1; /* cos(exact0) = exact1 */
  7842. else if (scm_is_real (z))
  7843. return scm_from_double (cos (scm_to_double (z)));
  7844. else if (SCM_COMPLEXP (z))
  7845. { double x, y;
  7846. x = SCM_COMPLEX_REAL (z);
  7847. y = SCM_COMPLEX_IMAG (z);
  7848. return scm_c_make_rectangular (cos (x) * cosh (y),
  7849. -sin (x) * sinh (y));
  7850. }
  7851. else
  7852. return scm_wta_dispatch_1 (g_scm_cos, z, 1, s_scm_cos);
  7853. }
  7854. #undef FUNC_NAME
  7855. SCM_PRIMITIVE_GENERIC (scm_tan, "tan", 1, 0, 0,
  7856. (SCM z),
  7857. "Compute the tangent of @var{z}.")
  7858. #define FUNC_NAME s_scm_tan
  7859. {
  7860. if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
  7861. return z; /* tan(exact0) = exact0 */
  7862. else if (scm_is_real (z))
  7863. return scm_from_double (tan (scm_to_double (z)));
  7864. else if (SCM_COMPLEXP (z))
  7865. { double x, y, w;
  7866. x = 2.0 * SCM_COMPLEX_REAL (z);
  7867. y = 2.0 * SCM_COMPLEX_IMAG (z);
  7868. w = cos (x) + cosh (y);
  7869. #ifndef ALLOW_DIVIDE_BY_ZERO
  7870. if (w == 0.0)
  7871. scm_num_overflow (s_scm_tan);
  7872. #endif
  7873. return scm_c_make_rectangular (sin (x) / w, sinh (y) / w);
  7874. }
  7875. else
  7876. return scm_wta_dispatch_1 (g_scm_tan, z, 1, s_scm_tan);
  7877. }
  7878. #undef FUNC_NAME
  7879. SCM_PRIMITIVE_GENERIC (scm_sinh, "sinh", 1, 0, 0,
  7880. (SCM z),
  7881. "Compute the hyperbolic sine of @var{z}.")
  7882. #define FUNC_NAME s_scm_sinh
  7883. {
  7884. if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
  7885. return z; /* sinh(exact0) = exact0 */
  7886. else if (scm_is_real (z))
  7887. return scm_from_double (sinh (scm_to_double (z)));
  7888. else if (SCM_COMPLEXP (z))
  7889. { double x, y;
  7890. x = SCM_COMPLEX_REAL (z);
  7891. y = SCM_COMPLEX_IMAG (z);
  7892. return scm_c_make_rectangular (sinh (x) * cos (y),
  7893. cosh (x) * sin (y));
  7894. }
  7895. else
  7896. return scm_wta_dispatch_1 (g_scm_sinh, z, 1, s_scm_sinh);
  7897. }
  7898. #undef FUNC_NAME
  7899. SCM_PRIMITIVE_GENERIC (scm_cosh, "cosh", 1, 0, 0,
  7900. (SCM z),
  7901. "Compute the hyperbolic cosine of @var{z}.")
  7902. #define FUNC_NAME s_scm_cosh
  7903. {
  7904. if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
  7905. return SCM_INUM1; /* cosh(exact0) = exact1 */
  7906. else if (scm_is_real (z))
  7907. return scm_from_double (cosh (scm_to_double (z)));
  7908. else if (SCM_COMPLEXP (z))
  7909. { double x, y;
  7910. x = SCM_COMPLEX_REAL (z);
  7911. y = SCM_COMPLEX_IMAG (z);
  7912. return scm_c_make_rectangular (cosh (x) * cos (y),
  7913. sinh (x) * sin (y));
  7914. }
  7915. else
  7916. return scm_wta_dispatch_1 (g_scm_cosh, z, 1, s_scm_cosh);
  7917. }
  7918. #undef FUNC_NAME
  7919. SCM_PRIMITIVE_GENERIC (scm_tanh, "tanh", 1, 0, 0,
  7920. (SCM z),
  7921. "Compute the hyperbolic tangent of @var{z}.")
  7922. #define FUNC_NAME s_scm_tanh
  7923. {
  7924. if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
  7925. return z; /* tanh(exact0) = exact0 */
  7926. else if (scm_is_real (z))
  7927. return scm_from_double (tanh (scm_to_double (z)));
  7928. else if (SCM_COMPLEXP (z))
  7929. { double x, y, w;
  7930. x = 2.0 * SCM_COMPLEX_REAL (z);
  7931. y = 2.0 * SCM_COMPLEX_IMAG (z);
  7932. w = cosh (x) + cos (y);
  7933. #ifndef ALLOW_DIVIDE_BY_ZERO
  7934. if (w == 0.0)
  7935. scm_num_overflow (s_scm_tanh);
  7936. #endif
  7937. return scm_c_make_rectangular (sinh (x) / w, sin (y) / w);
  7938. }
  7939. else
  7940. return scm_wta_dispatch_1 (g_scm_tanh, z, 1, s_scm_tanh);
  7941. }
  7942. #undef FUNC_NAME
  7943. SCM_PRIMITIVE_GENERIC (scm_asin, "asin", 1, 0, 0,
  7944. (SCM z),
  7945. "Compute the arc sine of @var{z}.")
  7946. #define FUNC_NAME s_scm_asin
  7947. {
  7948. if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
  7949. return z; /* asin(exact0) = exact0 */
  7950. else if (scm_is_real (z))
  7951. {
  7952. double w = scm_to_double (z);
  7953. if (w >= -1.0 && w <= 1.0)
  7954. return scm_from_double (asin (w));
  7955. else
  7956. return scm_product (scm_c_make_rectangular (0, -1),
  7957. scm_sys_asinh (scm_c_make_rectangular (0, w)));
  7958. }
  7959. else if (SCM_COMPLEXP (z))
  7960. { double x, y;
  7961. x = SCM_COMPLEX_REAL (z);
  7962. y = SCM_COMPLEX_IMAG (z);
  7963. return scm_product (scm_c_make_rectangular (0, -1),
  7964. scm_sys_asinh (scm_c_make_rectangular (-y, x)));
  7965. }
  7966. else
  7967. return scm_wta_dispatch_1 (g_scm_asin, z, 1, s_scm_asin);
  7968. }
  7969. #undef FUNC_NAME
  7970. SCM_PRIMITIVE_GENERIC (scm_acos, "acos", 1, 0, 0,
  7971. (SCM z),
  7972. "Compute the arc cosine of @var{z}.")
  7973. #define FUNC_NAME s_scm_acos
  7974. {
  7975. if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM1)))
  7976. return SCM_INUM0; /* acos(exact1) = exact0 */
  7977. else if (scm_is_real (z))
  7978. {
  7979. double w = scm_to_double (z);
  7980. if (w >= -1.0 && w <= 1.0)
  7981. return scm_from_double (acos (w));
  7982. else
  7983. return scm_sum (scm_from_double (acos (0.0)),
  7984. scm_product (scm_c_make_rectangular (0, 1),
  7985. scm_sys_asinh (scm_c_make_rectangular (0, w))));
  7986. }
  7987. else if (SCM_COMPLEXP (z))
  7988. { double x, y;
  7989. x = SCM_COMPLEX_REAL (z);
  7990. y = SCM_COMPLEX_IMAG (z);
  7991. return scm_sum (scm_from_double (acos (0.0)),
  7992. scm_product (scm_c_make_rectangular (0, 1),
  7993. scm_sys_asinh (scm_c_make_rectangular (-y, x))));
  7994. }
  7995. else
  7996. return scm_wta_dispatch_1 (g_scm_acos, z, 1, s_scm_acos);
  7997. }
  7998. #undef FUNC_NAME
  7999. SCM_PRIMITIVE_GENERIC (scm_atan, "atan", 1, 1, 0,
  8000. (SCM z, SCM y),
  8001. "With one argument, compute the arc tangent of @var{z}.\n"
  8002. "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
  8003. "using the sign of @var{z} and @var{y} to determine the quadrant.")
  8004. #define FUNC_NAME s_scm_atan
  8005. {
  8006. if (SCM_UNBNDP (y))
  8007. {
  8008. if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
  8009. return z; /* atan(exact0) = exact0 */
  8010. else if (scm_is_real (z))
  8011. return scm_from_double (atan (scm_to_double (z)));
  8012. else if (SCM_COMPLEXP (z))
  8013. {
  8014. double v, w;
  8015. v = SCM_COMPLEX_REAL (z);
  8016. w = SCM_COMPLEX_IMAG (z);
  8017. return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v, w - 1.0),
  8018. scm_c_make_rectangular (v, w + 1.0))),
  8019. scm_c_make_rectangular (0, 2));
  8020. }
  8021. else
  8022. return scm_wta_dispatch_1 (g_scm_atan, z, SCM_ARG1, s_scm_atan);
  8023. }
  8024. else if (scm_is_real (z))
  8025. {
  8026. if (scm_is_real (y))
  8027. return scm_from_double (atan2 (scm_to_double (z), scm_to_double (y)));
  8028. else
  8029. return scm_wta_dispatch_2 (g_scm_atan, z, y, SCM_ARG2, s_scm_atan);
  8030. }
  8031. else
  8032. return scm_wta_dispatch_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
  8033. }
  8034. #undef FUNC_NAME
  8035. SCM_PRIMITIVE_GENERIC (scm_sys_asinh, "asinh", 1, 0, 0,
  8036. (SCM z),
  8037. "Compute the inverse hyperbolic sine of @var{z}.")
  8038. #define FUNC_NAME s_scm_sys_asinh
  8039. {
  8040. if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
  8041. return z; /* asinh(exact0) = exact0 */
  8042. else if (scm_is_real (z))
  8043. return scm_from_double (asinh (scm_to_double (z)));
  8044. else if (scm_is_number (z))
  8045. return scm_log (scm_sum (z,
  8046. scm_sqrt (scm_sum (scm_product (z, z),
  8047. SCM_INUM1))));
  8048. else
  8049. return scm_wta_dispatch_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
  8050. }
  8051. #undef FUNC_NAME
  8052. SCM_PRIMITIVE_GENERIC (scm_sys_acosh, "acosh", 1, 0, 0,
  8053. (SCM z),
  8054. "Compute the inverse hyperbolic cosine of @var{z}.")
  8055. #define FUNC_NAME s_scm_sys_acosh
  8056. {
  8057. if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM1)))
  8058. return SCM_INUM0; /* acosh(exact1) = exact0 */
  8059. else if (scm_is_real (z) && scm_to_double (z) >= 1.0)
  8060. return scm_from_double (acosh (scm_to_double (z)));
  8061. else if (scm_is_number (z))
  8062. return scm_log (scm_sum (z,
  8063. scm_sqrt (scm_difference (scm_product (z, z),
  8064. SCM_INUM1))));
  8065. else
  8066. return scm_wta_dispatch_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
  8067. }
  8068. #undef FUNC_NAME
  8069. SCM_PRIMITIVE_GENERIC (scm_sys_atanh, "atanh", 1, 0, 0,
  8070. (SCM z),
  8071. "Compute the inverse hyperbolic tangent of @var{z}.")
  8072. #define FUNC_NAME s_scm_sys_atanh
  8073. {
  8074. if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
  8075. return z; /* atanh(exact0) = exact0 */
  8076. else if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0)
  8077. return scm_from_double (atanh (scm_to_double (z)));
  8078. else if (scm_is_number (z))
  8079. return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1, z),
  8080. scm_difference (SCM_INUM1, z))),
  8081. SCM_I_MAKINUM (2));
  8082. else
  8083. return scm_wta_dispatch_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
  8084. }
  8085. #undef FUNC_NAME
  8086. SCM
  8087. scm_c_make_rectangular (double re, double im)
  8088. {
  8089. SCM z;
  8090. z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex),
  8091. "complex"));
  8092. SCM_SET_CELL_TYPE (z, scm_tc16_complex);
  8093. SCM_COMPLEX_REAL (z) = re;
  8094. SCM_COMPLEX_IMAG (z) = im;
  8095. return z;
  8096. }
  8097. SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0,
  8098. (SCM real_part, SCM imaginary_part),
  8099. "Return a complex number constructed of the given @var{real_part} "
  8100. "and @var{imaginary_part} parts.")
  8101. #define FUNC_NAME s_scm_make_rectangular
  8102. {
  8103. SCM_ASSERT_TYPE (scm_is_real (real_part), real_part,
  8104. SCM_ARG1, FUNC_NAME, "real");
  8105. SCM_ASSERT_TYPE (scm_is_real (imaginary_part), imaginary_part,
  8106. SCM_ARG2, FUNC_NAME, "real");
  8107. /* Return a real if and only if the imaginary_part is an _exact_ 0 */
  8108. if (scm_is_eq (imaginary_part, SCM_INUM0))
  8109. return real_part;
  8110. else
  8111. return scm_c_make_rectangular (scm_to_double (real_part),
  8112. scm_to_double (imaginary_part));
  8113. }
  8114. #undef FUNC_NAME
  8115. SCM
  8116. scm_c_make_polar (double mag, double ang)
  8117. {
  8118. double s, c;
  8119. /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
  8120. use it on Glibc-based systems that have it (it's a GNU extension). See
  8121. http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
  8122. details. */
  8123. #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
  8124. sincos (ang, &s, &c);
  8125. #else
  8126. s = sin (ang);
  8127. c = cos (ang);
  8128. #endif
  8129. /* If s and c are NaNs, this indicates that the angle is a NaN,
  8130. infinite, or perhaps simply too large to determine its value
  8131. mod 2*pi. However, we know something that the floating-point
  8132. implementation doesn't know: We know that s and c are finite.
  8133. Therefore, if the magnitude is zero, return a complex zero.
  8134. The reason we check for the NaNs instead of using this case
  8135. whenever mag == 0.0 is because when the angle is known, we'd
  8136. like to return the correct kind of non-real complex zero:
  8137. +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
  8138. on which quadrant the angle is in.
  8139. */
  8140. if (SCM_UNLIKELY (isnan(s)) && isnan(c) && (mag == 0.0))
  8141. return scm_c_make_rectangular (0.0, 0.0);
  8142. else
  8143. return scm_c_make_rectangular (mag * c, mag * s);
  8144. }
  8145. SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0,
  8146. (SCM mag, SCM ang),
  8147. "Return the complex number @var{mag} * e^(i * @var{ang}).")
  8148. #define FUNC_NAME s_scm_make_polar
  8149. {
  8150. SCM_ASSERT_TYPE (scm_is_real (mag), mag, SCM_ARG1, FUNC_NAME, "real");
  8151. SCM_ASSERT_TYPE (scm_is_real (ang), ang, SCM_ARG2, FUNC_NAME, "real");
  8152. /* If mag is exact0, return exact0 */
  8153. if (scm_is_eq (mag, SCM_INUM0))
  8154. return SCM_INUM0;
  8155. /* Return a real if ang is exact0 */
  8156. else if (scm_is_eq (ang, SCM_INUM0))
  8157. return mag;
  8158. else
  8159. return scm_c_make_polar (scm_to_double (mag), scm_to_double (ang));
  8160. }
  8161. #undef FUNC_NAME
  8162. SCM_PRIMITIVE_GENERIC (scm_real_part, "real-part", 1, 0, 0,
  8163. (SCM z),
  8164. "Return the real part of the number @var{z}.")
  8165. #define FUNC_NAME s_scm_real_part
  8166. {
  8167. if (SCM_COMPLEXP (z))
  8168. return scm_from_double (SCM_COMPLEX_REAL (z));
  8169. else if (SCM_I_INUMP (z) || SCM_BIGP (z) || SCM_REALP (z) || SCM_FRACTIONP (z))
  8170. return z;
  8171. else
  8172. return scm_wta_dispatch_1 (g_scm_real_part, z, SCM_ARG1, s_scm_real_part);
  8173. }
  8174. #undef FUNC_NAME
  8175. SCM_PRIMITIVE_GENERIC (scm_imag_part, "imag-part", 1, 0, 0,
  8176. (SCM z),
  8177. "Return the imaginary part of the number @var{z}.")
  8178. #define FUNC_NAME s_scm_imag_part
  8179. {
  8180. if (SCM_COMPLEXP (z))
  8181. return scm_from_double (SCM_COMPLEX_IMAG (z));
  8182. else if (SCM_I_INUMP (z) || SCM_REALP (z) || SCM_BIGP (z) || SCM_FRACTIONP (z))
  8183. return SCM_INUM0;
  8184. else
  8185. return scm_wta_dispatch_1 (g_scm_imag_part, z, SCM_ARG1, s_scm_imag_part);
  8186. }
  8187. #undef FUNC_NAME
  8188. SCM_PRIMITIVE_GENERIC (scm_numerator, "numerator", 1, 0, 0,
  8189. (SCM z),
  8190. "Return the numerator of the number @var{z}.")
  8191. #define FUNC_NAME s_scm_numerator
  8192. {
  8193. if (SCM_I_INUMP (z) || SCM_BIGP (z))
  8194. return z;
  8195. else if (SCM_FRACTIONP (z))
  8196. return SCM_FRACTION_NUMERATOR (z);
  8197. else if (SCM_REALP (z))
  8198. return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
  8199. else
  8200. return scm_wta_dispatch_1 (g_scm_numerator, z, SCM_ARG1, s_scm_numerator);
  8201. }
  8202. #undef FUNC_NAME
  8203. SCM_PRIMITIVE_GENERIC (scm_denominator, "denominator", 1, 0, 0,
  8204. (SCM z),
  8205. "Return the denominator of the number @var{z}.")
  8206. #define FUNC_NAME s_scm_denominator
  8207. {
  8208. if (SCM_I_INUMP (z) || SCM_BIGP (z))
  8209. return SCM_INUM1;
  8210. else if (SCM_FRACTIONP (z))
  8211. return SCM_FRACTION_DENOMINATOR (z);
  8212. else if (SCM_REALP (z))
  8213. return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
  8214. else
  8215. return scm_wta_dispatch_1 (g_scm_denominator, z, SCM_ARG1,
  8216. s_scm_denominator);
  8217. }
  8218. #undef FUNC_NAME
  8219. SCM_PRIMITIVE_GENERIC (scm_magnitude, "magnitude", 1, 0, 0,
  8220. (SCM z),
  8221. "Return the magnitude of the number @var{z}. This is the same as\n"
  8222. "@code{abs} for real arguments, but also allows complex numbers.")
  8223. #define FUNC_NAME s_scm_magnitude
  8224. {
  8225. if (SCM_I_INUMP (z))
  8226. {
  8227. scm_t_inum zz = SCM_I_INUM (z);
  8228. if (zz >= 0)
  8229. return z;
  8230. else if (SCM_POSFIXABLE (-zz))
  8231. return SCM_I_MAKINUM (-zz);
  8232. else
  8233. return scm_i_inum2big (-zz);
  8234. }
  8235. else if (SCM_BIGP (z))
  8236. {
  8237. int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
  8238. scm_remember_upto_here_1 (z);
  8239. if (sgn < 0)
  8240. return scm_i_clonebig (z, 0);
  8241. else
  8242. return z;
  8243. }
  8244. else if (SCM_REALP (z))
  8245. return scm_from_double (fabs (SCM_REAL_VALUE (z)));
  8246. else if (SCM_COMPLEXP (z))
  8247. return scm_from_double (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z)));
  8248. else if (SCM_FRACTIONP (z))
  8249. {
  8250. if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
  8251. return z;
  8252. return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED),
  8253. SCM_FRACTION_DENOMINATOR (z));
  8254. }
  8255. else
  8256. return scm_wta_dispatch_1 (g_scm_magnitude, z, SCM_ARG1,
  8257. s_scm_magnitude);
  8258. }
  8259. #undef FUNC_NAME
  8260. SCM_PRIMITIVE_GENERIC (scm_angle, "angle", 1, 0, 0,
  8261. (SCM z),
  8262. "Return the angle of the complex number @var{z}.")
  8263. #define FUNC_NAME s_scm_angle
  8264. {
  8265. /* atan(0,-1) is pi and it'd be possible to have that as a constant like
  8266. flo0 to save allocating a new flonum with scm_from_double each time.
  8267. But if atan2 follows the floating point rounding mode, then the value
  8268. is not a constant. Maybe it'd be close enough though. */
  8269. if (SCM_I_INUMP (z))
  8270. {
  8271. if (SCM_I_INUM (z) >= 0)
  8272. return flo0;
  8273. else
  8274. return scm_from_double (atan2 (0.0, -1.0));
  8275. }
  8276. else if (SCM_BIGP (z))
  8277. {
  8278. int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
  8279. scm_remember_upto_here_1 (z);
  8280. if (sgn < 0)
  8281. return scm_from_double (atan2 (0.0, -1.0));
  8282. else
  8283. return flo0;
  8284. }
  8285. else if (SCM_REALP (z))
  8286. {
  8287. if (SCM_REAL_VALUE (z) >= 0)
  8288. return flo0;
  8289. else
  8290. return scm_from_double (atan2 (0.0, -1.0));
  8291. }
  8292. else if (SCM_COMPLEXP (z))
  8293. return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z)));
  8294. else if (SCM_FRACTIONP (z))
  8295. {
  8296. if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
  8297. return flo0;
  8298. else return scm_from_double (atan2 (0.0, -1.0));
  8299. }
  8300. else
  8301. return scm_wta_dispatch_1 (g_scm_angle, z, SCM_ARG1, s_scm_angle);
  8302. }
  8303. #undef FUNC_NAME
  8304. SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact, "exact->inexact", 1, 0, 0,
  8305. (SCM z),
  8306. "Convert the number @var{z} to its inexact representation.\n")
  8307. #define FUNC_NAME s_scm_exact_to_inexact
  8308. {
  8309. if (SCM_I_INUMP (z))
  8310. return scm_from_double ((double) SCM_I_INUM (z));
  8311. else if (SCM_BIGP (z))
  8312. return scm_from_double (scm_i_big2dbl (z));
  8313. else if (SCM_FRACTIONP (z))
  8314. return scm_from_double (scm_i_fraction2double (z));
  8315. else if (SCM_INEXACTP (z))
  8316. return z;
  8317. else
  8318. return scm_wta_dispatch_1 (g_scm_exact_to_inexact, z, 1,
  8319. s_scm_exact_to_inexact);
  8320. }
  8321. #undef FUNC_NAME
  8322. SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact, "inexact->exact", 1, 0, 0,
  8323. (SCM z),
  8324. "Return an exact number that is numerically closest to @var{z}.")
  8325. #define FUNC_NAME s_scm_inexact_to_exact
  8326. {
  8327. if (SCM_I_INUMP (z) || SCM_BIGP (z) || SCM_FRACTIONP (z))
  8328. return z;
  8329. else
  8330. {
  8331. double val;
  8332. if (SCM_REALP (z))
  8333. val = SCM_REAL_VALUE (z);
  8334. else if (SCM_COMPLEXP (z) && SCM_COMPLEX_IMAG (z) == 0.0)
  8335. val = SCM_COMPLEX_REAL (z);
  8336. else
  8337. return scm_wta_dispatch_1 (g_scm_inexact_to_exact, z, 1,
  8338. s_scm_inexact_to_exact);
  8339. if (!SCM_LIKELY (DOUBLE_IS_FINITE (val)))
  8340. SCM_OUT_OF_RANGE (1, z);
  8341. else
  8342. {
  8343. mpq_t frac;
  8344. SCM q;
  8345. mpq_init (frac);
  8346. mpq_set_d (frac, val);
  8347. q = scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac)),
  8348. scm_i_mpz2num (mpq_denref (frac)));
  8349. /* When scm_i_make_ratio throws, we leak the memory allocated
  8350. for frac...
  8351. */
  8352. mpq_clear (frac);
  8353. return q;
  8354. }
  8355. }
  8356. }
  8357. #undef FUNC_NAME
  8358. SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0,
  8359. (SCM x, SCM eps),
  8360. "Returns the @emph{simplest} rational number differing\n"
  8361. "from @var{x} by no more than @var{eps}.\n"
  8362. "\n"
  8363. "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
  8364. "exact result when both its arguments are exact. Thus, you might need\n"
  8365. "to use @code{inexact->exact} on the arguments.\n"
  8366. "\n"
  8367. "@lisp\n"
  8368. "(rationalize (inexact->exact 1.2) 1/100)\n"
  8369. "@result{} 6/5\n"
  8370. "@end lisp")
  8371. #define FUNC_NAME s_scm_rationalize
  8372. {
  8373. SCM_ASSERT_TYPE (scm_is_real (x), x, SCM_ARG1, FUNC_NAME, "real");
  8374. SCM_ASSERT_TYPE (scm_is_real (eps), eps, SCM_ARG2, FUNC_NAME, "real");
  8375. eps = scm_abs (eps);
  8376. if (scm_is_false (scm_positive_p (eps)))
  8377. {
  8378. /* eps is either zero or a NaN */
  8379. if (scm_is_true (scm_nan_p (eps)))
  8380. return scm_nan ();
  8381. else if (SCM_INEXACTP (eps))
  8382. return scm_exact_to_inexact (x);
  8383. else
  8384. return x;
  8385. }
  8386. else if (scm_is_false (scm_finite_p (eps)))
  8387. {
  8388. if (scm_is_true (scm_finite_p (x)))
  8389. return flo0;
  8390. else
  8391. return scm_nan ();
  8392. }
  8393. else if (scm_is_false (scm_finite_p (x))) /* checks for both inf and nan */
  8394. return x;
  8395. else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x, eps)),
  8396. scm_ceiling (scm_difference (x, eps)))))
  8397. {
  8398. /* There's an integer within range; we want the one closest to zero */
  8399. if (scm_is_false (scm_less_p (eps, scm_abs (x))))
  8400. {
  8401. /* zero is within range */
  8402. if (SCM_INEXACTP (x) || SCM_INEXACTP (eps))
  8403. return flo0;
  8404. else
  8405. return SCM_INUM0;
  8406. }
  8407. else if (scm_is_true (scm_positive_p (x)))
  8408. return scm_ceiling (scm_difference (x, eps));
  8409. else
  8410. return scm_floor (scm_sum (x, eps));
  8411. }
  8412. else
  8413. {
  8414. /* Use continued fractions to find closest ratio. All
  8415. arithmetic is done with exact numbers.
  8416. */
  8417. SCM ex = scm_inexact_to_exact (x);
  8418. SCM int_part = scm_floor (ex);
  8419. SCM tt = SCM_INUM1;
  8420. SCM a1 = SCM_INUM0, a2 = SCM_INUM1, a = SCM_INUM0;
  8421. SCM b1 = SCM_INUM1, b2 = SCM_INUM0, b = SCM_INUM0;
  8422. SCM rx;
  8423. int i = 0;
  8424. ex = scm_difference (ex, int_part); /* x = x-int_part */
  8425. rx = scm_divide (ex, SCM_UNDEFINED); /* rx = 1/x */
  8426. /* We stop after a million iterations just to be absolutely sure
  8427. that we don't go into an infinite loop. The process normally
  8428. converges after less than a dozen iterations.
  8429. */
  8430. while (++i < 1000000)
  8431. {
  8432. a = scm_sum (scm_product (a1, tt), a2); /* a = a1*tt + a2 */
  8433. b = scm_sum (scm_product (b1, tt), b2); /* b = b1*tt + b2 */
  8434. if (scm_is_false (scm_zero_p (b)) && /* b != 0 */
  8435. scm_is_false
  8436. (scm_gr_p (scm_abs (scm_difference (ex, scm_divide (a, b))),
  8437. eps))) /* abs(x-a/b) <= eps */
  8438. {
  8439. SCM res = scm_sum (int_part, scm_divide (a, b));
  8440. if (SCM_INEXACTP (x) || SCM_INEXACTP (eps))
  8441. return scm_exact_to_inexact (res);
  8442. else
  8443. return res;
  8444. }
  8445. rx = scm_divide (scm_difference (rx, tt), /* rx = 1/(rx - tt) */
  8446. SCM_UNDEFINED);
  8447. tt = scm_floor (rx); /* tt = floor (rx) */
  8448. a2 = a1;
  8449. b2 = b1;
  8450. a1 = a;
  8451. b1 = b;
  8452. }
  8453. scm_num_overflow (s_scm_rationalize);
  8454. }
  8455. }
  8456. #undef FUNC_NAME
  8457. /* conversion functions */
  8458. int
  8459. scm_is_integer (SCM val)
  8460. {
  8461. return scm_is_true (scm_integer_p (val));
  8462. }
  8463. int
  8464. scm_is_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max)
  8465. {
  8466. if (SCM_I_INUMP (val))
  8467. {
  8468. scm_t_signed_bits n = SCM_I_INUM (val);
  8469. return n >= min && n <= max;
  8470. }
  8471. else if (SCM_BIGP (val))
  8472. {
  8473. if (min >= SCM_MOST_NEGATIVE_FIXNUM && max <= SCM_MOST_POSITIVE_FIXNUM)
  8474. return 0;
  8475. else if (min >= LONG_MIN && max <= LONG_MAX)
  8476. {
  8477. if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val)))
  8478. {
  8479. long n = mpz_get_si (SCM_I_BIG_MPZ (val));
  8480. return n >= min && n <= max;
  8481. }
  8482. else
  8483. return 0;
  8484. }
  8485. else
  8486. {
  8487. scm_t_intmax n;
  8488. size_t count;
  8489. if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2)
  8490. > CHAR_BIT*sizeof (scm_t_uintmax))
  8491. return 0;
  8492. mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0,
  8493. SCM_I_BIG_MPZ (val));
  8494. if (mpz_sgn (SCM_I_BIG_MPZ (val)) >= 0)
  8495. {
  8496. if (n < 0)
  8497. return 0;
  8498. }
  8499. else
  8500. {
  8501. n = -n;
  8502. if (n >= 0)
  8503. return 0;
  8504. }
  8505. return n >= min && n <= max;
  8506. }
  8507. }
  8508. else
  8509. return 0;
  8510. }
  8511. int
  8512. scm_is_unsigned_integer (SCM val, scm_t_uintmax min, scm_t_uintmax max)
  8513. {
  8514. if (SCM_I_INUMP (val))
  8515. {
  8516. scm_t_signed_bits n = SCM_I_INUM (val);
  8517. return n >= 0 && ((scm_t_uintmax)n) >= min && ((scm_t_uintmax)n) <= max;
  8518. }
  8519. else if (SCM_BIGP (val))
  8520. {
  8521. if (max <= SCM_MOST_POSITIVE_FIXNUM)
  8522. return 0;
  8523. else if (max <= ULONG_MAX)
  8524. {
  8525. if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val)))
  8526. {
  8527. unsigned long n = mpz_get_ui (SCM_I_BIG_MPZ (val));
  8528. return n >= min && n <= max;
  8529. }
  8530. else
  8531. return 0;
  8532. }
  8533. else
  8534. {
  8535. scm_t_uintmax n;
  8536. size_t count;
  8537. if (mpz_sgn (SCM_I_BIG_MPZ (val)) < 0)
  8538. return 0;
  8539. if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2)
  8540. > CHAR_BIT*sizeof (scm_t_uintmax))
  8541. return 0;
  8542. mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0,
  8543. SCM_I_BIG_MPZ (val));
  8544. return n >= min && n <= max;
  8545. }
  8546. }
  8547. else
  8548. return 0;
  8549. }
  8550. static void
  8551. scm_i_range_error (SCM bad_val, SCM min, SCM max)
  8552. {
  8553. scm_error (scm_out_of_range_key,
  8554. NULL,
  8555. "Value out of range ~S to ~S: ~S",
  8556. scm_list_3 (min, max, bad_val),
  8557. scm_list_1 (bad_val));
  8558. }
  8559. #define TYPE scm_t_intmax
  8560. #define TYPE_MIN min
  8561. #define TYPE_MAX max
  8562. #define SIZEOF_TYPE 0
  8563. #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
  8564. #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
  8565. #include "libguile/conv-integer.i.c"
  8566. #define TYPE scm_t_uintmax
  8567. #define TYPE_MIN min
  8568. #define TYPE_MAX max
  8569. #define SIZEOF_TYPE 0
  8570. #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
  8571. #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
  8572. #include "libguile/conv-uinteger.i.c"
  8573. #define TYPE scm_t_int8
  8574. #define TYPE_MIN SCM_T_INT8_MIN
  8575. #define TYPE_MAX SCM_T_INT8_MAX
  8576. #define SIZEOF_TYPE 1
  8577. #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
  8578. #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
  8579. #include "libguile/conv-integer.i.c"
  8580. #define TYPE scm_t_uint8
  8581. #define TYPE_MIN 0
  8582. #define TYPE_MAX SCM_T_UINT8_MAX
  8583. #define SIZEOF_TYPE 1
  8584. #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
  8585. #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
  8586. #include "libguile/conv-uinteger.i.c"
  8587. #define TYPE scm_t_int16
  8588. #define TYPE_MIN SCM_T_INT16_MIN
  8589. #define TYPE_MAX SCM_T_INT16_MAX
  8590. #define SIZEOF_TYPE 2
  8591. #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
  8592. #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
  8593. #include "libguile/conv-integer.i.c"
  8594. #define TYPE scm_t_uint16
  8595. #define TYPE_MIN 0
  8596. #define TYPE_MAX SCM_T_UINT16_MAX
  8597. #define SIZEOF_TYPE 2
  8598. #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
  8599. #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
  8600. #include "libguile/conv-uinteger.i.c"
  8601. #define TYPE scm_t_int32
  8602. #define TYPE_MIN SCM_T_INT32_MIN
  8603. #define TYPE_MAX SCM_T_INT32_MAX
  8604. #define SIZEOF_TYPE 4
  8605. #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
  8606. #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
  8607. #include "libguile/conv-integer.i.c"
  8608. #define TYPE scm_t_uint32
  8609. #define TYPE_MIN 0
  8610. #define TYPE_MAX SCM_T_UINT32_MAX
  8611. #define SIZEOF_TYPE 4
  8612. #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
  8613. #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
  8614. #include "libguile/conv-uinteger.i.c"
  8615. #define TYPE scm_t_wchar
  8616. #define TYPE_MIN (scm_t_int32)-1
  8617. #define TYPE_MAX (scm_t_int32)0x10ffff
  8618. #define SIZEOF_TYPE 4
  8619. #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
  8620. #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
  8621. #include "libguile/conv-integer.i.c"
  8622. #define TYPE scm_t_int64
  8623. #define TYPE_MIN SCM_T_INT64_MIN
  8624. #define TYPE_MAX SCM_T_INT64_MAX
  8625. #define SIZEOF_TYPE 8
  8626. #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
  8627. #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
  8628. #include "libguile/conv-integer.i.c"
  8629. #define TYPE scm_t_uint64
  8630. #define TYPE_MIN 0
  8631. #define TYPE_MAX SCM_T_UINT64_MAX
  8632. #define SIZEOF_TYPE 8
  8633. #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
  8634. #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
  8635. #include "libguile/conv-uinteger.i.c"
  8636. void
  8637. scm_to_mpz (SCM val, mpz_t rop)
  8638. {
  8639. if (SCM_I_INUMP (val))
  8640. mpz_set_si (rop, SCM_I_INUM (val));
  8641. else if (SCM_BIGP (val))
  8642. mpz_set (rop, SCM_I_BIG_MPZ (val));
  8643. else
  8644. scm_wrong_type_arg_msg (NULL, 0, val, "exact integer");
  8645. }
  8646. SCM
  8647. scm_from_mpz (mpz_t val)
  8648. {
  8649. return scm_i_mpz2num (val);
  8650. }
  8651. int
  8652. scm_is_real (SCM val)
  8653. {
  8654. return scm_is_true (scm_real_p (val));
  8655. }
  8656. int
  8657. scm_is_rational (SCM val)
  8658. {
  8659. return scm_is_true (scm_rational_p (val));
  8660. }
  8661. double
  8662. scm_to_double (SCM val)
  8663. {
  8664. if (SCM_I_INUMP (val))
  8665. return SCM_I_INUM (val);
  8666. else if (SCM_BIGP (val))
  8667. return scm_i_big2dbl (val);
  8668. else if (SCM_FRACTIONP (val))
  8669. return scm_i_fraction2double (val);
  8670. else if (SCM_REALP (val))
  8671. return SCM_REAL_VALUE (val);
  8672. else
  8673. scm_wrong_type_arg_msg (NULL, 0, val, "real number");
  8674. }
  8675. SCM
  8676. scm_from_double (double val)
  8677. {
  8678. SCM z;
  8679. z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
  8680. SCM_SET_CELL_TYPE (z, scm_tc16_real);
  8681. SCM_REAL_VALUE (z) = val;
  8682. return z;
  8683. }
  8684. int
  8685. scm_is_complex (SCM val)
  8686. {
  8687. return scm_is_true (scm_complex_p (val));
  8688. }
  8689. double
  8690. scm_c_real_part (SCM z)
  8691. {
  8692. if (SCM_COMPLEXP (z))
  8693. return SCM_COMPLEX_REAL (z);
  8694. else
  8695. {
  8696. /* Use the scm_real_part to get proper error checking and
  8697. dispatching.
  8698. */
  8699. return scm_to_double (scm_real_part (z));
  8700. }
  8701. }
  8702. double
  8703. scm_c_imag_part (SCM z)
  8704. {
  8705. if (SCM_COMPLEXP (z))
  8706. return SCM_COMPLEX_IMAG (z);
  8707. else
  8708. {
  8709. /* Use the scm_imag_part to get proper error checking and
  8710. dispatching. The result will almost always be 0.0, but not
  8711. always.
  8712. */
  8713. return scm_to_double (scm_imag_part (z));
  8714. }
  8715. }
  8716. double
  8717. scm_c_magnitude (SCM z)
  8718. {
  8719. return scm_to_double (scm_magnitude (z));
  8720. }
  8721. double
  8722. scm_c_angle (SCM z)
  8723. {
  8724. return scm_to_double (scm_angle (z));
  8725. }
  8726. int
  8727. scm_is_number (SCM z)
  8728. {
  8729. return scm_is_true (scm_number_p (z));
  8730. }
  8731. /* Returns log(x * 2^shift) */
  8732. static SCM
  8733. log_of_shifted_double (double x, long shift)
  8734. {
  8735. double ans = log (fabs (x)) + shift * M_LN2;
  8736. if (x > 0.0 || double_is_non_negative_zero (x))
  8737. return scm_from_double (ans);
  8738. else
  8739. return scm_c_make_rectangular (ans, M_PI);
  8740. }
  8741. /* Returns log(n), for exact integer n of integer-length size */
  8742. static SCM
  8743. log_of_exact_integer_with_size (SCM n, long size)
  8744. {
  8745. long shift = size - 2 * scm_dblprec[0];
  8746. if (shift > 0)
  8747. return log_of_shifted_double
  8748. (scm_to_double (scm_ash (n, scm_from_long(-shift))),
  8749. shift);
  8750. else
  8751. return log_of_shifted_double (scm_to_double (n), 0);
  8752. }
  8753. /* Returns log(n), for exact integer n */
  8754. static SCM
  8755. log_of_exact_integer (SCM n)
  8756. {
  8757. return log_of_exact_integer_with_size
  8758. (n, scm_to_long (scm_integer_length (n)));
  8759. }
  8760. /* Returns log(n/d), for exact non-zero integers n and d */
  8761. static SCM
  8762. log_of_fraction (SCM n, SCM d)
  8763. {
  8764. long n_size = scm_to_long (scm_integer_length (n));
  8765. long d_size = scm_to_long (scm_integer_length (d));
  8766. if (abs (n_size - d_size) > 1)
  8767. return (scm_difference (log_of_exact_integer_with_size (n, n_size),
  8768. log_of_exact_integer_with_size (d, d_size)));
  8769. else if (scm_is_false (scm_negative_p (n)))
  8770. return scm_from_double
  8771. (log1p (scm_to_double (scm_divide2real (scm_difference (n, d), d))));
  8772. else
  8773. return scm_c_make_rectangular
  8774. (log1p (scm_to_double (scm_divide2real
  8775. (scm_difference (scm_abs (n), d),
  8776. d))),
  8777. M_PI);
  8778. }
  8779. /* In the following functions we dispatch to the real-arg funcs like log()
  8780. when we know the arg is real, instead of just handing everything to
  8781. clog() for instance. This is in case clog() doesn't optimize for a
  8782. real-only case, and because we have to test SCM_COMPLEXP anyway so may as
  8783. well use it to go straight to the applicable C func. */
  8784. SCM_PRIMITIVE_GENERIC (scm_log, "log", 1, 0, 0,
  8785. (SCM z),
  8786. "Return the natural logarithm of @var{z}.")
  8787. #define FUNC_NAME s_scm_log
  8788. {
  8789. if (SCM_COMPLEXP (z))
  8790. {
  8791. #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
  8792. && defined (SCM_COMPLEX_VALUE)
  8793. return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z)));
  8794. #else
  8795. double re = SCM_COMPLEX_REAL (z);
  8796. double im = SCM_COMPLEX_IMAG (z);
  8797. return scm_c_make_rectangular (log (hypot (re, im)),
  8798. atan2 (im, re));
  8799. #endif
  8800. }
  8801. else if (SCM_REALP (z))
  8802. return log_of_shifted_double (SCM_REAL_VALUE (z), 0);
  8803. else if (SCM_I_INUMP (z))
  8804. {
  8805. #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
  8806. if (scm_is_eq (z, SCM_INUM0))
  8807. scm_num_overflow (s_scm_log);
  8808. #endif
  8809. return log_of_shifted_double (SCM_I_INUM (z), 0);
  8810. }
  8811. else if (SCM_BIGP (z))
  8812. return log_of_exact_integer (z);
  8813. else if (SCM_FRACTIONP (z))
  8814. return log_of_fraction (SCM_FRACTION_NUMERATOR (z),
  8815. SCM_FRACTION_DENOMINATOR (z));
  8816. else
  8817. return scm_wta_dispatch_1 (g_scm_log, z, 1, s_scm_log);
  8818. }
  8819. #undef FUNC_NAME
  8820. SCM_PRIMITIVE_GENERIC (scm_log10, "log10", 1, 0, 0,
  8821. (SCM z),
  8822. "Return the base 10 logarithm of @var{z}.")
  8823. #define FUNC_NAME s_scm_log10
  8824. {
  8825. if (SCM_COMPLEXP (z))
  8826. {
  8827. /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
  8828. clog() and a multiply by M_LOG10E, rather than the fallback
  8829. log10+hypot+atan2.) */
  8830. #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
  8831. && defined SCM_COMPLEX_VALUE
  8832. return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z)));
  8833. #else
  8834. double re = SCM_COMPLEX_REAL (z);
  8835. double im = SCM_COMPLEX_IMAG (z);
  8836. return scm_c_make_rectangular (log10 (hypot (re, im)),
  8837. M_LOG10E * atan2 (im, re));
  8838. #endif
  8839. }
  8840. else if (SCM_REALP (z) || SCM_I_INUMP (z))
  8841. {
  8842. #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
  8843. if (scm_is_eq (z, SCM_INUM0))
  8844. scm_num_overflow (s_scm_log10);
  8845. #endif
  8846. {
  8847. double re = scm_to_double (z);
  8848. double l = log10 (fabs (re));
  8849. if (re > 0.0 || double_is_non_negative_zero (re))
  8850. return scm_from_double (l);
  8851. else
  8852. return scm_c_make_rectangular (l, M_LOG10E * M_PI);
  8853. }
  8854. }
  8855. else if (SCM_BIGP (z))
  8856. return scm_product (flo_log10e, log_of_exact_integer (z));
  8857. else if (SCM_FRACTIONP (z))
  8858. return scm_product (flo_log10e,
  8859. log_of_fraction (SCM_FRACTION_NUMERATOR (z),
  8860. SCM_FRACTION_DENOMINATOR (z)));
  8861. else
  8862. return scm_wta_dispatch_1 (g_scm_log10, z, 1, s_scm_log10);
  8863. }
  8864. #undef FUNC_NAME
  8865. SCM_PRIMITIVE_GENERIC (scm_exp, "exp", 1, 0, 0,
  8866. (SCM z),
  8867. "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
  8868. "base of natural logarithms (2.71828@dots{}).")
  8869. #define FUNC_NAME s_scm_exp
  8870. {
  8871. if (SCM_COMPLEXP (z))
  8872. {
  8873. #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
  8874. && defined (SCM_COMPLEX_VALUE)
  8875. return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z)));
  8876. #else
  8877. return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)),
  8878. SCM_COMPLEX_IMAG (z));
  8879. #endif
  8880. }
  8881. else if (SCM_NUMBERP (z))
  8882. {
  8883. /* When z is a negative bignum the conversion to double overflows,
  8884. giving -infinity, but that's ok, the exp is still 0.0. */
  8885. return scm_from_double (exp (scm_to_double (z)));
  8886. }
  8887. else
  8888. return scm_wta_dispatch_1 (g_scm_exp, z, 1, s_scm_exp);
  8889. }
  8890. #undef FUNC_NAME
  8891. SCM_DEFINE (scm_i_exact_integer_sqrt, "exact-integer-sqrt", 1, 0, 0,
  8892. (SCM k),
  8893. "Return two exact non-negative integers @var{s} and @var{r}\n"
  8894. "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
  8895. "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
  8896. "An error is raised if @var{k} is not an exact non-negative integer.\n"
  8897. "\n"
  8898. "@lisp\n"
  8899. "(exact-integer-sqrt 10) @result{} 3 and 1\n"
  8900. "@end lisp")
  8901. #define FUNC_NAME s_scm_i_exact_integer_sqrt
  8902. {
  8903. SCM s, r;
  8904. scm_exact_integer_sqrt (k, &s, &r);
  8905. return scm_values (scm_list_2 (s, r));
  8906. }
  8907. #undef FUNC_NAME
  8908. void
  8909. scm_exact_integer_sqrt (SCM k, SCM *sp, SCM *rp)
  8910. {
  8911. if (SCM_LIKELY (SCM_I_INUMP (k)))
  8912. {
  8913. scm_t_inum kk = SCM_I_INUM (k);
  8914. scm_t_inum uu = kk;
  8915. scm_t_inum ss;
  8916. if (SCM_LIKELY (kk > 0))
  8917. {
  8918. do
  8919. {
  8920. ss = uu;
  8921. uu = (ss + kk/ss) / 2;
  8922. } while (uu < ss);
  8923. *sp = SCM_I_MAKINUM (ss);
  8924. *rp = SCM_I_MAKINUM (kk - ss*ss);
  8925. }
  8926. else if (SCM_LIKELY (kk == 0))
  8927. *sp = *rp = SCM_INUM0;
  8928. else
  8929. scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
  8930. "exact non-negative integer");
  8931. }
  8932. else if (SCM_LIKELY (SCM_BIGP (k)))
  8933. {
  8934. SCM s, r;
  8935. if (mpz_sgn (SCM_I_BIG_MPZ (k)) < 0)
  8936. scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
  8937. "exact non-negative integer");
  8938. s = scm_i_mkbig ();
  8939. r = scm_i_mkbig ();
  8940. mpz_sqrtrem (SCM_I_BIG_MPZ (s), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (k));
  8941. scm_remember_upto_here_1 (k);
  8942. *sp = scm_i_normbig (s);
  8943. *rp = scm_i_normbig (r);
  8944. }
  8945. else
  8946. scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
  8947. "exact non-negative integer");
  8948. }
  8949. SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0,
  8950. (SCM z),
  8951. "Return the square root of @var{z}. Of the two possible roots\n"
  8952. "(positive and negative), the one with positive real part\n"
  8953. "is returned, or if that's zero then a positive imaginary part.\n"
  8954. "Thus,\n"
  8955. "\n"
  8956. "@example\n"
  8957. "(sqrt 9.0) @result{} 3.0\n"
  8958. "(sqrt -9.0) @result{} 0.0+3.0i\n"
  8959. "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
  8960. "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
  8961. "@end example")
  8962. #define FUNC_NAME s_scm_sqrt
  8963. {
  8964. if (SCM_COMPLEXP (z))
  8965. {
  8966. #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
  8967. && defined SCM_COMPLEX_VALUE
  8968. return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z)));
  8969. #else
  8970. double re = SCM_COMPLEX_REAL (z);
  8971. double im = SCM_COMPLEX_IMAG (z);
  8972. return scm_c_make_polar (sqrt (hypot (re, im)),
  8973. 0.5 * atan2 (im, re));
  8974. #endif
  8975. }
  8976. else if (SCM_NUMBERP (z))
  8977. {
  8978. double xx = scm_to_double (z);
  8979. if (xx < 0)
  8980. return scm_c_make_rectangular (0.0, sqrt (-xx));
  8981. else
  8982. return scm_from_double (sqrt (xx));
  8983. }
  8984. else
  8985. return scm_wta_dispatch_1 (g_scm_sqrt, z, 1, s_scm_sqrt);
  8986. }
  8987. #undef FUNC_NAME
  8988. void
  8989. scm_init_numbers ()
  8990. {
  8991. int i;
  8992. if (scm_install_gmp_memory_functions)
  8993. mp_set_memory_functions (custom_gmp_malloc,
  8994. custom_gmp_realloc,
  8995. custom_gmp_free);
  8996. mpz_init_set_si (z_negative_one, -1);
  8997. /* It may be possible to tune the performance of some algorithms by using
  8998. * the following constants to avoid the creation of bignums. Please, before
  8999. * using these values, remember the two rules of program optimization:
  9000. * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
  9001. scm_c_define ("most-positive-fixnum",
  9002. SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
  9003. scm_c_define ("most-negative-fixnum",
  9004. SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
  9005. scm_add_feature ("complex");
  9006. scm_add_feature ("inexact");
  9007. flo0 = scm_from_double (0.0);
  9008. flo_log10e = scm_from_double (M_LOG10E);
  9009. /* determine floating point precision */
  9010. for (i=2; i <= SCM_MAX_DBL_RADIX; ++i)
  9011. {
  9012. init_dblprec(&scm_dblprec[i-2],i);
  9013. init_fx_radix(fx_per_radix[i-2],i);
  9014. }
  9015. #ifdef DBL_DIG
  9016. /* hard code precision for base 10 if the preprocessor tells us to... */
  9017. scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG;
  9018. #endif
  9019. exactly_one_half = scm_divide (SCM_INUM1, SCM_I_MAKINUM (2));
  9020. #include "libguile/numbers.x"
  9021. }
  9022. /*
  9023. Local Variables:
  9024. c-file-style: "gnu"
  9025. End:
  9026. */