read.c 144 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635
  1. /* read.c Copyright (C) 1990-2002 Codemist Ltd */
  2. /*
  3. * Reading and symbol-table support.
  4. */
  5. /*
  6. * This code may be used and modified, and redistributed in binary
  7. * or source form, subject to the "CCL Public License", which should
  8. * accompany it. This license is a variant on the BSD license, and thus
  9. * permits use of code derived from this in either open and commercial
  10. * projects: but it does require that updates to this code be made
  11. * available back to the originators of the package.
  12. * Before merging other code in with this or linking this code
  13. * with other packages or libraries please check that the license terms
  14. * of the other material are compatible with those of this.
  15. */
  16. /* Signature: 09196b7c 10-Oct-2002 */
  17. #include <stdarg.h>
  18. #include <string.h>
  19. #include <ctype.h>
  20. #ifdef __WATCOMC__
  21. #include <float.h>
  22. #endif
  23. #include "machine.h"
  24. #include "tags.h"
  25. #include "cslerror.h"
  26. #include "externs.h"
  27. #include "read.h"
  28. #include "stream.h"
  29. #include "arith.h"
  30. #include "entries.h"
  31. #ifdef COMMON
  32. #include "clsyms.h"
  33. #endif
  34. #ifdef TIMEOUT
  35. #include "timeout.h"
  36. #endif
  37. #ifdef SOCKETS
  38. #include "sockhdr.h"
  39. #endif
  40. #define CTRL_C 3
  41. #define CTRL_D 4
  42. #ifdef Kanji
  43. #define ISalpha(a) iswalpha(a)
  44. #define ISdigit(a) iswdigit(a)
  45. #define ISspace(a) iswspace(a)
  46. #define TOupper(a) towupper(a)
  47. #define TOlower(a) towlower(a)
  48. int first_char(Lisp_Object ch)
  49. { /* ch is a symbol. Get the first character of its name. */
  50. int n;
  51. intxx l;
  52. ch = qpname(ch);
  53. l = length_of_header(vechdr(ch)) - CELL;
  54. if (l == 0) return 0;
  55. n = celt(ch, 0);
  56. if (is2byte(n) && l != 1)
  57. n = (n << 8) + ucelt(ch, 1);
  58. return n;
  59. }
  60. #else /* Kanji */
  61. #define ISalpha(a) isalpha(a)
  62. #define ISdigit(a) isdigit(a)
  63. #define ISspace(a) isspace(a)
  64. #define TOupper(a) toupper(a)
  65. #define TOlower(a) tolower(a)
  66. #define first_char(ch) ucelt(qpname(ch), 0)
  67. #endif /* Kanji */
  68. /*
  69. * Basic version of Lisp reader.
  70. */
  71. static int curchar = NOT_CHAR;
  72. FILE *non_terminal_input;
  73. static int boffop;
  74. #define boffo_char(i) ucelt(boffo, i)
  75. Lisp_Object make_string(char *b)
  76. /*
  77. * Given a C string, create a Lisp (simple-) string.
  78. */
  79. {
  80. int32 n = strlen(b);
  81. Lisp_Object r = getvector(TAG_VECTOR, TYPE_STRING, CELL+n);
  82. char *s = (char *)r - TAG_VECTOR;
  83. int32 k = (n + 3) & ~(int32)7;
  84. Lisp_Object nil;
  85. errexit();
  86. /* Here I go to some trouble to zero out the last doubleword of the vector */
  87. #ifdef ADDRESS_64
  88. if (k != 0)
  89. { *(int32 *)(s + k + 4) = 0;
  90. *(int32 *)(s + k) = 0;
  91. }
  92. #else
  93. *(int32 *)(s + k + 4) = 0;
  94. if (k != 0) *(int32 *)(s + k) = 0;
  95. #endif
  96. memcpy(s + CELL, b, (size_t)n);
  97. return r;
  98. }
  99. static Lisp_Object copy_string(Lisp_Object str, int32 n)
  100. /*
  101. * Given a Lisp string, plus its length, create a Lisp (simple-) string.
  102. * NOTE that the "string" passed in may not in fact have the length
  103. * you think it has - it may be boffo which is used as a string buffer.
  104. */
  105. {
  106. Lisp_Object nil, r;
  107. char *s;
  108. int32 k;
  109. push(str);
  110. r = getvector(TAG_VECTOR, TYPE_STRING, CELL+n);
  111. pop(str);
  112. s = (char *)r - TAG_VECTOR;
  113. k = (n + 3) & ~(int32)7;
  114. errexit();
  115. /* Here I go to some trouble to zero out the last doubleword of the vector */
  116. #ifdef ADDRESS_64
  117. if (k != 0)
  118. { *(int32 *)(s + k + 4) = 0;
  119. *(int32 *)(s + k) = 0;
  120. }
  121. #else
  122. *(int32 *)(s + k + 4) = 0;
  123. if (k != 0) *(int32 *)(s + k) = 0;
  124. #endif
  125. memcpy(s + CELL, (char *)str + (CELL-TAG_VECTOR), (size_t)n);
  126. return r;
  127. }
  128. Lisp_Object MS_CDECL Lbatchp(Lisp_Object nil, int nargs, ...)
  129. {
  130. CSL_IGNORE(nil);
  131. argcheck(nargs, 0, "batchp");
  132. #ifdef SOCKETS
  133. /*
  134. * If CSL is being run as a service (ie accessed via a socket) then I will
  135. * deem it to be in "interactive" mode. This leaves responsibility for stopping
  136. * after errors (if that is what is wanted) with the other end of the
  137. * communications link.
  138. */
  139. if (socket_server != 0) return onevalue(nil);
  140. #endif
  141. /*
  142. * If the user had specified input files on the command line I will say that
  143. * we are in batch mode even if there is a terminal present somewhere. So
  144. * a run of the form
  145. * csl inputfile.lsp
  146. * is a "batch" run, while
  147. * csl < inputfile.lsp
  148. * will MAYBE also be noticed as batch, but do not count on it!
  149. */
  150. if (non_terminal_input != NULL)
  151. return onevalue(batch_flag ? nil : lisp_true);
  152. /*
  153. * "sysxxx.c" now decides if we are in "batch processing" context,
  154. * in general by asking "isatty(fileno(stdin))" to see if stdin is
  155. * attached to an interactive terminal. Ideally this will say we are in
  156. * batch mode if the user has redirected input from a file, as in
  157. * csl < xxx.lsp
  158. * but catching such cases may be HARD with some operating systems.
  159. * With some operating systems we will NEVER report ourselves as "batch".
  160. */
  161. return onevalue(Lispify_predicate(batch_flag ? !batchp() : batchp()));
  162. }
  163. Lisp_Object Lgetenv(Lisp_Object nil, Lisp_Object a)
  164. {
  165. char parmname[LONGEST_LEGAL_FILENAME];
  166. Header h;
  167. Lisp_Object r;
  168. int32 len;
  169. char *w;
  170. #ifdef COMMON
  171. if (complex_stringp(a))
  172. { a = simplify_string(a);
  173. errexit();
  174. }
  175. #endif
  176. if (symbolp(a))
  177. { a = get_pname(a);
  178. errexit();
  179. h = vechdr(a);
  180. }
  181. else if (!is_vector(a) ||
  182. type_of_header(h = vechdr(a)) != TYPE_STRING)
  183. return aerror1("getenv", a);
  184. len = length_of_header(h) - CELL;
  185. memcpy(parmname, (char *)a + (CELL-TAG_VECTOR), (size_t)len);
  186. parmname[len] = 0;
  187. w = my_getenv(parmname);
  188. if (w == NULL) return onevalue(nil); /* not available */
  189. r = make_string(w);
  190. errexit();
  191. return onevalue(r);
  192. }
  193. Lisp_Object Lsystem(Lisp_Object nil, Lisp_Object a)
  194. {
  195. char parmname[LONGEST_LEGAL_FILENAME];
  196. Header h;
  197. int32 len;
  198. int w;
  199. #ifdef SOCKETS
  200. /*
  201. * Security measure - remote client can not do "system"
  202. */
  203. if (socket_server != 0) return onevalue(nil);
  204. #endif
  205. if (a == nil) /* enquire if command processor is available */
  206. { w = my_system(NULL);
  207. return onevalue(Lispify_predicate(w != 0));
  208. }
  209. #ifdef COMMON
  210. if (complex_stringp(a))
  211. { a = simplify_string(a);
  212. errexit();
  213. }
  214. #endif
  215. if (symbolp(a))
  216. { a = get_pname(a);
  217. errexit();nil = C_nil;
  218. h = vechdr(a);
  219. }
  220. else if (!is_vector(a) ||
  221. type_of_header(h = vechdr(a)) != TYPE_STRING)
  222. return aerror1("system", a);
  223. len = length_of_header(h) - CELL;
  224. memcpy(parmname, (char *)a + (CELL-TAG_VECTOR), (size_t)len);
  225. parmname[len] = 0;
  226. w = my_system(parmname);
  227. return onevalue(fixnum_of_int((int32)w));
  228. }
  229. static unsigned32 hash_lisp_string_with_length(Lisp_Object s, int32 n)
  230. {
  231. /*
  232. * I start off the hash calculation with something that depends on the
  233. * length of the string n.
  234. */
  235. unsigned32 hh = 0x01000000 + n;
  236. unsigned32 *b = (unsigned32 *)((char *)s + (CELL-TAG_VECTOR));
  237. char *b1;
  238. while (n >= CELL+4) /* Do as much as is possible word at a time */
  239. {
  240. unsigned32 temp;
  241. /*
  242. * The next few lines take a 32-bit value with digits PQRS and for a value
  243. * with digits Q^R and P^Q^R^S. Note that this is invariant under the change
  244. * to SRQP, and thus even though I fetched a whole word and the order of bytes
  245. * in that word is hard to know the hash value will not depend on the byte
  246. * order involved. By that time I have done all this and thereby lost any
  247. * chance of ABCD and DCBA not clashing maybe a simple byte at a time hash
  248. * procedure would have been more sense? Some day I should take comparative
  249. * timings and measurements of hash-table conflicts.
  250. */
  251. unsigned32 a = *b++; /* P Q R S */
  252. a = a ^ (a << 8); /* P^Q Q^R R^S S */
  253. a = a ^ (a >> 16); /* P^Q Q^R P^Q^R^S Q^R^S */
  254. a = a << 8; /* Q^R P^Q^R^S Q^R^S 0 */
  255. /*
  256. * And now compute a hash value using a CRC that has a period of
  257. * 0x7fffffff (i.e. maximum period in 31 bits). And at least if shift
  258. * operations are cheap on your computer it can be evaluated rapidly as well.
  259. */
  260. temp = hh << 7;
  261. hh = ((hh >> 25) ^
  262. (temp >> 1) ^
  263. (temp >> 4) ^
  264. (a >> 16)) & 0x7fffffff;
  265. n -= 4;
  266. }
  267. b1 = (char *)b;
  268. /*
  269. * Finish off the hash value byte-at-a-time. If I could be certain that
  270. * strings being hashed would always be zero-padded in their last word I
  271. * could avoid the need for this, but at present I can not.
  272. */
  273. while (n > CELL)
  274. { unsigned32 temp;
  275. temp = hh << 7;
  276. hh = ((hh >> 25) ^
  277. (temp >> 1) ^
  278. (temp >> 4) ^
  279. (unsigned32)*b1++) & 0x7fffffff;
  280. n -= 1;
  281. }
  282. /*
  283. * At the end I multiply by 139 so that at least symbols that differ
  284. * by just having adjacent last letters will be better spread out.
  285. */
  286. return ((139*hh) & 0x7fffffff);
  287. }
  288. unsigned32 hash_lisp_string(Lisp_Object s)
  289. /*
  290. * Argument is a (lisp) string. Return a 31 bit hash value.
  291. */
  292. {
  293. return hash_lisp_string_with_length(s, length_of_header(vechdr(s)));
  294. }
  295. static int value_in_radix(int c, int radix)
  296. {
  297. if (ISdigit(c)) c = c - '0'; /* Assumes digit codes are consecutive */
  298. /*
  299. * The next section tries hard not to depend on any particular character
  300. * code - this may slow it down a little bit but reading numbers that
  301. * have an explicit radix will not usually matter that much.
  302. */
  303. else if (ISalpha(c))
  304. { char *v = "abcdefghijklmnopqrstuvwxyz";
  305. int n = 0;
  306. c = tolower(c);
  307. while (*v++ != c)
  308. if (++n >= 26) return -1; /* break on unrecognized letter */
  309. c = n + 10;
  310. }
  311. else return -1;
  312. if (c < radix) return c;
  313. else return -1;
  314. }
  315. Lisp_Object intern(int len, CSLbool escaped)
  316. /*
  317. * This takes whatever is in the first len characters of
  318. * the Lisp string boffo, and maps it into a number, string
  319. * or symbol as relevant.
  320. */
  321. {
  322. int i, numberp = escaped ? -1 : 0;
  323. #ifdef COMMON
  324. int fplength = 2, explicit_fp_format = 0;
  325. #endif
  326. Lisp_Object nil = C_nil;
  327. stackcheck0(0);
  328. for (i=0; i<len; i++)
  329. { int c = boffo_char(i);
  330. switch (numberp)
  331. {
  332. default:
  333. break;
  334. case 0:
  335. if (c == '+' || c == '-')
  336. { numberp = 1;
  337. continue;
  338. }
  339. /* drop through */
  340. case 1:
  341. if (c == '.')
  342. { numberp = 6;
  343. continue;
  344. }
  345. if (ISdigit(c)) /* Really wants to inspect *read-base* */
  346. { numberp = 2;
  347. continue;
  348. }
  349. numberp = -1;
  350. break;
  351. case 2:
  352. if (ISdigit(c)) continue; /* *read-base* */
  353. switch (c)
  354. {
  355. #ifdef COMMON
  356. case '/': numberp = 3; continue;
  357. #endif
  358. case '.': numberp = 5; continue;
  359. case 'e': case 'E':
  360. /*
  361. * in CSL mode I will read all floating point numbers as if they had been
  362. * double-precision, so I disable recognition of s,f,d and l exponent
  363. * markers and force the length. In Common Lisp mode I have to look at the
  364. * value of *read-default-float-format* to see what to do.
  365. */
  366. numberp = 9;
  367. continue;
  368. #ifdef COMMON
  369. case 's': case 'S':
  370. boffo_char(i) = 'e';
  371. explicit_fp_format = 1;
  372. fplength = 0;
  373. numberp = 9;
  374. continue;
  375. case 'f': case 'F':
  376. boffo_char(i) = 'e';
  377. explicit_fp_format = 1;
  378. fplength = 1;
  379. numberp = 9;
  380. continue;
  381. case 'd': case 'D':
  382. boffo_char(i) = 'e';
  383. explicit_fp_format = 1;
  384. numberp = 9;
  385. continue;
  386. case 'l': case 'L':
  387. boffo_char(i) = 'e';
  388. explicit_fp_format = 1;
  389. fplength = 3;
  390. numberp = 9;
  391. continue;
  392. #endif
  393. default:
  394. numberp = -1;
  395. break;
  396. }
  397. break;
  398. #ifdef COMMON
  399. case 3:
  400. case 4:
  401. if (ISdigit(c)) /* *read-base* */
  402. { numberp = 4;
  403. continue;
  404. }
  405. numberp = -1;
  406. break;
  407. #endif
  408. case 5:
  409. case 8:
  410. if (ISdigit(c))
  411. { numberp = 8;
  412. continue;
  413. }
  414. switch (c)
  415. {
  416. case 'e': case 'E':
  417. numberp = 9;
  418. continue;
  419. #ifdef COMMON
  420. case 's': case 'S':
  421. /* Clobbering the string is a DISASTER if it is not in fact numeric */
  422. boffo_char(i) = 'e';
  423. explicit_fp_format = 1;
  424. fplength = 0;
  425. numberp = 9;
  426. continue;
  427. case 'f': case 'F':
  428. boffo_char(i) = 'e';
  429. explicit_fp_format = 1;
  430. fplength = 1;
  431. numberp = 9;
  432. continue;
  433. case 'd': case 'D':
  434. boffo_char(i) = 'e';
  435. explicit_fp_format = 1;
  436. numberp = 9;
  437. continue;
  438. case 'l': case 'L':
  439. boffo_char(i) = 'e';
  440. explicit_fp_format = 1;
  441. fplength = 3;
  442. numberp = 9;
  443. continue;
  444. #endif
  445. default:
  446. numberp = -1;
  447. break;
  448. }
  449. break;
  450. case 6:
  451. if (ISdigit(c))
  452. { numberp = 8;
  453. continue;
  454. }
  455. numberp = -1;
  456. break;
  457. case 9:
  458. if (c == '+' || c == '-')
  459. { numberp = 10;
  460. continue;
  461. }
  462. /* Drop through */
  463. case 10:
  464. case 11:
  465. if (ISdigit(c))
  466. { numberp = 11;
  467. continue;
  468. }
  469. numberp = -1;
  470. break;
  471. }
  472. break;
  473. }
  474. /* Here the item has been scanned, and it is known if it is numeric! */
  475. switch (numberp)
  476. {
  477. default:
  478. /* Not a number... look up in package system */
  479. #ifdef COMMON
  480. if (!escaped && boffo_char(0) == ':')
  481. { int i = 0;
  482. for (i = 0; i<boffop; i++) boffo_char(i) = boffo_char(i+1);
  483. boffop--;
  484. return iintern(boffo, (int32)boffop, qvalue(keyword_package), 0);
  485. }
  486. #endif
  487. return iintern(boffo, (int32)boffop, CP, 0);
  488. case 5: /* Integer written as 12345. (note trailing ".") */
  489. boffo_char(--boffop) = 0; /* ... trim off the trailing dot */
  490. /* drop through */
  491. case 2:
  492. /*
  493. * I speed up reading by working 7 digits at a time (using C integer
  494. * arithmetic to gobble them) and only resorting to Lisp generic
  495. * arithmetic to combine the chunks.
  496. */
  497. if (boffo_char(0) == '+')
  498. { int i = 0;
  499. for (i = 0; i<boffop; i++) boffo_char(i) = boffo_char(i+1);
  500. boffop--;
  501. }
  502. { Lisp_Object v = fixnum_of_int(0);
  503. CSLbool sign = NO;
  504. int32 d = 0, d1 = 10;
  505. for (i=0; i<boffop; i++)
  506. { if (i==0 && boffo_char(i) == '-') sign = YES;
  507. else if (d1 == 10000000 || i == boffop-1)
  508. { d = 10*d + (int32)value_in_radix(boffo_char(i), 10);
  509. v = times2(v, fixnum_of_int(d1));
  510. errexit();
  511. v = plus2(v, fixnum_of_int(d));
  512. d = 0;
  513. d1 = 10;
  514. errexit();
  515. }
  516. else
  517. { d = 10*d + (int32)value_in_radix(boffo_char(i), 10);
  518. d1 = 10*d1;
  519. }
  520. }
  521. if (sign) v = negate(v);
  522. return v;
  523. }
  524. #ifdef COMMON
  525. case 4:
  526. { int p, q, g;
  527. Lisp_Object r;
  528. /* Beware bignum issue here... but take view that ratios are not used! */
  529. boffo_char(boffop) = 0;
  530. /* p and q were made int not int32 to match up with the %d in scanf ... */
  531. sscanf((char *)&boffo_char(0), "%d/%d", &p, &q);
  532. /* Limit myself to fixnums here */
  533. g = (int)int_of_fixnum(gcd(fixnum_of_int((int32)p),
  534. fixnum_of_int((int32)q)));
  535. p /= g;
  536. q /= g;
  537. if (q < 0)
  538. { p = -p;
  539. q = -q;
  540. }
  541. r = getvector(TAG_NUMBERS, TYPE_RATNUM, sizeof(Rational_Number));
  542. errexit();
  543. numerator(r) = fixnum_of_int((int32)p);
  544. denominator(r) = fixnum_of_int((int32)q);
  545. return r;
  546. }
  547. #endif
  548. case 8:
  549. case 11:
  550. { double d;
  551. Lisp_Object r;
  552. #ifdef COMMON
  553. float f;
  554. if (!explicit_fp_format && is_symbol(read_float_format))
  555. { Lisp_Object w = qvalue(read_float_format);
  556. if (w == short_float) fplength = 0;
  557. else if (w == single_float) fplength = 1;
  558. /* else if (w == double_float) fplength = 2; */
  559. else if (w == long_float) fplength = 3;
  560. }
  561. #endif
  562. boffo_char(boffop) = 0;
  563. d = atof((char *)&boffo_char(0));
  564. #ifdef COMMON
  565. switch (fplength)
  566. {
  567. case 0:
  568. { Float_union ff;
  569. ff.f = (float)d;
  570. return TAG_SFLOAT + (ff.i & ~(int32)0xf);
  571. }
  572. case 1:
  573. f = (float)d;
  574. r = getvector(TAG_BOXFLOAT, TYPE_SINGLE_FLOAT,
  575. sizeof(Single_Float));
  576. errexit();
  577. single_float_val(r) = f;
  578. return r;
  579. default:
  580. /* case 2: case 3: */
  581. r = getvector(TAG_BOXFLOAT, TYPE_DOUBLE_FLOAT,
  582. sizeof(Double_Float));
  583. errexit();
  584. double_float_val(r) = d;
  585. return r;
  586. }
  587. #else
  588. /*
  589. * Only support double precision in CSL mode
  590. */
  591. r = getvector(TAG_BOXFLOAT, TYPE_DOUBLE_FLOAT,
  592. sizeof(Double_Float));
  593. errexit();
  594. double_float_val(r) = d;
  595. return r;
  596. #endif
  597. }
  598. }
  599. }
  600. Lisp_Object make_undefined_symbol(char const *s)
  601. {
  602. return make_symbol(s, 0, undefined1, undefined2, undefinedn);
  603. }
  604. Lisp_Object make_symbol(char const *s, int restartp,
  605. one_args *f1, two_args *f2, n_args *fn)
  606. /*
  607. * Used from the startup code to create an interned symbol and (maybe)
  608. * put something in its function cell.
  609. */
  610. {
  611. Lisp_Object v, nil = C_nil;
  612. int first_try = 1;
  613. /*
  614. * Here I blandly assume that boffo is long enough to hold the string
  615. * that I am about to copy into it. All is guaranteed well for
  616. * symbols predefined in Lisp in the normal way, but ones established
  617. * using command-line options like -Dname could cause trouble?
  618. */
  619. #ifdef COMMON
  620. /*
  621. * For COMMON Lisp I will make all the built-in symbols upper case, unless
  622. * the "2" bit of restartp is set...
  623. */
  624. char const *p1 = s;
  625. char *p2 = (char *)&boffo_char(0);
  626. int c;
  627. if ((restartp & 2) == 0)
  628. { while ((c = *p1++) != 0)
  629. { c = toupper(c);
  630. *p2++ = c;
  631. }
  632. *p2 = 0;
  633. }
  634. else
  635. #endif
  636. strcpy((char *)&boffo_char(0), s);
  637. start_again:
  638. v = iintern(boffo, (int32)strlen((char *)&boffo_char(0)), CP, 0);
  639. errexit();
  640. /*
  641. * I instate the definition given if (a) the definition is a real
  642. * one (ie not for an undefined function) and if (b) either I am doing a cold
  643. * start or the name is still marked as having a definition in the form
  644. * of C code.
  645. */
  646. if (f1 != undefined1)
  647. { if ((restartp & 1)==0 || (qheader(v) & SYM_C_DEF) != 0 || !first_try)
  648. { if (qenv(v) == v) qenv(v) = nil;
  649. /* only set env field to nil if it was otherwise not in use */
  650. ifn1(v) = (intxx)f1; ifn2(v) = (intxx)f2; ifnn(v) = (intxx)fn;
  651. qheader(v) |= SYM_C_DEF;
  652. }
  653. else
  654. { int l = strlen((char *)&boffo_char(0));
  655. /*
  656. * Another piece of curious behaviour here, intend to make it easier to
  657. * survive when the CSL/CCL kernel is extended. If a function that the
  658. * (new) kernel would like to define as a C-coded thing is already in
  659. * the current image either as undefined or with some other (byte-coded)
  660. * definition, I map the name of the new function, and XYZ goes to ~XYZ etc
  661. * by prefixing a '~'. The image as loaded can then access the new C coded
  662. * function by this name, and possibly transfer it across to the normal
  663. * name it was originally expected to have. Since this is a symptom of
  664. * somebody having done either a curious over-riding redefinition of something
  665. * in the kernel or not having re-build to get new symbols properly available,
  666. * I print a message about it. Note also that I only rename once, so if there
  667. * were to be existing symbols with names that started with "~" that could
  668. * make my attempts here less than fully effective.
  669. */
  670. if (init_flags & INIT_VERBOSE)
  671. term_printf(
  672. "+++ Built-in \"%s\" clashes with image file: => \"~%s\"\n",
  673. &boffo_char(0), &boffo_char(0));
  674. while (l >= 0) boffo_char(l+1) = boffo_char(l), l--;
  675. boffo_char(0) = '~';
  676. first_try = 0;
  677. goto start_again;
  678. }
  679. /*
  680. * All things that have been set up as copies of this symbol must be
  681. * initialised with the definition too.
  682. */
  683. if ((restartp & 1) != 0)
  684. {
  685. #ifdef COMMON
  686. Lisp_Object v1 = get(v, work_symbol, nil);
  687. #else
  688. Lisp_Object v1 = get(v, work_symbol);
  689. #endif
  690. while (consp(v1))
  691. { Lisp_Object w = qcar(v1);
  692. v1 = qcdr(v1);
  693. ifn1(w) = (intxx)f1; ifn2(w) = (intxx)f2; ifnn(w) = (intxx)fn;
  694. qenv(w) = qenv(v); /* Copy across environment too */
  695. qheader(w) |= SYM_C_DEF;
  696. }
  697. }
  698. }
  699. return v;
  700. }
  701. static CSLbool add_to_hash(Lisp_Object s, Lisp_Object vector, unsigned32 hash)
  702. /*
  703. * Adds an item into a hash table given that it is known that it is not
  704. * already there.
  705. */
  706. {
  707. Header h = vechdr(vector);
  708. int32 size = (length_of_header(h) - CELL)/CELL;
  709. int32 i = (int32)(hash & (size-1));
  710. /*
  711. * I have arranged (elsewhere) that the hash table will be a power of two
  712. * in size, so I can avoid primary clustering by stepping on by any odd
  713. * number. Furthermore I might replace the (perhaps expensive) remaindering
  714. * operations by (perhaps cheap) bitwise "AND" when I reduce my hash value
  715. * to the right range to be an index into the table.
  716. */
  717. int32 step = 1 | ((hash >> 10) & (size - 1));
  718. int32 probes = 0;
  719. /*
  720. * size is expected to be a power of 2 here - check that... just to be safe
  721. */
  722. #ifndef HASH_TABLES_SIZE_OK
  723. if (size != (size & (-size)))
  724. return aerror("hash table size not a power of 2");
  725. #endif
  726. while (++probes <= size)
  727. { if (is_fixnum(elt(vector, i)))
  728. { elt(vector, i) = s;
  729. return YES; /* Success */
  730. }
  731. i = i + step;
  732. if (i >= size) i -= size;
  733. }
  734. return NO; /* Table is totally full */
  735. }
  736. static int32 number_of_chunks;
  737. static Lisp_Object rehash(Lisp_Object v, Lisp_Object chunks, int grow)
  738. {
  739. /*
  740. * If (grow) is +1 this enlarges the table. If -1 it shrinks it. In the
  741. * case that the table is to shrink I should guarantee that the next smaller
  742. * table size down will have enough space for the number of active items
  743. * present. grow=0 leaves the table size alone but still rehashes.
  744. */
  745. int32 h = 16384, i;
  746. Lisp_Object new_obvec, nil;
  747. number_of_chunks = int_of_fixnum(chunks);
  748. #ifdef DEBUG
  749. term_printf("REHASHING: chunks = %d, grow=%d\n", number_of_chunks, grow);
  750. #endif
  751. /*
  752. * Now I decide how to format the new structure. To grow, If I had a single
  753. * vector at present I try to double its size. If that would give something
  754. * with over 40Kbytes I go to 48K, formatted as three chunks each of 16K.
  755. */
  756. if (grow > 0)
  757. { if (number_of_chunks == 1)
  758. { h = length_of_header(vechdr(v)) - CELL;
  759. if (h > 20480)
  760. { h = 16384;
  761. number_of_chunks = 3;
  762. }
  763. else h = 2*h;
  764. }
  765. else number_of_chunks++;
  766. /*
  767. * NB the linear growth of the hash table from this point on gives
  768. * bad performance for very large symbol tables due to excessive need
  769. * for rehashing.
  770. */
  771. }
  772. else if (grow < 0)
  773. { if (number_of_chunks == 1)
  774. { h = length_of_header(vechdr(v)) - CELL;
  775. /*
  776. * When shrinking, I will not permit the hash table to have room for
  777. * less than 8 entries.
  778. */
  779. if (h > 64) h = h / 2;
  780. }
  781. else if (number_of_chunks <= 3)
  782. { h = 32768;
  783. number_of_chunks = 1;
  784. }
  785. else number_of_chunks--;
  786. }
  787. nil = C_nil;
  788. stackcheck1(0, v);
  789. push(v);
  790. try_again:
  791. if (number_of_chunks == 1)
  792. { new_obvec = getvector_init(h+CELL, fixnum_of_int(0));
  793. errexitn(1);
  794. }
  795. else
  796. { new_obvec = nil;
  797. for (i=0; i<number_of_chunks; i++)
  798. { Lisp_Object w;
  799. push(new_obvec);
  800. w = getvector_init(h+CELL, fixnum_of_int(0));
  801. errexitn(2);
  802. pop(new_obvec);
  803. new_obvec = cons(w, new_obvec);
  804. errexitn(1);
  805. }
  806. }
  807. v = stack[0];
  808. while (v != nil)
  809. { Lisp_Object vv;
  810. if (is_vector(v))
  811. { vv = v;
  812. v = nil;
  813. }
  814. else
  815. { vv = qcar(v);
  816. v = qcdr(v);
  817. }
  818. h = (length_of_header(vechdr(vv)) - CELL)/CELL;
  819. while (h != 0)
  820. { Lisp_Object s, p, n = new_obvec;
  821. unsigned32 hash;
  822. h--;
  823. s = elt(vv, h);
  824. if (is_fixnum(s)) continue;
  825. p = qpname(s);
  826. hash = hash_lisp_string(p);
  827. if (number_of_chunks != 1)
  828. { int32 i = (hash ^ (hash >> 16)) % number_of_chunks;
  829. while (i-- != 0) n = qcdr(n);
  830. n = qcar(n);
  831. }
  832. if (!add_to_hash(s, n, hash))
  833. { number_of_chunks++;
  834. /*
  835. * In the grossly improbable case that clustering leads to one of the
  836. * sub-vectors overflowing I will go back and re-start the expansion
  837. * process but with yet more space available. This can ONLY happen
  838. * if I already had multiple sub-hash-tables.
  839. */
  840. goto try_again;
  841. }
  842. }
  843. }
  844. popv(1);
  845. return new_obvec;
  846. }
  847. #ifdef COMMON
  848. static Lisp_Object add_to_externals(Lisp_Object s,
  849. Lisp_Object p, unsigned32 hash)
  850. {
  851. Lisp_Object n = packnext_(p);
  852. Lisp_Object v = packext_(p);
  853. Lisp_Object nil = C_nil;
  854. int32 used = int_of_fixnum(packvext_(p));
  855. if (used == 1) used = length_of_header(vechdr(v));
  856. else used = 16384*used;
  857. /*
  858. * n is (16*sym_count+1) [Lisp fixnum for sym_count]
  859. * used = CELL*(spaces+1)
  860. * The effect is that I trigger a re-hash if the table reaches 62%
  861. * loading. For small vectors when I re-hash I will double the
  862. * table size, for large ones I will add another 16Kbytes (i.e. 4K
  863. * table entries on a 32-bit machine). The effect will be that small
  864. * packages will often be fairly lightly loaded (down to 31% just after
  865. * an expansion) while very large ones will be kept close to the 62% mark.
  866. * If I start off all tables with size that is a power of 2 that state
  867. * will persist.
  868. */
  869. try_again:
  870. if (CELL*(unsigned32)n >= 10u*used)
  871. { stackcheck3(0, s, p, v);
  872. push2(s, p);
  873. v = rehash(v, packvext_(p), 1);
  874. pop2(p, s);
  875. errexit();
  876. packext_(p) = v;
  877. packvext_(p) = fixnum_of_int(number_of_chunks);
  878. }
  879. packnext_(p) = n + (1<<4); /* increment as a Lisp fixnum */
  880. { int32 nv = int_of_fixnum(packvext_(p));
  881. if (nv == 1) add_to_hash(s, v, hash);
  882. else
  883. { nv = (hash ^ (hash >> 16)) % nv;
  884. /*
  885. * There is a systematic nasty problem here that I maybe ought to deal with
  886. * some time. Large packages are represented as a collection of smaller
  887. * hash tables, and part of the hash value of a symbol decides which of these
  888. * sub-tables any particular string will be placed in. I enlarge the whole
  889. * system when the set of tables (treated as a whole) is 70% full. But
  890. * clustering COULD potentially lead to one of the sub-tables becoming
  891. * totally full before then, and that would give a loop here if I was not
  892. * careful. To avoid the possibility I make add_to_hash() report any
  893. * trouble and if I have difficulty I go back and re-enlarge the tables.
  894. * This is not guaranteed safe, but I will be VERY unlucky if it ever bites
  895. * me!
  896. */
  897. while (nv-- != 0) v = qcdr(v);
  898. if (!add_to_hash(s, qcar(v), hash))
  899. { n = used = 0;
  900. goto try_again;
  901. }
  902. }
  903. }
  904. return nil;
  905. }
  906. #endif
  907. static Lisp_Object add_to_internals(Lisp_Object s,
  908. Lisp_Object p, unsigned32 hash)
  909. {
  910. Lisp_Object n = packnint_(p);
  911. Lisp_Object v = packint_(p);
  912. Lisp_Object nil = C_nil;
  913. int32 used = int_of_fixnum(packvint_(p));
  914. if (used == 1) used = length_of_header(vechdr(v));
  915. else used = 16384*used;
  916. try_again:
  917. if (CELL*(unsigned32)n >= 10u*used)
  918. { stackcheck3(0, s, p, v);
  919. push2(s, p);
  920. v = rehash(v, packvint_(p), 1);
  921. pop2(p, s);
  922. errexit();
  923. packint_(p) = v;
  924. packvint_(p) = fixnum_of_int(number_of_chunks);
  925. }
  926. packnint_(p) = (Lisp_Object)((int32)n + (1<<4));
  927. /* increment as a Lisp fixnum */
  928. { int32 nv = int_of_fixnum(packvint_(p));
  929. if (nv == 1) add_to_hash(s, v, hash);
  930. else
  931. { nv = (hash ^ (hash >> 16)) % nv;
  932. while (nv-- != 0) v = qcdr(v);
  933. if (!add_to_hash(s, qcar(v), hash))
  934. { n = used = 0;
  935. goto try_again;
  936. }
  937. }
  938. }
  939. return nil;
  940. }
  941. #ifdef __mips__
  942. #ifdef __GCC__
  943. /*
  944. * Bad news - with the version of gcc installed on the mips-based
  945. * DecStations in Cambridge as of February 1992 the memcmp() function
  946. * is plain broken. Here is a replacement.
  947. */
  948. static int my_memcmp(const void *a, const void *b, size_t n)
  949. {
  950. const unsigned char *ac = a, *bc = b;
  951. if ((((int)ac | (int)bc) & 3) == 0)
  952. { while (n >= 4 && *(int *)ac == *(int *)bc)
  953. ac += 4, bc += 4, n -= 4;
  954. }
  955. while (n-- > 0)
  956. { unsigned char c1,c2; /* unsigned cmp seems more intuitive */
  957. if ((c1 = *ac++) != (c2 = *bc++)) return c1 - c2;
  958. }
  959. return 0;
  960. }
  961. #define memcmp(a, b, n) my_memcmp(a, b, n)
  962. #endif
  963. #endif
  964. static CSLbool rehash_pending = NO;
  965. static Lisp_Object lookup(Lisp_Object str, int32 strsize,
  966. Lisp_Object v, Lisp_Object nv, int32 hash)
  967. /*
  968. * Searches a hash table for a symbol with name matching the given string,
  969. * and NOTE that the string passed down here is to be treated as having
  970. * just strsize characters in it. Return Lisp number 0 if not found.
  971. * Sets rehash_pending if the number of probes used to find the item is
  972. * at least half the size of the table. This case might arise in the following
  973. * way:
  974. * insert items into the table until it is just under 70% full.
  975. * remob (eg via EXPORT) items until the table is just over 25% full.
  976. * note that so far there will have been no need to rehash
  977. * insert more items, but select them so that thir hash values are all
  978. * different from the ones used before. You should be able to end up
  979. * with 70% of the table full of valid symbols and 30% left as the value
  980. * fixnum_of_int(1) which represents a place where a deleted symbol used
  981. * to be. There is now NO really empty space.
  982. * Now looking up symbols must keep searching past tombstones, and hence
  983. * here it will be necessary to scan the entire table before it is
  984. * possible to assert that a symbol is not present. Inserting new symbols
  985. * does not suffer in this way - only lookup. To help with this horror I set
  986. * rehash_pending if the lookup uses a number of probes > 75% of the table
  987. * size. This should only arise in degenerate cases!
  988. */
  989. {
  990. Header h;
  991. int32 size;
  992. int32 i = int_of_fixnum(nv), step, n;
  993. if (i != 1)
  994. { i = (hash ^ (hash >> 16)) % i; /* Segmented - find correct segment */
  995. while (i-- != 0) v = qcdr(v);
  996. v = qcar(v);
  997. }
  998. h = vechdr(v);
  999. size = (length_of_header(h) - CELL)/CELL;
  1000. i = (int32)(hash & (size - 1));
  1001. step = 1 | ((hash >> 10) & (size - 1));
  1002. /*
  1003. * I count the probes that I make here and if there are as many as the size
  1004. * of the hash table then I allow the lookup to report that the symbol is not
  1005. * present. But at least I do not get stuck in a loop.
  1006. */
  1007. for (n=0; n<size; n++)
  1008. { Lisp_Object w = elt(v, i);
  1009. Lisp_Object pn;
  1010. if (w == fixnum_of_int(0))
  1011. { if (4*n > 3*size) rehash_pending = YES;
  1012. return w; /* Not found */
  1013. }
  1014. if (w != fixnum_of_int(1))
  1015. { pn = qpname(w);
  1016. /* v comes out of a package so has a proper pname */
  1017. if (memcmp((char *)str + (CELL-TAG_VECTOR),
  1018. (char *)pn + (CELL-TAG_VECTOR),
  1019. (size_t)strsize) == 0 &&
  1020. (unsigned32)length_of_header(vechdr(pn)) == strsize+CELL)
  1021. { if (4*n > 3*size) rehash_pending = YES;
  1022. return w;
  1023. }
  1024. }
  1025. i = i + step;
  1026. if (i >= size) i -= size;
  1027. }
  1028. rehash_pending = YES;
  1029. return fixnum_of_int(0);
  1030. }
  1031. static int ordersymbol(Lisp_Object v1, Lisp_Object v2)
  1032. /*
  1033. * Compare two symbols to see if they are in alphabetic order.
  1034. * Returns 0 is the symbols have the same name, otherwise
  1035. * the comparison is a lexical one on their names, with -ve if
  1036. * v1 comes alphabetically before v2. Deals with gensyms, and in so
  1037. * doing has to allocate names for them, which seems a great misery
  1038. * since it means that this procedure can provoke garbage collection..
  1039. *
  1040. * Note that the ordering here is based on the bit-patterns that
  1041. * represent the names, so Kanji (etc) symbols may not come out in
  1042. * an order that is especially useful.
  1043. */
  1044. {
  1045. Lisp_Object pn1 = qpname(v1), pn2 = qpname(v2);
  1046. int c;
  1047. int32 l1, l2;
  1048. #ifndef COMMON
  1049. if (qheader(v1) & SYM_UNPRINTED_GENSYM)
  1050. { Lisp_Object nil;
  1051. push(v2);
  1052. pn1 = get_pname(v1);
  1053. pop(v2);
  1054. nil = C_nil;
  1055. if (exception_pending()) return 0;
  1056. pn2 = qpname(v2);
  1057. }
  1058. if (qheader(v2) & SYM_UNPRINTED_GENSYM)
  1059. { Lisp_Object nil;
  1060. push(pn1);
  1061. pn2 = get_pname(v2);
  1062. pop(pn1);
  1063. nil = C_nil;
  1064. if (exception_pending()) return 0;
  1065. }
  1066. #endif
  1067. l1 = length_of_header(vechdr(pn1)) - CELL;
  1068. l2 = length_of_header(vechdr(pn2)) - CELL;
  1069. c = memcmp((char *)pn1 + (CELL-TAG_VECTOR),
  1070. (char *)pn2 + (CELL-TAG_VECTOR),
  1071. (size_t)(l1 < l2 ? l1 : l2));
  1072. if (c == 0) c = (int)(l1 - l2);
  1073. return c;
  1074. }
  1075. /*
  1076. * This has been coded so that it provides the behavious that Reduce expects
  1077. * of ordp(). This is the REDUCE 3.6/3.7 version - it will need re-work
  1078. * if REDUCE is altered. Note the curious situation that symbols are
  1079. * alphabetically ordered, EXCEPT that "nil" comes before everything else!
  1080. * (NB for 3.6 this is as provided in a patch file rather than the original
  1081. * release. The places with *** represent updates since 3.6 and the initial
  1082. * version of 3.6)
  1083. *
  1084. * symbolic procedure ordp(u,v);
  1085. * if null u then null v
  1086. * else if null v then t
  1087. * else if vectorp u then if vectorp v then ordpv(u,v) else atom v
  1088. * else if atom u
  1089. * then if atom v
  1090. * then if numberp u then numberp v and not (u<v)
  1091. * else if idp v then orderp(u,v)
  1092. * else numberp v
  1093. * else nil
  1094. * else if atom v then t
  1095. * else if car u=car v then %%% ordp(cdr u,cdr v)
  1096. *** ordpl(cdr u, cdr v) *** 8 Feb 1999
  1097. *** %% flagp(car u,'noncom) or ordpl(cdr u,cdr v) ***
  1098. * else if flagp(car u,'noncom)
  1099. * then if flagp(car v,'noncom) then ordp(car u,car v) else t
  1100. * else if flagp(car v,'noncom) then nil
  1101. * else ordp(car u,car v);
  1102. *
  1103. *** symbolic procedure ordpl(u,v)
  1104. *** if atom u then ordp(u,v)
  1105. *** else if atom v then t
  1106. *** else if car u=car v then ordpl(cdr u,cdr v)
  1107. *** else ordp(car u, car v);
  1108. *
  1109. */
  1110. static int orderp(Lisp_Object u, Lisp_Object v);
  1111. static int ordpv(Lisp_Object u, Lisp_Object v)
  1112. {
  1113. Header hu = vechdr(u), hv = vechdr(v);
  1114. int32 lu = length_of_header(hu), lv = length_of_header(hv), n = CELL;
  1115. if (type_of_header(hu) != type_of_header(hv))
  1116. return (type_of_header(hu) < type_of_header(hv) ? -1 : 1);
  1117. if (vector_holds_binary(hu))
  1118. { while (n < lu && n < lv)
  1119. { unsigned int eu = *(unsigned char *)(u - TAG_VECTOR + n),
  1120. ev = *(unsigned char *)(v - TAG_VECTOR + n);
  1121. if (eu != ev) return (eu < ev ? -1 : 1);
  1122. n += 1;
  1123. }
  1124. return (lu == lv ? 0 : lu < lv ? -1 : 1);
  1125. }
  1126. /*
  1127. * At present it is an ERROR to include mixed vectors in structures passed
  1128. * to ordering functions, and if it is done the system may crash. Note that
  1129. * stream objects count as mixed for these purposes. I will get around to
  1130. * fixing things sometime...
  1131. */
  1132. else
  1133. { while (n < lu && n < lv)
  1134. { Lisp_Object eu = *(Lisp_Object *)(u - TAG_VECTOR + n),
  1135. ev = *(Lisp_Object *)(v - TAG_VECTOR + n),
  1136. nil = C_nil;
  1137. int w;
  1138. push2(u, v);
  1139. #ifdef SOFTWARE_TICKS
  1140. if (--countdown < 0) deal_with_tick();
  1141. #endif
  1142. if (stack >= (Lisp_Object *)stacklimit)
  1143. { push(ev);
  1144. eu = reclaim(eu, "stack", GC_STACK, 0);
  1145. pop(ev);
  1146. nil = C_nil;
  1147. /* stackcheck expanded by hand here to return an int, not nil, in bad case */
  1148. if (exception_pending()) { popv(2); return 0; }
  1149. }
  1150. w = orderp(eu, ev);
  1151. pop2(v, u);
  1152. nil = C_nil;
  1153. if (exception_pending()) return 0;
  1154. if (w != 0) return w;
  1155. n += CELL;
  1156. }
  1157. return (lu == lv ? 0 : lu < lv ? -1 : 1);
  1158. }
  1159. }
  1160. static int ordpl(Lisp_Object u, Lisp_Object v)
  1161. {
  1162. #ifdef COMMON
  1163. Lisp_Object nil = C_nil;
  1164. #endif
  1165. for (;;)
  1166. { int w = orderp(qcar(u), qcar(v));
  1167. if (w != 0) return w;
  1168. u = qcdr(u);
  1169. v = qcdr(v);
  1170. if (!consp(u)) return orderp(u, v);
  1171. if (!consp(v)) return -1;
  1172. }
  1173. }
  1174. #define flagged_noncom(v) \
  1175. ((fv = qfastgets(v)) != nil && elt(fv, 0) != SPID_NOPROP)
  1176. static int orderp(Lisp_Object u, Lisp_Object v)
  1177. {
  1178. Lisp_Object nil = C_nil;
  1179. for (;;)
  1180. { if (u == nil) return v == nil ? 0 : 1;
  1181. else if (v == nil) return -1; /* Special cases of NIL done */
  1182. else if (u == v) return 0; /* useful optimisation? */
  1183. /*
  1184. * I migrate the vectorp test inside where I have tested for atoms, since
  1185. * I expect vectors to be a somewhat uncommon case
  1186. */
  1187. else if (!consp(u))
  1188. { if (!consp(v))
  1189. { if (is_vector(u))
  1190. { if (is_vector(v)) return ordpv(u, v);
  1191. else return -1;
  1192. }
  1193. else if (is_number(u))
  1194. { if (is_number(v)) return lessp2(u, v) ? 1 :
  1195. eql(u, v) ? 0 : -1;
  1196. else return 1;
  1197. }
  1198. else if (is_number(v)) return -1;
  1199. else if (is_symbol(u))
  1200. { if (is_symbol(v)) return ordersymbol(u, v);
  1201. else return 1;
  1202. }
  1203. else if (is_symbol(v)) return -1;
  1204. /*
  1205. * Now the objects are not symbols, vectors or numbers. That maybe
  1206. * leaves character objects. I compare representations to give a
  1207. * rather arbitrary ordering. Note that any comparisons that get
  1208. * down here are yielding non portable results.
  1209. */
  1210. else return (u == v) ? 0 : (u < v) ? 1 : -1;
  1211. }
  1212. else return 1;
  1213. }
  1214. else if (!consp(v)) return -1;
  1215. else
  1216. { Lisp_Object cu = qcar(u), cv = qcar(v);
  1217. Lisp_Object fv; /* used by flagged_noncom */
  1218. int w;
  1219. push2(u, v);
  1220. /* stackcheck2(2, cu, cv); */
  1221. #ifdef SOFTWARE_TICKS
  1222. if (--countdown < 0) deal_with_tick();
  1223. #endif
  1224. if (stack >= (Lisp_Object *)stacklimit)
  1225. { push(cv);
  1226. cu = reclaim(cu, "stack", GC_STACK, 0);
  1227. pop(cv);
  1228. nil = C_nil;
  1229. /* stackcheck expanded by hand here to return an int, not nil, in bad case */
  1230. if (exception_pending()) { popv(2); return 0; }
  1231. }
  1232. w = orderp(cu, cv);
  1233. pop2(v, u);
  1234. nil = C_nil;
  1235. if (exception_pending()) return 0;
  1236. if (w != 0)
  1237. { cu = qcar(u);
  1238. if (is_symbol(cu) && flagged_noncom(cu))
  1239. { cv = qcar(v);
  1240. if (is_symbol(cv) && flagged_noncom(cv)) return w;
  1241. else return -1;
  1242. }
  1243. else
  1244. { cv = qcar(v);
  1245. if (is_symbol(cv) && flagged_noncom(cv)) return 1;
  1246. else return w;
  1247. }
  1248. }
  1249. /*
  1250. * here car u = car v
  1251. */
  1252. u = qcdr(u);
  1253. v = qcdr(v);
  1254. if (!consp(u)) continue;
  1255. if (!consp(v)) return -1;
  1256. /*
  1257. * The function I call ordpl here has the atom tests lifted out from
  1258. * its top...
  1259. */
  1260. return ordpl(u, v);
  1261. }
  1262. }
  1263. }
  1264. Lisp_Object Lorderp(Lisp_Object nil,
  1265. Lisp_Object a, Lisp_Object b)
  1266. {
  1267. int w;
  1268. w = orderp(a, b);
  1269. errexit();
  1270. return onevalue(Lispify_predicate(w <= 0));
  1271. }
  1272. static unsigned32 removed_hash;
  1273. static CSLbool remob(Lisp_Object sym, Lisp_Object v, Lisp_Object nv)
  1274. /*
  1275. * Searches a hash table for a symbol with name matching the given string,
  1276. * and remove it.
  1277. */
  1278. {
  1279. Lisp_Object str = qpname(sym);
  1280. Header h;
  1281. unsigned32 hash;
  1282. int32 i = int_of_fixnum(nv), size, step, n;
  1283. if (qheader(sym) & SYM_ANY_GENSYM) return NO; /* gensym case is easy! */
  1284. #ifdef COMMON
  1285. /* If not in any package it has no home & is not available */
  1286. qheader(sym) &= ~SYM_EXTERN_IN_HOME & ~(0xffffffff<<SYM_IN_PKG_SHIFT);
  1287. #endif
  1288. removed_hash = hash = hash_lisp_string(str);
  1289. /*
  1290. * The search procedure used here MUST match that coded in lookup().
  1291. */
  1292. if (i != 1)
  1293. { i = (hash ^ (hash >> 16)) % i;
  1294. while (i-- != 0) v = qcdr(v);
  1295. v = qcar(v);
  1296. }
  1297. h = vechdr(v);
  1298. size = (length_of_header(h) - CELL)/CELL;
  1299. i = (int32)(hash & (size - 1));
  1300. step = 1 | ((hash >> 10) & (size - 1));
  1301. for (n=0; n<size; n++)
  1302. { Lisp_Object w = elt(v, i);
  1303. if (w == fixnum_of_int(0)) return NO; /* Not found */
  1304. if (w == sym)
  1305. { elt(v, i) = fixnum_of_int(1);
  1306. /*
  1307. * I will shrink the hash table if it becomes less than 25% full,
  1308. * but not in this bit of code... because I want this internal
  1309. * remob() function to avoid any possible failure or garbage collection
  1310. * so I can call it from C code without any formality. Thus I should do
  1311. * any tidying up afterwards.
  1312. */
  1313. return YES;
  1314. }
  1315. i = i + step;
  1316. if (i >= size) i -= size;
  1317. }
  1318. return NO;
  1319. }
  1320. #ifdef COMMON
  1321. static Lisp_Object Lmake_symbol(Lisp_Object nil, Lisp_Object str)
  1322. /*
  1323. * Lisp function (make-symbol ..) creates an uninterned symbol.
  1324. */
  1325. {
  1326. Lisp_Object s;
  1327. stackcheck1(0, str);
  1328. /*
  1329. * Common Lisp wants a STRING passed here, but as a matter of generosity and
  1330. * for the benefit of some of my system code I support symbols too.
  1331. */
  1332. if (symbolp(str))
  1333. { str = get_pname(str);
  1334. errexit();
  1335. }
  1336. else if (!is_vector(str)) return aerror1("make-symbol", str);
  1337. else if (complex_stringp(str))
  1338. { str = simplify_string(str);
  1339. errexit();
  1340. }
  1341. else if (type_of_header(vechdr(str)) != TYPE_STRING)
  1342. return aerror1("make-symbol", str);
  1343. push(str);
  1344. s = getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length);
  1345. errexitn(1);
  1346. pop(str);
  1347. qheader(s) = TAG_ODDS+TYPE_SYMBOL;
  1348. qvalue(s) = unset_var;
  1349. qpname(s) = str;
  1350. qplist(s) = nil;
  1351. qfastgets(s) = nil;
  1352. qpackage(s) = nil;
  1353. qenv(s) = s;
  1354. ifn1(s) = (intxx)undefined1;
  1355. ifn2(s) = (intxx)undefined2;
  1356. ifnn(s) = (intxx)undefinedn;
  1357. qcount(s) = 0; /* set counts to zero to be tidy */
  1358. return onevalue(s);
  1359. }
  1360. #endif
  1361. Lisp_Object MS_CDECL Lgensym(Lisp_Object nil, int nargs, ...)
  1362. /*
  1363. * Lisp function (gensym) creates an uninterned symbol with odd name.
  1364. */
  1365. {
  1366. Lisp_Object id;
  1367. #ifdef COMMON
  1368. Lisp_Object pn;
  1369. char genname[64];
  1370. #endif
  1371. argcheck(nargs, 0, "gensym");
  1372. stackcheck0(0);
  1373. nil = C_nil;
  1374. #ifdef COMMON
  1375. sprintf(genname, "G%lu", (long unsigned)gensym_ser++);
  1376. pn = make_string(genname);
  1377. errexit();
  1378. push(pn);
  1379. #endif
  1380. id = getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length);
  1381. #ifdef COMMON
  1382. pop(pn);
  1383. #endif
  1384. errexit();
  1385. #ifdef COMMON
  1386. qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_ANY_GENSYM;
  1387. qpname(id) = pn;
  1388. #else
  1389. qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_UNPRINTED_GENSYM+SYM_ANY_GENSYM;
  1390. qpname(id) = gensym_base;
  1391. #endif
  1392. qvalue(id) = unset_var;
  1393. qplist(id) = nil;
  1394. qfastgets(id) = nil;
  1395. #ifdef COMMON
  1396. qpackage(id) = nil; /* Marks it as a uninterned */
  1397. #endif
  1398. qenv(id) = id;
  1399. ifn1(id) = (intxx)undefined1;
  1400. ifn2(id) = (intxx)undefined2;
  1401. ifnn(id) = (intxx)undefinedn;
  1402. qcount(id) = 0; /* to be tidy */
  1403. return onevalue(id);
  1404. }
  1405. Lisp_Object Lgensym1(Lisp_Object nil, Lisp_Object a)
  1406. /*
  1407. * Lisp function (gensym1 base) creates an uninterned symbol with odd name.
  1408. * The case (gensym <number>) is DEPRECATED by the Common Lisp standards
  1409. * committee and so I will not implement it at least for now.
  1410. */
  1411. {
  1412. Lisp_Object id, genbase;
  1413. #ifdef COMMON
  1414. unsigned32 len;
  1415. char genname[64];
  1416. if (complex_stringp(a))
  1417. { a = simplify_string(a);
  1418. errexit();
  1419. }
  1420. #endif
  1421. if (is_vector(a) &&
  1422. type_of_header(vechdr(a)) == TYPE_STRING) genbase = a;
  1423. else if (symbolp(a)) genbase = qpname(a); /* copy gensym base */
  1424. else return aerror1("gensym1", a);
  1425. push(genbase);
  1426. stackcheck0(0);
  1427. #ifdef COMMON
  1428. len = length_of_header(vechdr(genbase)) - CELL;
  1429. if (len > 60) len = 60; /* Unpublished truncation of the string */
  1430. sprintf(genname, "%.*s%lu", (int)len,
  1431. (char *)genbase + (CELL-TAG_VECTOR), (long unsigned)gensym_ser++);
  1432. stack[0] = make_string(genname);
  1433. errexitn(1);
  1434. #endif
  1435. id = getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length);
  1436. errexitn(1);
  1437. pop(genbase);
  1438. #ifdef COMMON
  1439. qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_ANY_GENSYM;
  1440. #else
  1441. qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_UNPRINTED_GENSYM+SYM_ANY_GENSYM;
  1442. #endif
  1443. qvalue(id) = unset_var;
  1444. qpname(id) = genbase;
  1445. qplist(id) = nil;
  1446. qfastgets(id) = nil;
  1447. #ifdef COMMON
  1448. qpackage(id) = nil; /* Marks it as a uninterned */
  1449. #endif
  1450. qenv(id) = id;
  1451. ifn1(id) = (intxx)undefined1;
  1452. ifn2(id) = (intxx)undefined2;
  1453. ifnn(id) = (intxx)undefinedn;
  1454. qcount(id) = 0; /* to be tidy */
  1455. return onevalue(id);
  1456. }
  1457. Lisp_Object Lgensym2(Lisp_Object nil, Lisp_Object a)
  1458. /*
  1459. * Lisp function (gensym2 base) whose name is exactly that given by the
  1460. * argument. This might be UNHELPFUL if one tried to print the value
  1461. * concerned, but seems to be what the Common Lisp syntax #:ggg expects
  1462. * to achieve!
  1463. */
  1464. {
  1465. Lisp_Object id, genbase;
  1466. unsigned32 len;
  1467. #ifdef COMMON
  1468. if (complex_stringp(a))
  1469. { a = simplify_string(a);
  1470. errexit();
  1471. }
  1472. #endif
  1473. if (is_vector(a) &&
  1474. type_of_header(vechdr(a)) == TYPE_STRING) genbase = a;
  1475. else if (symbolp(a)) genbase = qpname(a);
  1476. else return aerror1("gensym2", a);
  1477. push(genbase);
  1478. stackcheck0(0);
  1479. len = length_of_header(vechdr(genbase)) - CELL;
  1480. stack[0] = copy_string(genbase, len);
  1481. errexitn(1);
  1482. id = getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length);
  1483. errexitn(1);
  1484. pop(genbase);
  1485. qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_ANY_GENSYM;
  1486. qvalue(id) = unset_var;
  1487. qpname(id) = genbase;
  1488. qplist(id) = nil;
  1489. qfastgets(id) = nil;
  1490. #ifdef COMMON
  1491. qpackage(id) = nil; /* Marks it as a uninterned */
  1492. #endif
  1493. qenv(id) = id;
  1494. ifn1(id) = (intxx)undefined1;
  1495. ifn2(id) = (intxx)undefined2;
  1496. ifnn(id) = (intxx)undefinedn;
  1497. qcount(id) = 0; /* to be tidy */
  1498. return onevalue(id);
  1499. }
  1500. static Lisp_Object Lgensymp(Lisp_Object nil, Lisp_Object a)
  1501. {
  1502. if (is_symbol(a) &&
  1503. (qheader(a) & SYM_CODEPTR) == 0 &&
  1504. (qheader(a) & SYM_ANY_GENSYM) != 0) return onevalue(lisp_true);
  1505. else return onevalue(nil);
  1506. }
  1507. Lisp_Object iintern(Lisp_Object str, int32 h, Lisp_Object p, int str_is_ok)
  1508. /*
  1509. * Look up the first h chars of the string str with respect to the package p.
  1510. * The last arg is a boolean that allows me to decide if (when a new symbol
  1511. * has to be created) the string must be copied. If h differs from the
  1512. * real number of characters in arg1 then a copy MUST be made.
  1513. * If non-zero, the last arg is 1 for intern, 2 for extern, 3
  1514. * for find-symbol and 4 for "find-external-symbol" as in reader syntax p:x.
  1515. * NB in CSL mode only one value is returned.
  1516. */
  1517. {
  1518. Lisp_Object r, nil = C_nil;
  1519. unsigned32 hash;
  1520. stackcheck2(0, str, p);
  1521. hash = hash_lisp_string_with_length(str, h+CELL);
  1522. /* find-external-symbol will not look at the internals */
  1523. if (str_is_ok != 4)
  1524. { r = lookup(str, h, packint_(p), packvint_(p), hash);
  1525. /*
  1526. * rehash_pending is intended to deal with horrible cases that involve
  1527. * lots of remobs. But in the worst possible scenario one could have
  1528. * a symbol table where all symbols clashed on hashing, and then by
  1529. * restricting further use to just the last few symbols entered it would be
  1530. * possible for all lookup operations to take a number of probes that
  1531. * was almost 70% of the table size. In such cases rehashing (without
  1532. * expanding the table size at the same time) would leave the table
  1533. * unaltered and would not mend things. To avoid such repeated fruitless
  1534. * rehashing I only set rehash_pending if the number of probes was over
  1535. * 75% of the table size, and this should be impossible if there are no
  1536. * tombstones present.
  1537. */
  1538. if (rehash_pending)
  1539. { Lisp_Object v = packint_(p);
  1540. push2(p, r);
  1541. v = rehash(v, packvint_(p), 0);
  1542. pop2(r, p);
  1543. errexit();
  1544. packint_(p) = v;
  1545. packvint_(p) = fixnum_of_int(number_of_chunks);
  1546. rehash_pending = NO;
  1547. }
  1548. nil = C_nil;
  1549. if (r != fixnum_of_int(0))
  1550. {
  1551. #ifdef COMMON
  1552. mv_2 = internal_symbol;
  1553. #endif
  1554. return nvalues(r, 2);
  1555. }
  1556. }
  1557. #ifdef COMMON
  1558. r = lookup(str, h, packext_(p), packvext_(p), hash);
  1559. if (rehash_pending)
  1560. { Lisp_Object v = packext_(p);
  1561. push2(p, r);
  1562. v = rehash(v, packvext_(p), 0);
  1563. pop2(r, p);
  1564. errexit();
  1565. packext_(p) = v;
  1566. packvext_(p) = fixnum_of_int(number_of_chunks);
  1567. rehash_pending = NO;
  1568. }
  1569. if (r != fixnum_of_int(0))
  1570. {
  1571. mv_2 = external_symbol;
  1572. return nvalues(r, 2);
  1573. }
  1574. if (str_is_ok == 4)
  1575. {
  1576. #ifdef COMMON
  1577. mv_2 = nil;
  1578. #endif
  1579. return nvalues(nil, 2);
  1580. }
  1581. for (r = packuses_(p); r!=nil; r=qcdr(r))
  1582. { Lisp_Object w = qcar(r);
  1583. w = lookup(str, h, packext_(w), packvext_(w), hash);
  1584. if (rehash_pending)
  1585. { Lisp_Object v = packext_(p);
  1586. push2(p, r);
  1587. v = rehash(v, packvext_(p), 0);
  1588. pop2(r, p);
  1589. errexit();
  1590. packext_(p) = v;
  1591. packvext_(p) = fixnum_of_int(number_of_chunks);
  1592. rehash_pending = NO;
  1593. }
  1594. if (w != fixnum_of_int(0))
  1595. {
  1596. mv_2 = inherited_symbol;
  1597. return nvalues(w, 2);
  1598. }
  1599. }
  1600. #endif
  1601. if (str_is_ok == 3)
  1602. {
  1603. #ifdef COMMON
  1604. mv_2 = nil;
  1605. #endif
  1606. return nvalues(nil, 2);
  1607. }
  1608. { Lisp_Object s;
  1609. push2(str, p);
  1610. s = (Lisp_Object)getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length);
  1611. pop(p);
  1612. errexit();
  1613. qheader(s) = TAG_ODDS+TYPE_SYMBOL;
  1614. #ifdef COMMON
  1615. if (p == qvalue(keyword_package) && keyword_package != nil)
  1616. { qvalue(s) = (Lisp_Object)s;
  1617. qheader(s) |= SYM_SPECIAL_VAR;
  1618. }
  1619. else
  1620. #endif
  1621. qvalue(s) = unset_var;
  1622. qpname(s) = qpname(nil); /* At this stage the pname is a dummy */
  1623. qplist(s) = nil;
  1624. qfastgets(s) = nil;
  1625. #ifdef COMMON
  1626. qpackage(s) = p;
  1627. #endif
  1628. qenv(s) = (Lisp_Object)s;
  1629. ifn1(s) = (intxx)undefined1;
  1630. ifn2(s) = (intxx)undefined2;
  1631. ifnn(s) = (intxx)undefinedn;
  1632. qcount(s) = 0;
  1633. push(s);
  1634. #ifdef COMMON
  1635. if ((p == qvalue(keyword_package) && keyword_package != nil) ||
  1636. str_is_ok == 2)
  1637. { add_to_externals(s, p, hash);
  1638. errexitn(2);
  1639. qheader(s) |= SYM_EXTERN_IN_HOME;
  1640. }
  1641. else
  1642. #endif
  1643. add_to_internals(s, p, hash);
  1644. pop(s); pop(str);
  1645. errexit();
  1646. /* Now the symbol-head is safe enough that I can let the GC look at it */
  1647. if (str_is_ok != 0) qpname(s) = str;
  1648. else
  1649. { Lisp_Object pn;
  1650. push(s);
  1651. pn = copy_string(str, h);
  1652. pop(s);
  1653. qpname(s) = pn;
  1654. }
  1655. errexit();
  1656. #ifdef COMMON
  1657. mv_2 = nil;
  1658. #endif
  1659. return nvalues((Lisp_Object)s, 2);
  1660. }
  1661. }
  1662. #ifdef COMMON
  1663. static Lisp_Object Lfind_package(Lisp_Object nil, Lisp_Object name);
  1664. Lisp_Object Lintern_2(Lisp_Object nil, Lisp_Object str, Lisp_Object pp)
  1665. #else
  1666. Lisp_Object Lintern(Lisp_Object nil, Lisp_Object str)
  1667. #endif
  1668. /*
  1669. * Lisp entrypoint for (intern ..)
  1670. */
  1671. {
  1672. Header h;
  1673. Lisp_Object p;
  1674. #ifdef COMMON
  1675. push(str);
  1676. p = Lfind_package(nil, pp);
  1677. pop(str);
  1678. errexit();
  1679. #else
  1680. p = CP;
  1681. #endif
  1682. #ifdef COMMON
  1683. if (complex_stringp(str))
  1684. { push(p);
  1685. str = simplify_string(str);
  1686. pop(p);
  1687. errexit();
  1688. }
  1689. #endif
  1690. /*
  1691. * For COMMON it is perhaps undue generosity to permit a symbol here
  1692. * rather than just a string. However it will make life a bit easier for
  1693. * me in porting existing code. Note that the Common Lisp book says quite
  1694. * explicitly that symbols are NOT allowed here.
  1695. */
  1696. if (symbolp(str))
  1697. { str = get_pname(str);
  1698. errexit();
  1699. }
  1700. if (!is_vector(str) ||
  1701. type_of_header(h = vechdr(str)) != TYPE_STRING)
  1702. return aerror1("intern (not a string)", str);
  1703. return iintern(str, length_of_header(h) - CELL, p, 1);
  1704. }
  1705. #ifdef COMMON
  1706. Lisp_Object Lintern(Lisp_Object nil, Lisp_Object a)
  1707. {
  1708. return Lintern_2(nil, a, CP);
  1709. }
  1710. static Lisp_Object Lfind_symbol(Lisp_Object nil,
  1711. Lisp_Object str, Lisp_Object pp)
  1712. {
  1713. Header h;
  1714. Lisp_Object p;
  1715. push(str);
  1716. p = Lfind_package(nil, pp);
  1717. pop(str);
  1718. errexit();
  1719. if (symbolp(str))
  1720. { push(p);
  1721. str = get_pname(str);
  1722. pop(p);
  1723. errexit();
  1724. }
  1725. if (complex_stringp(str))
  1726. { push(p);
  1727. str = simplify_string(str);
  1728. pop(p);
  1729. errexit();
  1730. }
  1731. if (!is_vector(str) ||
  1732. type_of_header(h = vechdr(str)) != TYPE_STRING)
  1733. {
  1734. return aerror1("find-symbol (not a string)", str);
  1735. }
  1736. return iintern(str, length_of_header(h) - CELL, p, 3);
  1737. }
  1738. Lisp_Object Lfind_symbol_1(Lisp_Object nil, Lisp_Object str)
  1739. {
  1740. return Lfind_symbol(nil, str, CP);
  1741. }
  1742. static Lisp_Object Lextern(Lisp_Object nil,
  1743. Lisp_Object sym, Lisp_Object package)
  1744. /*
  1745. * If sym is internal in given package make it external - the inside parts
  1746. * of the export function. Note that the second argument must be a real
  1747. * package object, not a package name. Higher level code must have done
  1748. * a find-package as necessary.
  1749. */
  1750. {
  1751. if (!is_symbol(sym)) return onevalue(nil);
  1752. if (remob(sym, packint_(package), packvint_(package)))
  1753. { Lisp_Object n = packnint_(package);
  1754. Lisp_Object v = packint_(package);
  1755. int32 used = int_of_fixnum(packvint_(package));
  1756. if (used == 1) used = length_of_header(vechdr(v));
  1757. else used = 16384*used;
  1758. /*
  1759. * I will shrink a hash table if a sequence of remob-style operations,
  1760. * which will especially include the case where a symbol ceases to be
  1761. * internal to a package so that it can be external, leaves the table
  1762. * less than 25% full. Note that normal growth is supposed to leave these
  1763. * tables between 35 and 70% full, so the activity here will not be
  1764. * triggered frivolously. However note the following oddity: if a package
  1765. * is of minimum size (8 entries in the hash table) then rehashing will not
  1766. * cause it to shrink (but it will rehash and hence tidy it up). Hence
  1767. * every remob on such a table will cause it to be re-hashed.
  1768. */
  1769. if ((int32)n < used && used>INIT_OBVECI_SIZE+CELL)
  1770. { stackcheck3(0, sym, package, v);
  1771. push2(sym, package);
  1772. v = rehash(v, packvint_(package), -1);
  1773. pop2(package, sym);
  1774. errexit();
  1775. packint_(package) = v;
  1776. packvint_(package) = fixnum_of_int(number_of_chunks);
  1777. }
  1778. packnint_(package) -= (1<<4); /* decrement as fixnum */
  1779. /*
  1780. * removed_hash was left set up by remob, and it is known that the symbol
  1781. * was not already external, since it had been internal.
  1782. */
  1783. if (qpackage(sym) == package) qheader(sym) |= SYM_EXTERN_IN_HOME;
  1784. add_to_externals(sym, package, removed_hash);
  1785. errexit();
  1786. return onevalue(lisp_true);
  1787. }
  1788. return onevalue(nil);/* no action if it was not internal in this package */
  1789. }
  1790. static Lisp_Object Lextern_1(Lisp_Object nil, Lisp_Object str)
  1791. {
  1792. return Lextern(nil, str, CP);
  1793. }
  1794. static Lisp_Object Limport(Lisp_Object nil,
  1795. Lisp_Object sym, Lisp_Object package)
  1796. /*
  1797. * The internal part of the IMPORT and SHADOWING-IMPORT functions.
  1798. * makes sym internal in package. The symbol MUST NOT be present there
  1799. * before this function is called. The second argument must be a real
  1800. * package object, not just the name of one.
  1801. */
  1802. {
  1803. unsigned32 hash;
  1804. Lisp_Object pn;
  1805. if (!is_symbol(sym)) return onevalue(nil);
  1806. push2(sym, package);
  1807. pn = get_pname(sym);
  1808. errexitn(2);
  1809. hash = hash_lisp_string(pn);
  1810. add_to_internals(stack[-1], stack[0], hash);
  1811. pop2(package, sym);
  1812. errexit();
  1813. if (qpackage(sym) == nil) qpackage(sym) = package;
  1814. return onevalue(nil);
  1815. }
  1816. static Lisp_Object Limport_1(Lisp_Object nil, Lisp_Object str)
  1817. {
  1818. return Limport(nil, str, CP);
  1819. }
  1820. #endif
  1821. Lisp_Object ndelete(Lisp_Object a, Lisp_Object l)
  1822. /*
  1823. * Probably useful in various places throughout the system...
  1824. */
  1825. {
  1826. #ifdef COMMON
  1827. Lisp_Object nil = C_nil;
  1828. #endif
  1829. if (!consp(l)) return l;
  1830. if (a == qcar(l)) return qcdr(l);
  1831. { Lisp_Object z1 = l, z2 = qcdr(l);
  1832. while (consp(z2))
  1833. { if (a == qcar(z2))
  1834. { qcdr(z1) = qcdr(z2);
  1835. return l;
  1836. }
  1837. else
  1838. { z1 = z2;
  1839. z2 = qcdr(z2);
  1840. }
  1841. }
  1842. }
  1843. return l;
  1844. }
  1845. Lisp_Object Lunintern_2(Lisp_Object nil, Lisp_Object sym, Lisp_Object pp)
  1846. {
  1847. Lisp_Object package;
  1848. #ifdef COMMON
  1849. push(sym);
  1850. package = Lfind_package(nil, pp);
  1851. pop(sym);
  1852. errexit();
  1853. #else
  1854. package = pp;
  1855. #endif
  1856. if (!is_symbol(sym)) return onevalue(nil);
  1857. #ifdef COMMON
  1858. if (qpackage(sym) == package) qpackage(sym) = nil;
  1859. packshade_(package) = ndelete(sym, packshade_(package));
  1860. #endif
  1861. if ((qheader(sym) & SYM_C_DEF) != 0)
  1862. return aerror1("remob on function with kernel definition", sym);
  1863. if (remob(sym, packint_(package), packvint_(package)))
  1864. { Lisp_Object n = packnint_(package);
  1865. Lisp_Object v = packint_(package);
  1866. int32 used = int_of_fixnum(packvint_(package));
  1867. if (used == 1) used = length_of_header(vechdr(v));
  1868. else used = 16384*used;
  1869. if ((int32)n < used && used>INIT_OBVECI_SIZE+CELL)
  1870. { stackcheck2(0, package, v);
  1871. push(package);
  1872. v = rehash(v, packvint_(package), -1);
  1873. pop(package);
  1874. errexit();
  1875. packint_(package) = v;
  1876. packvint_(package) = fixnum_of_int(number_of_chunks);
  1877. }
  1878. packnint_(package) -= (1<<4); /* decrement as fixnum */
  1879. return onevalue(lisp_true);
  1880. }
  1881. #ifdef COMMON
  1882. if (remob(sym, packext_(package), packvext_(package)))
  1883. { Lisp_Object n = packnext_(package);
  1884. Lisp_Object v = packext_(package);
  1885. int32 used = int_of_fixnum(packvext_(package));
  1886. if (used == 1) used = length_of_header(vechdr(v));
  1887. else used = 16384*used;
  1888. if ((int32)n < used && used>INIT_OBVECX_SIZE+CELL)
  1889. { stackcheck2(0, package, v);
  1890. push(package);
  1891. v = rehash(v, packvext_(package), -1);
  1892. pop(package);
  1893. errexit();
  1894. packext_(package) = v;
  1895. packvext_(package) = fixnum_of_int(number_of_chunks);
  1896. }
  1897. packnext_(package) -= (1<<4); /* decrement as fixnum */
  1898. return onevalue(lisp_true);
  1899. }
  1900. #endif
  1901. return onevalue(nil);
  1902. }
  1903. Lisp_Object Lunintern(Lisp_Object nil, Lisp_Object str)
  1904. {
  1905. return Lunintern_2(nil, str, CP);
  1906. }
  1907. #ifdef COMMON
  1908. static Lisp_Object Lkeywordp(Lisp_Object nil, Lisp_Object a)
  1909. {
  1910. if (!symbolp(a)) return onevalue(nil);
  1911. return onevalue(Lispify_predicate(qpackage(a) == qvalue(keyword_package)));
  1912. }
  1913. #endif
  1914. /*
  1915. * If I have a window system then getting characters from the keyboard
  1916. * is deemed a system-dependent activity. On non-windowed systems I still
  1917. * do rather more than just getchar(), although under typical Unix what I
  1918. * do here may count as over-kill.
  1919. */
  1920. int tty_count;
  1921. #define TTYBUF_SIZE 256
  1922. #ifdef Kanji
  1923. static kchar_t tty_buffer[TTYBUF_SIZE];
  1924. static kchar_t *tty_pointer;
  1925. #else
  1926. /*
  1927. * Note: I should never have an END_OF_FILE in the buffere here: if I see
  1928. * this condition I pack in the character CTRL-D instead.
  1929. */
  1930. static char tty_buffer[TTYBUF_SIZE];
  1931. static char *tty_pointer;
  1932. #endif
  1933. static CSLbool int_nest = NO;
  1934. #ifndef CWIN
  1935. static int prevchar = '\n';
  1936. #endif
  1937. int terminal_pushed = NOT_CHAR;
  1938. int char_from_terminal(Lisp_Object dummy)
  1939. /*
  1940. * "What ..." you might ask, "is the meaning of this mess?". Well the answer
  1941. * is that when input is directly from the terminal I buffer up to 256
  1942. * characters in a private buffer, and I discount the time spent filling this
  1943. * buffer. On some miserable systems this will succeed in ensuring that the
  1944. * time reported at the end of a run reflects time that CSL spends computing
  1945. * and not time it spends waiting for the user to type something at it. Note
  1946. * that it is only stdin input that I intercept in this way, so the full cost
  1947. * of getting characters from disc files will be accounted. I also (rather
  1948. * improperly) map EOF onto a code (4) which will fit in a byte-sized buffer.
  1949. * I fill by buffer up as far as a newline or a vertical tab (or end of file),
  1950. * and hope that that will not seriously hurt any interactions with CSL.
  1951. * After all the operating system may well line-buffer input anyway, so that
  1952. * it can deal with the delete key on your keyboard for you.
  1953. *
  1954. * Furthermore here is where I display prompt strings to the user -
  1955. * in a way that Standard Lisp does not define, but PSL implements and
  1956. * some REDUCE programmers have come to expect... (in some cases I will
  1957. * let lower level code deal with prompts).
  1958. *
  1959. * If the user provokes an interrupt (^C, or ESC or whatever) while I am
  1960. * in here I will try to return promptly with an empty buffer and
  1961. * some indication of an exception.
  1962. */
  1963. {
  1964. /*
  1965. * I have a hook here for cases where I want to call CSL from other C
  1966. * code. In that case the variable used here points at a function that
  1967. * reads a single character. When I use this option I will NOT generate
  1968. * prompts.
  1969. */
  1970. int c;
  1971. Lisp_Object nil = C_nil;
  1972. CSL_IGNORE(dummy);
  1973. if (terminal_pushed != NOT_CHAR)
  1974. { c = terminal_pushed;
  1975. terminal_pushed = NOT_CHAR;
  1976. return c;
  1977. }
  1978. if (procedural_input != NULL) c = (*procedural_input)();
  1979. else if (non_terminal_input != NULL)
  1980. {
  1981. #ifdef Kanji
  1982. c = getwc(non_terminal_input);
  1983. #else
  1984. c = getc(non_terminal_input);
  1985. #endif
  1986. }
  1987. else
  1988. { if (tty_count == 0)
  1989. {
  1990. /*
  1991. * Time spent waiting for keyboard input is not counted against the user.
  1992. */
  1993. push_clock();
  1994. #ifdef CWIN
  1995. /* Under CWIN I will arrange prompts at a lower level. */
  1996. #else
  1997. if (prevchar == '\n')
  1998. { escaped_printing = 0;
  1999. if (prompt_thing != nil)
  2000. { push(active_stream);
  2001. active_stream = qvalue(terminal_io);
  2002. if (!is_stream(active_stream))
  2003. active_stream = lisp_terminal_io;
  2004. internal_prin(prompt_thing, NO);
  2005. nil = C_nil;
  2006. if (exception_pending()) flip_exception();
  2007. pop(active_stream);
  2008. }
  2009. }
  2010. ensure_screen();
  2011. if (exception_pending()) return EOF;
  2012. #endif
  2013. #ifdef WINDOW_SYSTEM
  2014. if (use_wimp)
  2015. { tty_count = wimpget(tty_buffer);
  2016. if (exception_pending()) return EOF;
  2017. if (interrupt_pending)
  2018. { interrupt_pending = 0;
  2019. if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
  2020. err_printf("+++ Interrupted\n");
  2021. exit_reason =
  2022. (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ?
  2023. UNWIND_ERROR : UNWIND_UNWIND;
  2024. exit_value = exit_tag = nil;
  2025. exit_count = 0;
  2026. flip_exception();
  2027. }
  2028. }
  2029. else
  2030. #endif
  2031. for (;;) /* The while loop is so I can restart after ^C */
  2032. {
  2033. /*
  2034. * The setjmp here can not mask any bindings of fluid variables...
  2035. */
  2036. errorset_msg = NULL;
  2037. #ifdef __cplusplus
  2038. try
  2039. #else
  2040. if (!setjmp(sigint_buf))
  2041. #endif
  2042. { while (tty_count<TTYBUF_SIZE && !interrupt_pending)
  2043. { int c;
  2044. sigint_must_longjmp = YES;
  2045. #ifdef Kanji
  2046. c = getwc(stdin);
  2047. #else
  2048. c = getchar();
  2049. #endif
  2050. sigint_must_longjmp = NO;
  2051. if (c == EOF)
  2052. { clearerr(stdin); /* Believed to be what is wanted */
  2053. c = CTRL_D; /* Use ASCII ^D as EOF marker */
  2054. }
  2055. tty_buffer[tty_count++] = (char)c;
  2056. if (c == '\n' || c == '\v' || c == CTRL_D) break;
  2057. }
  2058. if (interrupt_pending)
  2059. { push_clock();
  2060. /*
  2061. * Time spent in the interrupt handler here will not be counted as CPU
  2062. * time used.
  2063. */
  2064. interrupt_pending = NO;
  2065. if (int_nest)
  2066. { err_printf("\n+++ Nested interrupt ignored\n");
  2067. tty_count = 0;
  2068. break;
  2069. }
  2070. else
  2071. { int_nest = YES;
  2072. interrupted(nil);
  2073. int_nest = NO;
  2074. }
  2075. pop_clock();
  2076. tty_count = 0;
  2077. nil = C_nil;
  2078. if (!exception_pending()) continue;
  2079. }
  2080. break;
  2081. }
  2082. #ifdef __cplusplus
  2083. catch (int *)
  2084. #else
  2085. else
  2086. #endif
  2087. { if (errorset_msg != NULL)
  2088. { term_printf("\n%s detected\n", errorset_msg);
  2089. errorset_msg = NULL;
  2090. }
  2091. sigint_must_longjmp = NO;
  2092. interrupt_pending = YES;
  2093. tty_count = 0;
  2094. }
  2095. }
  2096. pop_clock();
  2097. tty_pointer = tty_buffer;
  2098. }
  2099. if (tty_count == 0) c = '\n'; /* ^C odd case */
  2100. else
  2101. { tty_count--;
  2102. c = *tty_pointer++;
  2103. #ifndef Kanji
  2104. c &= 0xff;
  2105. #endif
  2106. }
  2107. }
  2108. inject_randomness(c);
  2109. if (c == EOF || c == CTRL_D) return EOF;
  2110. if (qvalue(echo_symbol) != nil)
  2111. { Lisp_Object stream = qvalue(standard_output);
  2112. if (!is_stream(stream)) stream = qvalue(terminal_io);
  2113. if (!is_stream(stream)) stream = lisp_terminal_io;
  2114. putc_stream(c, stream);
  2115. if (exception_pending()) flip_exception();
  2116. }
  2117. else if (spool_file != NULL) putc(c, spool_file);
  2118. return c;
  2119. }
  2120. Lisp_Object Lrds(Lisp_Object nil, Lisp_Object a)
  2121. {
  2122. Lisp_Object old = qvalue(standard_input);
  2123. if (a == nil) a = qvalue(terminal_io);
  2124. if (a == old) return onevalue(old);
  2125. else if (!is_stream(a)) return aerror1("rds", a);
  2126. else if (stream_read_fn(a) == char_from_illegal)
  2127. return aerror("rds"); /* closed stream or output stream */
  2128. qvalue(standard_input) = a;
  2129. return onevalue(old);
  2130. }
  2131. Lisp_Object Lrtell_1(Lisp_Object nil, Lisp_Object stream)
  2132. {
  2133. int32 n;
  2134. if (!is_stream(stream)) return onevalue(nil);
  2135. n = other_read_action(READ_TELL, stream);
  2136. if (n == -1) return onevalue(nil);
  2137. else return onevalue(fixnum_of_int(n));
  2138. }
  2139. Lisp_Object MS_CDECL Lrtell(Lisp_Object nil, int nargs, ...)
  2140. /*
  2141. * RTELL returns an integer that indicates the position of the current
  2142. * input stream (as selected by RDS). If the position is not available
  2143. * (as would be the case for an interactive stream) then NIL is returned.
  2144. * Otherwise the result is an integer suitable for use with rseek. In the
  2145. * case that the file was opened in binary mode the number returned is a
  2146. * direct indication of the position in the file and arithmetic will
  2147. * behave predictably - for text streams the value returned should be
  2148. * thought of as an abstract position-tag.
  2149. */
  2150. {
  2151. argcheck(nargs, 0, "rtell");
  2152. return Lrtell_1(nil, qvalue(standard_input));
  2153. }
  2154. Lisp_Object Lrseekend(Lisp_Object nil, Lisp_Object stream)
  2155. {
  2156. if (!is_stream(stream)) stream = qvalue(terminal_io);
  2157. if (!is_stream(stream)) stream = lisp_terminal_io;
  2158. other_read_action(READ_FLUSH, stream);
  2159. if (other_read_action(READ_END, stream) != 0) return onevalue(nil);
  2160. else return onevalue(lisp_true);
  2161. }
  2162. Lisp_Object Lrseek_2(Lisp_Object nil, Lisp_Object stream, Lisp_Object a)
  2163. {
  2164. int32 n;
  2165. if (!is_stream(stream)) stream = qvalue(terminal_io);
  2166. if (!is_stream(stream)) stream = lisp_terminal_io;
  2167. if (is_fixnum(a)) n = (int32)int_of_fixnum(a);
  2168. else return aerror("rseek");
  2169. other_read_action(READ_FLUSH, stream);
  2170. if (other_read_action(n | 0x80000000, stream) != 0) return onevalue(nil);
  2171. else return onevalue(lisp_true);
  2172. }
  2173. Lisp_Object Lrseek(Lisp_Object nil, Lisp_Object a)
  2174. /*
  2175. * If the current input stream supports random access this re-positions
  2176. * it to a place indicated by the argument a. If the file was opened in
  2177. * binary mode then a can be an integer indicating how far down the file
  2178. * to set the position. For text files arguments to RSEEK should only be
  2179. * values returned by previous calls to RTELL. RSEEK returns nil if it
  2180. * failed (and if it noticed that fact) or T if it succeeded.
  2181. */
  2182. {
  2183. return Lrseek_2(nil, qvalue(standard_input), a);
  2184. }
  2185. /*
  2186. * The getc_stream() method must NEVER be able to cause garbage collection,
  2187. * since I code the reader here on the assumption that file control blocks
  2188. * do not move while individual characters are read.
  2189. */
  2190. /*
  2191. * While I am in the middle of reading a whole expression the variable
  2192. * curchar will hold the most recent character (or NOT_CHAR if there is none),
  2193. * but between expressions I will push that back into the stream header.
  2194. */
  2195. static void skip_whitespace(Lisp_Object stream)
  2196. {
  2197. Lisp_Object nil;
  2198. for (;;)
  2199. { switch (curchar)
  2200. {
  2201. case NOT_CHAR:
  2202. case 0: case '\v': case '\f':
  2203. case ' ': case '\t': case '\n':
  2204. case '\r': case CTRL_C:
  2205. curchar = getc_stream(stream);
  2206. errexitv();
  2207. continue;
  2208. #ifndef COMMON
  2209. case '%':
  2210. #else
  2211. case ';':
  2212. #endif
  2213. while (curchar != '\n' &&
  2214. curchar != EOF &&
  2215. curchar != CTRL_D)
  2216. { curchar = getc_stream(stream);
  2217. errexitv();
  2218. }
  2219. continue;
  2220. default:
  2221. return;
  2222. }
  2223. }
  2224. }
  2225. static Lisp_Object read_s(Lisp_Object stream);
  2226. #ifdef COMMON
  2227. static Lisp_Object read_hash(Lisp_Object stream);
  2228. #endif
  2229. static Lisp_Object read_list(Lisp_Object stream)
  2230. /*
  2231. * There is no code here to do anything about general read-macros,
  2232. * and it will be awkward to fit it in here because of the reliance
  2233. * that the Common Lisp readmacro scheme puts on the ability to return
  2234. * no values at all using (values). I implement ' and ; and ` since
  2235. * they seem very useful, but only simple cases of #.
  2236. * I require that when this function is called I have already done
  2237. * a skip_whitespace(), and as a result curchar will not be NOT_CHAR.
  2238. */
  2239. {
  2240. Lisp_Object l, w, nil = C_nil;
  2241. stackcheck0(0);
  2242. if (curchar == ')')
  2243. { curchar = NOT_CHAR;
  2244. return C_nil;
  2245. }
  2246. push(stream);
  2247. #ifdef COMMON
  2248. if (curchar == '#')
  2249. { l = read_hash(stream);
  2250. if (l == SPID_NOINPUT)
  2251. { pop(stream);
  2252. return read_list(stream);
  2253. }
  2254. }
  2255. else
  2256. #endif
  2257. l = read_s(stream);
  2258. errexitn(1);
  2259. l = ncons(l);
  2260. errexitn(1);
  2261. push(l); /* this will be the final result */
  2262. for (;;)
  2263. { skip_whitespace(stack[-1]);
  2264. switch (curchar)
  2265. {
  2266. #ifndef COMMON
  2267. case ']':
  2268. #endif
  2269. case ')':
  2270. curchar = NOT_CHAR;
  2271. pop2(l, stream);
  2272. return l;
  2273. case EOF:
  2274. case CTRL_D:
  2275. pop2(l, stream);
  2276. return l;
  2277. /* This code treats '.' as a special lexical marker, while the */
  2278. /* full version of the reader has to be more subtle. */
  2279. case '.':
  2280. curchar = NOT_CHAR;
  2281. push(l);
  2282. w = read_s(stack[-2]);
  2283. pop(l);
  2284. errexitn(2);
  2285. qcdr(l) = w;
  2286. skip_whitespace(stack[-1]);
  2287. if (curchar == ')') curchar = NOT_CHAR;
  2288. /* else error("missing rpar or bad dot"); */
  2289. pop2(l, stream);
  2290. return l;
  2291. #ifdef COMMON
  2292. case '#':
  2293. push(l);
  2294. w = read_hash(stack[-2]);
  2295. errexitn(3);
  2296. if (w == SPID_NOINPUT)
  2297. { pop(l);
  2298. continue;
  2299. }
  2300. w = ncons(w);
  2301. errexitn(3);
  2302. pop(l);
  2303. qcdr(l) = w;
  2304. l = w;
  2305. continue;
  2306. #endif
  2307. default:
  2308. push(l);
  2309. w = read_s(stack[-2]);
  2310. errexitn(3);
  2311. w = ncons(w);
  2312. errexitn(3);
  2313. pop(l);
  2314. qcdr(l) = w;
  2315. l = w;
  2316. continue;
  2317. }
  2318. }
  2319. }
  2320. static Lisp_Object list_to_vector(Lisp_Object l)
  2321. {
  2322. int32 len = 0;
  2323. Lisp_Object p = l, nil = C_nil;
  2324. while (consp(p)) len++, p = qcdr(p);
  2325. push(l);
  2326. p = getvector_init(CELL*(len+1), nil);
  2327. pop(l);
  2328. errexit();
  2329. len = 0;
  2330. while (consp(l))
  2331. { elt(p, len) = qcar(l);
  2332. len++;
  2333. l = qcdr(l);
  2334. }
  2335. return p;
  2336. }
  2337. #ifdef COMMON
  2338. static CSLbool evalfeature(Lisp_Object u)
  2339. {
  2340. Lisp_Object w, nil = C_nil;
  2341. if (consp(u))
  2342. { Lisp_Object fn = qcar(u);
  2343. u = qcdr(u);
  2344. if (!consp(u)) return NO;
  2345. if (fn == not_symbol) return !evalfeature(qcar(u));
  2346. else if (fn == and_symbol)
  2347. { while (consp(u))
  2348. { if (!evalfeature(qcar(u))) return NO;
  2349. nil = C_nil;
  2350. if (exception_pending()) return NO;
  2351. u = qcdr(u);
  2352. }
  2353. return YES;
  2354. }
  2355. else if (fn == or_symbol)
  2356. { while (consp(u))
  2357. { if (evalfeature(qcar(u))) return YES;
  2358. nil = C_nil;
  2359. if (exception_pending()) return NO;
  2360. u = qcdr(u);
  2361. }
  2362. return NO;
  2363. }
  2364. else return NO;
  2365. }
  2366. w = qvalue(features_symbol);
  2367. while (consp(w))
  2368. { if (u == qcar(w)) return YES;
  2369. w = qcdr(w);
  2370. }
  2371. return NO;
  2372. }
  2373. static Lisp_Object read_hash(Lisp_Object stream)
  2374. {
  2375. /*
  2376. * A small subset of the # escaped read-macros will be supported here.
  2377. * curchar must already be set to the character that follows the '#'
  2378. */
  2379. int32 v, w = -1;
  2380. int radix;
  2381. Lisp_Object nil = C_nil;
  2382. Lisp_Object p;
  2383. curchar = getc_stream(stream);
  2384. errexit();
  2385. if (ISdigit(curchar))
  2386. { w = 0;
  2387. do
  2388. { w = 10*w + curchar - '0';
  2389. /*
  2390. * Observe that I do not do long arithmetic here!
  2391. */
  2392. curchar = getc_stream(stream);
  2393. errexit();
  2394. } while (ISdigit(curchar));
  2395. }
  2396. switch (curchar)
  2397. {
  2398. default:
  2399. /* error("Unknown # escape"); */
  2400. return pack_char(0, 0, '#');
  2401. #ifdef COMMON
  2402. case '#':
  2403. curchar = NOT_CHAR;
  2404. p = reader_workspace;
  2405. while (p != nil)
  2406. { Lisp_Object k = qcar(p);
  2407. if (fixnum_of_int(w) == qcar(k)) return qcdr(k);
  2408. p = qcdr(p);
  2409. }
  2410. return aerror1("Label not found with #n# syntax", fixnum_of_int(w));
  2411. case '=':
  2412. curchar = NOT_CHAR;
  2413. push(stream);
  2414. /*
  2415. * Hmmm - is it necessary for #nn# to refer back to the label here from
  2416. * within the value about to be read?
  2417. */
  2418. p = read_s(stream);
  2419. pop(stream);
  2420. errexit();
  2421. push(p);
  2422. p = acons(fixnum_of_int(w), p, reader_workspace);
  2423. errexitn(1);
  2424. reader_workspace = p;
  2425. pop(p);
  2426. return p;
  2427. #endif
  2428. case ':': /* #:XXX reads in a gensym... */
  2429. curchar = NOT_CHAR;
  2430. { Lisp_Object base = read_s(stream), al; /* The XXX bit unadorned */
  2431. errexit();
  2432. /*
  2433. * This keeps an association list of gensyms present in this call to READ.
  2434. * Note that if you use #.(read) [or other clever things] you may get
  2435. * muddled about contexts. Note that this is sometimes helpful with
  2436. * Standard Lisp but that for Common Lisp the more general #= and ##
  2437. * mechanism should be used and this behaviour here would count as
  2438. * WRONG.
  2439. */
  2440. al = reader_workspace;
  2441. while (al != nil)
  2442. { Lisp_Object k = qcar(al);
  2443. if (base == qcar(k)) return qcdr(k);
  2444. al = qcdr(al);
  2445. }
  2446. push(base);
  2447. /*
  2448. * Beware that #:ggg has just ggg as its name, with no numeric suffix.
  2449. */
  2450. al = Lgensym2(nil, base);
  2451. pop(base);
  2452. errexit();
  2453. al = acons(base, al, reader_workspace);
  2454. errexit();
  2455. reader_workspace = al;
  2456. return qcdr(qcar(al));
  2457. }
  2458. case '(': /* Simple vector */
  2459. curchar = getc_stream(stream);
  2460. errexit();
  2461. skip_whitespace(stream);
  2462. errexit();
  2463. { Lisp_Object l = read_list(stream);
  2464. errexit();
  2465. return list_to_vector(l);
  2466. }
  2467. case '\'':
  2468. curchar = NOT_CHAR;
  2469. p = read_s(stream);
  2470. errexit();
  2471. return list2(function_symbol, p);
  2472. case '\\':
  2473. /*
  2474. * The character just after "#\" is read without any case folding
  2475. */
  2476. curchar = getc_stream(stream);
  2477. errexit();
  2478. w = curchar;
  2479. #ifdef COMMON
  2480. /*
  2481. * The word after "#\" is always spelt in regular ASCII so Kanji support
  2482. * does not cut in here.
  2483. */
  2484. if (isalpha(w))
  2485. { char buffer[32];
  2486. int bp = 0, w0 = w;
  2487. while (isalpha(w) && bp < 30)
  2488. { buffer[bp++] = toupper(w); /* Force word to upper case */
  2489. curchar = getc_stream(stream);
  2490. errexit();
  2491. w = curchar;
  2492. }
  2493. if (bp == 1)
  2494. #ifdef Kanji
  2495. return pack_char(0, 0, w0 & 0xffff);
  2496. #else
  2497. return pack_char(0, 0, w0 & 0xff);
  2498. #endif
  2499. buffer[bp] = 0;
  2500. p = make_string(buffer);
  2501. errexit();
  2502. p = Lintern_2(nil, p, qvalue(keyword_package));
  2503. errexit();
  2504. p = get(p, named_character, nil);
  2505. errexit();
  2506. return p;
  2507. }
  2508. #endif
  2509. curchar = NOT_CHAR;
  2510. errexit();
  2511. #ifdef Kanji
  2512. return pack_char(0, 0, w & 0xffff);
  2513. #else
  2514. return pack_char(0, 0, w & 0xff);
  2515. #endif
  2516. case '.':
  2517. curchar = NOT_CHAR;
  2518. p = read_s(stream);
  2519. errexit();
  2520. /*
  2521. * The next is in case the expression evaluated involves reading from
  2522. * this or another stream.
  2523. */
  2524. if (curchar != NOT_CHAR)
  2525. { other_read_action(curchar, stream);
  2526. curchar = NOT_CHAR;
  2527. }
  2528. p = eval(p, nil);
  2529. errexit();
  2530. return onevalue(p);
  2531. case '+':
  2532. case '-':
  2533. v = (curchar == '-');
  2534. curchar = NOT_CHAR;
  2535. /*
  2536. * In March 1988 X3J13 voted that feature names read here should be in
  2537. * the keyword package unless explicily otherwise qualified, but (I guess)
  2538. * the AND, OR and NOT operators applying to them are NOT in the keyword
  2539. * package. Thus I can not just rebind *package* here in any simple way.
  2540. * Oh dear - I hope nobody relies on what those kind experts decided!
  2541. * Meanwhile REMEMBER to go #+ :whatever please.
  2542. */
  2543. push(stream);
  2544. p = read_s(stream);
  2545. errexitn(1);
  2546. w = evalfeature(p);
  2547. pop(stream);
  2548. errexit();
  2549. if (w == v)
  2550. { read_s(stream);
  2551. errexit();
  2552. }
  2553. /*
  2554. * The following flag-value shows that read_hash() has not actually read
  2555. * anything - but it may have skipped over some unwanted stuff.
  2556. */
  2557. return onevalue(SPID_NOINPUT);
  2558. case 'r': case 'R':
  2559. radix = (w>=2 && w<=36) ? (int)w : 10;
  2560. break;
  2561. case 'b': case 'B':
  2562. radix = 2;
  2563. break;
  2564. case 'o': case 'O':
  2565. radix = 8;
  2566. break;
  2567. case 'x': case 'X':
  2568. radix = 16;
  2569. break;
  2570. }
  2571. /* Here I have a number specified in some unusual radix */
  2572. w = fixnum_of_int(0);
  2573. curchar = getc_stream(stream);
  2574. errexit();
  2575. while ((v = value_in_radix(curchar, radix)) >= 0)
  2576. { w = times2(w, fixnum_of_int((int32)radix));
  2577. errexit();
  2578. w = plus2(w, fixnum_of_int(v));
  2579. errexit();
  2580. curchar = getc_stream(stream);
  2581. errexit();
  2582. }
  2583. return w;
  2584. }
  2585. #endif /* COMMON */
  2586. CSLbool is_constituent(int c)
  2587. {
  2588. if (c == EOF) return NO;
  2589. if (c & ESCAPED_CHAR) return YES; /* escaped */
  2590. switch (c)
  2591. {
  2592. /* The following characters terminate symbols */
  2593. case ' ': case '\n': case '\t': case '\v': case '\f': case 0:
  2594. case '(': case ')': case '\'': case ';': case '"': case '`':
  2595. case ',': case '\r':
  2596. case CTRL_D: /* character 4 is EOF in ASCII */
  2597. #ifndef COMMON
  2598. case '+': case '-': case '*': case '/': case '~': case '\\':
  2599. case '@': case '#': case '$': case '%': case '^': case '&':
  2600. case '=': case '{': case '}': case '[': case ']': case ':':
  2601. case '<': case '>': case '?': case '!': case '|':
  2602. /*
  2603. * case '_': In OLD Standard Lisp underscore was a break character -
  2604. * these days it is classified rather oddly, in that it does not terminate
  2605. * a symbol but behaves specially if it starts one.
  2606. * What about '.', which may need to be treated specially?
  2607. */
  2608. case '.':
  2609. #endif
  2610. return NO;
  2611. default:
  2612. return YES;
  2613. }
  2614. }
  2615. static Lisp_Object backquote_expander(Lisp_Object a)
  2616. /*
  2617. * ClTl (edition 2) seems to suggest that nested backquotes are a disgusting
  2618. * morass - this code does not worry about the fine details!
  2619. */
  2620. {
  2621. Lisp_Object w1, f, nil = C_nil;
  2622. if (a == nil) return a;
  2623. if (!consp(a)) return list2(quote_symbol, a);
  2624. stackcheck1(0, a);
  2625. nil = C_nil;
  2626. f = qcar(a);
  2627. if (f == comma_symbol) return qcar(qcdr(a));
  2628. if (consp(f) && qcar(f) == comma_at_symbol)
  2629. { w1 = qcar(qcdr(f));
  2630. push(w1);
  2631. a = backquote_expander(qcdr(a));
  2632. errexit();
  2633. pop(w1);
  2634. w1 = list2(w1, a);
  2635. errexit();
  2636. return cons(append_symbol, w1);
  2637. }
  2638. /*
  2639. * There is noticable scope for further optimisation here, with the
  2640. * introduction of uses of list, list* as well as just cons and append.
  2641. * It is also probably useful to worry about ,. as well as ,@ but for
  2642. * now I defer that until the full version of the reader is installed.
  2643. */
  2644. push(a);
  2645. f = backquote_expander(f);
  2646. pop(a);
  2647. errexit();
  2648. push(f);
  2649. a = backquote_expander(qcdr(a));
  2650. pop(f);
  2651. errexit();
  2652. a = list2(f, a);
  2653. errexit();
  2654. return cons(cons_symbol, a);
  2655. }
  2656. static CSLbool read_failure;
  2657. static void packbyte(int c)
  2658. {
  2659. Lisp_Object nil = C_nil;
  2660. int32 boffo_size = length_of_header(vechdr(boffo));
  2661. /*
  2662. * I expand boffo (maybe) several characters earlier than you might
  2663. * consider necessary. Some of that is to be extra certain about having
  2664. * space in it when I pack a multi-byte (eg Kanji) character.
  2665. */
  2666. if (boffop >= (int)boffo_size-(int)CELL-8)
  2667. { Lisp_Object new_boffo =
  2668. getvector(TAG_VECTOR, TYPE_STRING, 2*boffo_size);
  2669. nil = C_nil;
  2670. if (exception_pending())
  2671. { flip_exception();
  2672. /*
  2673. * What should I do if I fail to expand boffo - for present I silently
  2674. * truncate the object I am reading. But I set a flag that will be checked
  2675. * on the way out of read/compress, so the user will know.
  2676. */
  2677. read_failure = YES;
  2678. return;
  2679. }
  2680. memcpy((void *)((char *)new_boffo + (CELL-TAG_VECTOR)),
  2681. &boffo_char(0), boffop);
  2682. boffo = new_boffo;
  2683. }
  2684. #ifdef Kanji
  2685. if (iswchar(c)) boffo_char(boffop++) = c >> 8;
  2686. #endif
  2687. boffo_char(boffop) = (char)c;
  2688. boffop++;
  2689. }
  2690. #ifdef COMMON
  2691. static char package_name[32];
  2692. #endif
  2693. static Lisp_Object read_s(Lisp_Object stream)
  2694. {
  2695. Lisp_Object w, nil = C_nil;
  2696. for (;;)
  2697. { skip_whitespace(stream);
  2698. errexit();
  2699. switch (curchar)
  2700. {
  2701. case EOF:
  2702. case CTRL_D:
  2703. return CHAR_EOF;
  2704. case '(':
  2705. curchar = NOT_CHAR;
  2706. skip_whitespace(stream);
  2707. errexit();
  2708. return read_list(stream);
  2709. #ifndef COMMON
  2710. case '[':
  2711. curchar = NOT_CHAR;
  2712. skip_whitespace(stream);
  2713. errexit();
  2714. w = read_list(stream);
  2715. errexit();
  2716. return list_to_vector(w);
  2717. case ']':
  2718. #endif
  2719. case ')':
  2720. curchar = NOT_CHAR;
  2721. continue; /* Ignore spurious rpar */
  2722. case '\'':
  2723. curchar = NOT_CHAR;
  2724. w = read_s(stream);
  2725. errexit();
  2726. return list2(quote_symbol, w);
  2727. case '`':
  2728. curchar = NOT_CHAR;
  2729. w = read_s(stream);
  2730. errexit();
  2731. return backquote_expander(w);
  2732. case ',':
  2733. curchar = getc_stream(stream);
  2734. errexit();
  2735. if (curchar == '@')
  2736. { curchar = NOT_CHAR;
  2737. w = read_s(stream);
  2738. errexit();
  2739. return list2(comma_at_symbol, w);
  2740. }
  2741. else
  2742. { w = read_s(stream);
  2743. errexit();
  2744. return list2(comma_symbol, w);
  2745. }
  2746. /*
  2747. * Neither Standard nor Common Lisp make stray dots very welcome. In Common
  2748. * Lisp multiple adjacent dots are supposed to be an error. Here I just ignore
  2749. * stray dots, and hope that nobody is silly enough to have them in their code.
  2750. */
  2751. case '.':
  2752. /* error("Bad dot"); */
  2753. curchar = NOT_CHAR;
  2754. continue; /* Ignore spurious dot */
  2755. #ifdef COMMON
  2756. case '#':
  2757. push(stream);
  2758. w = read_hash(stream);
  2759. pop(stream);
  2760. if (w != SPID_NOINPUT) return w;
  2761. else return read_s(stream);
  2762. #endif
  2763. case '"':
  2764. boffop = 0;
  2765. { for (;;) /* Used to cope with "abc""def" */
  2766. { curchar = getc_stream(stream);
  2767. errexit();
  2768. #ifdef COMMON
  2769. if (curchar == ESCAPE_CHAR)
  2770. { curchar = getc_stream(stream);
  2771. errexit();
  2772. if (curchar!=EOF) curchar |= ESCAPED_CHAR;
  2773. }
  2774. #endif
  2775. if (curchar == EOF || curchar == CTRL_D)
  2776. return CHAR_EOF;
  2777. while (curchar != '"' &&
  2778. curchar != EOF &&
  2779. curchar != CTRL_D)
  2780. { push(stream);
  2781. packbyte(curchar);
  2782. pop(stream);
  2783. curchar = getc_stream(stream);
  2784. errexit();
  2785. #ifdef COMMON
  2786. if (curchar == ESCAPE_CHAR)
  2787. { curchar = getc_stream(stream);
  2788. errexit();
  2789. if (curchar!=EOF) curchar |= ESCAPED_CHAR;
  2790. }
  2791. #endif
  2792. }
  2793. #ifndef COMMON
  2794. curchar = getc_stream(stream);
  2795. errexit();
  2796. if (curchar == '"')
  2797. { push(stream);
  2798. packbyte(curchar);
  2799. pop(stream);
  2800. continue; /* Handle "abc""def" for Standard Lisp */
  2801. }
  2802. #else
  2803. curchar = NOT_CHAR;
  2804. #endif
  2805. return copy_string(boffo, boffop);
  2806. }
  2807. }
  2808. #ifndef COMMON
  2809. case '+': case '-':
  2810. case '0': case '1': case '2': case '3': case '4':
  2811. case '5': case '6': case '7': case '8': case '9':
  2812. /*
  2813. * I treat numbers specially here since I want to allow '.' within
  2814. * numbers, but NOT within symbols. Common Lisp views '.' as a
  2815. * constituent character and so does not need quite so much effort
  2816. * just here.
  2817. */
  2818. { boffop = 0;
  2819. if (curchar == '+' || curchar == '-')
  2820. { push(stream);
  2821. packbyte(curchar);
  2822. pop(stream);
  2823. curchar = getc_stream(stream);
  2824. errexit();
  2825. /* + or - not followed by a digit will be read as a symbol */
  2826. if (!ISdigit(curchar)) return intern(boffop, NO);
  2827. }
  2828. while (ISdigit(curchar))
  2829. { push(stream);
  2830. packbyte(curchar);
  2831. pop(stream);
  2832. curchar = getc_stream(stream);
  2833. errexit();
  2834. }
  2835. /* accept possible decimal point */
  2836. if (curchar == '.')
  2837. { push(stream);
  2838. packbyte(curchar);
  2839. pop(stream);
  2840. curchar = getc_stream(stream);
  2841. errexit();
  2842. while (ISdigit(curchar))
  2843. { push(stream);
  2844. packbyte(curchar);
  2845. pop(stream);
  2846. curchar = getc_stream(stream);
  2847. errexit();
  2848. }
  2849. }
  2850. /* accept possible exponent */
  2851. if (curchar == 'e' || curchar == 'E')
  2852. { push(stream);
  2853. packbyte('e');
  2854. pop(stream);
  2855. curchar = getc_stream(stream);
  2856. errexit();
  2857. if (curchar == '+' || curchar == '-')
  2858. { push(stream);
  2859. packbyte(curchar);
  2860. pop(stream);
  2861. curchar = getc_stream(stream);
  2862. errexit();
  2863. }
  2864. while (ISdigit(curchar))
  2865. { push(stream);
  2866. packbyte(curchar);
  2867. pop(stream);
  2868. curchar = getc_stream(stream);
  2869. errexit();
  2870. }
  2871. }
  2872. return intern(boffop, NO);
  2873. }
  2874. case '_': /* This seems to have to be a funny case for REDUCE */
  2875. boffop = 0;
  2876. push(stream);
  2877. packbyte(curchar);
  2878. pop(stream);
  2879. curchar = getc_stream(stream);
  2880. errexit();
  2881. return intern(boffop, NO);
  2882. #endif
  2883. default:
  2884. { CSLbool escaped = NO;
  2885. #ifdef COMMON
  2886. CSLbool within_vbars = NO;
  2887. int colon = -1, double_colon = -1, i;
  2888. #endif
  2889. boffop = 0;
  2890. #ifdef COMMON
  2891. while (curchar == '|')
  2892. { nil = C_nil;
  2893. stackcheck0(0);
  2894. curchar = getc_stream(stream);
  2895. errexit();
  2896. within_vbars = !within_vbars;
  2897. /*
  2898. * A funny thought arises here - maybe the characters ||123 are a potential
  2899. * number, since there are no characters inside the vertical bars to show
  2900. * otherwise! Hence I need to set escaped only when I find a genuine character
  2901. * within the vertical-bar protected region. Hence this coded as a while
  2902. * loop not a simple IF statement. Another horrid issue is that the input
  2903. * "|| " (where there are two initial vertical bars and then a terminating
  2904. * character) ought to parse as an identifier with an empty name. Thus
  2905. * if I read ahead here and find whitespace etc I need to exit here.
  2906. */
  2907. if (!within_vbars && !is_constituent(curchar))
  2908. return intern(0, YES);
  2909. }
  2910. #endif
  2911. if (curchar == ESCAPE_CHAR)
  2912. { nil = C_nil;
  2913. stackcheck0(0);
  2914. curchar = getc_stream(stream);
  2915. errexit();
  2916. /* However, any character escaped with '\' means we do not have a number */
  2917. escaped = YES;
  2918. }
  2919. else
  2920. #ifdef COMMON
  2921. if (!within_vbars)
  2922. { if (curchar == ':') colon = boffop, escaped = YES;
  2923. #else
  2924. {
  2925. #endif
  2926. if (curchar != EOF)
  2927. { if (qvalue(lower_symbol) != nil)
  2928. curchar = TOlower(curchar);
  2929. else if (qvalue(raise_symbol) != nil)
  2930. curchar = TOupper(curchar);
  2931. #ifdef Kanji
  2932. if (qvalue(hankaku_symbol) != nil)
  2933. is (iszenkaku(curchar))
  2934. curchar = tohankaku(curchar);
  2935. #endif
  2936. }
  2937. }
  2938. /*
  2939. * Here is the main loop that reads an identifier. Observe the extra
  2940. * complication that Common Lisp generates with the need to support
  2941. * package markers and '|' style escapes...
  2942. */
  2943. do
  2944. { push(stream);
  2945. packbyte(curchar);
  2946. pop(stream);
  2947. curchar = getc_stream(stream);
  2948. errexit();
  2949. #ifdef COMMON
  2950. if (within_vbars) escaped = YES;
  2951. while (curchar == '|')
  2952. { nil = C_nil;
  2953. stackcheck0(0);
  2954. curchar = getc_stream(stream);
  2955. errexit();
  2956. within_vbars = !within_vbars;
  2957. }
  2958. #endif
  2959. if (curchar == EOF) break;
  2960. else if (curchar == ESCAPE_CHAR)
  2961. { nil = C_nil;
  2962. stackcheck0(0);
  2963. curchar = getc_stream(stream);
  2964. errexit();
  2965. curchar |= ESCAPED_CHAR;
  2966. escaped = YES;
  2967. }
  2968. #ifdef COMMON
  2969. else if (!within_vbars)
  2970. { if (curchar == ':')
  2971. { if (colon >= 0) double_colon = boffop;
  2972. else colon = boffop, escaped = YES;
  2973. }
  2974. #endif
  2975. else if (qvalue(lower_symbol) != nil)
  2976. curchar = TOlower(curchar);
  2977. else if (qvalue(raise_symbol) != nil)
  2978. curchar = TOupper(curchar);
  2979. #ifdef Kanji
  2980. if (qvalue(hankaku_symbol) != nil)
  2981. is (iszenkaku(curchar))
  2982. curchar = tohankaku(curchar);
  2983. #endif
  2984. #ifdef COMMON
  2985. }
  2986. } while (within_vbars || is_constituent(curchar));
  2987. #else
  2988. } while (is_constituent(curchar));
  2989. #endif
  2990. #ifdef COMMON
  2991. /*
  2992. * If there are no colons present, or if there are two but they
  2993. * are not consecutive, or of there are three or more, or if the last
  2994. * character of the symbol was a colon, I will just look it up in
  2995. * the current package.
  2996. */
  2997. if (colon < 0 || colon+1==boffop)
  2998. return intern(boffop, escaped);
  2999. if ((double_colon >= 0 && double_colon != colon+1) ||
  3000. double_colon+1==boffop)
  3001. return intern(boffop, escaped);
  3002. /*
  3003. * If the first character was a colon I use the keyword package.
  3004. */
  3005. memset(package_name, 0, sizeof(package_name));
  3006. strncpy(package_name, &celt(boffo, 0), (size_t)colon);
  3007. package_name[sizeof(package_name)-1] = 0;
  3008. /* term_printf("Package lookup <%.*s>\n", (int)colon, &celt(boffo, 0)); */
  3009. if (colon == 0) w = qvalue(keyword_package);
  3010. else w = find_package(&celt(boffo, 0), colon);
  3011. /*
  3012. * Here I rely on find_package never raising an exception and never giving
  3013. * a possible entry into a break loop (etc), since I need boffo[] intact
  3014. * after the call.
  3015. */
  3016. if (w == nil)
  3017. { err_printf(
  3018. "+++ Package %s not found: using current package\n",
  3019. package_name);
  3020. /*
  3021. * Similarly I assume, unreasonably, that boffo can not be disturbed by
  3022. * printing this warning message.
  3023. */
  3024. w = CP; /* default behaviour: unknown package */
  3025. }
  3026. if (double_colon >= 0) colon = double_colon;
  3027. i = 0;
  3028. colon++;
  3029. while (colon < boffop)
  3030. boffo_char(i++) = boffo_char(colon++);
  3031. boffop = i;
  3032. /* term_printf("Name within package <%.*s>\n", (int)boffop, &celt(boffo, 0)); */
  3033. if (double_colon < 0 && w != qvalue(keyword_package))
  3034. { /* In the case ppp:sss it MUST be external in ppp */
  3035. Lisp_Object wx;
  3036. push(w);
  3037. wx = iintern(boffo, (int32)boffop, w, 4);
  3038. pop(w);
  3039. errexit();
  3040. if (mv_2 == nil)
  3041. { err_printf("+++ Symbol %.*s not external in %s\n",
  3042. (int)boffop, &celt(boffo, 0), package_name);
  3043. err_printf("+++ Treating as internal symbol...\n");
  3044. }
  3045. else return wx;
  3046. }
  3047. /*
  3048. * Curiously I will always take keywords (as in :kkk) through the path
  3049. * that corresponds to looking up an internal symbol, ie ::kkk, since that
  3050. * way I allow the reader to create a new symbol. If I handled the keyword
  3051. * case in the usual external symbol way it would demand that the keyword
  3052. * already existed (since in all other packages nothing is external unless
  3053. * it already exists and has been exported).
  3054. */
  3055. return iintern(boffo, (int32)boffop, w, 0);
  3056. #else
  3057. return intern(boffop, escaped);
  3058. #endif
  3059. }
  3060. }
  3061. }
  3062. }
  3063. int char_from_synonym(Lisp_Object stream)
  3064. {
  3065. stream = qvalue(stream_read_data(stream));
  3066. if (!is_stream(stream)) return aerror1("bad synonym stream", stream);
  3067. return getc_stream(stream);
  3068. }
  3069. int char_from_concatenated(Lisp_Object stream)
  3070. {
  3071. Lisp_Object l = stream_read_data(stream), s1;
  3072. Lisp_Object nil = C_nil;
  3073. int c;
  3074. while (consp(l))
  3075. { s1 = qcar(l);
  3076. if (!is_symbol(s1))
  3077. { l = qcdr(l);
  3078. stream_read_data(stream) = l;
  3079. continue;
  3080. }
  3081. s1 = qvalue(s1);
  3082. if (!is_stream(s1))
  3083. { l = qcdr(l);
  3084. stream_read_data(stream) = l;
  3085. continue;
  3086. }
  3087. push2(l, stream);
  3088. c = getc_stream(s1);
  3089. pop2(stream, l);
  3090. errexit();
  3091. if (c == EOF)
  3092. { l = qcdr(l);
  3093. stream_read_data(stream) = l;
  3094. continue;
  3095. }
  3096. }
  3097. return EOF;
  3098. }
  3099. int char_from_echo(Lisp_Object stream)
  3100. {
  3101. int c;
  3102. Lisp_Object stream1 = qvalue(stream_read_data(stream));
  3103. if (!is_stream(stream1)) return aerror1("bad synonym stream", stream1);
  3104. c = getc_stream(stream1);
  3105. char_to_synonym(c, stream);
  3106. return c;
  3107. }
  3108. int char_from_file(Lisp_Object stream)
  3109. {
  3110. Lisp_Object nil = C_nil;
  3111. int ch = stream_pushed_char(stream);
  3112. if (ch == NOT_CHAR)
  3113. {
  3114. #ifdef Kanji
  3115. ch = getwc(stream_file(stream));
  3116. #else
  3117. ch = getc(stream_file(stream));
  3118. #endif
  3119. if (ch == EOF
  3120. /* || ch == CTRL_D */
  3121. ) return EOF;
  3122. if (qvalue(echo_symbol) != nil)
  3123. { Lisp_Object stream1 = qvalue(standard_output);
  3124. if (!is_stream(stream1)) stream1 = qvalue(terminal_io);
  3125. if (!is_stream(stream1)) stream1 = lisp_terminal_io;
  3126. putc_stream(ch, stream1);
  3127. if (exception_pending()) flip_exception();
  3128. }
  3129. }
  3130. else stream_pushed_char(stream) = NOT_CHAR;
  3131. return ch;
  3132. }
  3133. int32 read_action_illegal(int32 op, Lisp_Object f)
  3134. {
  3135. CSL_IGNORE(f);
  3136. if (op != READ_CLOSE && op != READ_IS_CONSOLE)
  3137. aerror1("Illegal operation on stream",
  3138. cons_no_gc(fixnum_of_int(op), stream_type(f)));
  3139. return 0;
  3140. }
  3141. int32 read_action_file(int32 op, Lisp_Object f)
  3142. {
  3143. if (op < -1) return fseek(stream_file(f), op & 0x7fffffff, SEEK_SET);
  3144. else if (op <= 0xffff) return (stream_pushed_char(f) = op);
  3145. else switch (op)
  3146. {
  3147. case READ_CLOSE:
  3148. if (stream_file(f) == NULL) op = 0;
  3149. else op = fclose(stream_file(f));
  3150. set_stream_read_fn(f, char_from_illegal);
  3151. set_stream_read_other(f, read_action_illegal);
  3152. set_stream_file(f, NULL);
  3153. return op;
  3154. case READ_FLUSH:
  3155. stream_pushed_char(f) = NOT_CHAR;
  3156. return 0;
  3157. case READ_TELL:
  3158. if ((op = stream_pushed_char(f)) != NOT_CHAR)
  3159. { ungetc(op, stream_file(f));
  3160. stream_pushed_char(f) = NOT_CHAR;
  3161. }
  3162. return (int32)ftell(stream_file(f));
  3163. case READ_END:
  3164. return fseek(stream_file(f), 0L, SEEK_END);
  3165. case READ_IS_CONSOLE:
  3166. return 0;
  3167. default:
  3168. return 0;
  3169. }
  3170. }
  3171. int32 read_action_output_file(int32 op, Lisp_Object f)
  3172. {
  3173. if (op < -1) return fseek(stream_file(f), op & 0x7fffffff, SEEK_SET);
  3174. else if (op <= 0xffff) return 0;
  3175. else switch (op)
  3176. {
  3177. case READ_TELL:
  3178. op = ftell(stream_file(f));
  3179. return op;
  3180. case READ_END:
  3181. return fseek(stream_file(f), 0L, SEEK_END);
  3182. default:
  3183. return 0;
  3184. }
  3185. }
  3186. int32 read_action_terminal(int32 op, Lisp_Object f)
  3187. {
  3188. CSL_IGNORE(f);
  3189. if (op < -1) return 1;
  3190. else if (op <= 0xffff) return (terminal_pushed = op);
  3191. else switch (op)
  3192. {
  3193. case READ_CLOSE:
  3194. return 0;
  3195. case READ_FLUSH:
  3196. terminal_pushed = NOT_CHAR;
  3197. tty_count = 0;
  3198. return 0;
  3199. case READ_TELL:
  3200. return -1;
  3201. case READ_IS_CONSOLE:
  3202. return 1;
  3203. default:
  3204. return 0;
  3205. }
  3206. }
  3207. int32 read_action_synonym(int32 c, Lisp_Object f)
  3208. {
  3209. int32 r;
  3210. Lisp_Object f1;
  3211. f1 = qvalue(stream_read_data(f));
  3212. if (!is_stream(f1)) return aerror1("bad synonym stream", f1);
  3213. r = other_read_action(c, f1);
  3214. if (c == READ_CLOSE)
  3215. { set_stream_read_fn(f, char_from_illegal);
  3216. set_stream_read_other(f, read_action_illegal);
  3217. set_stream_file(f, NULL);
  3218. }
  3219. return r;
  3220. }
  3221. int32 read_action_concatenated(int32 c, Lisp_Object f)
  3222. {
  3223. int32 r = 0, r1;
  3224. Lisp_Object l, f1;
  3225. #ifdef COMMON
  3226. Lisp_Object nil = C_nil;
  3227. #endif
  3228. l = stream_read_data(f);
  3229. while (consp(l))
  3230. { f1 = qcar(l);
  3231. l = qcdr(l);
  3232. if (!is_symbol(f1)) continue;
  3233. f1 = qvalue(f1);
  3234. if (!is_stream(f1)) continue;
  3235. push2(l, f);
  3236. r1 = other_read_action(c, f1);
  3237. pop2(f, l);
  3238. if (r == 0) r = r1;
  3239. }
  3240. if (c == READ_CLOSE)
  3241. { set_stream_read_fn(f, char_from_illegal);
  3242. set_stream_read_other(f, read_action_illegal);
  3243. set_stream_file(f, NULL);
  3244. }
  3245. return r;
  3246. }
  3247. int32 read_action_list(int32 op, Lisp_Object f)
  3248. {
  3249. if (op < -1) return 1;
  3250. else if (op <= 0xffff) return (stream_pushed_char(f) = op);
  3251. else switch (op)
  3252. {
  3253. case READ_CLOSE:
  3254. set_stream_read_fn(f, char_from_illegal);
  3255. set_stream_read_other(f, read_action_illegal);
  3256. set_stream_file(f, NULL);
  3257. stream_read_data(f) = C_nil;
  3258. return 0;
  3259. case READ_FLUSH:
  3260. stream_pushed_char(f) = NOT_CHAR;
  3261. return 0;
  3262. case READ_TELL:
  3263. return -1;
  3264. case READ_IS_CONSOLE:
  3265. return 0;
  3266. default:
  3267. return 0;
  3268. }
  3269. }
  3270. int32 read_action_vector(int32 op, Lisp_Object f)
  3271. {
  3272. if (op < -1) return 1;
  3273. else if (op <= 0xffff) return (stream_pushed_char(f) = op);
  3274. else switch (op)
  3275. {
  3276. case READ_CLOSE:
  3277. set_stream_read_fn(f, char_from_illegal);
  3278. set_stream_read_other(f, read_action_illegal);
  3279. set_stream_file(f, NULL);
  3280. stream_read_data(f) = C_nil;
  3281. return 0;
  3282. case READ_FLUSH:
  3283. stream_pushed_char(f) = NOT_CHAR;
  3284. return 0;
  3285. case READ_TELL:
  3286. return -1;
  3287. case READ_IS_CONSOLE:
  3288. return 0;
  3289. default:
  3290. return 0;
  3291. }
  3292. }
  3293. static int most_recent_read_point = 0;
  3294. Lisp_Object MS_CDECL Lread(Lisp_Object nil, int nargs, ...)
  3295. /*
  3296. * The full version of read_s() has to support extra optional args
  3297. * that deal with error and eof returns... and a recursive-p arg!
  3298. */
  3299. {
  3300. Lisp_Object w, stream = qvalue(standard_input);
  3301. int cursave = curchar;
  3302. argcheck(nargs, 0, "read");
  3303. #ifdef COMMON
  3304. push(reader_workspace);
  3305. reader_workspace = nil;
  3306. #endif
  3307. read_failure = NO;
  3308. if (!is_stream(stream)) stream = qvalue(terminal_io);
  3309. if (!is_stream(stream)) stream = lisp_terminal_io;
  3310. curchar = NOT_CHAR;
  3311. most_recent_read_point = other_read_action(READ_TELL, stream);
  3312. push(stream);
  3313. w = read_s(stream);
  3314. pop(stream);
  3315. if (curchar != NOT_CHAR) other_read_action(curchar, stream);
  3316. curchar = cursave;
  3317. current_file = stream_type(stream);
  3318. #ifdef COMMON
  3319. nil = C_nil;
  3320. if (exception_pending())
  3321. { flip_exception();
  3322. pop(reader_workspace);
  3323. flip_exception();
  3324. return nil;
  3325. }
  3326. pop(reader_workspace);
  3327. #else
  3328. errexit();
  3329. #endif
  3330. if (read_failure) return aerror("read");
  3331. return onevalue(w);
  3332. }
  3333. static Lisp_Object MS_CDECL Lwhere_was_that(Lisp_Object nil, int nargs, ...)
  3334. {
  3335. Lisp_Object w;
  3336. argcheck(nargs, 0, "where-was-that");
  3337. #ifdef COMMON
  3338. w = list3(current_file, fixnum_of_int(most_recent_read_point),
  3339. packname_(CP));
  3340. #else
  3341. w = list2(current_file, fixnum_of_int(most_recent_read_point));
  3342. #endif
  3343. errexit();
  3344. return onevalue(w);
  3345. }
  3346. #ifdef COMMON
  3347. Lisp_Object Lread_1(Lisp_Object nil, Lisp_Object stream)
  3348. {
  3349. int cursave = curchar;
  3350. Lisp_Object w;
  3351. Lisp_Object save = Lrds(nil, stream);
  3352. errexit();
  3353. push2(reader_workspace, save);
  3354. reader_workspace = nil;
  3355. read_failure = NO;
  3356. stream = qvalue(standard_input);
  3357. if (!is_stream(stream)) stream = qvalue(terminal_io);
  3358. if (!is_stream(stream)) stream = lisp_terminal_io;
  3359. curchar = NOT_CHAR;
  3360. w = read_s(stream);
  3361. if (curchar != NOT_CHAR) other_read_action(curchar, stream);
  3362. curchar = cursave;
  3363. nil = C_nil;
  3364. if (exception_pending())
  3365. { flip_exception();
  3366. pop2(save, reader_workspace);
  3367. Lrds(nil, save);
  3368. errexit();
  3369. flip_exception();
  3370. return nil;
  3371. }
  3372. pop2(save, reader_workspace);
  3373. push(w);
  3374. Lrds(nil, save);
  3375. pop(w);
  3376. errexit();
  3377. if (read_failure) return aerror("read");
  3378. return onevalue(w);
  3379. }
  3380. #endif
  3381. /*
  3382. * compress is not a Common Lisp function, but it is another on those
  3383. * things that I want within my implementation for internal purposes as
  3384. * well as for real use.
  3385. */
  3386. int char_from_list(Lisp_Object f)
  3387. {
  3388. #ifdef COMMON
  3389. Lisp_Object nil = C_nil;
  3390. #else
  3391. nil_as_base
  3392. #endif
  3393. Lisp_Object ch = stream_pushed_char(f);
  3394. if (ch == NOT_CHAR)
  3395. { if (!consp(stream_read_data(f))) ch = EOF;
  3396. else
  3397. { ch = qcar(stream_read_data(f));
  3398. stream_read_data(f) = qcdr(stream_read_data(f));
  3399. }
  3400. /*
  3401. * here I tend towards generosity - a symbol stands for the first character
  3402. * of its name, and character objects and numbers (representing internal
  3403. * codes) are also permitted. Incomplete gensyms are OK here - I just
  3404. * use the first character of the base of the name.
  3405. */
  3406. if (is_symbol(ch)) ch = first_char(ch);
  3407. else if (is_char(ch)) ch = (char)code_of_char(ch);
  3408. else if (is_fixnum(ch)) ch = (char)int_of_fixnum(ch);
  3409. else ch = EOF; /* Bad item in the list */
  3410. }
  3411. else stream_pushed_char(f) = NOT_CHAR;
  3412. return ch;
  3413. }
  3414. int char_from_vector(Lisp_Object f)
  3415. {
  3416. #ifdef COMMON
  3417. Lisp_Object nil = C_nil;
  3418. #else
  3419. nil_as_base
  3420. #endif
  3421. Lisp_Object ch = stream_pushed_char(f);
  3422. if (ch == NOT_CHAR)
  3423. { char *v = (char *)stream_file(f);
  3424. if (v == NULL) ch = EOF;
  3425. else
  3426. { ch = *v++;
  3427. if (ch == 0) ch = EOF;
  3428. else set_stream_file(f, (FILE *)v);
  3429. }
  3430. }
  3431. else stream_pushed_char(f) = NOT_CHAR;
  3432. return ch;
  3433. }
  3434. Lisp_Object read_from_vector(char *v)
  3435. {
  3436. int savecur = curchar;
  3437. Lisp_Object nil = C_nil, r;
  3438. stream_read_data(lisp_work_stream) = nil;
  3439. set_stream_read_fn(lisp_work_stream, char_from_vector);
  3440. set_stream_read_other(lisp_work_stream, read_action_vector);
  3441. stream_pushed_char(lisp_work_stream) = NOT_CHAR;
  3442. set_stream_file(lisp_work_stream, (FILE *)v);
  3443. read_failure = NO;
  3444. curchar = NOT_CHAR;
  3445. r = read_s(lisp_work_stream);
  3446. errexit();
  3447. curchar = savecur;
  3448. if (read_failure) return aerror("read-from-vector");
  3449. return onevalue(r);
  3450. }
  3451. Lisp_Object Lcompress(Lisp_Object env, Lisp_Object stream)
  3452. {
  3453. int savecur = curchar;
  3454. Lisp_Object nil = C_nil;
  3455. stream_read_data(lisp_work_stream) = stream;
  3456. set_stream_read_fn(lisp_work_stream, char_from_list);
  3457. set_stream_read_other(lisp_work_stream, read_action_list);
  3458. stream_pushed_char(lisp_work_stream) = NOT_CHAR;
  3459. read_failure = NO;
  3460. curchar = NOT_CHAR;
  3461. env = read_s(lisp_work_stream);
  3462. errexit();
  3463. stream_read_data(lisp_work_stream) = C_nil;
  3464. curchar = savecur;
  3465. if (read_failure) return aerror("compress");
  3466. return onevalue(env);
  3467. }
  3468. Lisp_Object Llist_to_string(Lisp_Object nil, Lisp_Object stream)
  3469. {
  3470. int n = CELL, k;
  3471. Lisp_Object str;
  3472. char *s;
  3473. stream_read_data(lisp_work_stream) = stream;
  3474. set_stream_read_fn(lisp_work_stream, char_from_list);
  3475. set_stream_read_other(lisp_work_stream, read_action_list);
  3476. stream_pushed_char(lisp_work_stream) = NOT_CHAR;
  3477. while (consp(stream)) n++, stream = qcdr(stream);
  3478. str = getvector(TAG_VECTOR, TYPE_STRING, n);
  3479. errexit();
  3480. s = (char *)str + CELL - TAG_VECTOR;
  3481. for (k=CELL; k<n; k++) *s++ = (char)char_from_list(lisp_work_stream);
  3482. for (;(k&7) != 0; k++) *s++ = 0; /* zero-pad final doubleword */
  3483. return onevalue(str);
  3484. }
  3485. Lisp_Object Llist_to_symbol(Lisp_Object nil, Lisp_Object stream)
  3486. {
  3487. stream = Llist_to_string(nil, stream);
  3488. errexit();
  3489. #ifdef COMMON
  3490. stream = Lintern_2(nil, stream, CP);
  3491. errexit();
  3492. return onevalue(stream); /* NB intern would have returned 2 values */
  3493. #else
  3494. return Lintern(nil, stream);
  3495. #endif
  3496. }
  3497. void read_eval_print(int noisy)
  3498. {
  3499. Lisp_Object nil = C_nil, *save = stack;
  3500. #ifndef __cplusplus
  3501. jmp_buf this_level, *saved_buffer = errorset_buffer;
  3502. #endif
  3503. push2(codevec, litvec);
  3504. for (;;) /* Loop for each s-expression found */
  3505. { Lisp_Object u;
  3506. #ifdef COMMON
  3507. int32 nvals, i;
  3508. #endif
  3509. miscflags |= (HEADLINE_FLAG | MESSAGES_FLAG);
  3510. errorset_msg = NULL;
  3511. #ifdef __cplusplus
  3512. try
  3513. #else
  3514. if (!setjmp(this_level))
  3515. #endif
  3516. {
  3517. #ifndef __cplusplus
  3518. errorset_buffer = &this_level;
  3519. #endif
  3520. u = Lread(nil, 0);
  3521. }
  3522. #ifdef __cplusplus
  3523. catch (char *)
  3524. #else
  3525. else
  3526. #endif
  3527. { if (errorset_msg != NULL)
  3528. { term_printf("\n%s detected\n", errorset_msg);
  3529. errorset_msg = NULL;
  3530. }
  3531. unwind_stack(save, NO);
  3532. stack = save;
  3533. signal(SIGFPE, low_level_signal_handler);
  3534. #ifdef __WATCOMC__
  3535. _control87(_EM_OVERFLOW | _EM_INVALID | _EM_DENORMAL |
  3536. _EM_ZERODIVIDE | _EM_INEXACT | _EM_UNDERFLOW,
  3537. _MCW_EM);
  3538. #endif
  3539. if (segvtrap) signal(SIGSEGV, low_level_signal_handler);
  3540. #ifdef SIGBUS
  3541. if (segvtrap) signal(SIGBUS, low_level_signal_handler);
  3542. #endif
  3543. #ifdef SIGILL
  3544. if (segvtrap) signal(SIGILL, low_level_signal_handler);
  3545. #endif
  3546. err_printf("\n... read failed\n");
  3547. continue;
  3548. }
  3549. nil = C_nil;
  3550. if (exception_pending())
  3551. { flip_exception();
  3552. /*
  3553. * Maybe (stop) or (preserve) was called from a read-macro? Otherwise
  3554. * errors reading are ignored and the system tries to read the next
  3555. * expression for evaluation. Note that this behaviour means that
  3556. * perhaps unreasonably or unexpectedly, THROW will not be propagated
  3557. * back past a read_eval_print loop.
  3558. */
  3559. if (exit_reason == UNWIND_RESTART)
  3560. {
  3561. #ifndef __cplusplus
  3562. errorset_buffer = saved_buffer;
  3563. #endif
  3564. pop2(litvec, codevec);
  3565. flip_exception();
  3566. return;
  3567. }
  3568. err_printf("\n... read failed\n");
  3569. continue;
  3570. }
  3571. /*
  3572. * This will stop at end of file. That could EITHER be a real proper
  3573. * end of file, or the user having #\eof in the input file. These are NOT
  3574. * equivalent, in that #\eof is read once and then further stuff from the
  3575. * stream can be read, while a real EOF (eg typing ^D at the terminal in
  3576. * some cases) ends the stream once and for all.
  3577. */
  3578. if (u == CHAR_EOF)
  3579. {
  3580. #ifndef __cplusplus
  3581. errorset_buffer = saved_buffer;
  3582. #endif
  3583. pop2(litvec, codevec);
  3584. return;
  3585. }
  3586. if (qvalue(standard_input) == lisp_terminal_io &&
  3587. spool_file != NULL) putc('\n', spool_file);
  3588. miscflags |= (HEADLINE_FLAG | MESSAGES_FLAG);
  3589. errorset_msg = NULL;
  3590. #ifdef __cplusplus
  3591. try
  3592. #else
  3593. if (!setjmp(this_level))
  3594. #endif
  3595. {
  3596. u = eval(u, nil);
  3597. nil = C_nil;
  3598. if (exception_pending())
  3599. { flip_exception(); /* safe again! */
  3600. if (exit_reason == UNWIND_RESTART)
  3601. {
  3602. #ifndef __cplusplus
  3603. errorset_buffer = saved_buffer;
  3604. #endif
  3605. pop2(litvec, codevec);
  3606. flip_exception();
  3607. return;
  3608. }
  3609. err_printf("\n... continuing after error\n");
  3610. if (spool_file != NULL) fflush(spool_file);
  3611. continue;
  3612. }
  3613. if (noisy)
  3614. {
  3615. #ifndef COMMON
  3616. print(u); /* Always exactly one value */
  3617. stdout_printf("\n");
  3618. nil = C_nil;
  3619. if (exception_pending()) flip_exception();
  3620. #else
  3621. nvals = exit_count;
  3622. /*
  3623. * These days I have to push mv_2 because print can call find-symbol to
  3624. * decide if it needs to display a package qualifier, and in that case
  3625. * it alters mv_2 on the way... But at present it should never change
  3626. * any higher multiple value. I guess if it were interrupted then a break
  3627. * loop (if one existed) could corrupt almost anything, but I will
  3628. * ignore that worry.
  3629. */
  3630. if (nvals > 0)
  3631. { push(mv_2);
  3632. print(u);
  3633. pop(u);
  3634. }
  3635. nil = C_nil;
  3636. if (exception_pending()) flip_exception();
  3637. mv_2 = u;
  3638. miscflags |= (HEADLINE_FLAG | MESSAGES_FLAG);
  3639. for (i=2; i<=nvals; i++)
  3640. { print((&mv_2)[i-2]);
  3641. nil = C_nil;
  3642. if (exception_pending())
  3643. { flip_exception();
  3644. break;
  3645. }
  3646. }
  3647. stdout_printf("\n");
  3648. #endif
  3649. }
  3650. }
  3651. #ifdef __cplusplus
  3652. catch (char *)
  3653. #else
  3654. else
  3655. #endif
  3656. { if (errorset_msg != NULL)
  3657. { term_printf("\n%s detected\n", errorset_msg);
  3658. errorset_msg = NULL;
  3659. }
  3660. unwind_stack(save, NO);
  3661. stack = save;
  3662. signal(SIGFPE, low_level_signal_handler);
  3663. #ifdef __WATCOMC__
  3664. _control87(_EM_OVERFLOW | _EM_INVALID | _EM_DENORMAL |
  3665. _EM_ZERODIVIDE | _EM_INEXACT | _EM_UNDERFLOW,
  3666. _MCW_EM);
  3667. #endif
  3668. if (segvtrap) signal(SIGSEGV, low_level_signal_handler);
  3669. #ifdef SIGBUS
  3670. if (segvtrap) signal(SIGBUS, low_level_signal_handler);
  3671. #endif
  3672. #ifdef SIGILL
  3673. if (segvtrap) signal(SIGILL, low_level_signal_handler);
  3674. #endif
  3675. err_printf("\n... continuing after error\n");
  3676. if (spool_file != NULL) fflush(spool_file);
  3677. continue;
  3678. }
  3679. }
  3680. }
  3681. /*
  3682. * RDF is wanted as it is in Standard Lisp. In Common Lisp the corresponding
  3683. * function is LOAD. LOAD takes keyword arguments, which are decoded
  3684. * elsewhere, leaving the code here which takes a variable number of
  3685. * args, but all with definite simple interpretations.
  3686. */
  3687. Lisp_Object Lrdf4(Lisp_Object nil, Lisp_Object file, Lisp_Object noisyp,
  3688. Lisp_Object verbosep, Lisp_Object nofilep)
  3689. {
  3690. Lisp_Object r = nil;
  3691. int noisy = (noisyp != nil),
  3692. #ifdef COMMON
  3693. nofile = (nofilep != nil),
  3694. #endif
  3695. verbose = (verbosep != nil);
  3696. #ifndef COMMON
  3697. CSL_IGNORE(nofilep);
  3698. #endif
  3699. /*
  3700. * (rdf nil)/(load nil) obeys Lisp commands from the current input
  3701. */
  3702. push3(nil, nil, file);
  3703. /*
  3704. * I have a somewhat comical chunk of code here. If the file-name passed
  3705. * across ends in a suffix that is one of ".o", ".fsl" or ".fasl" then
  3706. * instead of reading a textual source file the way one might have
  3707. * expected I will subvert things and perform LOAD-MODULE instead.
  3708. */
  3709. if (file != nil)
  3710. { Header h;
  3711. char *filestring;
  3712. char tail[8];
  3713. int32 i, len;
  3714. #ifdef COMMON
  3715. if (complex_stringp(file))
  3716. { file = simplify_string(file);
  3717. errexitn(3);
  3718. }
  3719. #endif
  3720. if (symbolp(file))
  3721. { file = get_pname(file);
  3722. errexitn(3);
  3723. h = vechdr(file);
  3724. }
  3725. else if (!is_vector(file) ||
  3726. type_of_header(h = vechdr(file)) != TYPE_STRING)
  3727. return aerror1("load", file);
  3728. len = length_of_header(h) - CELL;
  3729. filestring = (char *)file + CELL-TAG_VECTOR;
  3730. for (i=0; i<6; i++)
  3731. { if (len == 0)
  3732. { tail[i] = 0;
  3733. break;
  3734. }
  3735. else tail[i] = (char)tolower(filestring[--len]);
  3736. }
  3737. if (strncmp(tail, "lsf.", 4) == 0 ||
  3738. strncmp(tail, "lasf.", 5) == 0 ||
  3739. strncmp(tail, "o.", 2) == 0)
  3740. { stack[0] = file;
  3741. if (verbose)
  3742. {
  3743. #ifdef COMMON
  3744. trace_printf("\n;; Loading module ");
  3745. #else
  3746. trace_printf("\nReading module ");
  3747. #endif
  3748. loop_print_trace(file); trace_printf("\n");
  3749. }
  3750. Lload_module(nil, stack[0]);
  3751. errexitn(3);
  3752. if (verbose)
  3753. {
  3754. #ifdef COMMON
  3755. trace_printf("\n;; Loaded module ");
  3756. #else
  3757. trace_printf("\nRead module ");
  3758. #endif
  3759. loop_print_trace(stack[0]); trace_printf("\n");
  3760. }
  3761. popv(3);
  3762. #ifdef COMMON
  3763. return onevalue(lisp_true);
  3764. #else
  3765. return onevalue(nil);
  3766. #endif
  3767. }
  3768. #ifdef COMMON
  3769. stack[-1] = r = Lopen(nil, file, fixnum_of_int(1+(nofile?64:0)));
  3770. #else
  3771. stack[-1] = r = Lopen(nil, file, fixnum_of_int(1+64));
  3772. #endif
  3773. errexitn(3);
  3774. #ifdef COMMON
  3775. /*
  3776. * The test here is necessary since in Common Lisp mode an attempt to OPEN a
  3777. * file that can not be accessed returns NIL rather than raising an
  3778. * exception.
  3779. */
  3780. if (r == nil)
  3781. { pop(file);
  3782. popv(2);
  3783. if (nofile) return error(1, err_open_failed, file);
  3784. else return onevalue(nil);
  3785. }
  3786. #endif
  3787. stack[-2] = r = Lrds(nil, r);
  3788. errexitn(3);
  3789. if (verbose)
  3790. { file = stack[0];
  3791. #ifdef COMMON
  3792. trace_printf("\n;; Loading "); loop_print_trace(file); trace_printf("\n");
  3793. #else
  3794. trace_printf("\nReading "); loop_print_trace(file); trace_printf("\n");
  3795. #endif
  3796. }
  3797. errexitn(3);
  3798. }
  3799. read_eval_print(noisy);
  3800. nil = C_nil;
  3801. if (exception_pending())
  3802. { flip_exception();
  3803. if (exit_reason == UNWIND_ERROR)
  3804. {
  3805. #ifdef COMMON
  3806. trace_printf("\n;; Loaded ");
  3807. #else
  3808. trace_printf("\nFinished reading ");
  3809. #endif
  3810. loop_print_trace(stack[0]);
  3811. trace_printf(" (bad)\n");
  3812. }
  3813. if (stack[0] != nil)
  3814. { Lclose(nil, stack[-1]);
  3815. nil = C_nil;
  3816. if (exception_pending()) flip_exception();
  3817. Lrds(nil, stack[-2]);
  3818. errexitn(3);
  3819. }
  3820. flip_exception();
  3821. popv(3);
  3822. return nil;
  3823. }
  3824. if (verbose)
  3825. {
  3826. #ifdef COMMON
  3827. trace_printf("\n;; Loaded ");
  3828. #else
  3829. trace_printf("\nRead ");
  3830. #endif
  3831. }
  3832. loop_print_trace(stack[0]);
  3833. trace_printf("\n");
  3834. if (stack[0] != nil)
  3835. {
  3836. Lclose(nil, stack[-1]);
  3837. nil = C_nil;
  3838. if (exception_pending()) flip_exception();
  3839. Lrds(nil, stack[-2]);
  3840. errexitn(3);
  3841. }
  3842. popv(3);
  3843. #ifdef COMMON
  3844. return onevalue(lisp_true);
  3845. #else
  3846. return onevalue(nil);
  3847. #endif
  3848. }
  3849. Lisp_Object Lrdf1(Lisp_Object nil, Lisp_Object file)
  3850. {
  3851. return Lrdf4(nil, file, lisp_true, lisp_true, lisp_true);
  3852. }
  3853. Lisp_Object Lrdf2(Lisp_Object nil, Lisp_Object file, Lisp_Object noisy)
  3854. {
  3855. return Lrdf4(nil, file, noisy, lisp_true, lisp_true);
  3856. }
  3857. Lisp_Object MS_CDECL Lrdfn(Lisp_Object nil, int nargs, ...)
  3858. {
  3859. va_list a;
  3860. Lisp_Object file, noisy, verbose, nofile = lisp_true;
  3861. if (nargs < 3 || nargs > 4) return aerror("load");
  3862. va_start(a, nargs);
  3863. file = va_arg(a, Lisp_Object);
  3864. noisy = va_arg(a, Lisp_Object);
  3865. verbose = va_arg(a, Lisp_Object);
  3866. if (nargs > 3) nofile = va_arg(a, Lisp_Object);
  3867. va_end(a);
  3868. return Lrdf4(nil, file, noisy, verbose, nofile);
  3869. }
  3870. #ifdef COMMON
  3871. #define spool_name "dribble"
  3872. #else
  3873. #define spool_name "spool"
  3874. #endif
  3875. Lisp_Object Lspool(Lisp_Object nil, Lisp_Object file)
  3876. {
  3877. char filename[LONGEST_LEGAL_FILENAME];
  3878. Header h;
  3879. int32 len;
  3880. #ifdef SOCKETS
  3881. /*
  3882. * Security measure - remote client can not do "spool"
  3883. */
  3884. if (socket_server != 0) return onevalue(nil);
  3885. #endif
  3886. if (spool_file != NULL)
  3887. {
  3888. #ifdef COMMON
  3889. fprintf(spool_file, "\nFinished dribbling to %s.\n", spool_file_name);
  3890. #else
  3891. fprintf(spool_file, "\n+++ End of transcript +++\n");
  3892. #endif
  3893. fclose(spool_file);
  3894. spool_file = NULL;
  3895. }
  3896. if (file == nil) return onevalue(lisp_true);
  3897. #ifdef COMMON
  3898. if (complex_stringp(file))
  3899. { file = simplify_string(file);
  3900. errexit();
  3901. }
  3902. #endif
  3903. if (symbolp(file))
  3904. { file = get_pname(file);
  3905. errexit();
  3906. h = vechdr(file);
  3907. }
  3908. if (!is_vector(file) ||
  3909. type_of_header(h = vechdr(file)) != TYPE_STRING)
  3910. return aerror1(spool_name, file);
  3911. len = length_of_header(h) - CELL;
  3912. spool_file = open_file(filename,
  3913. (char *)file + (CELL-TAG_VECTOR),
  3914. (size_t)len, "w", NULL);
  3915. if (spool_file != NULL)
  3916. { time_t t0 = time(NULL);
  3917. strncpy(spool_file_name, filename, 32);
  3918. spool_file_name[31] = 0;
  3919. #ifdef COMMON
  3920. fprintf(spool_file, "Starts dribbling to %s (%.24s)\n",
  3921. spool_file_name, ctime(&t0));
  3922. #else
  3923. fprintf(spool_file, "+++ Transcript to %s started at %.24s +++\n",
  3924. spool_file_name, ctime(&t0));
  3925. #endif
  3926. return onevalue(lisp_true);
  3927. }
  3928. return onevalue(nil);
  3929. }
  3930. static Lisp_Object MS_CDECL Lspool0(Lisp_Object nil, int nargs, ...)
  3931. {
  3932. argcheck(nargs, 0, spool_name);
  3933. return Lspool(nil, nil);
  3934. }
  3935. #ifdef COMMON
  3936. #define STARTING_SIZE_X 32
  3937. #define STARTING_SIZE_I 32
  3938. Lisp_Object make_package(Lisp_Object name)
  3939. /*
  3940. * ... assuming that there is not already one with this name. Packages
  3941. * can grow as extra symbols are inserted into them, so I can reasonably
  3942. * start off with a very small package.
  3943. */
  3944. {
  3945. Lisp_Object nil = C_nil;
  3946. Lisp_Object p = getvector_init(sizeof(Package), nil), w;
  3947. errexit();
  3948. packhdr_(p) = TYPE_STRUCTURE + (packhdr_(p) & ~header_mask);
  3949. packid_(p) = package_symbol;
  3950. packname_(p) = name;
  3951. packext_(p) = getvector_init(STARTING_SIZE_X+CELL, fixnum_of_int(0));
  3952. errexit();
  3953. packint_(p) = getvector_init(STARTING_SIZE_I+CELL, fixnum_of_int(0));
  3954. errexit();
  3955. packflags_(p) = fixnum_of_int(++package_bits);
  3956. packvext_(p) = fixnum_of_int(1);
  3957. packvint_(p) = fixnum_of_int(1);
  3958. packnext_(p) = fixnum_of_int(0);
  3959. packnint_(p) = fixnum_of_int(0);
  3960. w = cons(p, all_packages);
  3961. errexit();
  3962. all_packages = w;
  3963. return onevalue(p);
  3964. }
  3965. static Lisp_Object want_a_string(Lisp_Object name)
  3966. {
  3967. #ifdef COMMON
  3968. Lisp_Object nil = C_nil;
  3969. if (complex_stringp(name)) return simplify_string(name);
  3970. #else
  3971. nil_as_base
  3972. #endif
  3973. if (symbolp(name)) return get_pname(name);
  3974. else if (is_vector(name) &&
  3975. type_of_header(vechdr(name)) == TYPE_STRING) return name;
  3976. else return aerror1("name or string needed", name);
  3977. }
  3978. static Lisp_Object Lfind_package(Lisp_Object nil, Lisp_Object name)
  3979. /*
  3980. * This should be given a string as an argument. If it is given a
  3981. * symbol it takes its pname as the string to be used. It scans the list
  3982. * of all packages and returns the first that it finds where the name
  3983. * or a nickname matches the string passed in.
  3984. */
  3985. {
  3986. Lisp_Object w;
  3987. Header h;
  3988. int32 len;
  3989. CSL_IGNORE(nil);
  3990. if (is_vector(name))
  3991. { h = vechdr(name);
  3992. if (type_of_header(h) == TYPE_STRUCTURE &&
  3993. packid_(name) == package_symbol) return onevalue(name);
  3994. }
  3995. name = want_a_string(name);
  3996. errexit();
  3997. h = vechdr(name);
  3998. len = length_of_header(h) - CELL;
  3999. for (w = all_packages; w!=nil; w=qcdr(w))
  4000. { Lisp_Object nn, n = packname_(qcar(w));
  4001. if (is_vector(n) && vechdr(n) == h &&
  4002. memcmp((char *)name + (CELL-TAG_VECTOR),
  4003. (char *)n + (CELL-TAG_VECTOR), (size_t)len) == 0)
  4004. return onevalue(qcar(w));
  4005. for (nn = packnick_(qcar(w)); nn!=nil; nn=qcdr(nn))
  4006. { n = qcar(nn);
  4007. if (!is_vector(n) || vechdr(n) != h) continue;
  4008. if (memcmp((char *)name + (CELL-TAG_VECTOR),
  4009. (char *)n + (CELL-TAG_VECTOR), (size_t)len) == 0)
  4010. return onevalue(qcar(w));
  4011. }
  4012. }
  4013. return onevalue(nil);
  4014. }
  4015. Lisp_Object find_package(char *name, int len)
  4016. /*
  4017. * This is like Lfind_package but takes a C string as its arg. Note that
  4018. * this can not cause garbage collection or return an error, so is safe to
  4019. * call from the middle of other things...
  4020. */
  4021. {
  4022. Lisp_Object w, nil = C_nil;
  4023. for (w = all_packages; w!=nil; w=qcdr(w))
  4024. { Lisp_Object nn, n = packname_(qcar(w));
  4025. if (is_vector(n) &&
  4026. length_of_header(vechdr(n))==(unsigned32)(len+CELL) &&
  4027. memcmp(name, (char *)n + (CELL-TAG_VECTOR), (size_t)len) == 0)
  4028. return qcar(w);
  4029. for (nn = packnick_(qcar(w)); nn!=nil; nn=qcdr(nn))
  4030. { n = qcar(nn);
  4031. if (!is_vector(n) ||
  4032. length_of_header(vechdr(n)) != (unsigned32)(len+CELL))
  4033. continue;
  4034. if (memcmp(name,
  4035. (char *)n + (CELL-TAG_VECTOR), (size_t)len) == 0)
  4036. return qcar(w);
  4037. }
  4038. }
  4039. return nil;
  4040. }
  4041. static Lisp_Object Luse_package(Lisp_Object nil, Lisp_Object uses,
  4042. Lisp_Object pkg)
  4043. {
  4044. CSL_IGNORE(nil);
  4045. push(uses);
  4046. pkg = Lfind_package(nil, pkg);
  4047. pop(uses);
  4048. errexit();
  4049. if (pkg == nil) return onevalue(nil);
  4050. if (consp(uses))
  4051. { while (consp(uses))
  4052. { push2(uses, pkg);
  4053. Luse_package(nil, qcar(uses), pkg);
  4054. errexitn(2);
  4055. pop2(pkg, uses);
  4056. uses = qcdr(uses);
  4057. }
  4058. }
  4059. else
  4060. { Lisp_Object w, w1;
  4061. push(pkg);
  4062. uses = Lfind_package(nil, uses);
  4063. pop(pkg);
  4064. errexit();
  4065. if (uses == nil || uses == pkg) return onevalue(nil);
  4066. push2(pkg, uses);
  4067. /*
  4068. * Around here I am supposed to do a large-scale check to ensure that there
  4069. * are no unexpected name conflicts between the packages that are being
  4070. * worked linked.
  4071. */
  4072. w = cons(uses, packuses_(pkg));
  4073. errexitn(2);
  4074. uses = stack[0];
  4075. pkg = stack[-1];
  4076. push(w);
  4077. w1 = cons(pkg, packused_(uses));
  4078. errexitn(3);
  4079. pop3(w, uses, pkg);
  4080. packuses_(pkg) = w;
  4081. packused_(uses) = w1;
  4082. }
  4083. return onevalue(lisp_true);
  4084. }
  4085. static Lisp_Object MS_CDECL Lmake_package(Lisp_Object nil, int nargs, ...)
  4086. {
  4087. Lisp_Object name, nicknames = nil, uses = nil, w = nil, k;
  4088. CSLbool has_use = NO;
  4089. va_list a;
  4090. int i;
  4091. if (nargs == 0) return aerror("make-package");
  4092. /*
  4093. * First I scan the arguments - there may be a lot of them - looking for
  4094. * any relevant keyword parameters
  4095. */
  4096. va_start(a, nargs);
  4097. push_args(a, nargs);
  4098. name = stack[1-nargs];
  4099. if ((nargs & 1) == 0)
  4100. { popv(1);
  4101. nargs--;
  4102. }
  4103. for (i=1; i<nargs; i+=2)
  4104. { pop2(k, w);
  4105. if (w == nicknames_symbol) nicknames = k;
  4106. else if (w == use_symbol) has_use = YES, uses = k;
  4107. }
  4108. popv(1);
  4109. /*
  4110. * I provide a default value for the ":use" argument
  4111. */
  4112. if (!has_use)
  4113. { push2(name, nicknames);
  4114. uses = make_string("LISP");
  4115. errexitn(2);
  4116. uses = ncons(uses);
  4117. errexitn(2);
  4118. pop2(nicknames, name);
  4119. }
  4120. push2(uses, nicknames);
  4121. /*
  4122. * Now I need to ensure that the name I had for the package is
  4123. * a string...
  4124. */
  4125. name = want_a_string(name);
  4126. errexitn(2);
  4127. push(name);
  4128. w = Lfind_package(nil, name);
  4129. pop(name);
  4130. errexitn(2);
  4131. /*
  4132. * It is SUPPOSED to be a continuable error if the package already exists.
  4133. * For the present I will just display a message and keep going.
  4134. */
  4135. if (w != nil)
  4136. { popv(2);
  4137. err_printf("\n+++++ package already exists: ");
  4138. prin_to_error(name);
  4139. err_printf("\n");
  4140. return onevalue(w);
  4141. }
  4142. /*
  4143. * The package does not exist yet - so I will make one...
  4144. */
  4145. name = make_package(name);
  4146. errexitn(2);
  4147. /*
  4148. * ensure that NICKNAMES is a list of strings...
  4149. */
  4150. uses = nil;
  4151. while (consp(stack[0]))
  4152. { w = stack[0];
  4153. push(uses);
  4154. w = want_a_string(qcar(w));
  4155. errexitn(3);
  4156. pop(uses);
  4157. uses = cons(w, uses);
  4158. errexitn(2);
  4159. stack[0] = qcdr(stack[0]);
  4160. }
  4161. nicknames = nil;
  4162. while (uses != nil)
  4163. { w = uses;
  4164. uses = qcdr(w);
  4165. qcdr(w) = nicknames;
  4166. nicknames = w;
  4167. }
  4168. popv(1);
  4169. packnick_(name) = nicknames;
  4170. uses = stack[0];
  4171. stack[0] = name;
  4172. Luse_package(nil, uses, name);
  4173. errexitn(1);
  4174. pop(name);
  4175. return onevalue(name);
  4176. }
  4177. static Lisp_Object Lmake_package_2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
  4178. {
  4179. return Lmake_package(nil, 2, a, b);
  4180. }
  4181. static Lisp_Object Lmake_package_1(Lisp_Object nil, Lisp_Object a)
  4182. {
  4183. return Lmake_package(nil, 1, a);
  4184. }
  4185. static Lisp_Object MS_CDECL Llist_all_packages(Lisp_Object nil, int nargs, ...)
  4186. {
  4187. CSL_IGNORE(nargs);
  4188. CSL_IGNORE(nil);
  4189. return onevalue(all_packages);
  4190. }
  4191. #endif
  4192. Lisp_Object MS_CDECL Ltyi(Lisp_Object nil, int nargs, ...)
  4193. {
  4194. int ch;
  4195. argcheck(nargs, 0, "tyi");
  4196. if (curchar == NOT_CHAR)
  4197. { Lisp_Object stream = qvalue(standard_input);
  4198. if (!is_stream(stream)) stream = qvalue(terminal_io);
  4199. if (!is_stream(stream)) stream = lisp_terminal_io;
  4200. ch = getc_stream(stream);
  4201. errexit();
  4202. }
  4203. else
  4204. { ch = curchar;
  4205. curchar = NOT_CHAR;
  4206. }
  4207. if (ch == EOF || ch == CTRL_D) return onevalue(CHAR_EOF);
  4208. #ifdef Kanji
  4209. return onevalue(pack_char(0, 0, ch & 0xffff));
  4210. #else
  4211. return onevalue(pack_char(0, 0, ch & 0xff));
  4212. #endif
  4213. }
  4214. Lisp_Object Lreadbyte(Lisp_Object nil, Lisp_Object stream)
  4215. {
  4216. int ch;
  4217. if (!is_stream(stream)) aerror0("readb requires an appropriate stream");
  4218. ch = getc_stream(stream);
  4219. errexit();
  4220. /*
  4221. * At one stage this code treated ^D as an end-of file marker - that is
  4222. * most nasty for binary files! The code should now be more transparent.
  4223. */
  4224. if (ch == EOF) return onevalue(CHAR_EOF);
  4225. else return fixnum_of_int(ch & 0xff);
  4226. }
  4227. Lisp_Object Lreadch1(Lisp_Object nil, Lisp_Object stream)
  4228. {
  4229. Lisp_Object w;
  4230. int ch;
  4231. if (!is_stream(stream)) stream = qvalue(terminal_io);
  4232. if (!is_stream(stream)) stream = lisp_terminal_io;
  4233. ch = getc_stream(stream);
  4234. errexit();
  4235. if (ch == EOF || ch == CTRL_D) w = CHAR_EOF;
  4236. else
  4237. {
  4238. if (qvalue(lower_symbol) != nil) ch = TOlower(ch);
  4239. else if (qvalue(raise_symbol) != nil) ch = TOupper(ch);
  4240. #ifdef Kanji
  4241. if (qvalue(hankaku_symbol) != nil)
  4242. is (iszenkaku(curchar)) curchar = tohankaku(curchar);
  4243. if (iswchar(ch))
  4244. { boffo_char(0) = ch >> 8;
  4245. boffo_char(1) = ch;
  4246. w = iintern(boffo, 2, lisp_package, 1);
  4247. errexit();
  4248. }
  4249. else
  4250. { w = elt(charvec, ch & 0xff);
  4251. if (w == nil)
  4252. { boffo_char(0) = ch;
  4253. /* NB I always want to intern in the LISP package here */
  4254. w = iintern(boffo, 1, lisp_package, 0);
  4255. errexit();
  4256. elt(charvec, ch & 0xff) = w;
  4257. }
  4258. }
  4259. #else
  4260. w = elt(charvec, ch & 0xff);
  4261. if (w == nil)
  4262. { boffo_char(0) = (char)ch;
  4263. /* NB I always want to intern in the LISP package here */
  4264. w = iintern(boffo, 1, lisp_package, 0);
  4265. errexit();
  4266. elt(charvec, ch & 0xff) = w;
  4267. }
  4268. #endif
  4269. }
  4270. return onevalue(w);
  4271. }
  4272. Lisp_Object MS_CDECL Lreadch(Lisp_Object nil, int nargs, ...)
  4273. {
  4274. argcheck(nargs, 0, "readch");
  4275. return Lreadch1(nil, qvalue(standard_input));
  4276. }
  4277. Lisp_Object Lpeekch2(Lisp_Object nil, Lisp_Object type, Lisp_Object stream)
  4278. {
  4279. Lisp_Object w;
  4280. int ch;
  4281. if (!is_stream(stream)) stream = qvalue(terminal_io);
  4282. if (!is_stream(stream)) stream = lisp_terminal_io;
  4283. if (type != nil)
  4284. { do
  4285. { ch = getc_stream(stream);
  4286. errexit();
  4287. } while (ISspace(ch));
  4288. }
  4289. else
  4290. { ch = getc_stream(stream);
  4291. errexit();
  4292. }
  4293. other_read_action(ch, stream);
  4294. errexit();
  4295. if (ch == EOF || ch == CTRL_D) w = CHAR_EOF;
  4296. else
  4297. { if (qvalue(lower_symbol) != nil) ch = TOlower(ch);
  4298. else if (qvalue(raise_symbol) != nil) ch = TOupper(ch);
  4299. #ifdef Kanji
  4300. if (qvalue(hankaku_symbol) != nil)
  4301. is (iszenkaku(curchar)) curchar = tohankaku(curchar);
  4302. if (iswchar(curchar))
  4303. { boffo_char(0) = curchar >> 8;
  4304. boffo_char(1) = curchar;
  4305. w = iintern(boffo, 2, lisp_package, 0);
  4306. errexit();
  4307. }
  4308. else
  4309. { w = elt(charvec, ch & 0xff);
  4310. if (w == nil)
  4311. { boffo_char(0) = ch;
  4312. /* NB I always want to intern in the LISP package here */
  4313. w = iintern(boffo, 1, lisp_package, 0);
  4314. errexit();
  4315. elt(charvec, ch & 0xff) = w;
  4316. }
  4317. }
  4318. #else
  4319. w = elt(charvec, ch & 0xff);
  4320. if (w == nil)
  4321. { boffo_char(0) = (char)ch;
  4322. /* NB I always want to intern in the LISP package here */
  4323. w = iintern(boffo, 1, lisp_package, 0);
  4324. errexit();
  4325. elt(charvec, ch & 0xff) = w;
  4326. }
  4327. #endif
  4328. }
  4329. return onevalue(w);
  4330. }
  4331. Lisp_Object Lpeekch1(Lisp_Object nil, Lisp_Object type)
  4332. {
  4333. return Lpeekch2(nil, type, qvalue(standard_input));
  4334. }
  4335. Lisp_Object MS_CDECL Lpeekch(Lisp_Object nil, int nargs, ...)
  4336. {
  4337. argcheck(nargs, 0, "peekch");
  4338. return Lpeekch2(nil, nil, qvalue(standard_input));
  4339. }
  4340. Lisp_Object Lunreadch2(Lisp_Object nil, Lisp_Object a, Lisp_Object stream)
  4341. {
  4342. int ch;
  4343. CSL_IGNORE(nil);
  4344. if (!is_stream(stream)) stream = qvalue(terminal_io);
  4345. if (!is_stream(stream)) stream = lisp_terminal_io;
  4346. if (a == CHAR_EOF) ch = EOF;
  4347. else
  4348. { if (is_symbol(a)) a = pack_char(0, 0, first_char(a));
  4349. ch = (char)code_of_char(a);
  4350. }
  4351. other_read_action(ch, stream);
  4352. return onevalue(a);
  4353. }
  4354. Lisp_Object Lunreadch(Lisp_Object nil, Lisp_Object a)
  4355. {
  4356. return Lunreadch2(nil, a, qvalue(standard_input));
  4357. }
  4358. Lisp_Object Lreadline1(Lisp_Object nil, Lisp_Object stream)
  4359. {
  4360. Lisp_Object w;
  4361. int ch, n = 0;
  4362. char *s;
  4363. if (!is_stream(stream)) stream = qvalue(terminal_io);
  4364. if (!is_stream(stream)) stream = lisp_terminal_io;
  4365. boffop = 0;
  4366. while ((ch = getc_stream(stream)) != EOF && ch != '\n')
  4367. { errexit();
  4368. if (ch != '\r') packbyte(ch);
  4369. n++;
  4370. }
  4371. errexit();
  4372. if (ch == EOF && n == 0) w = CHAR_EOF;
  4373. else
  4374. { w = getvector(TAG_VECTOR, TYPE_STRING, CELL+n);
  4375. errexit();
  4376. s = (char *)w + CELL - TAG_VECTOR;
  4377. memcpy(s, &boffo_char(0), n);
  4378. while ((n&7) != 0) s[n++] = 0;
  4379. }
  4380. #ifdef COMMON
  4381. mv_2 = Lispify_predicate(ch == EOF);
  4382. #endif
  4383. return nvalues(w, 2);
  4384. }
  4385. Lisp_Object MS_CDECL Lreadline(Lisp_Object nil, int nargs, ...)
  4386. {
  4387. argcheck(nargs, 0, "readline");
  4388. return Lreadline1(nil, qvalue(standard_input));
  4389. }
  4390. setup_type const read_setup[] =
  4391. {
  4392. {"batchp", wrong_no_na, wrong_no_nb, Lbatchp},
  4393. {"rseek", Lrseek, Lrseek_2, wrong_no_1},
  4394. #ifdef COMMON
  4395. {"rseekend", Lrseekend, too_many_1, wrong_no_1},
  4396. #endif
  4397. {"rtell", Lrtell_1, wrong_no_nb, Lrtell},
  4398. {"gensym1", Lgensym1, too_many_1, wrong_no_1},
  4399. {"gensym2", Lgensym2, too_many_1, wrong_no_1},
  4400. {"gensymp", Lgensymp, too_many_1, wrong_no_1},
  4401. {"getenv", Lgetenv, too_many_1, wrong_no_1},
  4402. {"orderp", too_few_2, Lorderp, wrong_no_2},
  4403. {"rdf", Lrdf1, Lrdf2, Lrdfn},
  4404. {"rds", Lrds, too_many_1, wrong_no_1},
  4405. {"peekch", Lpeekch1, Lpeekch2, Lpeekch},
  4406. {"readch", Lreadch1, wrong_no_nb, Lreadch},
  4407. {"readb", Lreadbyte, too_many_1, wrong_no_1},
  4408. {"unreadch", Lunreadch, Lunreadch2, wrong_no_1},
  4409. {"readline", Lreadline1, wrong_no_nb, Lreadline},
  4410. {"setpchar", Lsetpchar, too_many_1, wrong_no_1},
  4411. {"spool", Lspool, too_many_1, Lspool0},
  4412. {"system", Lsystem, too_many_1, wrong_no_1},
  4413. {"~tyi", wrong_no_na, wrong_no_nb, Ltyi},
  4414. {"list-to-string", Llist_to_string, too_many_1, wrong_no_1},
  4415. {"list-to-symbol", Llist_to_symbol, too_many_1, wrong_no_1},
  4416. {"where-was-that", wrong_no_na, wrong_no_nb, Lwhere_was_that},
  4417. #ifdef COMMON
  4418. {"compress1", Lcompress, too_many_1, wrong_no_1},
  4419. {"dribble", Lspool, too_many_1, Lspool0},
  4420. {"read", Lread_1, wrong_no_nb, Lread},
  4421. {"intern", Lintern, Lintern_2, wrong_no_1},
  4422. {"gensym", Lgensym1, wrong_no_nb, Lgensym},
  4423. {"extern", Lextern_1, Lextern, wrong_no_1},
  4424. {"import*", Limport_1, Limport, wrong_no_1},
  4425. {"find-symbol", Lfind_symbol_1, Lfind_symbol, wrong_no_1},
  4426. {"keywordp", Lkeywordp, too_many_1, wrong_no_1},
  4427. {"find-package", Lfind_package, too_many_1, wrong_no_1},
  4428. {"make-package", Lmake_package_1, Lmake_package_2, Lmake_package},
  4429. {"use-package*", too_few_2, Luse_package, wrong_no_2},
  4430. {"list-all-packages", wrong_no_na, wrong_no_nb, Llist_all_packages},
  4431. {"make-symbol", Lmake_symbol, too_many_1, wrong_no_1},
  4432. {"unintern", Lunintern, Lunintern_2, wrong_no_1},
  4433. #else
  4434. {"compress", Lcompress, too_many_1, wrong_no_1},
  4435. {"read", wrong_no_na, wrong_no_nb, Lread},
  4436. {"intern", Lintern, too_many_1, wrong_no_1},
  4437. {"gensym", Lgensym1, wrong_no_nb, Lgensym},
  4438. {"ordp", too_few_2, Lorderp, wrong_no_2},
  4439. {"remob", Lunintern, too_many_1, wrong_no_1},
  4440. #endif
  4441. {NULL, 0, 0, 0}
  4442. };
  4443. /* end of read.c */