123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804 |
- // "vsl.c" A C Norman, 2012-21
- //
- // This is a small Lisp system.
- // It should build on almost any computer with a modern C compiler.
- // This code may be used subject to the BSD licence:
- // Copyright (C) 2011-2021, A C Norman
- //
- // Redistribution and use in source and binary forms, with or without
- // modification, are permitted provided that the following conditions are
- // met:
- //
- // * Redistributions of source code must retain the relevant
- // copyright notice, this list of conditions and the following
- // disclaimer.
- // * Redistributions in binary form must reproduce the above
- // copyright notice, this list of conditions and the following
- // disclaimer in the documentation and/or other materials provided
- // with the distribution.
- //
- // THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- // "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- // LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
- // FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- // COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
- // INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
- // BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- // OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
- // ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
- // TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF
- // THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
- // DAMAGE.
- #include <stdio.h>
- #include <string.h>
- #include <stdlib.h>
- #include <ctype.h>
- #include <time.h>
- #include <math.h>
- #include <stdint.h>
- #include <inttypes.h>
- #include <stdarg.h>
- #include <setjmp.h>
- #include <histedit.h>
- static EditLine *elx_e;
- static History *elx_h;
- static HistEvent elx_v;
- // A Lisp item is represented as an integer and the low 3 bits
- // contain tag information that specify how the rest will be used.
- typedef intptr_t LispObject;
- #define TAGBITS 0x7
- #define tagCONS 0 // Traditional Lisp "cons" item.
- #define tagSYMBOL 1 // a symbol.
- #define tagFIXNUM 2 // An immediate integer value (29 or 61 bits).
- #define tagFLOAT 3 // A double-precision number.
- #define tagATOM 4 // Something else that will have a header word.
- #define tagFORWARD 5 // Used during garbage collection.
- #define tagHDR 6 // the header word at the start of an atom .
- #define tagSPARE 7 // not used!
- // Note that in the above I could have used tagATOM to include the case
- // of symbols (aka identifiers) but as an optimisation I choose to make that
- // a special case. I still have one spare code (tagSPARE) that could be
- // used to extend the system.
- // Now I provide macros that test the tag bits. These are all rather obvious!
- #define isCONS(x) (((x) & TAGBITS) == tagCONS)
- #define isSYMBOL(x) (((x) & TAGBITS) == tagSYMBOL)
- #define isFIXNUM(x) (((x) & TAGBITS) == tagFIXNUM)
- #define isFLOAT(x) (((x) & TAGBITS) == tagFLOAT)
- #define isATOM(x) (((x) & TAGBITS) == tagATOM)
- #define isFORWARD(x) (((x) & TAGBITS) == tagFORWARD)
- #define isHDR(x) (((x) & TAGBITS) == tagHDR)
- // In memory CONS cells and FLOATS exist as just 2-word items with all their
- // bits in use. All other sorts of data have a header word at their start. This
- // contains extra information about the exact form of data present
- #define TYPEBITS 0x78
- #define typeSYM 0x00
- #define typeGENSYM 0x08
- #define typeSTRING 0x10
- #define typeVEC 0x18
- #define typeBIGNUM 0x20
- #define typeEQHASH 0x28
- #define typeEQHASHX 0x30
- // Codes 0x38, 0x40, 0x48, 0x50, 0x58, 0x60, 0x68,
- // 0x70 and 0x78 spare!
- #define veclength(h) (((uintptr_t)(h)) >> 7)
- #define packlength(n) ((LispObject)(((uintptr_t)(n)) << 7))
- // Accessor macros the extract fields from LispObjects ...
- #define qcar(x) (((LispObject *)(x))[0])
- #define qcdr(x) (((LispObject *)(x))[1])
- // For all other types I must remove the tagging information before I
- // can use the item as a pointer.
- // An especially important case is that of Symbols. These are the fields that
- // they provide.
- #define qflags(x) (((LispObject *)((x)-tagSYMBOL))[0])
- #define qvalue(x) (((LispObject *)((x)-tagSYMBOL))[1])
- #define qplist(x) (((LispObject *)((x)-tagSYMBOL))[2])
- #define qpname(x) (((LispObject *)((x)-tagSYMBOL))[3])
- #define qdefn(x) (((void **) ((x)-tagSYMBOL))[4])
- #define qlits(x) (((LispObject *)((x)-tagSYMBOL))[5])
- // Bits within the flags field of a symbol. Uses explained later on.
- #define flagTRACED 0x080
- #define flagSPECFORM 0x100
- #define flagMACRO 0x200
- // There are LOTS more bits available for flags etc here if needbe!
- // Other atoms have a header that gives info about them. Well as a special
- // case I will allow that something tagged with tagATOM but with zero as
- // its address is a special marker value...
- #define NULLATOM (tagATOM + 0)
- #define qheader(x) (((LispObject *)((x)-tagATOM))[0])
- // Fixnums and Floating point numbers are rather easy!
- #define qfixnum(x) (((intptr_t)(x) - tagFIXNUM) / 8)
- #define packfixnum(n) ((LispObject)((((uintptr_t)(n)) << 3) + tagFIXNUM))
- #define MIN_FIXNUM qfixnum((INTPTR_MIN & (-(uintptr_t)7u)) | tagFIXNUM)
- #define MAX_FIXNUM qfixnum((INTPTR_MAX & (-(uintptr_t)7u)) | tagFIXNUM)
- #define qfloat(x) (((double *)((x)-tagFLOAT))[0])
- #define isBIGNUM(x) (isATOM(x) && ((qheader(x) & TYPEBITS) == typeBIGNUM))
- #define qint64(x) (*(int64_t *)((x) - tagATOM + 8))
- #define isSTRING(x) (isATOM(x) && ((qheader(x) & TYPEBITS) == typeSTRING))
- #define qstring(x) ((char *)((x) - tagATOM + sizeof(LispObject)))
- #define isVEC(x) (isATOM(x) && ((qheader(x) & TYPEBITS) == typeVEC))
- #define isEQHASH(x) (isATOM(x) && ((qheader(x) & TYPEBITS) == typeEQHASH))
- #define isEQHASHX(x) (isATOM(x) && ((qheader(x) & TYPEBITS) == typeEQHASHX))
- // The Lisp heap will have fixed size. Here I make it 64 Mbytes which should
- // fit comfortable on a Raspberry Pi but will also be ample for many serious
- // applications. On a 64-bit machine twice as much memory will be used.
- #ifndef MEM
- #define MEM 16
- #endif
- #define HEAPSIZE (MEM*1024*1024*sizeof(LispObject))
- #define STACKSIZE (256*1024*sizeof(LispObject))
- // I force sizes to be multiples of some power of 2 mostly because I view
- // it as tidy, but in part to guarantee alignment of addresses.
- #define ROUNDED_HEAPSIZE ((HEAPSIZE+0xfff) & ~0xfff)
- #define ROUNDED_STACKSIZE ((STACKSIZE+0xfff) & ~0xfff)
- #define BITMAPSIZE (ROUNDED_HEAPSIZE/128)
- LispObject stackbase, *sp, stacktop;
- // I should probably arrange to check for stack overflow here.
- #define push(x) { *sp++ = (x); }
- #define TOS (sp[-1])
- #define pop(x) { (x) = *--sp; }
- #define push2(x, y) { push(x); push(y); }
- #define pop2(y, x) { pop(y); pop(x); }
- #define push3(x, y, z) { push(x); push(y); push(z); }
- #define pop3(z, y, x) { pop(z); pop(y); pop(x); }
- #define discard(n) { sp -= (n); }
- // This sets the size of the hash table used to store all the symbols
- // that Lisp knows about. I note that if I built a serious application
- // such as the Reduce algebra system (reduce-algebra.sourceforge.net) I would
- // end up with around 7000 symbols in a basic installation! So the size
- // table I use here intended to give decent performance out to that scale.
- #define OBHASH_SIZE 11213
- // Some Lisp values that I will use frequently...
- #define nil bases[ 0]
- #define undefined bases[ 1]
- #define lisptrue bases[ 2]
- #define lispsystem bases[ 3]
- #define echo bases[ 4]
- #define lambda bases[ 5]
- #define function bases[ 6]
- #define quote bases[ 7]
- #define backquote bases[ 8]
- #define comma bases[ 9]
- #define comma_at bases[10]
- #define comma_dot bases[11]
- #define eofsym bases[12]
- #define cursym bases[13]
- #define work1 bases[14]
- #define work2 bases[15]
- #define restartfn bases[16]
- #define expr bases[17]
- #define subr bases[18]
- #define fexpr bases[19]
- #define fsubr bases[20]
- #define macro bases[21]
- #define input bases[22]
- #define output bases[23]
- #define pipe bases[24]
- #define raise bases[25]
- #define lower bases[26]
- #define dfprint bases[27]
- #define bignum bases[28]
- #define charvalue bases[29]
- #define toploopeval bases[30]
- #define loseflag bases[31]
- #define condsymbol bases[32]
- #define prognsymbol bases[33]
- #define gosymbol bases[34]
- #define returnsymbol bases[35]
- #ifdef PSL
- #define dummyvar bases[36]
- #endif
- #define BASES_SIZE 37
- LispObject bases[BASES_SIZE];
- LispObject obhash[OBHASH_SIZE];
- // ... and non-LispObject values that need to be saved as part of a
- // heap image.
- #define headerword nonbases[0]
- #define heap1base nonbases[1]
- #define heap1top nonbases[2]
- #define fringe1 nonbases[3]
- #define fpfringe1 nonbases[4]
- #define saveinterp nonbases[5]
- #define saveinterpspec nonbases[6]
- #define NONBASES_SIZE 7
- LispObject nonbases[NONBASES_SIZE];
- LispObject heap2base, heap2top, fringe2, fpfringe2, bitmap;
- // allocate memory for the heap... to be done once at the start of a run.
- void allocateheap()
- { void *pool = (void *)
- malloc(ROUNDED_HEAPSIZE+BITMAPSIZE+ROUNDED_STACKSIZE+16);
- if (pool == NULL)
- { printf("Not enough memory available: Unable to proceed\n");
- exit(1);
- }
- heap1base = (LispObject)pool;
- heap1base = (heap1base + 7) & ~7; // ensure alignment
- heap1top = heap2base = heap1base + (ROUNDED_HEAPSIZE/2);
- heap2top = heap2base + (ROUNDED_HEAPSIZE/2);
- fringe1 = heap1base;
- fpfringe1 = heap1top;
- fringe2 = heap2base;
- fpfringe2 = heap2top;
- stackbase = heap2top;
- stacktop = stackbase + ROUNDED_STACKSIZE;
- bitmap = stacktop;
- }
- // Now I have enough to let me define various allocation functions.
- extern void reclaim();
- LispObject cons(LispObject a, LispObject b)
- {
- if (fringe1 >= fpfringe1)
- { push2(a, b);
- reclaim();
- pop2(b, a);
- }
- qcar(fringe1) = a;
- qcdr(fringe1) = b;
- a = fringe1;
- fringe1 += 2*sizeof(LispObject);
- return a;
- }
- LispObject list2star(LispObject a, LispObject b, LispObject c)
- { // (cons a (cons b c))
- if (fringe1 + 2*sizeof(LispObject) >= fpfringe1)
- { push3(a, b, c);
- reclaim();
- pop3(c, b, a);
- }
- qcar(fringe1) = a;
- qcdr(fringe1) = fringe1 + 2*sizeof(LispObject);
- a = fringe1;
- fringe1 += 2*sizeof(LispObject);
- qcar(fringe1) = b;
- qcdr(fringe1) = c;
- fringe1 += 2*sizeof(LispObject);
- return a;
- }
- LispObject acons(LispObject a, LispObject b, LispObject c)
- { // (cons (cons a b) c)
- if (fringe1 + 2*sizeof(LispObject) >= fpfringe1)
- { push3(a, b, c);
- reclaim();
- pop3(c, b, a);
- }
- qcar(fringe1) = fringe1 + 2*sizeof(LispObject);
- qcdr(fringe1) = c;
- c = fringe1;
- fringe1 += 2*sizeof(LispObject);
- qcar(fringe1) = a;
- qcdr(fringe1) = b;
- fringe1 += 2*sizeof(LispObject);
- return c;
- }
- LispObject boxfloat(double a)
- { LispObject r;
- if (fringe1 >= fpfringe1) reclaim();
- fpfringe1 -= sizeof(double);
- r = fpfringe1 + tagFLOAT;
- qfloat(r) = a;
- return r;
- }
- // The code here does not fill in ANY of the fields within the symbol. That
- // needs to be done promptly.
- LispObject allocatesymbol()
- { LispObject r;
- if (fringe1 + 4*sizeof(LispObject) >= fpfringe1) reclaim();
- r = fringe1 + tagSYMBOL;
- qflags(r) = tagHDR + typeSYM;
- fringe1 += 6*sizeof(LispObject);
- return r;
- }
- // This one allocates an atom that is n bytes long (plus its header
- // word) and again does not fill in ANY of the fields.
- LispObject allocateatom(int n)
- { LispObject r;
- if (fringe1 + n*sizeof(LispObject) >= fpfringe1) reclaim();
- r = fringe1 + tagATOM;
- // The actual amount of space allocated must include a word for the
- // header and must then be rounded up to be a multiple of 8.
- n = (n + sizeof(LispObject) + 7) & ~7;
- fringe1 += n;
- return r;
- }
- LispObject makestring(const char *s, int len)
- { LispObject r = allocateatom(len);
- qheader(r) = tagHDR + typeSTRING + packlength(len);
- memcpy(qstring(r), s, len);
- return r;
- }
- #define elt(v, n) (((LispObject *)((v) - tagATOM + sizeof(LispObject)))[n])
- LispObject makevector(int maxindex)
- { int len = (maxindex+1)*sizeof(LispObject);
- LispObject r = allocateatom(len);
- int i;
- qheader(r) = tagHDR + typeVEC + packlength(len);
- for (i=0; i<=maxindex; i++) elt(r, i) = nil;
- return r;
- }
- LispObject boxint64(int64_t a)
- { LispObject r = allocateatom(16);
- qheader(r) = tagHDR + typeBIGNUM + packlength(16);
- qint64(r) = a;
- return r;
- }
- void disaster(int line)
- { printf("\nInternal inconsistency detected on line %d\n", line);
- printf("Unable to continue. Apologies.\n");
- abort();
- }
- extern LispObject error1(const char *msg, LispObject data);
- // I will try to have a general macro that will help me with bringing
- // everything to consistent numeric types - ie I can start off with a
- // mix of fixnums, bignums and floats. The strategy here is that if either
- // args is a float then the other is forced to that, and then for all sorts
- // of pure integer work everything will be done as int64_t
- #define NUMOP(name, a, b) \
- if (isFLOAT(a)) \
- { if (isFLOAT(b)) return FF(qfloat(a), qfloat(b)); \
- else if (isFIXNUM(b)) return FF(qfloat(a), (double)qfixnum(b)); \
- else if (isBIGNUM(b)) return FF(qfloat(a), (double)qint64(b)); \
- else return error1("Bad argument for " name, b); \
- } \
- else if (isBIGNUM(a)) \
- { if (isFLOAT(b)) return FF((double)qint64(a), qfloat(b)); \
- else if (isFIXNUM(b)) return BB(qint64(a), (int64_t)qfixnum(b)); \
- else if (isBIGNUM(b)) return BB(qint64(a), qint64(b)); \
- else return error1("Bad argument for " name, b); \
- } \
- else if (isFIXNUM(a)) \
- { if (isFLOAT(b)) return FF((double)qfixnum(a), qfloat(b)); \
- else if (isFIXNUM(b)) return BB((int64_t)qfixnum(a), \
- (int64_t)qfixnum(b)); \
- else if (isBIGNUM(b)) return BB((int64_t)qfixnum(a), qint64(b)); \
- else return error1("Bad argument for " name, b); \
- } \
- else return error1("Bad argument for " name, a)
- #define UNARYOP(name, a) \
- if (isFIXNUM(a)) return BB((int64_t)qfixnum(a)); \
- else if (isFLOAT(a)) return FF(qfloat(a)); \
- else if (isBIGNUM(a)) return BB(qint64(a)); \
- else return error1("Bad argument for " name, a)
- // Similar, but only supporting integer (not floating point) values
- #define INTOP(name, a, b) \
- if (isBIGNUM(a)) \
- { if (isFIXNUM(b)) return BB(qint64(a), (int64_t)qfixnum(b)); \
- else if (isBIGNUM(b)) return BB(qint64(a), qint64(b)); \
- else return error1("Bad argument for " name, b); \
- } \
- else if (isFIXNUM(a)) \
- { if (isFIXNUM(b)) return BB((int64_t)qfixnum(a), \
- (int64_t)qfixnum(b)); \
- else if (isBIGNUM(b)) return BB((int64_t)qfixnum(a), qint64(b)); \
- else return error1("Bad argument for " name, b); \
- } \
- else return error1("Bad argument for " name, a)
- #define UNARYINTOP(name, a) \
- if (isFIXNUM(a)) return BB((int64_t)qfixnum(a)); \
- else if (isBIGNUM(a)) return BB(qint64(a)); \
- else return error1("Bad argument for " name, a)
- // This takes an arbitrary 64-bit integer and returns either a fixnum
- // or a bignum as necessary.
- LispObject makeinteger(int64_t a)
- { if (a >= MIN_FIXNUM && a <= MAX_FIXNUM) return packfixnum(a);
- else return boxint64(a);
- }
- #undef FF
- #undef BB
- #define FF(a) boxfloat(-(a))
- #define BB(a) makeinteger(-(a))
- LispObject Nminus(LispObject a)
- { UNARYOP("minus", a);
- }
- #undef FF
- #undef BB
- #define FF(a, b) boxfloat((a) + (b))
- #define BB(a, b) makeinteger((a) + (b))
- LispObject Nplus2(LispObject a, LispObject b)
- { NUMOP("plus", a, b);
- }
- #undef FF
- #undef BB
- #define FF(a, b) boxfloat((a) * (b))
- #define BB(a, b) makeinteger((a) * (b))
- LispObject Ntimes2(LispObject a, LispObject b)
- { NUMOP("times", a, b);
- }
- #undef BB
- #define BB(a, b) makeinteger((a) & (b))
- LispObject Nlogand2(LispObject a, LispObject b)
- { INTOP("logand", a, b);
- }
- #undef BB
- #define BB(a, b) makeinteger((a) | (b))
- LispObject Nlogor2(LispObject a, LispObject b)
- { INTOP("logor", a, b);
- }
- #undef BB
- #define BB(a, b) makeinteger((a) ^ (b))
- LispObject Nlogxor2(LispObject a, LispObject b)
- { INTOP("logxor", a, b);
- }
- #undef FF
- #undef BB
- #define BOFFO_SIZE 4096
- char boffo[BOFFO_SIZE+4];
- int boffop;
- #define swap(a,b) w = (a); (a) = (b); (b) = w;
- extern LispObject copy(LispObject x);
- int gccount = 1;
- void reclaim()
- {
- // The strategy here is due to C J Cheyney ("A Nonrecursive List Compacting
- // Algorithm". Communications of the ACM 13 (11): 677-678, 1970).
- LispObject *s, w;
- printf("+++ GC number %d", gccount++);
- // I need to clear the part of the bitmap that could be relevant for floating
- // point values.
- int o = (fpfringe1 - heap1base)/(8*8);
- while (o < BITMAPSIZE) ((unsigned char *)bitmap)[o++] = 0;
- // Process everything that is on the stack.
- for (s=(LispObject *)stackbase; s<sp; s++) *s = copy(*s);
- // I should also copy any other list base values here.
- for (o=0; o<BASES_SIZE; o++) bases[o] = copy(bases[o]);
- for (o=0; o<OBHASH_SIZE; o++)
- obhash[o] = copy(obhash[o]);
- // Now perform the second part of Cheyney's algorithm, scanning the
- // data that has been put in the new heap.
- s = (LispObject *)heap2base;
- while ((LispObject)s != fringe2)
- { LispObject h = *s;
- if (!isHDR(h)) // The item to be processed is a simple cons cell
- { *s++ = copy(h);
- *s = copy(*s);
- s++;
- }
- else // The item is one that uses a header
- switch (h & TYPEBITS)
- { case typeSYM:
- case typeGENSYM:
- w = ((LispObject)s) + tagSYMBOL;
- // qflags(w) does not need adjusting
- qvalue(w) = copy(qvalue(w));
- qplist(w) = copy(qplist(w));
- qpname(w) = copy(qpname(w));
- // qdefn(w) does not need adjusting
- qlits(w) = copy(qlits(w));
- s += 6;
- continue;
- case typeSTRING:
- case typeBIGNUM:
- // These only contain binary information, so none of their content needs
- // any more processing.
- w = (sizeof(LispObject) + veclength(h) + 7) & ~7;
- s += w/sizeof(LispObject);
- continue;
- case typeVEC:
- case typeEQHASH:
- case typeEQHASHX:
- // These are to be processed the same way. They contain a bunch of
- // reference items.
- s++; // Past the header
- w = veclength(h);
- while (w > 0)
- { *s = copy(*s);
- s++;
- w -= sizeof(LispObject);
- }
- w = (LispObject)s;
- w = (w + 7) & ~7;
- s = (LispObject *)w;
- continue;
- default:
- // all the "spare" codes!
- disaster(__LINE__);
- }
- }
- // Finally flip the two heaps ready for next time.
- swap(heap1base, heap2base);
- swap(heap1top, heap2top);
- fringe1 = fringe2;
- fpfringe1 = fpfringe2;
- fringe2 = heap2base;
- fpfringe2 = heap2top;
- printf(" - collection complete (%" PRIu64 " Kbytes free)\n",
- ((uint64_t)(fpfringe1-fringe1))/1024);
- if (fpfringe1 - fringe1 < 1000*sizeof(LispObject))
- { printf("\nRun out of memory.\n");
- exit(1);
- }
- fflush(stdout);
- }
- LispObject copy(LispObject x)
- { LispObject h;
- int o, b;
- switch (x & TAGBITS)
- { case tagCONS:
- if (x == 0) disaster(__LINE__);
- h = *((LispObject *)x);
- if (isFORWARD(h)) return (h - tagFORWARD);
- qcar(fringe2) = h;
- qcdr(fringe2) = qcdr(x);
- h = fringe2;
- qcar(x) = tagFORWARD + h;
- fringe2 += 2*sizeof(LispObject);
- return h;
- case tagSYMBOL:
- h = *((LispObject *)(x - tagSYMBOL));
- if (isFORWARD(h)) return (h - tagFORWARD + tagSYMBOL);
- if (!isHDR(h)) disaster(__LINE__);
- h = fringe2 + tagSYMBOL;
- qflags(h) = qflags(x);
- qvalue(h) = qvalue(x);
- qplist(h) = qplist(x);
- qpname(h) = qpname(x);
- qdefn(h) = qdefn(x);
- qlits(h) = qlits(x);
- fringe2 += 6*sizeof(LispObject);
- qflags(x) = h - tagSYMBOL + tagFORWARD;
- return h;
- case tagATOM:
- if (x == NULLATOM) return x; // special case!
- h = qheader(x);
- if (isFORWARD(h)) return (h - tagFORWARD + tagATOM);
- if (!isHDR(h)) disaster(__LINE__);
- switch (h & TYPEBITS)
- { case typeEQHASH:
- // When a hash table is copied its header is changes to EQHASHX, which
- // indicates that it will need rehashing before further use.
- h ^= (typeEQHASH ^ typeEQHASHX);
- case typeEQHASHX:
- case typeSTRING:
- case typeVEC:
- case typeBIGNUM:
- o = (int)veclength(h); // number of bytes excluding the header
- *((LispObject *)fringe2) = h; // copy header word across
- h = fringe2 + tagATOM;
- *((LispObject *)(x - tagATOM)) = fringe2 + tagFORWARD;
- fringe2 += sizeof(LispObject);
- x = x - tagATOM + sizeof(LispObject);
- while (o > 0)
- { *((LispObject *)fringe2) = *((LispObject *)x);
- fringe2 += sizeof(LispObject);
- x += sizeof(LispObject);
- o -= sizeof(LispObject);
- }
- fringe2 = (fringe2 + 7) & ~7;
- return h;
- default:
- //case typeSYM: case typeGENSYM:
- // also the spare codes!
- disaster(__LINE__);
- }
- case tagFLOAT:
- // every float is 8 bytes wide, regardless of what sort of machine I am on.
- h = (x - tagFLOAT - heap1base)/8;
- o = h/8;
- b = 1 << (h%8);
- // now o is an offset and b a bit in the bitmap.
- if ((((unsigned char *)bitmap)[o] & b) != 0) // marked already.
- return *((LispObject *)(x-tagFLOAT));
- else
- { ((unsigned char *)bitmap)[o] |= b; // mark it now.
- fpfringe2 -= sizeof(double);
- h = fpfringe2 + tagFLOAT;
- qfloat(h) = qfloat(x); // copy the float.
- *((LispObject *)(x-tagFLOAT)) = h; // write in forwarding address.
- return h;
- }
- case tagFIXNUM:
- return x;
- default:
- //case tagFORWARD:
- //case tagHDR:
- disaster(__LINE__);
- return 0; // avoid GCC moans.
- }
- }
- #define printPLAIN 1
- #define printESCAPES 2
- #define printHEX 4
- int linelength = 80, linepos = 0, printflags = printESCAPES;
- #define MAX_LISPFILES 30
- FILE *lispfiles[MAX_LISPFILES];
- int32_t file_direction = 0, interactive = 0;
- int lispin = 0, lispout = 1;
- extern LispObject lookup(const char *s, int n, int createp);
- void wrch(int c)
- {
- if (lispout == -1)
- { char w[4];
- // This bit is for the benefit of explode and explodec
- LispObject r;
- w[0] = c; w[1] = 0;
- r = lookup(w, 1, 1);
- work1 = cons(r, work1);
- }
- else if (lispout == -2) boffo[boffop++] = c;
- else
- { putc(c, lispfiles[lispout]);
- if (c == '\n' || c == '\r')
- { linepos = 0;
- fflush(lispfiles[lispout]);
- }
- else linepos++;
- }
- }
- const char *prompt(EditLine *e)
- { return "> ";
- }
- const char *elx_line = NULL;
- int elx_count = 0;
- int my_getc(FILE *f)
- {
- #ifdef NOLIBEDIT
- // This can help while running under a debugger!
- return getc(f);
- #else
- if (f != stdin) return getc(f);
- if (elx_count == 0)
- { elx_line = el_gets(elx_e, &elx_count);
- if (elx_count <= 0) return EOF;
- if (elx_count > 1 || (elx_line[0] != '\n' && elx_line[0] != '\r'))
- history(elx_h, &elx_v, H_ENTER, elx_line);
- }
- elx_count--;
- return *elx_line++;
- #endif
- }
- int rdch()
- { LispObject w;
- if (lispin == -1)
- { if (!isCONS(work1)) return EOF;
- w = qcar(work1);
- work1 = qcdr(work1);
- if (isSYMBOL(w)) w = qpname(w);
- if (!isSTRING(w)) return EOF;
- return *qstring(w);
- }
- else
- { int c = my_getc(lispfiles[lispin]);
- if (c != EOF && qvalue(echo) != nil) wrch(c);
- return c;
- }
- }
- int gensymcounter = 1;
- void checkspace(int n)
- { if (linepos + n >= linelength && lispout != -1)
- wrch('\n');
- }
- char printbuffer[32];
- extern LispObject call1(const char *name, LispObject a1);
- extern LispObject call2(const char *name, LispObject a1, LispObject a2);
- void internalprint(LispObject x)
- { int sep = '(', i, esc, len;
- char *s;
- LispObject pn;
- switch (x & TAGBITS)
- { case tagCONS:
- if (x == 0) // can only occur in case of bugs here.
- { wrch('#');
- return;
- }
- while (isCONS(x))
- { i = printflags;
- if (qcar(x) == bignum &&
- qcdr(x) != nil &&
- (pn = call1(((printflags & printHEX) ?
- "~big2strhex" :
- "~big2str"), x)) != nil)
- { printflags = printPLAIN;
- internalprint(pn);
- printflags = i;
- return;
- }
- printflags = i;
- checkspace(1);
- if (linepos != 0 || sep != ' ' || lispout < 0) wrch(sep);
- sep = ' ';
- push(x);
- internalprint(qcar(x));
- pop(x);
- x = qcdr(x);
- }
- if (x != nil)
- { checkspace(3);
- wrch(' '); wrch('.'); wrch(' ');
- internalprint(x);
- }
- checkspace(1);
- wrch(')');
- return;
- case tagSYMBOL:
- // gensyms get their print-names allocated when first printed.
- pn = qpname(x);
- if (pn == nil)
- { int len = sprintf(printbuffer, "g%.3d", gensymcounter++);
- push(x);
- pn = makestring(printbuffer, len);
- pop(x);
- qpname(x) = pn;
- }
- len = veclength(qheader(pn));
- s = qstring(pn);
- if ((printflags & printESCAPES) == 0)
- { int i;
- checkspace(len);
- for (i=0; i<len; i++) wrch(s[i]);
- }
- else if (len != 0)
- { esc = 0;
- #ifdef PSL
- if (!(islower((int)s[0]) && qvalue(raise) == nil) &&
- !(isupper((int)s[0]) && qvalue(lower) == nil) &&
- // My implmentation here will fail to put an escape character in front
- // of a symbol named "+1", resulting in it reading back in as an integer.
- // PSL seems to have some sort of input concept of "maybe a number but I can't
- // tell yet" that defers interpretation as between number and symbol until
- // later in the day. So the symbol "1+" is another example of this effect.
- !isdigit((int)s[0]) &&
- s[0]!='!' && s[0]!='+' && s[0]!='-' &&
- s[0]!='$' && s[0]!='^' && s[0]!='&' && s[0]!='*' &&
- s[0]!='_' && s[0]!='=' && s[0]!=';' && s[0]!=':' &&
- s[0]!='@' && s[0]!='#' && s[0]!='~' && s[0]!='<' &&
- s[0]!='>' && s[0]!='/' && s[0]!='?' && s[0]!='\\' &&
- s[0]!='{' && s[0]!='}' && s[0]!='_') esc++;
- #else
- if (!(islower((int)s[0]) && qvalue(raise) == nil)) esc++;
- #endif
- for (i=1; i<len; i++)
- { if (!(islower((int)s[i]) && qvalue(raise) == nil) &&
- !isdigit((int)s[i]) &&
- #ifdef PSL
- !(isupper((int)s[i]) && qvalue(lower) == nil) &&
- s[i]!='!' && s[i]!='+' && s[i]!='-' &&
- s[i]!='$' && s[i]!='^' && s[i]!='&' && s[i]!='*' &&
- s[i]!='_' && s[i]!='=' && s[i]!=';' && s[i]!=':' &&
- s[i]!='@' && s[i]!='#' && s[i]!='~' && s[i]!='<' &&
- s[i]!='>' && s[i]!='/' && s[i]!='?' && s[i]!='\\' &&
- s[i]!='{' && s[i]!='}' &&
- #endif
- s[i]!='_') esc++;
- }
- checkspace(len + esc);
- #ifdef PSL
- if (!(islower((int)s[0]) && qvalue(raise) == nil) &&
- !(isupper((int)s[0]) && qvalue(lower) == nil) &&
- // My implmentation here will fail to put an escape character in front
- // of a symbol named "+1", resulting in it reading back in as an integer.
- // PSL seems to have some sort of input concept of "maybe a number but I can't
- // tell yet" that defers interpretation as between number and symbol until
- // later in the day. So the symbol "1+" is another example of this effect.
- !isdigit((int)s[0]) &&
- s[0]!='!' && s[0]!='+' && s[0]!='-' &&
- s[0]!='$' && s[0]!='^' && s[0]!='&' && s[0]!='*' &&
- s[0]!='_' && s[0]!='=' && s[0]!=';' && s[0]!=':' &&
- s[0]!='@' && s[0]!='#' && s[0]!='~' && s[0]!='<' &&
- s[0]!='>' && s[0]!='/' && s[0]!='?' && s[0]!='\\' &&
- s[0]!='{' && s[0]!='}' && s[0]!='_') wrch('!');
- #else
- if (!(islower((int)s[0]) && qvalue(raise) == nil)) wrch('!');
- #endif
- wrch(s[0]);
- for (i=1; i<len; i++)
- { if (!(islower((int)s[i]) && qvalue(raise) == nil) &&
- !isdigit((int)s[i]) &&
- #ifdef PSL
- !(isupper((int)s[i]) && qvalue(lower) == nil) &&
- s[i]!='!' && s[i]!='+' && s[i]!='-' &&
- s[i]!='$' && s[i]!='^' && s[i]!='&' && s[i]!='*' &&
- s[i]!='_' && s[i]!='=' && s[i]!=';' && s[i]!=':' &&
- s[i]!='@' && s[i]!='#' && s[i]!='~' && s[i]!='<' &&
- s[i]!='>' && s[i]!='/' && s[i]!='?' && s[i]!='\\' &&
- s[i]!='{' && s[i]!='}' &&
- #endif
- s[i]!='_')
- wrch('!');
- wrch(s[i]);
- }
- }
- return;
- case tagATOM:
- if (x == NULLATOM)
- { checkspace(5);
- wrch('#'); wrch('n'); wrch('u'); wrch('l'); wrch('l');
- return;
- }
- else switch (qheader(x) & TYPEBITS)
- { case typeSTRING:
- len = veclength(qheader(x));
- s = qstring(x);
- if ((printflags & printESCAPES) == 0)
- { int i;
- checkspace(len);
- for (i=0; i<len; i++) wrch(s[i]);
- }
- else
- { esc = 2;
- for (i=0; i<len; i++)
- if (s[i] == '"') esc++;
- checkspace(len+esc);
- wrch('"');
- for (i=0; i<len; i++)
- { if (s[i] == '"') wrch('"');
- wrch(s[i]);
- }
- wrch('"');
- }
- return;
- case typeBIGNUM:
- if (printflags & printHEX)
- sprintf(printbuffer, "%" PRIx64, qint64(x));
- else sprintf(printbuffer, "%" PRId64, qint64(x));
- checkspace(len = strlen(printbuffer));
- for (i=0; i<len; i++) wrch(printbuffer[i]);
- return;
- case typeVEC:
- case typeEQHASH:
- case typeEQHASHX:
- sep = '[';
- push(x);
- for (i=0; i<veclength(qheader(TOS))/sizeof(LispObject); i++)
- { checkspace(1);
- wrch(sep);
- sep = ' ';
- internalprint(elt(TOS, i));
- }
- pop(x);
- checkspace(1);
- wrch(']');
- return;
- default:
- //case typeSYM: case typeGENSYM:
- // also the spare codes!
- disaster(__LINE__);
- }
- case tagFLOAT:
- { double d = *((double *)(x - tagFLOAT));
- if (isnan(d)) strcpy(printbuffer, "NaN");
- else if (isfinite(d)) sprintf(printbuffer, "%.14g", d);
- else strcpy(printbuffer, "inf");
- }
- s = printbuffer;
- // The C printing of floating point values is not to my taste, so I (slightly)
- // adjust the output here...
- if (*s == '+' || *s == '-') s++;
- while (isdigit((int)*s)) s++;
- if (*s == 0 || *s == 'e') // No decimal point present!
- { len = strlen(s);
- while (len >= 0) // Move existing text up 2 places
- { s[len+2] = s[len];
- len--;
- }
- s[0] = '.'; s[1] = '0'; // insert ".0"
- }
- checkspace(len = strlen(printbuffer));
- for (i=0; i<len; i++) wrch(printbuffer[i]);
- return;
- case tagFIXNUM:
- if (printflags & printHEX)
- sprintf(printbuffer, "%" PRIx64, (int64_t)qfixnum(x));
- else sprintf(printbuffer, "%" PRId64, (int64_t)qfixnum(x));
- checkspace(len = strlen(printbuffer));
- for (i=0; i<len; i++) wrch(printbuffer[i]);
- return;
- default:
- //case tagFORWARD:
- //case tagHDR:
- disaster(__LINE__);
- }
- }
- LispObject prin(LispObject a)
- { printflags = printESCAPES;
- push(a);
- internalprint(a);
- pop(a);
- return a;
- }
- LispObject princ(LispObject a)
- { printflags = printPLAIN;
- push(a);
- internalprint(a);
- pop(a);
- return a;
- }
- LispObject prinhex(LispObject a)
- { printflags = printESCAPES | printHEX;
- push(a);
- internalprint(a);
- pop(a);
- return a;
- }
- LispObject print(LispObject a)
- { printflags = printESCAPES;
- push(a);
- internalprint(a);
- pop(a);
- wrch('\n');
- return a;
- }
- void errprint(LispObject a)
- { int saveout = lispout, saveflags = printflags;
- lispout = 1; printflags = printESCAPES;
- internalprint(a);
- wrch('\n');
- lispout = saveout; printflags = saveflags;
- }
- LispObject printc(LispObject a)
- { printflags = printPLAIN;
- push(a);
- internalprint(a);
- pop(a);
- wrch('\n');
- return a;
- }
- int curchar = '\n', symtype = 0;
- // This version of hexval will cope with 0-9A-Z to support any radix up to
- // 36. This is for PSL compatibility even though the only sane radix to use
- // will be 16.
- int hexval(int n)
- { if (isdigit(n)) return n - '0';
- else if ('a' <= n && n <= 'z') return n - 'a' + 10;
- else if ('A' <= n && n <= 'Z') return n - 'A' + 10;
- else return -1;
- }
- LispObject token()
- { symtype = 'a'; // Default result is an atom.
- while (1)
- { while (curchar == ' ' ||
- curchar == '\t' ||
- curchar == '\n' ||
- curchar == '\r' ||
- curchar == '\f') curchar = rdch(); // Skip whitespace
- // Discard comments from "%" to end of line.
- if (curchar == '%')
- { while (curchar != '\n' &&
- curchar != '\r' &&
- curchar != '\f' &&
- curchar != EOF) curchar = rdch();
- continue;
- }
- break;
- }
- if (curchar == EOF)
- { symtype = curchar;
- return NULLATOM; // End of file marker.
- }
- if (curchar == '(' || curchar == '.' ||
- curchar == ')' || curchar == '\'' ||
- curchar == '`' || curchar == ',' ||
- curchar == '[' || curchar == ']' ||
- curchar == '#')
- { symtype = curchar; // Lisp special characters.
- curchar = rdch();
- if (symtype == ',' && curchar == '@')
- { symtype = '@';
- curchar = rdch();
- }
- else if (symtype == ',' && curchar == '.')
- { symtype = '.' + 0x100;
- curchar = rdch();
- }
- return NULLATOM;
- }
- boffop = 0;
- #ifdef PSL
- // "words" starting with '+ or '-' are handled later on...
- #define wordstart(c) (isalpha(c) || (c)=='!' || \
- (c)=='$' || (c)=='^' || (c)=='&' || (c)=='*' || \
- (c)=='_' || (c)=='=' || (c)==';' || (c)==':' || \
- (c)=='@' || (c)=='#' || (c)=='~' || (c)=='<' || \
- (c)=='>' || (c)=='/' || (c)=='?' || (c)=='\\' || \
- (c)=='{' || (c)=='}')
- #define constituent(c) (wordstart(c) || isdigit(c) || (c)=='+' || (c)=='-')
- #else
- #define wordstart(c) (isalpha(c) || (c)=='!')
- #define constituent(c) (wordstart(c) || isdigit(c) || (c)=='_')
- #endif
- symbol_after_all:
- if (wordstart(curchar)) // Start a symbol.
- { while (constituent(curchar))
- { if (curchar == '!') curchar = rdch();
- else if (curchar != EOF && qvalue(lower) != nil) curchar = tolower(curchar);
- else if (curchar != EOF && qvalue(raise) != nil) curchar = toupper(curchar);
- if (curchar != EOF)
- { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
- curchar = rdch();
- }
- }
- boffo[boffop] = 0;
- return lookup(boffo, boffop, 1);
- }
- if (curchar == '"') // Start a string
- { curchar = rdch();
- while (1)
- { while (curchar != '"' && curchar != EOF)
- { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
- curchar = rdch();
- }
- // Note that a double-quote can be repeated within a string to denote
- // a string with that character within it. As in
- // "abc""def" is a string with contents abc"def.
- if (curchar != EOF) curchar = rdch();
- if (curchar != '"') break;
- if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
- curchar = rdch();
- }
- return makestring(boffo, boffop);
- }
- if (curchar == '+' || curchar == '-')
- { boffo[boffop++] = curchar;
- curchar = rdch();
- // + and - are treated specially, since if followed by a digit they
- // introduce a (signed) number, but otherwise they are treated as punctuation.
- if (!isdigit(curchar))
- {
- #ifdef PSL
- if (constituent(curchar)) goto symbol_after_all;
- #endif
- boffo[boffop] = 0;
- return lookup(boffo, boffop, 1);
- }
- }
- // Note that in some cases after a + or - I drop through to here.
- if (curchar == '0' && boffop == 0) // "0" without a sign in front
- { boffo[boffop++] = curchar;
- curchar = rdch();
- // I will recognize 0xddddd as a hex number, even though PSL would probably
- // treat it is just a symbol with a funny name.
- if (curchar == 'x' || curchar == 'X') // Ahah - hexadecimal input
- { LispObject r;
- boffop = 0;
- curchar = rdch();
- while (isxdigit(curchar))
- { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
- curchar = rdch();
- }
- if (constituent(curchar)) goto symbol_after_all;
- boffo[boffop] = 0;
- r = packfixnum(0);
- boffop = 0;
- while (boffo[boffop] != 0)
- { r = call2("plus2", call2("times2", packfixnum(16), r),
- packfixnum(hexval(boffo[boffop++])));
- }
- // I will not accept +0xddd or -0xddd as a hex number here.
- return r;
- }
- }
- // Also for PSL-support reasons I will sort out the notation "nnn#mmm" for a
- // number is radix nnn.
- int radix = 0;
- if (isdigit(curchar) || (boffop == 1 && boffo[0] == '0'))
- { while (isdigit(curchar))
- {
- // I will not accept a radix over 36, so when accumularing one I stop at
- // 100 (a randomish limit over 36 but well below overflow).
- if (radix < 100) radix = 10*radix + curchar - '0';
- if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
- curchar = rdch();
- }
- // I may have a number with a specified radix in the PSL style. In such cases
- // the radix must be in the range 2 to 36.
- if (curchar == '#' && radix > 1 && radix <=36)
- { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
- curchar = rdch();
- int dd;
- while ((dd = hexval(curchar))>=0 && dd<radix)
- { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
- curchar = rdch();
- }
- // Now the buffer contains a string of the form "rr#dddddd" where all
- // the digits are legitimate in the specified radix. If the very next
- // character is a constituent then I drop back to treating all this as a
- // symbol.
- if (constituent(curchar)) goto symbol_after_all;
- // Now I KNOW I have an integer with a specified radix. So compute its
- // value.
- boffo[boffop] = 0;
- LispObject r = packfixnum(0);
- boffop = 0;
- while (boffo[boffop] != '#') boffop++;
- boffop++;
- while (boffo[boffop] != 0)
- { r = call2("plus2", call2("times2", packfixnum(radix), r),
- packfixnum(hexval(boffo[boffop++])));
- }
- // I do allow signed numbers with radix such as -8#777
- if (boffo[0]=='-') r = Nminus(r);
- return r;
- }
- // At this point I have a (possibly signed) integer. If it is immediately
- // followed by a "." then a floating point value is indicated.
- else if (curchar == '.')
- { symtype = 'f';
- if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
- curchar = rdch();
- while (isdigit(curchar))
- { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
- curchar = rdch();
- }
- }
- // Whether or not there was a ".", an "e" or "E" introduces an exponent and
- // hence indicates a floating point value.
- if (curchar == 'e' || curchar == 'E')
- { symtype = 'f';
- if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
- curchar = rdch();
- if (curchar == '+' || curchar == '-')
- { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
- curchar = rdch();
- }
- while (isdigit(curchar))
- { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
- curchar = rdch();
- }
- }
- if (constituent(curchar)) goto symbol_after_all;
- boffo[boffop] = 0;
- if (symtype == 'a')
- { int neg = 0;
- LispObject r = packfixnum(0);
- boffop = 0;
- if (boffo[boffop] == '+') boffop++;
- else if (boffo[boffop] == '-') neg=1, boffop++;
- while (boffo[boffop] != 0)
- { r = call2("plus2", call2("times2", packfixnum(10), r),
- packfixnum(boffo[boffop++] - '0'));
- }
- if (neg) r = Nminus(r);
- return r;
- }
- else
- { double d;
- sscanf(boffo, "%lg", &d);
- return boxfloat(d);
- }
- }
- boffo[boffop++] = curchar;
- curchar = rdch();
- boffo[boffop] = 0;
- symtype = 'a';
- return lookup(boffo, boffop, 1);
- }
- extern LispObject Lget(LispObject lits, int nargs, ...);
- LispObject char_function(LispObject a)
- { if (!isSYMBOL(a)) return nil;
- LispObject pn = qpname(a);
- char *s = qstring(pn);
- if (strlen(s) == 1) return packfixnum(s[0]);
- return Lget(nil, 2, a, charvalue);
- }
- // Syntax for Lisp input
- //
- // S ::= name
- // | integer
- // | radix#based-integer
- // | float
- // | string
- // | ' S | ` S | , S | ,@ S | ,. S
- // | #/ char integer code for char
- // | #\ char integer code is char is single character,
- // otherwise NULL, BELL, BACKSPACE, TAB, LF, EOL,
- // FF, CR, EOF, ESC, ESCAPE, SPACE, RUBOUT, RUB,
- // DELETE, DEL, (lower x), (control x), (ctrl x),
- // (meta x). *raise can case-fold x unless ! is used.
- // | #' S
- // | #. S
- // | #+ S S
- // | #- S S
- // | ( T
- // | [ V
- // ;
- //
- // T ::= )
- // | . S )
- // | S T
- // ;
- //
- // V ::= ]
- // | S V
- // ;
- extern LispObject readS();
- extern LispObject readT();
- extern LispObject readV();
- extern LispObject eval(LispObject x);
- LispObject read_hash_macro()
- { LispObject w;
- int c = curchar;
- curchar = rdch();
- switch (c)
- { case '\'': // #'X => (function X)
- cursym = token();
- w = readS();
- return list2star(function, w, nil);
- case '.':
- cursym = token();
- w = readS();
- return eval(w);
- case '+':
- cursym = token();
- w = readS();
- // For now I will suppose that the machine in use is NEVER one of the
- // ones tested fpr. The consequence is that "#+ machine S" always gets
- // ignored.
- (void)readS();
- return readS();
- case '-':
- cursym = token();
- w = readS();
- // To match the behaviour of #+ I just make "#- machine" get ignored so that
- // the S-expression beyond that is the one that is read.
- return readS();
- case '/':
- c = curchar;
- curchar = rdch();
- cursym = token();
- return packfixnum(c & 0xff);
- case '\\':
- cursym = token();
- w = readS();
- return char_function(w);
- default:
- return nil;
- }
- }
- LispObject list_to_vector(LispObject a)
- { int n = 0;
- for (LispObject p=a; p!=nil; p=qcdr(p)) n++;
- LispObject r = makevector(n-1);
- n = 0;
- for (LispObject p=a; p!=nil; p=qcdr(p)) elt(r, n++) = qcar(p);
- return r;
- }
- LispObject readS()
- { LispObject q, w;
- while (1)
- { switch (symtype)
- { case '?':
- cursym = token();
- continue;
- case '(':
- cursym = token();
- return readT();
- case '[':
- cursym = token();
- return list_to_vector(readV());
- case '#':
- return read_hash_macro();
- case '.':
- case ')': // Ignore spurious ")" input
- cursym = token();
- continue;
- case '\'':
- w = quote;
- break;
- case '`':
- w = backquote;
- break;
- case ',':
- w = comma;
- break;
- case '@':
- w = comma_at;
- break;
- case '.'+0x100:
- w = comma_dot;
- break;
- case EOF:
- return eofsym;
- default:
- symtype = '?';
- return cursym;
- }
- push(w);
- cursym = token();
- q = readS();
- pop(w);
- return list2star(w, q, nil);
- }
- }
- LispObject readT()
- { LispObject q, r;
- if (symtype == '?') cursym = token();
- switch (symtype)
- { case EOF:
- return eofsym;
- case '.':
- cursym = token();
- q = readS();
- if (symtype == '?') cursym = token();
- if (symtype == ')') symtype = '?'; // Ignore if not ")".
- return q;
- case ')':
- symtype = '?';
- return nil;
- // case '(': case '\'':
- // case '`': case ',':
- // case '@':
- default:
- q = readS();
- push(q);
- r = readT();
- pop(q);
- return cons(q, r);
- }
- }
- LispObject readV()
- { LispObject q, r;
- if (symtype == '?') cursym = token();
- switch (symtype)
- { case EOF:
- return eofsym;
- case ']':
- symtype = '?';
- return nil;
- default:
- q = readS();
- push(q);
- r = readV();
- pop(q);
- return cons(q, r);
- }
- }
- // createp = -1 for remob
- // = 0 for lookup if exists, but do not create
- // = 1 for create symbol if necessary.
- LispObject lookup(const char *s, int len, int createp)
- { LispObject w, pn;
- int i, hash = 1;
- for (i=0; i<len; i++) hash = 13*hash + s[i];
- hash = (hash & 0x7fffffff) % OBHASH_SIZE;
- LispObject *prev = &obhash[hash];
- w = *prev;
- while (w != tagFIXNUM)
- { LispObject a = qcar(w); // Will be a symbol.
- LispObject n = qpname(a); // Will be a string.
- int l = veclength(qheader(n)); // Length of the name.
- if (l == len &&
- strncmp(s, qstring(n), len) == 0)
- { if (createp == -1) *prev = qcdr(w);
- return a; // Existing symbol found.
- }
- prev = &qcdr(w);
- w = *prev;
- }
- // here the symbol as required was not already present.
- if (createp <= 0) return undefined;
- pn = makestring(s, len);
- push(pn);
- w = allocatesymbol();
- pop(pn);
- qflags(w) = tagHDR + typeSYM;
- qvalue(w) = undefined;
- qplist(w) = nil;
- qpname(w) = pn;
- qdefn(w) = NULL;
- qlits(w) = nil;
- push(w);
- obhash[hash] = cons(w, obhash[hash]);
- pop(w);
- return w;
- }
- int unwindflag = 0;
- #define unwindNONE 0
- #define unwindERROR 1
- #define unwindBACKTRACE 2
- #define unwindGO 3
- #define unwindRETURN 4
- int backtraceflag = -1;
- #define backtraceHEADER 1
- #define backtraceTRACE 2
- LispObject error1(const char *msg, LispObject data)
- { if ((backtraceflag & backtraceHEADER) != 0)
- { linepos = printf("\n+++ Error: %s: ", msg);
- errprint(data);
- }
- unwindflag = (backtraceflag & backtraceTRACE) != 0 ? unwindBACKTRACE :
- unwindERROR;
- return nil;
- }
- LispObject error1s(const char *msg, const char *data)
- { if ((backtraceflag & backtraceHEADER) != 0)
- printf("\n+++ Error: %s %s\n", msg, data);
- unwindflag = (backtraceflag & backtraceTRACE) != 0 ? unwindBACKTRACE :
- unwindERROR;
- return nil;
- }
- typedef LispObject specialform(LispObject data, LispObject x);
- typedef LispObject lispfn(LispObject data, int nargs, ...);
- LispObject function_name = 0;
- LispObject applytostack(int n)
- {
- // Apply a function to n arguments.
- // Here the stack has first the function, and then n arguments. The code is
- // grim and basically repetitive, and to avoid it being even worse I will
- // expect that almost all Lisp functions have at most 4 arguments, so
- // if there are more than that I will pass the fifth and beyond all in a list.
- LispObject f, w;
- int traced = (qflags(sp[-n-1]) & flagTRACED) != 0;
- if (sp - (LispObject *)stackbase > 10000)
- error1("Stack overflow", sp[-n-1]);
- if (traced)
- { int i;
- linepos = printf("Calling: ");
- errprint(sp[-n-1]);
- for (i=1; i<=n; i++)
- { linepos = printf("Arg%d: ", i);
- errprint(sp[i-n-1]);
- }
- }
- if (n >= 5)
- { push(nil);
- n++;
- while (n > 5)
- { pop(w);
- TOS = cons(TOS, w);
- n--;
- }
- }
- switch (n)
- { case 0: f = TOS;
- function_name = f;
- w = (*(lispfn *)qdefn(f))(qlits(f), 0);
- break;
- case 1:
- { LispObject a1;
- pop(a1);
- f = TOS;
- function_name = f;
- w = (*(lispfn *)qdefn(f))(qlits(f), 1, a1);
- break;
- }
- case 2:
- { LispObject a1, a2;
- pop(a2)
- pop(a1);
- f = TOS;
- function_name = f;
- w = (*(lispfn *)qdefn(f))(qlits(f), 2, a1, a2);
- break;
- }
- case 3:
- { LispObject a1, a2, a3;
- pop(a3);
- pop(a2)
- pop(a1);
- f = TOS;
- function_name = f;
- w = (*(lispfn *)qdefn(f))(qlits(f), 3, a1, a2, a3);
- break;
- }
- case 4:
- { LispObject a1, a2, a3, a4;
- pop(a4);
- pop(a3);
- pop(a2)
- pop(a1);
- f = TOS;
- function_name = f;
- w = (*(lispfn *)qdefn(f))(qlits(f), 4,
- a1, a2, a3, a4);
- break;
- }
- case 5:
- { LispObject a1, a2, a3, a4, a5andup;
- pop(a5andup);
- pop(a4);
- pop(a3);
- pop(a2)
- pop(a1);
- f = TOS;
- function_name = f;
- w = (*(lispfn *)qdefn(f))(qlits(f), 5,
- a1, a2, a3, a4, a5andup);
- break;
- }
- default:disaster(__LINE__);
- return nil;
- }
- pop(f);
- if (unwindflag == unwindBACKTRACE)
- { linepos = printf("Calling: ");
- errprint(f);
- }
- else if (traced)
- { push(w);
- prin(f);
- linepos += printf(" = ");
- errprint(w);
- pop(w);
- }
- return w;
- }
- LispObject call1(const char *name, LispObject a1)
- {
- LispObject fn = lookup(name, strlen(name), 0);
- if (fn == undefined || qdefn(fn) == NULL) return nil;
- push2(fn, a1);
- return applytostack(1);
- }
- LispObject call2(const char *name, LispObject a1, LispObject a2)
- {
- LispObject fn = lookup(name, strlen(name), 0);
- if (fn == undefined || qdefn(fn) == NULL) return nil;
- push3(fn, a1, a2);
- return applytostack(2);
- }
- LispObject interpret(LispObject def, int nargs, ...);
- LispObject Lgensym(LispObject lits, int nargs, ...);
- LispObject eval(LispObject x)
- { while (isCONS(x) && isSYMBOL(qcar(x)) && (qflags(qcar(x)) & flagMACRO))
- { push2(qcar(x), x);
- x = applytostack(1); // Macroexpand before anything else.
- if (unwindflag != unwindNONE) return nil;
- }
- if (isSYMBOL(x))
- { LispObject v = qvalue(x);
- if (v == undefined) return error1("undefined variable", x);
- else return v;
- }
- else if (!isCONS(x)) return x;
- // Now I have something of the form
- // (f arg1 ... argn)
- // to process.
- { LispObject f = qcar(x);
- if (isSYMBOL(f))
- { LispObject flags = qflags(f), aa, av;
- int i, n = 0;
- if (flags & flagSPECFORM)
- { specialform *fn = (specialform *)qdefn(f);
- return (*fn)(qlits(f), qcdr(x));
- }
- // ... else not a special form...
- if (qdefn(f) == NULL) return error1("undefined function", f);
- aa = qcdr(x);
- while (isCONS(aa))
- { n++; // Count number of args supplied.
- aa = qcdr(aa);
- }
- aa = qcdr(x);
- push(f);
- // Here I will evaluate all the arguments for the function, leaving the
- // evaluated results on the stack.
- for (i=0; i<n; i++)
- { push(aa);
- av = eval(qcar(aa));
- if (unwindflag != unwindNONE)
- { while (i != 0) // Restore the stack if unwinding.
- { pop(aa);
- i--;
- }
- pop2(aa, aa);
- return nil;
- }
- aa = qcdr(TOS);
- TOS = av;
- }
- return applytostack(n);
- }
- else if (isCONS(f) && qcar(f) == lambda)
- { LispObject w;
- push(x);
- w = Lgensym(nil, 0);
- pop(x);
- qdefn(w) = (void *)interpret;
- qlits(w) = qcdr(qcar(x));
- return eval(cons(w, qcdr(x)));
- }
- else return error1("invalid function", f);
- }
- }
- LispObject nreverse(LispObject a)
- { LispObject b = nil, w;
- while (isCONS(a))
- { w = qcdr(a);
- qcdr(a) = b;
- b = a;
- a = w;
- }
- return b;
- }
- LispObject Lprogn(LispObject lits, LispObject x);
- // The next array is used to help with error recovery, and it does
- // not need to be protected by the garbage collector.
- #define MAX_ARGS 50
- LispObject pushedvars[MAX_ARGS];
- LispObject interpret(LispObject def, int nargs, ...)
- {
- // def should be ((a1 a2 ...) e1 e2 ...)
- // where the number of args a1 ... should the same as nargs. Use
- // "shallow binding" to cope with the need for a1 ... to have some
- // sort of local scope. Note with mild distress that this implements
- // "dynamic" rather than "static" scoping, but old-fashioned Lisp code
- // will have coped with that!
- //
- #ifdef PSL
- // For bootstrapping PSL it appears to be pragmatically necessary to be
- // rather flexible about functions called with too few or too many arguments.
- // the PSL compiler seems to have a number of such issues, and until they
- // are resolved I will find that strict behaviour here results is
- // failure (rather than merely unreliable behaviour!)
- #endif
- va_list aa;
- int i, npushed;
- LispObject arglist, body, w, r = nil;
- if (!isCONS(def)) return error1("bad definition", def);
- va_start(aa, nargs);
- w = arglist = qcar(def);
- body = qcdr(def);
- npushed = 0;
- for (i=0; i<nargs && i<4; i++)
- { LispObject var;
- if (!isCONS(w)) // Too many args passed
- {
- #ifdef PSL
- // With PSL if I have either too many arguments I will ignore the
- // excess ones.
- if (linepos != 0) printf("\n");
- printf("+++ Warning: Function called with too many arguments\n");
- print(function_name);
- linepos = 0;
- w = qcdr(w);
- continue;
- #else
- while (npushed != 0) pop(qvalue(pushedvars[--npushed]));
- va_end(aa);
- return error1("invalid variable-name", w);
- #endif
- }
- if (!isSYMBOL(var = qcar(w)))
- {
- #ifdef PSL
- // With PSL if I have some junk in the list of variables that are to
- // be bound I will just bind something called "~dummyvar".
- var = dummyvar;
- if (linepos != 0) printf("\n");
- printf("+++ Warning: Junk in bound variable list\n");
- linepos = 0;
- print(function_name);
- #else
- while (npushed != 0) pop(qvalue(pushedvars[--npushed]));
- va_end(aa);
- return error1("excess arguments", w);
- #endif
- }
- push(qvalue(var));
- pushedvars[npushed++] = var;
- qvalue(var) = va_arg(aa, LispObject);
- w = qcdr(w);
- }
- // To make life easier in "eval" where I call functions I will pass up to
- // 4 arguments "naturally", but any beyond that will all be collected as
- // a list. So if nargs==5 then arg5 actually represents a list of the form
- // (arg5 arg6 ...).
- if (nargs == 5)
- { r = va_arg(aa, LispObject);
- while (isCONS(w) && isCONS(r))
- { LispObject var = qcar(w);
- if (!isSYMBOL(var))
- #ifdef PSL
- { var = dummyvar;
- if (linepos != 0) printf("\n");
- printf("+++ Warning: Function called with too many arguments\n");
- linepos = 0;
- print(function_name);
- }
- #else
- { while (npushed != 0) pop(qvalue(pushedvars[--npushed]));
- va_end(aa);
- return error1("invalid variable-name", var);
- }
- #endif
- push(qvalue(var));
- pushedvars[npushed++] = var;
- qvalue(var) = qcar(r);
- w = qcdr(w);
- r = qcdr(r);
- }
- }
- va_end(aa);
- if (isCONS(w) || isCONS(r))
- {
- #ifdef PSL
- // For PSL if I am given too many arguments I will merely ingnore the
- // extra unwanted ones.
- if (linepos != 0) printf("\n");
- printf("+++ Warning: Function called with too many arguments\n");
- linepos = 0;
- print(function_name);
- #else
- while (npushed != 0) pop(qvalue(pushedvars[--npushed]));
- return error1("too many args", cons(r, w));
- #endif
- }
- push(arglist);
- r = Lprogn(nil, body);
- // Now I must restore the bound variables (regardless of whether there
- // has been an error).
- pop(arglist);
- w = nreverse(arglist);
- arglist = nil;
- while (isCONS(w))
- { LispObject x = w, var;
- w = qcdr(w);
- qcdr(x) = arglist;
- arglist = x;
- var = qcar(arglist);
- #ifdef PSL
- if (!isSYMBOL(var)) var = dummyvar;
- #endif
- pop(qvalue(var));
- }
- return r;
- }
- LispObject interpretspecform(LispObject lits, LispObject x)
- { // lits should be ((var) body...)
- LispObject v;
- if (!isCONS(lits)) return nil;
- v = qcar(lits);
- lits = qcdr(lits);
- if (!isCONS(v) || !isSYMBOL(v = qcar(v))) return nil;
- push2(qvalue(v), v);
- qvalue(v) = x;
- lits = Lprogn(nil, lits);
- pop2(v, qvalue(v));
- return lits;
- }
- // Special forms are things that do not have their arguments pre-evaluated.
- LispObject Lquote(LispObject lits, LispObject x)
- { if (isCONS(x)) return qcar(x);
- else return nil;
- }
- LispObject Lcond(LispObject lits, LispObject x)
- {
- // Arg is in form
- // ((predicate1 val1a val1b ...)
- // (predicate2 val2a val2b ...)
- // ...)
- while (isCONS(x))
- { push(x);
- x = qcar(x);
- if (isCONS(x))
- { LispObject p = eval(qcar(x));
- if (unwindflag != unwindNONE)
- { pop(x);
- return nil;
- }
- else if (p != nil)
- { pop(x);
- return Lprogn(nil, qcdr(qcar(x)));
- }
- }
- pop(x);
- x = qcdr(x);
- }
- return nil;
- }
- LispObject Land(LispObject lits, LispObject x)
- { LispObject r = lisptrue;
- while (isCONS(x))
- { push(x);
- r = eval(qcar(x));
- pop(x);
- if (r == nil || unwindflag != unwindNONE) return nil;
- x = qcdr(x);
- }
- return r;
- }
- LispObject Lor(LispObject lits, LispObject x)
- { while (isCONS(x))
- { LispObject r;
- push(x);
- r = eval(qcar(x));
- pop(x);
- if (r != nil || unwindflag != unwindNONE) return r;
- x = qcdr(x);
- }
- return nil;
- }
- LispObject definer(LispObject x, int flags, void *fn)
- {
- // x should be of the form
- // (name (arg list ...) body)
- //
- // I check for a LOSE flag to give me a way of
- // ignoring definitions that I do not like.
- LispObject name, def;
- if (!isCONS(x) ||
- !isSYMBOL(name = qcar(x)) ||
- !isCONS(def = qcdr(x)))
- return error1("malformed use of de, df or dm", x);
- // For the moment I prohibit redefinition of special forms...
- if ((qflags(name) & flagSPECFORM) != 0)
- return error1("attempt to redefine special form", name);
- if (Lget(nil, 2, name, loseflag) != nil)
- { printf("\n+++ LOSE flag on function, so definition ignored: ");
- errprint(name);
- return name;
- }
- // Now I will try to call macroexpand_list to expand all macros.
- x = lookup("macroexpand_list", 16, 0);
- if (x != undefined && qdefn(x) != NULL)
- { push2(name, def);
- push2(x, qcdr(def));
- x = applytostack(1);
- pop2(def, name);
- if (unwindflag != unwindNONE) return name;
- qlits(name) = cons(qcar(def), x);
- }
- else qlits(name) = def;
- qflags(name) = (qflags(name) & ~(flagSPECFORM|flagMACRO)) | flags;
- qdefn(name) = fn;
- return name;
- }
- LispObject Lde(LispObject lits, LispObject x)
- { return definer(x, 0, (void*)interpret);
- }
- LispObject Ldf(LispObject lits, LispObject x)
- { return definer(x, flagSPECFORM, (void*)interpretspecform);
- }
- LispObject Ldm(LispObject lits, LispObject x)
- { return definer(x, flagMACRO, (void*)interpret);
- }
- LispObject Lsetq(LispObject lits, LispObject x)
- { // (setq var1 val1 var2 val2 ...)
- LispObject w = nil;
- while (isCONS(x) && isCONS(qcdr(x)))
- { if (!isSYMBOL(w=qcar(x)) ||
- w == nil || w == lisptrue)
- return error1("bad variable in setq", x);
- push(x);
- w = eval(qcar(qcdr(x)));
- pop(x);
- if (unwindflag != unwindNONE) return nil;
- qvalue(qcar(x)) = w;
- x = qcdr(qcdr(x));
- }
- return w;
- }
- LispObject Lprogn(LispObject lits, LispObject x)
- { LispObject r = nil;
- while (isCONS(x))
- { push(x);
- r = eval(qcar(x));
- pop(x);
- x = qcdr(x);
- if (unwindflag != unwindNONE) return nil;
- }
- return r;
- }
- // I want to police a constraint that GO and RETURN are only used in
- // "prog context". The following limited number of forms are relevant to
- // this:
- // COND
- // PROGN
- // GO
- // RETURN
- // and (at least for now) I am not going to allow other conditionals, macros
- // or anything else to be transparent to it.
- static LispObject eval_prog_context(LispObject x);
- LispObject progprogn(LispObject x)
- { LispObject r = nil;
- while (isCONS(x))
- { push(x);
- r = eval_prog_context(qcar(x));
- pop(x);
- x = qcdr(x);
- if (unwindflag != unwindNONE) return nil;
- }
- return r;
- }
- LispObject progcond(LispObject x)
- {
- while (isCONS(x))
- { push(x);
- x = qcar(x);
- if (isCONS(x))
- { LispObject p = eval(qcar(x));
- if (unwindflag != unwindNONE)
- { pop(x);
- return nil;
- }
- else if (p != nil)
- { pop(x);
- return progprogn(qcdr(qcar(x)));
- }
- }
- pop(x);
- x = qcdr(x);
- }
- return nil;
- }
- LispObject proggo(LispObject x)
- { if (!isCONS(x) || !isSYMBOL(work1 = qcar(x)))
- return error1("bad go", x);
- work1 = qcar(x);
- unwindflag = unwindGO;
- return nil;
- }
- LispObject progreturn(LispObject args)
- { if (!isCONS(args) || isCONS(qcdr(args)))
- return error1("RETURN need just 1 argument", args);
- args = eval(qcar(args));
- if (unwindflag != unwindNONE) return nil;
- work1 = args;
- unwindflag = unwindRETURN;
- return nil;
- }
- static LispObject eval_prog_context(LispObject x)
- { if (!isCONS(x)) return eval(x);
- else if (qcar(x) == condsymbol) return progcond(qcdr(x));
- else if (qcar(x) == prognsymbol) return progprogn(qcdr(x));
- else if (qcar(x) == gosymbol) return proggo(qcdr(x));
- else if (qcar(x) == returnsymbol) return progreturn(qcdr(x));
- else return eval(x);
- }
- LispObject Lprog(LispObject lits, LispObject x)
- {
- // Does merely progn just now!!!
- LispObject w, vars;
- if (!isCONS(x)) return nil;
- vars = qcar(x);
- x = qcdr(x);
- w = vars;
- // Now bind all the local variables, giving them the value nil.
- while (isCONS(w))
- { LispObject v = qcar(w);
- w = qcdr(w);
- if (isSYMBOL(v))
- { push(qvalue(v));
- qvalue(v) = nil;
- }
- }
- push(vars); // So that I know what to unbind at the end.
- push(x); // So that "go" can scan the whole block to find a label.
- work1 = nil;
- while (isCONS(x))
- { push(x);
- if (isCONS(qcar(x))) eval_prog_context(qcar(x));
- pop(x);
- x = qcdr(x);
- if (unwindflag == unwindRETURN)
- { unwindflag = unwindNONE;
- break;
- }
- else if (unwindflag == unwindGO)
- { unwindflag = unwindNONE;
- x = TOS;
- while (isCONS(x) && qcar(x) != work1) x = qcdr(x);
- continue;
- }
- work1 = nil;
- if (unwindflag != unwindNONE) break;
- }
- // Now I must unbind all the variables.
- pop(x);
- pop(vars);
- w = nreverse(vars);
- vars = nil;
- while (isCONS(w))
- { LispObject x = w;
- w = qcdr(w);
- qcdr(x) = vars;
- vars = x;
- x = qcar(vars);
- if (isSYMBOL(x)) pop(qvalue(x));
- }
- return work1;
- }
- LispObject Lgo(LispObject lits, LispObject x)
- { return error1("GO not in PROG context", x);
- // if (!isCONS(x) || !isSYMBOL(work1 = qcar(x)))
- // return error1("bad go", x);
- // work1 = qcar(x);
- // unwindflag = unwindGO;
- // return nil;
- }
- #define NARY(x, base, combinefn) \
- LispObject r; \
- if (!isCONS(x)) return base; \
- push(x); \
- r = eval(qcar(x)); \
- pop(x); \
- if (unwindflag != unwindNONE) \
- return nil; \
- x = qcdr(x); \
- while (isCONS(x)) \
- { LispObject a; \
- push2(x, r); \
- a = eval(qcar(x)); \
- if (unwindflag != unwindNONE) \
- { pop2(r, x); \
- return nil; \
- } \
- pop(r); \
- r = combinefn(r, a); \
- pop(x); \
- x = qcdr(x); \
- } \
- return r
- LispObject Lplus(LispObject lits, LispObject x)
- { NARY(x, packfixnum(0), Nplus2);
- }
- LispObject Ltimes(LispObject lits, LispObject x)
- { NARY(x, packfixnum(1), Ntimes2);
- }
- LispObject Llogand(LispObject lits, LispObject x)
- { NARY(x, packfixnum(-1), Nlogand2);
- }
- LispObject Llogor(LispObject lits, LispObject x)
- { NARY(x, packfixnum(0), Nlogor2);
- }
- LispObject Llogxor(LispObject lits, LispObject x)
- { NARY(x, packfixnum(0), Nlogxor2);
- }
- LispObject Llist(LispObject lits, LispObject x)
- { int n = 0;
- LispObject r;
- while (isCONS(x))
- { push(x);
- r = eval(qcar(x));
- if (unwindflag != unwindNONE)
- { while (n != 0)
- { pop(x);
- n--;
- }
- pop(x);
- return nil;
- }
- x = qcdr(TOS);
- TOS = r;
- n++;
- }
- r = nil;
- while (n > 0)
- { pop(x);
- r = cons(x, r);
- n--;
- }
- return r;
- }
- LispObject Lliststar(LispObject lits, LispObject x)
- { int n = 0;
- LispObject r;
- while (isCONS(x))
- { push(x);
- r = eval(qcar(x));
- if (unwindflag != unwindNONE)
- { while (n != 0)
- { pop(x);
- n--;
- }
- pop(x);
- return nil;
- }
- x = qcdr(TOS);
- TOS = r;
- n++;
- }
- if (n == 0) return nil;
- pop(r);
- n--;
- while (n > 0)
- { pop(x);
- r = cons(x, r);
- n--;
- }
- return r;
- }
- // The way that arguments are passed to functions is a little
- // ugly, and uses the C facility for calling functions with variable
- // numbers of arguments. To shorten the code I put much of the mess into
- // macros
- #define ARG0(name) \
- if (nargs != 0) return error1s("wrong number of arguments for", name)
- #define ARG1(name, x) \
- va_list a; \
- LispObject x; \
- if (nargs != 1) return error1s("wrong number of arguments for", name); \
- va_start(a, nargs); \
- x = va_arg(a, LispObject); \
- va_end(a)
- #define ARG2(name, x, y) \
- va_list a; \
- LispObject x, y; \
- if (nargs != 2) return error1s("wrong number of arguments for", name); \
- va_start(a, nargs); \
- x = va_arg(a, LispObject); \
- y = va_arg(a, LispObject); \
- va_end(a)
- #define ARG3(name, x, y, z) \
- va_list a; \
- LispObject x, y, z; \
- if (nargs != 3) return error1s("wrong number of arguments for", name); \
- va_start(a, nargs); \
- x = va_arg(a, LispObject); \
- y = va_arg(a, LispObject); \
- z = va_arg(a, LispObject); \
- va_end(a)
- #define ARG0123(name, x, y, z) \
- va_list a; \
- LispObject x=NULLATOM, y=NULLATOM, z=NULLATOM; \
- if (nargs > 3) return error1s("wrong number of arguments for", name); \
- va_start(a, nargs); \
- if (nargs > 0) x = va_arg(a, LispObject); \
- if (nargs > 1) y = va_arg(a, LispObject); \
- if (nargs > 2) z = va_arg(a, LispObject); \
- va_end(a)
- LispObject Lcar(LispObject lits, int nargs, ...)
- { ARG1("car", x); // Note that this WILL take car of a bignum!
- if (isCONS(x)) return qcar(x);
- else return error1("car of an atom", x);
- }
- LispObject Lcdr(LispObject lits, int nargs, ...)
- { ARG1("cdr", x);
- if (isCONS(x)) return qcdr(x);
- else return error1("cdr of an atom", x);
- }
- LispObject Lrplaca(LispObject lits, int nargs, ...)
- { ARG2("rplaca", x, y);
- if (isCONS(x))
- { qcar(x) = y;
- return x;
- }
- else return error1("rplaca on an atom", x);
- }
- LispObject Lrplacd(LispObject lits, int nargs, ...)
- { ARG2("rplacd", x, y);
- if (isCONS(x))
- { qcdr(x) = y;
- return x;
- }
- else return error1("rplaca on an atom", x);
- }
- LispObject Lcons(LispObject lits, int nargs, ...)
- { ARG2("cons", x, y);
- return cons(x, y);
- }
- LispObject Lbignump(LispObject lits, int nargs, ...)
- { ARG1("bignump", x);
- if (!isCONS(x) || qcar(x) != bignum) return nil;
- x = qcdr(x);
- // As a matter of caution I only treat something as a bignum if it not
- // only has ~bignum at the start but all that follows is a list of fixnums.
- if (x == nil) return nil; // No digits so not a bignum.
- while (isCONS(x))
- { if (!isFIXNUM(qcar(x))) return nil;
- x = qcdr(x);
- }
- if (x != nil) return nil;
- return lisptrue;
- }
- LispObject Latom(LispObject lits, int nargs, ...)
- { ARG1("atom", x); // Observe treatment of bignums!
- return (isCONS(x) && (Lbignump(lits, 1, x)==nil) ? nil : lisptrue);
- }
- LispObject Lsymbolp(LispObject lits, int nargs, ...)
- { ARG1("symbolp", x);
- return (isSYMBOL(x) ? lisptrue : nil);
- }
- LispObject Lstringp(LispObject lits, int nargs, ...)
- { ARG1("stringp", x);
- return (isSTRING(x) ? lisptrue : nil);
- }
- LispObject Lvectorp(LispObject lits, int nargs, ...)
- { ARG1("vectorp", x);
- return (isVEC(x) ? lisptrue : nil);
- }
- LispObject Lnumberp(LispObject lits, int nargs, ...)
- { ARG1("numberp", x);
- return ((isFIXNUM(x) || isBIGNUM(x) || isFLOAT(x)) ? lisptrue : nil);
- }
- LispObject Lfixp(LispObject lits, int nargs, ...)
- { ARG1("fixp", x);
- return ((isFIXNUM(x) || isBIGNUM(x)) ? lisptrue : nil);
- }
- LispObject Lfloatp(LispObject lits, int nargs, ...)
- { ARG1("floatp", x);
- return (isFLOAT(x) ? lisptrue : nil);
- }
- LispObject Lfix(LispObject lits, int nargs, ...)
- { ARG1("fix", x);
- return ((isFIXNUM(x) || isBIGNUM(x)) ? x :
- isFLOAT(x) ? boxint64((int64_t)qfloat(x)) :
- error1("arg for fix", x));
- }
- LispObject Lfloor(LispObject lits, int nargs, ...)
- { ARG1("floor", x);
- return ((isFIXNUM(x) || isBIGNUM(x)) ? x :
- isFLOAT(x) ? boxint64((int64_t)floor(qfloat(x))) :
- error1("arg for floor", x));
- }
- LispObject Lceiling(LispObject lits, int nargs, ...)
- { ARG1("ceiling", x);
- return ((isFIXNUM(x) || isBIGNUM(x)) ? x :
- isFLOAT(x) ? boxint64((int64_t)ceil(qfloat(x))) :
- error1("arg for ceiling", x));
- }
- LispObject Lfloat(LispObject lits, int nargs, ...)
- { ARG1("float", x);
- return (isFLOAT(x) ? x :
- isFIXNUM(x) ? boxfloat((double)qfixnum(x)) :
- isBIGNUM(x) ? boxfloat((double)qint64(x)) :
- error1("arg for fix", x));
- }
- #define floatval(x) \
- isFLOAT(x) ? qfloat(x) : \
- isFIXNUM(x) ? (double)qfixnum(x) : \
- isBIGNUM(x) ? (double)qint64(x) : \
- 0.0
- LispObject Lcos(LispObject lits, int nargs, ...)
- { ARG1("cos", x);
- return boxfloat(cos(floatval(x)));
- }
- LispObject Lsin(LispObject lits, int nargs, ...)
- { ARG1("sin", x);
- return boxfloat(sin(floatval(x)));
- }
- LispObject Lsqrt(LispObject lits, int nargs, ...)
- { ARG1("sqrt", x);
- return boxfloat(sqrt(floatval(x)));
- }
- LispObject Llog(LispObject lits, int nargs, ...)
- { ARG1("log", x);
- return boxfloat(log(floatval(x)));
- }
- LispObject Lexp(LispObject lits, int nargs, ...)
- { ARG1("exp", x);
- return boxfloat(exp(floatval(x)));
- }
- LispObject Latan(LispObject lits, int nargs, ...)
- { ARG1("atan", x);
- return boxfloat(atan(floatval(x)));
- }
- LispObject Lnull(LispObject lits, int nargs, ...)
- { ARG1("null", x);
- return (x == nil ? lisptrue : nil);
- }
- LispObject Leq(LispObject lits, int nargs, ...)
- { ARG2("eq", x, y);
- return (x == y ? lisptrue : nil);
- }
- LispObject Lequal(LispObject lits, int nargs, ...)
- { ARG2("equal", x, y);
- while (x != y && isCONS(x) && isCONS(y))
- { if (Lequal(lits, 2, qcar(x), qcar(y)) == nil) return nil;
- x = qcdr(x); y = qcdr(y);
- }
- if (x == y) return lisptrue;
- if ((x & TAGBITS) != (y & TAGBITS)) return nil;
- if (isSYMBOL(x) || isFIXNUM(x)) return nil;
- if (isFLOAT(x)) return (qfloat(x) == qfloat(y) ? lisptrue : nil);
- if (qheader(x) != qheader(y)) return nil;
- switch (qheader(x) & TYPEBITS)
- { case typeVEC: case typeEQHASH: case typeEQHASHX:
- { int i;
- for (i=0; i<veclength(qheader(x))/sizeof(LispObject); i++)
- if (Lequal(lits, 2, elt(x, i), elt(y, i)) == nil) return nil;
- return lisptrue;
- }
- default: // Treat all other cases as containing binary information.
- { int i;
- const char *xx = qstring(x), *yy = qstring(y);
- for (i=0; i<veclength(qheader(x)); i++)
- if (xx[i] != yy[i]) return nil;
- return lisptrue;
- }
- }
- }
- LispObject Lset(LispObject lits, int nargs, ...)
- { ARG2("set", x, y);
- if (!isSYMBOL(x)) return error1("bad arg for set", x);
- return (qvalue(x) = y);
- }
- LispObject Lboundp(LispObject lits, int nargs, ...)
- { ARG1("boundp", x);
- return (isSYMBOL(x) && qvalue(x)!=undefined) ? lisptrue : nil;
- }
- LispObject Lmakeunbound(LispObject lits, int nargs, ...)
- { ARG1("makeunbound", x);
- if (isSYMBOL(x)) qvalue(x) = undefined;
- return nil;
- }
- LispObject Lgensym(LispObject lits, int nargs, ...)
- { LispObject r;
- ARG0("gensym");
- r = allocatesymbol();
- qflags(r) = tagHDR + typeGENSYM;
- qvalue(r) = undefined;
- qplist(r) = nil;
- qpname(r) = nil; // A nil pname marks this as a not-yet-printed gensym.
- qdefn(r) = NULL;
- qlits(r) = nil;
- return r;
- }
- LispObject Lgensymp(LispObject lits, int nargs, ...)
- { ARG1("gensymp", x);
- if (!isSYMBOL(x)) return nil;
- return (qflags(x) & TYPEBITS) == typeGENSYM ? lisptrue : nil;
- }
- LispObject Lchar(LispObject lits, int nargs, ...)
- { ARG1("char", x);
- return char_function(x);
- }
- LispObject Ltime(LispObject lits, int nargs, ...)
- { clock_t c = clock();
- ARG0("time"); // I will convert the time to be in milliseconds
- return packfixnum((intptr_t)((1000*(int64_t )c)/CLOCKS_PER_SEC));
- }
- LispObject Loblist(LispObject lits, int nargs, ...)
- { ARG0("oblist");
- int i;
- work1 = nil;
- for (i=0; i<OBHASH_SIZE; i++)
- for (work2=obhash[i]; isCONS(work2); work2 = qcdr(work2))
- { if (qcar(work2) != undefined)
- work1 = cons(qcar(work2), work1);
- }
- return work1;
- }
- LispObject Leval(LispObject lits, int nargs, ...)
- { ARG1("eval", x);
- return eval(x);
- }
- LispObject Lapply(LispObject lits, int nargs, ...)
- { int n = 0;
- ARG2("apply", x, y);
- if (isCONS(x) && qcar(x) == lambda)
- { LispObject g;
- push2(x, y);
- g = Lgensym(nil, 0);
- pop2(y, x);
- qdefn(g) = (void *)interpret;
- qlits(g) = qcdr(x);
- x = g;
- }
- else if (!isSYMBOL(x) ||
- x == undefined ||
- qdefn(x) == NULL) return error1("bad arg to apply", x);
- push(x);
- while (isCONS(y))
- { push(qcar(y));
- y = qcdr(y);
- n++;
- }
- return applytostack(n);
- }
- LispObject Lplist(LispObject lits, int nargs, ...)
- { ARG1("plist", x);
- if (!isSYMBOL(x)) return nil;
- else return qplist(x);
- }
- LispObject Lpname(LispObject lits, int nargs, ...)
- { ARG1("pname", x);
- if (!isSYMBOL(x)) return nil;
- else return qpname(x);
- }
- LispObject Lput(LispObject lits, int nargs, ...)
- { LispObject w;
- ARG3("put", x, y, z);
- if (!isSYMBOL(x)) return error1("bad arg put", x);
- w = qplist(x);
- while (isCONS(w))
- { LispObject a = qcar(w);
- w = qcdr(w);
- if (isCONS(a) && qcar(a) == y)
- { qcdr(a) = z;
- return z;
- }
- }
- push3(x, y, z);
- w = acons(y, z, qplist(x));
- pop3(z, y, x);
- qplist(x) = w;
- return z;
- }
- LispObject Lget(LispObject lits, int nargs, ...)
- { ARG2("get", x, y);
- if (!isSYMBOL(x)) return nil;
- x = qplist(x);
- while (isCONS(x))
- { LispObject a = qcar(x);
- x = qcdr(x);
- if (isCONS(a) && qcar(a) == y) return qcdr(a);
- }
- return nil;
- }
- LispObject Lremprop(LispObject lits, int nargs, ...)
- { LispObject p, r, *prev;
- ARG2("remprop", x, y);
- if (!isSYMBOL(x)) return nil;
- p = *(prev = &qplist(x));
- while (p != nil)
- { if (isCONS(r = qcar(p)) && qcar(qcar(p)) == y)
- { *prev = qcdr(p);
- return r;
- }
- p = *(prev = &qcdr(p));
- }
- return nil;
- }
- LispObject Lmkvect(LispObject lits, int nargs, ...)
- { int n;
- ARG1("mkvect", x);
- if (!isFIXNUM(x)) return error1("bad size in mkvect", x);
- n = (int)qfixnum(x);
- // I put an (arbitrary) limit on the size of the largest vector.
- if (n < 0 || n > 100000) return error1("bad size in mkvect", x);
- return makevector(n);
- }
- LispObject Lupbv(LispObject lits, int nargs, ...)
- { ARG1("upbv", x);
- if (!isVEC(x)) return error1("bad arg to upbv", x);
- return makeinteger(veclength(qheader(x))/sizeof(LispObject)-1);
- }
- LispObject Lputv(LispObject lits, int nargs, ...)
- { int n;
- ARG3("putv", x, y, z);
- if (!isVEC(x) || !isFIXNUM(y))
- return error1("bad arg to putv", cons(x, y));
- n = (int)qfixnum(y);
- if (n < 0 || n >= veclength(qheader(x))/sizeof(LispObject))
- return error1("subscript out of range in putv", y);
- elt(x, n) = z;
- return z;
- }
- LispObject Lgetv(LispObject lits, int nargs, ...)
- { int n;
- ARG2("getvec", x, y);
- // As a metter of convenience and generosity I will allow "getv" to
- // access items from hash tables as well as ordinary vectors.
- if ((!isVEC(x) && !isEQHASH(x) && !isEQHASHX(x)) || !isFIXNUM(y))
- return error1("bad arg to getv", cons(x, y));
- n = (int)qfixnum(y);
- if (n < 0 || n >= veclength(qheader(x))/sizeof(LispObject))
- return error1("subscript out of range in getv", y);
- return elt(x, n);
- }
- LispObject Lmkhash(LispObject lits, int nargs, ...)
- { int n;
- LispObject x, r;
- va_list a; // I am going to permit mkhash to have extra arguments.
- va_start(a, nargs); // This is for easier compatibility with Reduce.
- x = va_arg(a, LispObject);
- va_end(a);
- if (!isFIXNUM(x)) return error1("bad size in mkhash", x);
- n = (int)qfixnum(x);
- // I force hash tables to be of limited size.
- if (n <= 10) n = 11;
- else if (n > 1000) n = 997;
- n |= 1; // Force table-size to be an odd number
- r = makevector(n-1);
- qheader(r) ^= (typeVEC ^ typeEQHASH);
- return r;
- }
- LispObject Lclrhash(LispObject lits, int nargs, ...)
- { ARG1("clrhash", x);
- if (isEQHASHX(x)) qheader(x) ^= (typeEQHASH ^ typeEQHASHX);
- if (!isEQHASH(x)) return error1("not a hash table in clrhash", x);
- size_t n = veclength(qheader(x))/sizeof(LispObject);
- for (size_t i=0; i<n; i++) elt(x, i) = nil;
- return x;
- }
- void rehash(LispObject x)
- {
- // At the moment that this is invoked it is at least certain that
- // garbage collection is not in progress. Hence the second half-space
- // is all memory available for use! So on a temporary basis I will put
- // a copy of the hash table there.
- LispObject x1 = heap2base + tagATOM;
- int n = veclength(qheader(x));
- int i;
- memcpy((void *)heap2base, (void *)(x - tagATOM), n + sizeof(LispObject));
- n = n/sizeof(LispObject); // Now a count of slots in the table.
- // I will now re-hash from the copy that I made back into the hash table, but
- // now using the new hash values that reflect and changes that might have
- // arisen.
- for (i=0; i<n; i++) elt(x, i) = nil;
- for (i=0; i<n; i++)
- { LispObject b = elt(x1, i);
- while (b != nil)
- { LispObject ca = qcar(b), cd = qcdr(b);
- int h = (int)(((uintptr_t)qcar(ca))/((uintptr_t)n)); // New bucket.
- qcdr(b) = elt(x, h);
- elt(x, h) = b; // Re-inserted in table.
- b = cd;
- }
- }
- qheader(x) ^= (typeEQHASH ^ typeEQHASHX);
- }
- LispObject Lputhash(LispObject lits, int nargs, ...)
- { int n, h;
- LispObject c;
- ARG3("puthash", x, y, z);
- if (isEQHASHX(y)) rehash(y);
- if (!isEQHASH(y)) return error1("not a hash table in puthash", cons(x, y));
- n = veclength(qheader(y))/sizeof(LispObject);
- // I use unsigned types so I get a positive remainder.
- h = (int)(((uintptr_t)x) % ((uintptr_t)n));
- c = elt(y, h);
- while (isCONS(c))
- { if (qcar(qcar(c)) == x)
- { qcdr(qcar(c)) = z;
- return z;
- }
- c = qcdr(c);
- }
- push2(y, z);
- c = acons(x, z, elt(y, h));
- pop2(z, y);
- elt(y, h) = c;
- return z;
- }
- LispObject Lremhash(LispObject lits, int nargs, ...)
- { int n, h;
- LispObject c, *cp;
- ARG2("remhash", x, y);
- if (isEQHASHX(y)) rehash(y);
- if (!isEQHASH(y)) return error1("not a hash table in remhash", cons(x, y));
- n = veclength(qheader(y))/sizeof(LispObject);
- h = (int)(((uintptr_t)x) % ((uintptr_t)n));
- c = *(cp = &elt(y, h));
- while (isCONS(c))
- { if (qcar(qcar(c)) == x)
- { *cp = qcdr(c);
- return qcdr(qcar(c));
- }
- c = *(cp = &qcdr(c));
- }
- return nil;
- }
- LispObject Lgethash(LispObject lits, int nargs, ...)
- { int n, h;
- LispObject c;
- ARG2("gethash", x, y);
- if (isEQHASHX(y)) rehash(y);
- if (!isEQHASH(y)) return error1("not a hash table in gethash", cons(x, y));
- n = veclength(qheader(y))/sizeof(LispObject);
- h = (int)(((uintptr_t)x) % ((uintptr_t)n));
- c = elt(y, h);
- while (isCONS(c))
- { if (qcar(qcar(c)) == x) return qcdr(qcar(c));
- c = qcdr(c);
- }
- return nil;
- }
- LispObject Lgetd(LispObject lits, int nargs, ...)
- { ARG1("getd", x);
- if (!isSYMBOL(x)) return nil;
- if ((qflags(x) & flagSPECFORM) != 0)
- { if (qdefn(x) == (void *)interpretspecform)
- return list2star(fexpr, lambda, qlits(x));
- else return cons(fsubr, x);
- }
- else if (qdefn(x) == NULL) return nil;
- else if (qdefn(x) == (void *)interpret)
- return list2star((qflags(x) & flagMACRO) ? macro : expr,
- lambda, qlits(x));
- else return cons(subr, x);
- }
- LispObject Lreturn(LispObject lits, int nargs, ...)
- { ARG1("return", x);
- return error1("RETURN not in PROG context", x);
- // work1 = x;
- // unwindflag = unwindRETURN;
- // return nil;
- }
- // Now some numeric functions
- #undef FF
- #undef BB
- #define FF(a, b) ((a) > (b) ? lisptrue : nil)
- #define BB(a, b) ((a) > (b) ? lisptrue : nil)
- LispObject Lgreaterp(LispObject lits, int nargs, ...)
- { ARG2("greaterp", x, y);
- NUMOP("greaterp", x, y);
- }
- #undef FF
- #undef BB
- #define FF(a, b) ((a) >= (b) ? lisptrue : nil)
- #define BB(a, b) ((a) >= (b) ? lisptrue : nil)
- LispObject Lgeq(LispObject lits, int nargs, ...)
- { ARG2("geq", x, y);
- NUMOP("geq", x, y);
- }
- #undef FF
- #undef BB
- #define FF(a, b) ((a) < (b) ? lisptrue : nil)
- #define BB(a, b) ((a) < (b) ? lisptrue : nil)
- LispObject Llessp(LispObject lits, int nargs, ...)
- { ARG2("lessp", x, y);
- NUMOP("lessp", x, y);
- }
- #undef FF
- #undef BB
- #define FF(a, b) ((a) <= (b) ? lisptrue : nil)
- #define BB(a, b) ((a) <= (b) ? lisptrue : nil)
- LispObject Lleq(LispObject lits, int nargs, ...)
- { ARG2("leq", x, y);
- NUMOP("leq", x, y);
- }
- LispObject Lminus(LispObject lits, int nargs, ...)
- { ARG1("minus", x);
- return Nminus(x);
- }
- LispObject Lminusp(LispObject lits, int nargs, ...)
- { ARG1("minusp", x);
- // Anything non-numeric will not be negative!
- if ((isFIXNUM(x) && x < 0) ||
- (isFLOAT(x) && qfloat(x) < 0.0) ||
- (isATOM(x) &&
- (qheader(x) & TYPEBITS) == typeBIGNUM &&
- qint64(x) < 0)) return lisptrue;
- else return nil;
- }
- #undef BB
- #define BB(a) makeinteger(~(a))
- LispObject Llognot(LispObject lits, int nargs, ...)
- { ARG1("lognot", x);
- UNARYINTOP("lognot", x);
- }
- LispObject Lzerop(LispObject lits, int nargs, ...)
- { ARG1("zerop", x);
- // Note that a bignum can never be zero! Because that is not "big".
- // This code is generous and anything non-numeric is not zero.
- if (x == packfixnum(0) ||
- (isFLOAT(x) && qfloat(x) == 0.0)) return lisptrue;
- else return nil;
- }
- LispObject Lonep(LispObject lits, int nargs, ...)
- { ARG1("onep", x);
- if (x == packfixnum(1) ||
- (isFLOAT(x) && qfloat(x) == 1.0)) return lisptrue;
- else return nil;
- }
- #undef FF
- #undef BB
- #define FF(a) boxfloat((a) + 1.0)
- #define BB(a) makeinteger((a) + 1)
- LispObject Ladd1(LispObject lits, int nargs, ...)
- { ARG1("add1", x);
- UNARYOP("add1", x);
- }
- #undef FF
- #undef BB
- #define FF(a) boxfloat((a) - 1.0)
- #define BB(a) makeinteger((a) - 1)
- LispObject Lsub1(LispObject lits, int nargs, ...)
- { ARG1("sub1", x);
- UNARYOP("sub1", x);
- }
- #undef FF
- #undef BB
- #define FF(a, b) boxfloat((a) - (b))
- #define BB(a, b) makeinteger((a) - (b))
- LispObject Ldifference(LispObject lits, int nargs, ...)
- { ARG2("difference", x, y);
- NUMOP("difference", x, y);
- }
- #undef FF
- #undef BB
- #define FF(a, b) ((b) == 0.0 ? error1("division by 0.0", nil) : \
- boxfloat((a) / (b)))
- #define BB(a, b) ((b) == 0 ? error1("division by 0", nil) : \
- makeinteger((a) / (b)))
- LispObject Lquotient(LispObject lits, int nargs, ...)
- { ARG2("quotient", x, y);
- NUMOP("quotient", x, y);
- }
- #undef BB
- #define BB(a, b) ((b) == 0 ? error1("remainder by 0", nil) : \
- makeinteger((a) % (b)))
- LispObject Lremainder(LispObject lits, int nargs, ...)
- { ARG2("remainder", x, y);
- INTOP("remainder", x, y);
- }
- #undef BB
- #define BB(a, b) ((b) == 0 ? error1("division by 0", nil) : \
- cons(makeinteger((a) / (b)), makeinteger((a) % (b))))
- LispObject Ldivide(LispObject lits, int nargs, ...)
- { ARG2("divide", x, y);
- INTOP("divide", x, y);
- }
- #undef BB
- #define BB(a) makeinteger(((uint64_t)(a)) << sh)
- LispObject Lleftshift(LispObject lits, int nargs, ...)
- { int sh;
- ARG2("leftshift", x, y);
- if (!isFIXNUM(y)) return error1("Bad argument for leftshift", y);
- sh = (int)qfixnum(y);
- UNARYINTOP("leftshift", x);
- }
- // In C right shifts on signed values are "implementation defined" and so
- // to be really cautious I will put in code that should work everywhere!
- static inline intptr_t rightshift(intptr_t a, int n)
- { if (n == 0) return a;
- uintptr_t w1 = ((uintptr_t)a) >> n; // All the interesting bits.
- uintptr_t w2 = ((uintptr_t)a) >> (8*sizeof(a)-1); // The top bit.
- w2 = (-w2) << (8*sizeof(a) - n); // Bits to force in.
- return (intptr_t)(w1 | w2);
- }
- #undef BB
- #define BB(a) makeinteger(rightshift(a, sh))
- LispObject Lrightshift(LispObject lits, int nargs, ...)
- { int sh;
- ARG2("rightshift", x, y);
- if (!isFIXNUM(y)) return error1("Bad argument for rightshift", y);
- sh = (int)qfixnum(y);
- UNARYINTOP("rightshift", x);
- }
- // A saved image will start with a word that contains the following 32-bit
- // code. This can identify the byte-ordering and word-width of the system
- // involved, so protects against attempts to reload an image on a machine
- // other than the one it was build on. If I was being more proper I would
- // include a version number as well.
- // I rather demand that ('0'+sizeof(LispObject)) is at most 0x7f here so
- // that the shifts do not overflow in 32-bit signed arithmetic.
- #define FILEID (('v' << 0) | ('s' << 8) | ('l' << 16) | \
- (('0' + sizeof(LispObject)) << 24))
- static const char *imagename = "vsl.img";
- static const char *outimagename = NULL;
- LispObject Lpreserve(LispObject lits, int nargs, ...)
- {
- // preserve can take either 0 or 1 args. If it has a (non-nil) arg that will
- // be a startup function for the image when restored.
- FILE *f;
- ARG0123("preserve", x,y,z);
- if (y != NULLATOM || z != NULLATOM)
- return error1s("wrong number of arguments for", "preserve");
- restartfn = (x == NULLATOM ? nil : x);
- f = fopen(outimagename, "wb");
- if (f == NULL) return error1("unable to open image for writing", nil);
- headerword = FILEID;
- reclaim(); // To compact memory.
- // I write this stuff out as a bunch of bytes, since I only intend to
- // re-read it on exactly the same computer.
- saveinterp = (LispObject)(void *)interpret;
- saveinterpspec = (LispObject)(void *)interpretspecform;
- fwrite(nonbases, 1, sizeof(nonbases), f);
- fwrite(bases, 1, sizeof(bases), f);
- fwrite(obhash, 1, sizeof(obhash), f);
- fwrite((void *)heap1base, 1, (size_t)(fringe1-heap1base), f);
- fwrite((void *)fpfringe1, 1, (size_t)(heap1top-fpfringe1), f);
- fclose(f);
- // A cautious person would have checked for error codes returned by the
- // above calls to fwrite and close. I omit that here to be concise.
- return nil;
- }
- jmp_buf restart_buffer;
- int coldstart = 0;
- LispObject Lrestart_csl(LispObject lits, int nargs, ...)
- { LispObject save = lispout;
- ARG0123("restart-csl", x, y, z);
- if (z != NULLATOM)
- return error1s("wrong number of arguments for", "restart-csl");
- coldstart = 0;
- if (x == nil || x == NULLATOM) coldstart = 1, x = nil;
- if (y == NULLATOM) x = cons(x, nil);
- else x = list2star(x, y, nil);
- boffop = 0;
- lispout = -2;
- prin(x);
- lispout = save;
- longjmp(restart_buffer, 1);
- }
- LispObject Lstop(LispObject lits, int nargs, ...)
- { if (nargs == 0) exit(0);
- ARG1("stop", x);
- exit(isFIXNUM(x) ? (int)qfixnum(x) : 0);
- }
- LispObject Lposn(LispObject lits, int nargs, ...)
- { ARG0("posn");
- return packfixnum(linepos);
- }
- LispObject Llinelength(LispObject lits, int nargs, ...)
- { ARG1("linelength", n);
- LispObject prev = packfixnum(linelength);
- if (isFIXNUM(n)) linelength = qfixnum(n);
- return prev;
- }
- LispObject Lprinbyte(LispObject lits, int nargs, ...)
- { ARG1("prinbyte", x); // Arg is an integer, send it to output
- // with no messing around.
- putc(qfixnum(x), lispfiles[lispout]);
- return x;
- }
- LispObject Lprin(LispObject lits, int nargs, ...)
- { ARG1("prin", x);
- return prin(x);
- }
- LispObject Lprint(LispObject lits, int nargs, ...)
- { ARG1("print", x);
- return print(x);
- }
- LispObject Lprinc(LispObject lits, int nargs, ...)
- { ARG1("princ", x);
- return princ(x);
- }
- LispObject Lprinhex(LispObject lits, int nargs, ...)
- { ARG1("princ", x);
- return prinhex(x);
- }
- LispObject Lprintc(LispObject lits, int nargs, ...)
- { ARG1("printc", x);
- return printc(x);
- }
- LispObject Lterpri(LispObject lits, int nargs, ...)
- { ARG0("terpri");
- wrch('\n');
- return nil;
- }
- LispObject Lnreverse(LispObject lits, int nargs, ...)
- { ARG1("nreverse", x);
- return nreverse(x);
- }
- LispObject Lexplode(LispObject lits, int nargs, ...)
- { int f = lispout;
- ARG1("explode", x);
- lispout = -1;
- work1 = nil;
- prin(x);
- lispout = f;
- return nreverse(work1);
- }
- LispObject Lexplodec(LispObject lits, int nargs, ...)
- { int f = lispout;
- ARG1("explodec", x);
- lispout = -1;
- work1 = nil;
- princ(x);
- lispout = f;
- return nreverse(work1);
- }
- LispObject Lcharcode(LispObject lits, int nargs, ...)
- { ARG1("char-code", x);
- if (isSYMBOL(x)) x = qpname(x);
- if (!isSTRING(x)) return error1("bad arg for char-code", x);
- return packfixnum(*qstring(x));
- }
- LispObject Lcodechar(LispObject lits, int nargs, ...)
- { char b[4];
- ARG1("code-char", x);
- if (!isFIXNUM(x)) return error1("bad arg for code-char", x);
- b[0] = (char)qfixnum(x); b[1] = 0;
- return lookup(b, 1, 1);
- }
- LispObject Lreadbyte(LispObject lits, int nargs, ...)
- { int ch;
- ARG0("readbyte"); // Read byte and return integer.
- ch = curchar;
- curchar = rdch();
- return packfixnum(ch & 0xff);
- }
- LispObject Lreadch(LispObject lits, int nargs, ...)
- { char ch[4];
- ARG0("readch");
- ch[0] = qvalue(lower) != nil ? tolower(curchar) :
- qvalue(raise) != nil ? toupper(curchar) : curchar;
- ch[1] = 0;
- curchar = rdch();
- return lookup(ch, 1, 1);
- }
- LispObject Lreadline(LispObject lits, int nargs, ...)
- { char ch[100];
- int n = 0;
- ARG0("readline");
- if (curchar == '\n' || curchar == '\r') curchar = rdch();
- while (curchar != '\n' && curchar != '\r' &&
- curchar != '\f' && curchar != EOF)
- { if (n < sizeof(ch)-1) ch[n++] = curchar;
- curchar = rdch();
- }
- ch[n] = 0;
- return lookup(ch, n, 1);
- }
- LispObject Lremob(LispObject lits, int nargs, ...)
- { ARG1("remob", x);
- if (!isSYMBOL(x)) return x;
- LispObject pn = qpname(x);
- int len = veclength(qheader(pn));
- const char *s = qstring(pn);
- return lookup(s, len, -1);
- }
- LispObject Lread(LispObject lits, int nargs, ...)
- { ARG0("read");
- return readS();
- }
- LispObject Lcompress(LispObject lits, int nargs, ...)
- { int f = lispin;
- LispObject r;
- int savetype = symtype, savech = curchar;
- ARG1("compress", x);
- lispin = -1;
- symtype = '?';
- curchar = '\n';
- push(cursym);
- work1 = x;
- r = readS();
- lispin = f;
- pop(cursym);
- symtype = savetype;
- curchar = savech;
- return r;
- }
- LispObject Lrds(LispObject lits, int nargs, ...)
- { int old = lispin;
- ARG1("rds", x);
- if (x == nil) x = packfixnum(3);
- if (isFIXNUM(x))
- { int n = (int)qfixnum(x);
- if (0 <= n && n < MAX_LISPFILES && lispfiles[n] != NULL &&
- (file_direction & (1u<<n)) == 0)
- { lispin = n;
- symtype = '?';
- if (curchar == EOF) curchar = '\n';
- return packfixnum(old);
- }
- }
- return error1("rds failed", x);
- }
- LispObject Lwrs(LispObject lits, int nargs, ...)
- { int old = lispout;
- ARG1("wrs", x);
- if (x == nil) x = packfixnum(1);
- if (isFIXNUM(x))
- { int n = (int)qfixnum(x);
- if (0 <= n && n < MAX_LISPFILES && lispfiles[n] != NULL &&
- (file_direction & (1u<<n)) != 0)
- { lispout = n;
- return packfixnum(old);
- }
- }
- return error1("wrs failed", x);
- }
- #define LONGEST_FILENAME 100
- char filename[LONGEST_FILENAME];
- LispObject Lopen(LispObject lits, int nargs, ...)
- { FILE *f;
- int n, loadp = (lits != nil), how = 0;
- char *p;
- ARG2("open", x, y);
- if (isSYMBOL(x)) x = qpname(x);
- if (!isSTRING(x) ||
- !((y == input && (how=1)!=0) ||
- (y == output && (how=2)!=0) ||
- (y == pipe && (how=3)!=0)))
- return error1("bad arg for open", cons(x, y));
- if (loadp) sprintf(filename, "modules/%.*s.fasl",
- (int)veclength(qheader(x)), qstring(x));
- // If the filename starts "$xxx/..." then the "$xxx" part gets replaced
- // with the value of the symbol !@xxx.
- // PSL might have looked in an environment variable...
- else if (*qstring(x)=='$' && (p=strchr(qstring(x), '/'))!=NULL)
- { sprintf(filename, "@%.*s", (int)(p-qstring(x))-1, 1+qstring(x));
- lits = qvalue(lookup(filename, strlen(filename), 0));
- if (isSTRING(lits)) sprintf(filename, "%.*s%.*s",
- (int)veclength(qheader(lits)), qstring(lits),
- (int)(veclength(qheader(x)) - (p-qstring(x))), p);
- else sprintf(filename, "%.*s", (int)veclength(qheader(x)), qstring(x));
- }
- else sprintf(filename, "%.*s", (int)veclength(qheader(x)), qstring(x));
- #ifdef _WIN32
- while (strchr(filename, '/') != NULL) *strchr(filename, '/') = '\\';
- #endif
- if (how == 3) f = popen(filename, "w");
- else f = fopen(filename, (how == 1 ? "r" : "w"));
- if (f == NULL) return error1("file could not be opened", x);
- for (n=4; n<MAX_LISPFILES && lispfiles[n]!=NULL; n++);
- if (n<MAX_LISPFILES)
- { lispfiles[n] = f;
- if (y != input) file_direction |= (1u << n);
- return packfixnum(n);
- }
- return error1("too many open files", x);;
- }
- LispObject Lclose(LispObject lits, int nargs, ...)
- { ARG1("close", x);
- if (isFIXNUM(x))
- { int n = (int)qfixnum(x);
- if (n > 3 && n < MAX_LISPFILES)
- { if (lispin == n) lispin = 3;
- if (lispout == n) lispout = 1;
- if (lispfiles[n] != NULL) fclose(lispfiles[n]);
- lispfiles[n] = NULL;
- file_direction &= ~(1u<<n);
- }
- }
- return nil;
- }
- void readevalprint(int loadp)
- { while (symtype != EOF)
- { LispObject r;
- push(qvalue(echo));
- unwindflag = unwindNONE;
- if (loadp) qvalue(echo) = nil;
- backtraceflag = backtraceHEADER | backtraceTRACE;
- r = readS();
- pop(qvalue(echo));
- if (loadp || qvalue(dfprint) == nil ||
- (isCONS(r) && (qcar(r) == lookup("rdf", 3, 0) ||
- qcar(r) == lookup("faslend", 7, 0))))
- { if (qvalue(toploopeval) == nil) r = eval(r);
- else
- { push2(qvalue(toploopeval), r);
- r = applytostack(1);
- }
- if (unwindflag == unwindNONE && !loadp)
- { linepos += printf("Value: ");
- print(r);
- }
- }
- else Lapply(nil, 2, qvalue(dfprint), cons(r, nil));
- }
- }
- LispObject Lrdf(LispObject lits, int nargs, ...)
- { int f, f1, loadp = (lits != nil), savech = curchar, savetype = symtype;
- ARG1("rdf", x);
- f1 = Lopen(lits, 2, x, input);
- if (unwindflag != unwindNONE) return nil;
- f = Lrds(nil, 1, f1);
- readevalprint(loadp);
- Lrds(nil, 1, f);
- Lclose(nil, 1, f1);
- curchar = savech;
- symtype = savetype;
- if (!loadp) printf("+++ End of rdf\n");
- return nil;
- }
- LispObject Ltrace(LispObject lits, int nargs, ...)
- { ARG1("trace", x);
- while (isCONS(x))
- { if (isSYMBOL(qcar(x))) qflags(qcar(x)) |= flagTRACED;
- x = qcdr(x);
- }
- return nil;
- }
- LispObject Luntrace(LispObject lits, int nargs, ...)
- { ARG1("untrace", x);
- while (isCONS(x))
- { if (isSYMBOL(qcar(x))) qflags(qcar(x)) &= ~flagTRACED;
- x = qcdr(x);
- }
- return nil;
- }
- LispObject Lerror(LispObject lits, int nargs, ...)
- { ARG2("error", x, y);
- return error1("error function called", list2star(x,y,nil));
- }
- LispObject Lerrorset(LispObject lits, int nargs, ...)
- { int save = backtraceflag;
- ARG3("errorset", x, y, z);
- backtraceflag = 0;
- if (y != nil) backtraceflag |= backtraceHEADER;
- if (z != nil) backtraceflag |= backtraceTRACE;
- x = eval(x);
- if (unwindflag == unwindERROR ||
- unwindflag == unwindBACKTRACE)
- { unwindflag = unwindNONE;
- x = nil;
- }
- else x = cons(x, nil);
- backtraceflag = save;
- return x;
- }
- struct defined_functions
- { const char *name;
- int flags;
- void *entrypoint;
- };
- struct defined_functions fnsetup[] =
- {
- // First the special forms
- {"quote", flagSPECFORM, (void *)Lquote},
- {"cond", flagSPECFORM, (void *)Lcond},
- {"and", flagSPECFORM, (void *)Land},
- {"or", flagSPECFORM, (void *)Lor},
- {"de", flagSPECFORM, (void *)Lde},
- {"df", flagSPECFORM, (void *)Ldf},
- {"dm", flagSPECFORM, (void *)Ldm},
- {"setq", flagSPECFORM, (void *)Lsetq},
- {"progn", flagSPECFORM, (void *)Lprogn},
- {"prog", flagSPECFORM, (void *)Lprog},
- {"go", flagSPECFORM, (void *)Lgo},
- // The following are implemented as special forms here because they
- // take variable or arbitrary numbers of arguments - however they all
- // evaluate all their arguments in a rather simple way, so they
- // could be treated a sorts of "ordinary" function.
- {"list", flagSPECFORM, (void *)Llist},
- {"list*", flagSPECFORM, (void *)Lliststar},
- {"iplus", flagSPECFORM, (void *)Lplus},
- {"itimes", flagSPECFORM, (void *)Ltimes},
- {"ilogand", flagSPECFORM, (void *)Llogand},
- {"ilogor", flagSPECFORM, (void *)Llogor},
- {"ilogxor", flagSPECFORM, (void *)Llogxor},
- // Now ordinary functions. I have put these in alphabetic order.
- {"iadd1", 0, (void *)Ladd1},
- {"apply", 0, (void *)Lapply},
- {"atan", 0, (void *)Latan},
- {"atom", 0, (void *)Latom},
- {"bignump", 0, (void *)Lbignump},
- {"boundp", 0, (void *)Lboundp},
- {"car", 0, (void *)Lcar},
- {"cdr", 0, (void *)Lcdr},
- {"char-code", 0, (void *)Lcharcode},
- {"char", 0, (void *)Lchar},
- {"iceiling", 0, (void *)Lceiling},
- {"close", 0, (void *)Lclose},
- {"clrhash", 0, (void *)Lclrhash},
- {"code-char", 0, (void *)Lcodechar},
- {"compress", 0, (void *)Lcompress},
- {"cons", 0, (void *)Lcons},
- {"cos", 0, (void *)Lcos},
- {"idifference",0, (void *)Ldifference},
- {"idivide", 0, (void *)Ldivide},
- {"eq", 0, (void *)Leq},
- {"equal", 0, (void *)Lequal},
- {"error", 0, (void *)Lerror},
- {"errorset", 0, (void *)Lerrorset},
- {"eval", 0, (void *)Leval},
- {"exp", 0, (void *)Lexp},
- {"explode", 0, (void *)Lexplode},
- {"explodec", 0, (void *)Lexplodec},
- {"ifix", 0, (void *)Lfix},
- {"ifixp", 0, (void *)Lfixp},
- {"ifloat", 0, (void *)Lfloat},
- {"floatp", 0, (void *)Lfloatp},
- {"ifloor", 0, (void *)Lfloor},
- {"gensym", 0, (void *)Lgensym},
- {"gensymp", 0, (void *)Lgensymp},
- {"igeq", 0, (void *)Lgeq},
- {"get", 0, (void *)Lget},
- {"getd", 0, (void *)Lgetd},
- {"gethash", 0, (void *)Lgethash},
- {"getv", 0, (void *)Lgetv},
- {"igreaterp", 0, (void *)Lgreaterp},
- {"ileftshift", 0, (void *)Lleftshift},
- {"ileq", 0, (void *)Lleq},
- {"ilessp", 0, (void *)Llessp},
- {"linelength", 0, (void *)Llinelength},
- {"load-module",0, (void *)Lrdf},
- {"log", 0, (void *)Llog},
- {"lposn", 0, (void *)Lposn},
- {"ilognot", 0, (void *)Llognot},
- {"iminus", 0, (void *)Lminus},
- {"iminusp", 0, (void *)Lminusp},
- {"makeunbound",0, (void *)Lmakeunbound},
- {"mkhash", 0, (void *)Lmkhash},
- {"mkvect", 0, (void *)Lmkvect},
- {"null", 0, (void *)Lnull},
- {"inumberp", 0, (void *)Lnumberp},
- {"oblist", 0, (void *)Loblist},
- {"onep", 0, (void *)Lonep},
- {"open", 0, (void *)Lopen},
- {"plist", 0, (void *)Lplist},
- {"pname", 0, (void *)Lpname},
- {"symbol-name",0, (void *)Lpname},
- {"posn", 0, (void *)Lposn},
- {"preserve", 0, (void *)Lpreserve},
- {"prin", 0, (void *)Lprin},
- {"prinbyte", 0, (void *)Lprinbyte},
- {"princ", 0, (void *)Lprinc},
- {"prinhex", 0, (void *)Lprinhex},
- {"print", 0, (void *)Lprint},
- {"printc", 0, (void *)Lprintc},
- {"put", 0, (void *)Lput},
- {"puthash", 0, (void *)Lputhash},
- {"putv", 0, (void *)Lputv},
- {"iquotient", 0, (void *)Lquotient},
- {"rdf", 0, (void *)Lrdf},
- {"rds", 0, (void *)Lrds},
- {"read", 0, (void *)Lread},
- {"readbyte", 0, (void *)Lreadbyte},
- {"readch", 0, (void *)Lreadch},
- {"readline", 0, (void *)Lreadline},
- {"remob", 0, (void *)Lremob},
- {"iremainder", 0, (void *)Lremainder},
- {"remhash", 0, (void *)Lremhash},
- {"remprop", 0, (void *)Lremprop},
- {"restart-csl",0, (void *)Lrestart_csl},
- {"return", 0, (void *)Lreturn},
- {"irightshift",0, (void *)Lrightshift},
- {"rplaca", 0, (void *)Lrplaca},
- {"rplacd", 0, (void *)Lrplacd},
- {"set", 0, (void *)Lset},
- {"sin", 0, (void *)Lsin},
- {"sqrt", 0, (void *)Lsqrt},
- {"stop", 0, (void *)Lstop},
- {"stringp", 0, (void *)Lstringp},
- {"isub1", 0, (void *)Lsub1},
- {"symbolp", 0, (void *)Lsymbolp},
- {"terpri", 0, (void *)Lterpri},
- {"time", 0, (void *)Ltime},
- {"trace", 0, (void *)Ltrace},
- {"untrace", 0, (void *)Luntrace},
- {"upbv", 0, (void *)Lupbv},
- {"vectorp", 0, (void *)Lvectorp},
- {"wrs", 0, (void *)Lwrs},
- {"zerop", 0, (void *)Lzerop},
- {NULL, 0, NULL}
- };
- void setup()
- {
- // Ensure that initial symbols and functions are in place. Parts of this
- // code are rather rambling and repetitive but this is at least a simple
- // way to do things. I am going to assume that nothing can fail within this
- // setup code, so I can omit all checks for error conditions.
- struct defined_functions *p;
- undefined = lookup("~indefinite-value~", 18, 1);
- qvalue(undefined) = undefined;
- nil = lookup("nil", 3, 1);
- qvalue(nil) = nil;
- lisptrue = lookup("t", 1, 1);
- qvalue(lisptrue) = lisptrue;
- qvalue(echo = lookup("*echo", 5, 1)) = interactive ? nil : lisptrue;
- qvalue(lispsystem = lookup("lispsystem*", 11, 1)) =
- list2star(lookup("vsl", 3, 1), lookup("csl", 3, 1),
- cons(lookup("embedded", 8, 1), nil));
- quote = lookup("quote", 5, 1);
- function = lookup("function", 8, 1);
- backquote = lookup("`", 1, 1);
- comma = lookup(",", 1, 1);
- comma_at = lookup(",@", 2, 1);
- comma_dot = lookup(",.", 2, 1);
- eofsym = lookup("$eof$", 5, 1);
- qvalue(eofsym) = eofsym;
- lambda = lookup("lambda", 6, 1);
- expr = lookup("expr", 4, 1);
- subr = lookup("subr", 4, 1);
- fexpr = lookup("fexpr", 5, 1);
- fsubr = lookup("fsubr", 5, 1);
- macro = lookup("macro", 5, 1);
- input = lookup("input", 5, 1);
- output = lookup("output", 6, 1);
- pipe = lookup("pipe", 4, 1);
- charvalue = lookup("charvalue", 9, 1);
- raise = lookup("*raise", 6, 1);
- lower = lookup("*lower", 6, 1);
- dfprint = lookup("dfprint*", 8, 1);
- toploopeval = lookup("toploopeval*", 12, 1);
- loseflag = lookup("lose", 4, 1);
- bignum = lookup("~bignum", 7, 1);
- condsymbol = lookup("cond", 4, 1);
- prognsymbol = lookup("progn", 5, 1);
- gosymbol = lookup("go", 2, 1);
- returnsymbol = lookup("return", 6, 1);
- #ifdef PSL
- dummyvar = lookup("~dummyvar", 9, 1);
- #endif
- qlits(lookup("load-module", 11, 1)) = lisptrue;
- cursym = nil;
- work1 = work2 = nil;
- p = fnsetup;
- while (p->name != NULL)
- { LispObject w = lookup(p->name, strlen(p->name), 1);
- qflags(w) |= p->flags;
- qdefn(w) = p->entrypoint;
- printf("Setting up %s %p\n", p->name, p->entrypoint);
- p++;
- }
- }
- void cold_setup()
- {
- // version of setup to call when there is no initial heap image at all.
- int i;
- // I make the object-hash-table lists end in a fixnum rather than nil
- // because I want to create the hash table before even the symbol nil
- // exists.
- for (i=0; i<OBHASH_SIZE; i++) obhash[i] = tagFIXNUM;
- for (i=0; i<BASES_SIZE; i++) bases[i] = NULLATOM;
- setup();
- // The following fields could not be set up quite early enough in the
- // cold start case, so I repair them now.
- restartfn = qplist(undefined) = qlits(undefined) =
- qplist(nil) = qlits(nil) = nil;
- // I must only initialize these in the code start case. For hot starts the
- // values are saved in the image file.
- qvalue(raise) = nil;
- qvalue(lower) = lisptrue;
- qvalue(dfprint) = nil;
- qvalue(toploopeval) = nil;
- }
- LispObject relocate(LispObject a, LispObject change)
- {
- // Used to update a LispObject when reloaded from a saved heap image.
- switch (a & TAGBITS)
- { case tagATOM:
- if (a == NULLATOM) return a;
- case tagCONS:
- case tagSYMBOL:
- case tagFLOAT:
- return a + change;
- default:
- //case tagFIXNUM:
- //case tagFORWARD:
- //case tagHDR:
- return a;
- }
- }
- void warm_setup()
- {
- // The idea here is that a file called "vsl.img" will already have been
- // created by a previous use of vsl, and it should be re-loaded.
- FILE *f = fopen(imagename, "rb");
- int i;
- LispObject currentbase = heap1base, change, *s;
- if (f == NULL)
- { printf("Error: unable to open image for reading\n");
- exit(1);
- }
- if (fread(nonbases, 1, sizeof(nonbases), f) != sizeof(nonbases) ||
- headerword != FILEID ||
- fread(bases, 1, sizeof(bases), f) != sizeof(bases) ||
- fread(obhash, 1, sizeof(obhash), f) != sizeof(obhash))
- { printf("Error: Image file corrupted or incompatible\n");
- exit(1);
- }
- change = currentbase - heap1base;
- // Now I relocate the key addresses to refer to the CURRENT rather than
- // the saved address map.
- heap1base += change;
- heap1top += change;
- fringe1 += change;
- fpfringe1 += change;
- if (fread((void *)heap1base, 1, (size_t)(fringe1-heap1base), f) !=
- (size_t)(fringe1-heap1base) ||
- fread((void *)fpfringe1, 1, (size_t)(heap1top-fpfringe1), f) !=
- (size_t)(heap1top-fpfringe1))
- { printf("Error: Unable to read image file\n");
- exit(1);
- }
- fclose(f);
- for (i=0; i<BASES_SIZE; i++)
- bases[i] = relocate(bases[i], change);
- for (i=0; i<OBHASH_SIZE; i++)
- obhash[i] = relocate(obhash[i], change);
- // The main heap now needs to be scanned and addresses in it corrected.
- s = (LispObject *)heap1base;
- while ((LispObject)s != fringe1)
- { LispObject h = *s, w;
- if (!isHDR(h)) // The item to be processed is a simple cons cell
- { *s++ = relocate(h, change);
- *s = relocate(*s, change);
- s++;
- }
- else // The item is one that uses a header
- switch (h & TYPEBITS)
- { case typeSYM:
- case typeGENSYM:
- w = ((LispObject)s) + tagSYMBOL;
- // qflags(w) does not need adjusting
- qvalue(w) = relocate(qvalue(w), change);
- qplist(w) = relocate(qplist(w), change);
- qpname(w) = relocate(qpname(w), change);
- if (qdefn(w) == (void *)saveinterp)
- qdefn(w) = (void *)interpret;
- else if (qdefn(w) == (void *)saveinterpspec)
- qdefn(w) = (void *)interpretspecform;
- qlits(w) = relocate(qlits(w), change);
- s += 6;
- continue;
- case typeSTRING: case typeBIGNUM:
- // These sorts of atom just contain binary data so do not need adjusting,
- // but I have to allow for the length code being in bytes etc.
- w = (LispObject)s;
- w += veclength(h);
- w = (w + sizeof(LispObject) + 7) & ~7;
- s = (LispObject *)w;
- continue;
- case typeVEC: case typeEQHASH: case typeEQHASHX:
- s++;
- w = veclength(h);
- while (w > 0)
- { *s = relocate(*s, change);
- s++;
- w -= sizeof(LispObject);
- }
- s = (LispObject *)(((LispObject)s + 7) & ~7);
- continue;
- default:
- // The spare codes!
- disaster(__LINE__);
- }
- }
- setup(); // resets all built-in functions properly.
- }
- int main(int argc, char *argv[])
- { elx_e = el_init(argv[0], stdin, stdout, stderr);
- el_set(elx_e, EL_PROMPT, prompt);
- el_set(elx_e, EL_EDITOR, "emacs");
- if ((elx_h = history_init()) == 0)
- { fprintf(stderr, "Unable to initialize history\n");
- exit(1);
- }
- history(elx_h, &elx_v, H_SETSIZE, 400);
- el_set(elx_e, EL_HIST, history, elx_h);
-
- const char *inputfilename = NULL;
- coldstart = 0;
- interactive = 1;
- for (int i=1; i<argc; i++)
- {
- // I have some VERY simple command-line options here.
- // -z do a "cold start".
- // -ifilename use that as image file
- // -i filename ditto
- // -ofilename and -o filename: specify output image
- // filename read from that file rather than from the standard input.
- if (strcmp(argv[i], "-z") == 0) coldstart = 1;
- else if (strcmp(argv[i], "-i") == 0 && i<argc-1)
- imagename = argv[++i];
- else if (strcmp(argv[i], "-o") == 0 && i<argc-1)
- outimagename = argv[++i];
- else if (strncmp(argv[i], "-i", 2) == 0) imagename=argv[i]+2;
- else if (strncmp(argv[i], "-o", 2) == 0) outimagename=argv[i]+2;
- else if (argv[i][0] != '-') inputfilename = argv[i], interactive = 0;
- }
- if (outimagename == NULL) outimagename = imagename;
- printf("VSL version 1.01\n");
- linepos = 0;
- for (int i=0; i>MAX_LISPFILES; i++) lispfiles[i] = 0;
- lispfiles[0] = stdin; lispfiles[1] = stdout;
- lispfiles[2] = stderr; lispfiles[3] = stdin;
- file_direction = (1<<1) | (1<<2); // 1 bits for writable files.
- lispin = 3; lispout = 1;
- if (inputfilename != NULL)
- { FILE *in = fopen(inputfilename, "r");
- if (in == NULL)
- printf("Unable to read from %s, so using standard input\n",
- inputfilename);
- else lispfiles[3] = in;
- }
- allocateheap();
- // A warm start will read a file "vsl.img" which it expects to have been
- // made by a previous use of vsl.
- boffop = 0; setjmp(restart_buffer);
- sp = (LispObject *)stackbase;
- if (coldstart) cold_setup();
- else warm_setup();
- for (int i=1; i<argc; i++)
- { if (argv[i][0] == '-' && argv[i][1] == 'D')
- { const char *d1 = strchr(argv[i], '=');
- if (d1 == NULL) continue;
- qvalue(lookup(argv[i]+2, (d1-argv[i])-2, 1)) =
- makestring(d1+1, strlen(d1+1));
- }
- }
- curchar = '\n'; symtype = '?'; cursym = nil;
- if (boffop == 0) // normal start, not following restart-csl
- { if (restartfn != nil) // restart function saved by preserve
- {
- Lapply(nil, 2, restartfn, nil);
- return 0;
- }
- }
- else
- { LispObject x, data = makestring(boffo, boffop);
- data = Lcompress(nil, 1, Lexplodec(nil, 1, data));
- x = qcar(data);
- if (x != nil)
- { if (x == lisptrue) x = restartfn;
- else if (isCONS(x) && isCONS(qcdr(x)))
- { LispObject m = qcar(x);
- push2(data, qcar(qcdr(x)));
- Lrdf(lisptrue, 1, m);
- pop2(x, data);
- }
- Lapply(nil, 2, x, qcdr(data));
- return 0;
- }
- }
- readevalprint(0);
- return 0;
- }
- // end of "vsl.c"
|