123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751 |
- % This is a collection of commonly useful Lisp
- % functions that can be defined in terms of the
- % things that are built into vsl.
- % The vsl system supports big-number arithmetic via Lisp
- % code in this file. It can not even read in numbers properly
- % until arithmetic is working. So the next two definitions
- % instate temporary versions of "plus2" and "times2" that will
- % make it possible to read this file.
- (de plus2 (u v) (iplus u v))
- (de times2 (u v) (itimes u v))
- (de minus (u) (iminus u))
- % There are a number of pre-defined symbols that stand for
- % characters and the like. Define them here.
- (setq blank '! )
- (setq tab (code!-char 9))
- (setq !$eol!$ (code!-char 10))
- (setq dollar '!$)
- (setq lpar '!()
- (setq rpar '!))
- (setq f nil)
- % The following names are used with "#\name" to get the character code of
- % various special characters.
- (put 'null 'charvalue 0)
- (put 'bell 'charvalue 7)
- (put 'backspace 'charvalue 8)
- (put 'tab 'charvalue 9)
- (put 'lf 'charvalue 10)
- (put 'eol 'charvalue 10)
- (put 'ff 'charvalue 12)
- (put 'cr 'charvalue 13)
- (put 'eof 'charvalue -1)
- (put 'escape 'charvalue 27)
- (put 'space 'charvalue 32)
- (put 'rubout 'charvalue 8)
- (put 'rub 'charvalue 8)
- (put 'delete 'charvalue 127)
- (put 'del 'charvalue 127)
- % Many combinations of car and cdr are supported. Here I define
- % versions that do up to four accesses. These would of course be
- % trivial to move into C code!
- (de caar (x)
- (car (car x)))
- (de cadr (x)
- (car (cdr x)))
- (de cdar (x)
- (cdr (car x)))
- (de cddr (x)
- (cdr (cdr x)))
- (de caaar (x)
- (car (car (car x))))
- (de caadr (x)
- (car (car (cdr x))))
- (de cadar (x)
- (car (cdr (car x))))
- (de caddr (x)
- (car (cdr (cdr x))))
- (de cdaar (x)
- (cdr (car (car x))))
- (de cdadr (x)
- (cdr (car (cdr x))))
- (de cddar (x)
- (cdr (cdr (car x))))
- (de cdddr (x)
- (cdr (cdr (cdr x))))
- (de caaaar (x)
- (car (car (car (car x)))))
- (de caaadr (x)
- (car (car (car (cdr x)))))
- (de caadar (x)
- (car (car (cdr (car x)))))
- (de caaddr (x)
- (car (car (cdr (cdr x)))))
- (de cadaar (x)
- (car (cdr (car (car x)))))
- (de cadadr (x)
- (car (cdr (car (cdr x)))))
- (de caddar (x)
- (car (cdr (cdr (car x)))))
- (de cadddr (x)
- (car (cdr (cdr (cdr x)))))
- (de cdaaar (x)
- (cdr (car (car (car x)))))
- (de cdaadr (x)
- (cdr (car (car (cdr x)))))
- (de cdadar (x)
- (cdr (car (cdr (car x)))))
- (de cdaddr (x)
- (cdr (car (cdr (cdr x)))))
- (de cddaar (x)
- (cdr (cdr (car (car x)))))
- (de cddadr (x)
- (cdr (cdr (car (cdr x)))))
- (de cdddar (x)
- (cdr (cdr (cdr (car x)))))
- (de cddddr (x)
- (cdr (cdr (cdr (cdr x)))))
- % "not" and "eqcar" are used while processing some parts of
- % this file and so get defined early.
- (de not (x)
- (null x))
- (de eqcar (a b) % Is (car a) the same as b?
- (and (not (atom a)) (eq (car a) b)))
- % The vsl kernel checks for a function called macroexpand_list
- % whenever it is about to define a function, and expects it to
- % expand macros in all the expressions in a list. So before
- % I define any macros that could usefully be expanded I will
- % define it!
- (de macroexpand_cond (l)
- (cond
- ((null l) nil)
- (t (cons (macroexpand_list (car l))
- (macroexpand_cond (cdr l))))))
- (de macroexpand (x)
- (cond
- ((atom x) x)
- ((not (atom (car x)))
- (cons (macroexpand (car x))
- (macroexpand_list (cdr x))))
- ((eqcar x 'quote) x)
- ((eqcar x 'cond)
- (cons 'cond (macroexpand_cond (cdr x))))
- ((or (eqcar x 'prog) (eqcar x 'lambda))
- (cons (car x) (cons (cadr x)
- (macroexpand_list (cddr x)))))
- ((eqcar (getd (car x)) 'macro)
- (macroexpand (apply (cdr (getd (car x)))
- (list x))))
- (t (cons (car x) (macroexpand_list (cdr x))))))
- (de macroexpand_list (l)
- (cond
- ((atom l) l)
- (t (cons (macroexpand (car l))
- (macroexpand_list (cdr l))))))
- % Now I start on defining the proper arithmetic including
- % in particular support for big integers. The function
- % "expand" is used to map (plus a b c d) onto
- % (plus2 a (plus2 b (plus2 c d))) [and similarly for other
- % arithmetic functions that take arbitrary numbers of arguments].
- (de expand (l fn)
- (cond
- ((null (cdr l)) (car l))
- (t (list fn (car l) (expand (cdr l) fn)))))
- (dm plus (u) (expand (cdr u) 'plus2))
- (dm times (u) (expand (cdr u) 'times2))
- (dm logand (u) (expand (cdr u) 'logand2))
- (dm logor (u) (expand (cdr u) 'logor2))
- (dm logxor (u) (expand (cdr u) 'logxor2))
- (dm max (u) (expand (cdr u) 'max2))
- (dm min (u) (expand (cdr u) 'min2))
- % The function "iplus2" behaved like "iplus" but accepts
- % exactly two arguments. And similarly for several others.
- (de iplus2 (u v) (iplus u v))
- (de itimes2 (u v) (itimes u v))
- (de ilogand2 (u v) (ilogand u v))
- (de ilogor2 (u v) (ilogor u v))
- (de ilogxor2 (u v) (ilogxor u v))
- % Back to defining what are sometimes merely alternate
- % names for very basic operations.
- (de idp (x)
- (symbolp x))
- (de pairp (x)
- (null (atom x)))
- (de prog1 (a b)
- a)
- (de prog2 (a b)
- b)
- (de reverse (x)
- (prog (y)
- loop
- (cond ((atom x) (return y)))
- (setq y (cons (car x) y))
- (setq x (cdr x))
- (go loop)))
- % "reverse" reverses a list, while "reversip" creates the
- % reversed version by overwriting the data that makes up its
- % input. This may be held to save a little space, but is
- % to be used with care.
- (de reversip2 (a b)
- (prog (w)
- loop
- (cond ((atom a) (return b)))
- (setq w (cdr a))
- (rplacd a b)
- (setq b a)
- (setq a w)
- (go loop)))
- (de reversip (x) (reversip2 x nil)) % Destructive reverse
- (de append (a b) % Append a pair of lists.
- (cond
- ((atom a) b)
- (t (cons (car a) (append (cdr a) b)))))
- % I have written various of these in ugly imperative styles so that they
- % end up iterative not recursive...
- (de length (l) % Find length of a list.
- (prog (n)
- (setq n 0)
- top(cond ((atom l) (return n)))
- (setq n (add1 n))
- (setq l (cdr l))
- (go top)))
- (de last (l) % Last element of a (non-empty) list.
- (cond
- ((atom l) (error 1 "last on emtpy list"))
- ((atom (cdr l)) (car l))
- (t (last (cdr l)))))
- (de lastcar (x) % Not in Standard Lisp
- (cond
- ((atom x) nil)
- ((atom (cdr x)) (car x))
- (t (lastcar (cdr x)))))
- (de lastpair (l) % Last pair of a (non-empty) list,
- (cond % or nil if the input is empty.
- ((atom l) nil)
- ((atom (cdr l)) l)
- (t (lastpair (cdr l)))))
- % #else /* XXX */
- % (prog ()
- % (cond
- % ((null l) (error 1 "last on emtpy list")))
- % top(cond
- % ((atom (cdr l)) (return l)))
- % (setq l (cdr l))
- % (go top)))
- %
- % (de lastcar (l) % Not in Standard Lisp
- % (prog ()
- % (cond
- % ((null l) (error 1 "lastcar on emtpy list")))
- % top(cond
- % ((atom (cdr l)) (return (car l))))
- % (setq l (cdr l))
- % (go top)))
- %
- % (de lastpair (l) % Last pair of a (non-empty) list.
- % (prog ()
- % (cond
- % ((null l) (error 1 "lastpair on emtpy list")))
- % top(cond
- % ((atom (cdr l)) (return l)))
- % (setq l (cdr l))
- % (go top)))
- % #endif /* XXX */
- (de member (a l)
- (cond
- ((atom l) nil)
- ((equal a (car l)) l)
- (t (member a (cdr l)))))
- % "member" checks it a value is present in a list using the
- % "equal" test, while "memq" uses "eq".
- % #else /* XXX */
- % (prog ()
- % top
- % (cond
- % ((null l) (return nil))
- % ((equal a (car l)) (return l)))
- % (setq l (cdr l))
- % (go top)))
- % #endif /* XXX */
- (de memq (a l)
- (cond
- ((atom l) nil)
- ((eq a (car l)) l)
- (t (memq a (cdr l)))))
- % #else /* XXX */
- % (prog ()
- % top
- % (cond
- % ((null l) (return nil))
- % ((eq a (car l)) (return l)))
- % (setq l (cdr l))
- % (go top)))
- % #endif /* XXX */
- (de delete (a l)
- (cond
- ((atom l) l)
- ((equal a (car l)) (cdr l))
- (t (cons (car l) (delete a (cdr l))))))
- (de intersection (a b)
- (cond
- ((atom a) nil)
- ((member (car a) b) (cons (car a) (intersection (cdr a) b)))
- (t (intersection (cdr a) b))))
- (de union (a b)
- (cond
- ((atom a) b)
- ((member (car a) b) (union (cdr a) b))
- (t (cons (car a) (union (cdr a) b)))))
- (de neq (a b) % Not equal.
- (null (equal a b)))
- (de assoc (a l) % Look item up in association list using equal.
- (cond
- ((atom l) nil)
- ((and (not (atom (car l)))
- (equal (caar l) a)) (car l))
- (t (assoc a (cdr l)))))
- (de atsoc (a l) % Look item up in association list using eq.
- (cond
- ((atom l) nil)
- ((and (not (atom (car l)))
- (eq (caar l) a)) (car l))
- (t (atsoc a (cdr l)))))
- (de subst (a b c) % Substitute a for b in c
- (cond
- ((equal b c) a)
- ((atom c) c)
- (t (cons (subst a b (car c)) (subst a b (cdr c))))))
- (de sublis (x y)
- (if (atom x) y
- (prog (u)
- (setq u (assoc y x))
- (return (cond
- ((not (atom u)) (cdr u))
- ((atom y) y)
- (t (cons (sublis x (car y))
- (sublis x (cdr y)))))))))
- (de subla (x y)
- (if (atom x) y
- (prog (u)
- (setq u (atsoc y x))
- (return (cond
- ((not (atom u)) (cdr u))
- ((atom y) y)
- (t (cons (subla x (car y))
- (subla x (cdr y)))))))))
- (de pair (u v)
- (cond
- ((or (atom u) (atom v)) nil)
- (t (cons (cons (car u) (car v)) (pair (cdr u) (cdr v))))))
- (de spaces (n) % Print n blanks.
- (cond
- ((zerop n) nil)
- (t (princ " ") (spaces (sub1 n)))))
- % The prettyprint code here is a version of the code described
- % as an example of the use of vsl.
- (de prettyprint (x) % Display something with indentation.
- (terpri)
- (pprint x 0)
- (terpri)
- nil)
- (de pprint (x n) % Sub-function for prettyprint.
- (cond
- ((or (atom x)
- (lessp (length (explode x)) 40)) (prin x))
- (t (princ "(")
- (pprint (car x) (add1 n))
- (pprintail (cdr x) (plus n 3)))))
- (de pprintail (x n) % Sub-function for prettyprint.
- (cond
- ((null x) (princ ")"))
- ((atom x) (princ " . ")
- (prin x)
- (princ ")"))
- (t (terpri)
- (spaces n)
- (pprint (car x) n)
- (pprintail (cdr x) n))))
- (de rplacw (a b) (progn (rplaca a (car b)) (rplacd a (cdr b))))
- % The "map" functions apply some function to each item defined by
- % a list.
- % mapc and map return nil
- % mapcar and maplist build a list out of the computed values
- % mapcan and mapcon expect the values to be lists, and use "nconc"
- % to join them.
- % map, maplist and mapcon pass a pointer into the list itself
- % as argument to the function, while mapc, mapcar and mapcon pass
- % items from the list.
- % Note that some other Lisp systems have functions like this that take
- % the function as their first argument and the list as second, unlike the
- % argument order used here.
- % The use of awkward variables names such as "!~l" here is because under
- % the dynamic scoping regime in vsl if the function passed relied on a
- % free variable whose name clashed with a name used locally in these
- % definitions there could be confusion.
- (de mapcar (!~l !~fn)
- (prog (!~r)
- top (cond ((atom !~l) (return (reversip !~r))))
- (setq !~r (cons (apply !~fn (list (car !~l))) !~r))
- (setq !~l (cdr !~l))
- (go top)))
- (de maplist (!~l !~fn)
- (prog (!~r)
- top (cond ((atom !~l) (return (reversip !~r))))
- (setq !~r (cons (apply !~fn (list !~l)) !~r))
- (setq !~l (cdr !~l))
- (go top)))
- (de mapcan (!~l !~fn)
- (cond ((atom !~l) nil)
- (t (nconc (apply !~fn (list (car !~l))) (mapcan (cdr !~l) !~fn)))))
- (de mapcon (!~l !~fn)
- (cond ((atom !~l) nil)
- (t (nconc (apply !~fn (list !~l)) (mapcon (cdr !~l) !~fn)))))
- (de mapc (!~l !~fn)
- (prog ()
- top (cond ((atom !~l) (return nil)))
- (apply !~fn (list (car !~l)))
- (setq !~l (cdr !~l))
- (go top)))
- (de map (!~l !~fn)
- (prog ()
- top (cond ((atom !~l) (return nil)))
- (apply !~fn (list !~l))
- (setq !~l (cdr !~l))
- (go top)))
- (de copy (a)
- (cond
- ((atom a) a)
- (t (cons (copy (car a)) (copy (cdr a))))))
- (de sassoc (a l fn)
- (cond
- ((atom l) (apply fn nil))
- ((equal a (caar l)) (car l))
- (t (sassoc a (cdr l) fn))))
- (de rassoc (x l) % Not in Standard Lisp
- (prog ()
- loop (cond ((atom l) (return nil))
- ((equal x (cdar l)) (return (car l)))
- (t (setq l (cdr l)) (go loop))) ))
- (de deflist (a b)
- (prog (r)
- top (cond ((atom a) (return (reversip r))))
- (put (caar a) b (cadar a))
- (setq r (cons (caar a) r))
- (setq a (cdr a))
- (go top)))
- % The Lisp "backquote" capability is coped with in vsl by having
- % `(a b c) read in as (!` (a b c)) [and similarly for "," and ",@"]
- % and then using macro-expansion to convert into executable code.
- (de expand_backquote (x)
- (cond
- ((and (symbolp x) (null (null x))) (list 'quote x))
- ((atom x) x) % nil, number or string
- ((eq (car x) '!,) (cadr x))
- ((eq (car x) '!`) (expand_backquote (expand_backquote (cadr x))))
- ((eqcar (car x) '!,!@)
- (list 'append (cadar x) (expand_backquote (cdr x))))
- ((eqcar (car x) '!,!.)
- (list 'nconc (cadar x) (expand_backquote (cdr x))))
- (t (list 'cons (expand_backquote (car x)) (expand_backquote (cdr x))))))
- (dm !` (x) (expand_backquote (cadr x)))
- % Now a few things not needed by Standard Lisp but maybe helpful
- % when using Lisp directly.
- % Reduce uses the name "let" and so if I called this what I naturally
- % want to there would be a clash and trouble. So I use a mangled name here.
- % I also use let!* rather than let in those cases here where I can...
- % Both "let" and "let!*" expand naturally into uses of lambda-expressions.
- (de let_name (x)
- (if (atom x) x (car x)))
- (de let_val (x)
- (if (or (atom x) (atom (cdr x)))
- nil
- (cadr x)))
- (dm !~let (x) % (!~let ((v1 E1) (v2 E2) ...) body)
- (cons (cons 'lambda (cons (mapcar (cadr x) 'let_name) (cddr x)))
- (mapcar (cadr x) 'let_val)))
- (de expand_let!* (b x)
- (cond
- ((null b) x)
- (t (list (list 'lambda (list (let_name (car b))) (expand_let!* (cdr b) x))
- (let_val (car b))))))
- (dm let!* (x) % As !~let, but do bindings sequentially
- (expand_let!* (cadr x) (cons 'progn (cddr x))))
- % A set of macros provide various neat and easy-to-use control structures.
- % Note that tis version of IF allows a sequence of forms in the place
- % that gets processed if the predicate evaluates to nil.
- (dm if (x) % (IF predicate yes no*) or (IF predicate yes)
- `(cond
- (,(cadr x) ,(caddr x))
- (t ,@(cdddr x))))
- (dm when (x) % (WHEN predicate yes yes yes ...)
- `(cond
- (,(cadr x) ,@(cddr x))))
- (dm unless (x) % (UNLESS predicate no no no ...)
- `(cond
- ((null ,(cadr x)) ,@(cddr x))))
- (dm while (x) % (WHILE predicate body body body ...)
- (let!* ((g (gensym)))
- `(prog nil
- ,g (cond ((null ,(cadr x)) (return nil)))
- ,@(cddr x)
- (go ,g)))))
- % (psetq a A b B) must arrange to evaluate both A and B before
- % either is saved in a or b. This can be expressed in terms of
- % use of "let" - but the expansion process is a little messy to
- % establish.
- (de make_psetq_vars (u)
- (if (null u)
- nil
- (if (null (cdr u))
- (error "odd number of items in psetq")
- (cons (gensym) (make_psetq_vars (cddr u))))))
- (de make_psetq_bindings (vars u)
- (if (null u)
- nil
- (cons
- (list (car vars) (cadr u))
- (make_psetq_bindings (cdr vars) (cddr u)))))
- (de make_psetq_assignments (vars u)
- (if (null u)
- nil
- (cons
- (list 'setq (car u) (car vars))
- (make_psetq_assignments (cdr vars) (cddr u)))))
- (dm psetq (x) % parallel setq as in (psetq x X y Y z Z)
- (let!* ((vars (make_psetq_vars (cdr x))))
- `(let!* ,(make_psetq_bindings vars (cdr x))
- ,@(make_psetq_assignments vars (cdr x)))))
- % The "do" macro provides a rather general iteration capabilty
- % of the form
- % (do ((var init step) ..)
- % (endcondition result ...)
- % body)
- % and again can be expressed via macro-expansion into simpler or
- % more basic constructions.
- (de do_bindings (u)
- (if (null u)
- nil
- (if (atom (car u))
- (cons (car u) (do_bindings (cdr u)))
- (if (null (cdar u))
- (cons (list (caar u) nil) (do_bindings (cdr u)))
- (cons (list (caar u) (cadar u)) (do_bindings (cdr u)))))))
- (de do_endtest (u)
- (if (null u)
- nil
- (car u)))
- (de do_result (u)
- (if (null u)
- nil
- (cdr u)))
- (de do_updates (u)
- (if (null u)
- nil
- (let!* ((v (car u))
- (x (do_updates (cdr u))))
- (if (or (atom v)
- (null (cdr v))
- (null (cddr v)))
- x
- (cons (car v) (cons (caddr v) x))))))
- (de expand_do (u letter setter)
- (let!* ((bindings (do_bindings (car u)))
- (result (do_result (cadr u)))
- (updates (do_updates (car u)))
- (body (cddr u))
- (endtest (do_endtest (cadr u)))
- (upd (if updates (list (cons setter updates)) nil))
- (res (if (null result)
- nil
- (if (null (cdr result))
- (car result)
- (cons 'progn result))))
- (x (if (null endtest) nil
- `((when ,endtest (return ,res)))))
- (g (gensym)))
- (if bindings
- `(,letter ,bindings
- (prog nil
- ,g ,@x
- ,@body
- ,@upd
- (go ,g)))
- `(prog nil
- ,g ,@x
- ,@body
- ,@upd
- (go ,g)))))
- (dm do (u) (expand_do (cdr u) '!~let 'psetq))
- (dm do!* (u) (expand_do (cdr u) 'let!* 'setq))
- % "dolist" is much simpler, and is used as in
- % (dolist (a '(1 2 3)) (print a))
- (de expand_dolist (vir b)
- (prog (l v var init res)
- (setq var (car vir))
- (setq init (car (setq vir (cdr vir))))
- (setq res (cdr vir))
- (setq v (gensym))
- (setq l (gensym))
- (return `(prog (,v ,var)
- (setq ,v ,init)
- ,l (cond ((null ,v) (return (progn ,@res))))
- (setq ,var (car ,v))
- ,@b
- (setq ,v (cdr ,v))
- (go ,l)))))
- (dm dolist (u) (expand_dolist (cadr u) (cddr u)))
- % "dotimes" arranges to perform some actions a fixed number of times,
- % counting (starting from 0) in a variable that the user can name.
- % (dotimes (i 10) (prin i) (princ blank) (print (times i i)))
- (de expand_dotimes (vnr b)
- (prog (l v var count res)
- (setq var (car vnr))
- (setq count (car (setq vnr (cdr vnr))))
- (setq res (cdr vnr))
- (setq v (gensym))
- (setq l (gensym))
- (return `(prog (,v ,var)
- (setq ,v ,count)
- (setq ,var 0)
- ,l (cond ((geq ,var ,v) (return (progn ,@res))))
- ,@b
- (setq ,var (add1 ,var))
- (go ,l)))))
- (dm dotimes (u) (expand_dotimes (cadr u) (cddr u)))
- (de nconc (u v)
- (if (atom u) v
- (let!* ((w u))
- (while (not (atom (cdr u))) (setq u (cdr u)))
- (rplacd u v)
- w)))
- % Now the main body of the arithmetic code. the vsl kernel provides
- % functions with names like iplus, itimes, igreaterp, ... that
- % work with either floating point values or with integers up to 64-bits.
- % Building on that this code allows a list of the form
- % (!~bignum d0 d1 d2 ...)
- % to stand for a number expressed with radix 2^30 and with d0 as its
- % least significant digit. A very small number of hooks within vsl
- % allow reading and printing of general numbers to divert into the
- % code written here.
- % Implementing arithmetic in (interpreted) Lisp like this will be
- % seriously inefficient, so there would be big gains from re-working
- % the C code to make this stuff irrelevant!
- (setq !~radix (itimes 1024 1024 1024))
- (setq !~fpradix (ifloat !~radix))
- % The numeric data type must now include these cases.
- % The "atom" test in vsl needs to know that a bit of
- % data stored as (!~bignum ...) should viewed as atomic.
- (de fixp (u) (and (numberp u) (not (floatp u))))
- (de numberp (u) (or (inumberp u) (bignump u)))
- (de integerp (u) (and (numberp u) (not (floatp u))))
- % There are two representations of numbers. The one used in the
- % main parts of the code are
- % integer < 2^30
- % float
- % (!~bignum list of digits ...)
- %
- % but within the code that implements big arithemetic I want
- % to keep things JUST as lists of digits with the "~bignum"
- % marker omitted. I need functions that map between these two
- % formats are here they are.
- (de !~embiggen (n)
- (cond
- ((zerop n) nil)
- ((ifixp n) (list n))
- ((bignump n) (cdr n))
- (t (error "number expected but received" n))))
- (de !~sizecheck (l)
- (cond
- ((null l) 0)
- ((null (cdr l)) (car l))
- (t (cons '!~bignum l))))
- % Various two-argument functions will be able to use built-in
- % vsl functions on floating point input but need to do more
- % if they have a potentially big integer. The dispatch between
- % these cases can be encapsulated within a macro...
- (dm !~bignum_dispatch2 (u)
- `(cond
- ((or (floatp ,(cadr u)) (floatp ,(caddr u)))
- (,(car (cdddr u)) (float ,(cadr u)) (float ,(caddr u))))
- (t (!~sizecheck (,(cadr (cdddr u))
- (!~embiggen ,(cadr u)) (!~embiggen ,(caddr u)))))))
- % The version above converts its result back into a "number". But eg
- % comparison operations do not want to do that, so here is a
- % second version that does not insert calls to !~sizecheck.
- (dm !~bignum_dispatch2a (u)
- `(cond
- ((or (floatp ,(cadr u)) (floatp ,(caddr u)))
- (,(car (cdddr u)) (float ,(cadr u)) (float ,(caddr u))))
- (t (,(cadr (cdddr u))
- (!~embiggen ,(cadr u)) (!~embiggen ,(caddr u))))))
- % The Lisp reader in vsl will call plus2 and times2 when it reads
- % in integers, so I defer defining either until all their sub-functions
- % are in place.
- %(de plus2 (u v)
- % (!~bignum_dispatch2 u v iplus !~bigplus2))
- % The internal functions used here are all given names starting with
- % "~" to reduce the prospect of clashes with user-written code.
- (de !~bigplus2 (u v) (!~bigplus2carry u v 0))
- % "~xdivide" is like divide on native small numbers except that
- % it guarantees that the remainder it returns is non-negative.
- (de !~xdivide (u v)
- (let!* ((r (idivide u v)))
- (if (iminusp (cdr r))
- (cons (isub1 (car r)) (iplus (cdr r) v))
- r)))
- % "~bigcons" arranged to avoid leaving superfluous leading zeros
- % as part of big-numbers.
- (de !~bigcons (a b)
- (cond
- ((and (zerop a) (null b)) nil)
- ((equal b '(-1)) (if (onep a) nil (cons (idifference a !~radix) nil)))
- (t (cons a b))))
- (de !~carryinto (u c)
- (cond
- ((zerop c) u)
- ((null u) (!~bigcons c nil))
- (t (let!* ((x (!~xdivide (iplus (car u) c) !~radix)))
- (!~bigcons (cdr x) (!~carryinto (cdr u) (car x)))))))
- (de !~bigplus2carry (u v c)
- (cond
- ((null u) (!~carryinto v c))
- ((null v) (!~carryinto u c))
- (t (let!* ((x (!~xdivide (iplus (car u) (car v) c) !~radix)))
- (!~bigcons (cdr x) (!~bigplus2carry (cdr u) (cdr v) (car x)))))))
- %(de times2 (u v)
- % (!~bignum_dispatch2 u v itimes !~bigtimes2))
- % Multiply a big-number by a simple small integer.
- (de !~bigtimesn (n u c)
- (cond
- ((null u) (if (zerop c) nil (list c)))
- (t (let!* ((x (!~xdivide (iplus (itimes n (car u)) c) !~radix)))
- (!~bigcons (cdr x) (!~bigtimesn n (cdr u) (car x)))))))
- (de !~bigtimes2 (u v)
- (cond
- ((or (null u) (null v)) nil)
- (t (!~bigplus2carry
- (!~bigtimesn (car u) v 0)
- (!~bigcons 0 (!~bigtimes2 (cdr u) v))
- 0))))
- (de logand2 (u v)
- (!~bignum_dispatch2 u v ilogand !~biglogand2))
- (de logor2 (u v)
- (!~bignum_dispatch2 u v ilogor !~biglogor2))
- (de logxor2 (u v)
- (!~bignum_dispatch2 u v ilogxor !~biglogxor2))
- (de difference (u v)
- (!~bignum_dispatch2 u v idifference !~bigdifference))
- (de divide (u v)
- (!~bigdivide (!~embiggen u) (!~embiggen v)))
- % Now a patched version that will report inputs that cause trouble
- (de divide (u v)
- (prog (r)
- (setq r (errorset
- (list '!~bigdivide
- (mkquote (!~embiggen u))
- (mkquote (!~embiggen v))) t t))
- (when (null (atom r)) (return (car r)))
- (printc "divide failed")
- (print u)
- (print v)
- (error 99 "division messup")))
- (de geq (u v)
- (not (greaterp v u)))
- (de greaterp (u v)
- (cond
- ((floatp u) (igreaterp u (float v)))
- ((floatp v) (igreaterp (float u) v))
- ((or (bignump u) (bignump v))
- (!~biggreaterp (!~embiggen u) (!~embiggen v)))
- (t (igreaterp u v))))
- (de leftshift (u v)
- (if (iminusp v)
- (rightshift u (iminus v))
- (times u (expt 2 v))))
- (de leq (u v)
- (not (greaterp u v)))
- (de lessp (u v)
- (greaterp v u)))
- (de quotient (u v)
- (cond
- ((floatp u) (iquotient u (float v)))
- ((floatp v) (iquotient (float u) v))
- (t (car (divide u v)))))
- (de remainder (u v)
- (cdr (divide u v)))
- (de rightshift (u v)
- (if (iminusp v)
- (leftshift u (iminus v))
- (let!* ((p (expt 2 v)))
- (if (minusp u)
- (quotient (add1 (difference u p)) p)
- (quotient u p)))))
- % Negative numbers give special fun for boolean operations because
- % they have to be treated rather as if they had unlimited numbers of
- % leading 1 bits.
- % Here u will be negative but v positive. The two are about to be ANDed
- % together. This delivers a version of u that has been truncated it is
- % is longer than v or extended out with additional "-1" values if it
- % is shorter. That can be ANDed digit by digit to yield the evenual
- % result.
- (de !~bigpos (u v)
- (cond
- ((null v) u)
- ((null u) (cons -1 (!~bigpos nil (cdr v))))
- (t (cons (car u) (!~bigpos (cdr u) (cdr v))))))
- % Strategy for -ve numbers:
- % (1) Both args +ve. AND digit by digit
- % (2) Both args -v1. use ~(~u | ~v) knowing that the OR will be on +ve vals
- % (3) Mixed. adjust length of negetive value either by padding
- % with extra leading -1s or by trincating it. Then
- % treat as case (a).
- % For OR work digit by digit if both args +ve otherwise use ~(~u & ~v)
- % knowing that this will not be re-converted to use of OR.
- (de !~biglogand2 (u v)
- (if (!~bigminusp u)
- (if (!~bigminusp v)
- (!~biglognot (!~biglogor2a (!~biglognot u) (!~biglognot v)))
- (!~biglogand2a v (!~bigpos u v)))
- (if (!~bigminusp v)
- (!~biglogand2a u (!~bigpos v u))
- (!~biglogand2a u v))))
- (de !~biglogand2a (u v)
- (cond
- ((null u) nil)
- ((null v) nil)
- (t (!~bigcons (ilogand (car u) (car v))
- (!~biglogand2a (cdr u) (cdr v))))))
- (de !~biglogor2 (u v)
- (if (or (!~bigminusp u) (!~bigminusp v))
- (!~biglognot (!~biglogand2 (!~biglognot a) (!~biglognot b)))
- (!~biglogor2 u v)))
- (de !~biglogor2a (u v)
- (cond
- ((null u) v)
- ((null v) u)
- (t (!~bigcons (ilogor (car u) (car v))
- (!~biglogor2a (cdr u) (cdr v))))))
- (de !~biglogxor2 (u v)
- (prog (s)
- (when (!~bigminusp u) (setq u (!~biglognot u)) (setq s t))
- (when (!~bigminusp v) (setq v (!~biglognot v)) (setq s (null s)))
- (setq u (!~biglogxor2a u v))
- (when s (setq u (!~biglognot u)))
- (return u)))
- (de !~biglogxor2a (u v)
- (cond
- ((null u) v)
- ((null v) u)
- (t (!~bigcons (ilogxor (car u) (car v))
- (!~biglogxor2 (cdr u) (cdr v))))))
- (de !~bigdifference (u v)
- (!~bigplus2carry u (!~bigminus v) 0))
- % Division is pretty well the messiest thing to implement
- % here. The first function deals with the consequences of
- % negative values, while the second ones actually does the work.
- (de !~bigdivide (u v)
- (prog (su sv)
- (when (null u) (return (cons 0 0)))
- (when (null v) (error "attempt to divide by zero" u))
- (when (!~bigminusp u) (setq su t u (!~bigminus u)))
- (when (!~bigminusp v) (setq sv t v (!~bigminus v)))
- (if (null (cdr v))
- (progn
- (setq u (!~shortdivide 0 (reverse u) (car v)))
- (setq v (car u))
- (while (eqcar v 0) (setq v (cdr v)))
- (setq u (cons
- (reverse v)
- (if (zerop (cdr u)) nil (list (cdr u))))))
- (setq u (!~bigdivide1 u v)))
- (return (cons
- (!~sizecheck (if (eq su sv) (car u) (!~bigminus (car u))))
- (!~sizecheck (if su (!~bigminus (cdr u)) (cdr u)))))))
- (de !~shortdivide (u1 u v)
- (cond
- ((null u) (cons nil u1))
- (t (let!* ((d (idivide (iplus (itimes !~radix u1) (car u)) v))
- (d1 (!~shortdivide (cdr d) (cdr u) v)))
- (cons (cons (car d) (car d1)) (cdr d1))))))
- (de !~bigdivide1 (u v) % Positive arguments and v is at least 2 digits
- (prog (r d)
- (while (not (!~biggreaterp1 v u))
- (setq d (!~approx_quotient u v))
- (setq u (!~bigdifference u (!~bigtimes2 d v)))
- (if (!~bigminusp u)
- (error 99 (list "approx was overestimate, v=" v " d=" d " u=" u)))
- (setq r (!~bigplus2carry r d 0)))
- (return (cons r u))))
- (setq !~big (itimes 1024 1024 1024 1024 1024 512))
- (de !~approx_quotient (u v) % v has at least 2 digits and u >= v
- (prog (x xx un vn q)
- (when (null (cddr u)) % then v must also be short
- (setq un (iplus (car u) (itimes !~radix (cadr u))))
- (setq vn (iplus (car v) (itimes !~radix (cadr v))))
- (return (list (iquotient un vn))))
- (while (cddr v) (setq u (cdr u) v (cdr v)))
- (setq x 0)
- (while (cddr u) (setq u (cdr u) x (add1 x)))
- (setq un (iplus (car u) (itimes !~radix (cadr u))))
- (setq vn (iplus (car v) (itimes !~radix (cadr v))))
- (setq xx 0)
- (while (ilessp un !~big) (setq un (ileftshift un 1) xx (iadd1 xx)))
- (while (igeq vn !~radix) (setq vn (irightshift vn 1) xx (iadd1 xx)))
- (setq q (iquotient un (iadd1 vn)))
- (when (igeq xx 30) (setq x (isub1 x) xx (idifference xx 30)))
- (if (zerop xx)
- (setq un q vn 0)
- (progn
- (setq un (irightshift q xx))
- (setq vn (ileftshift (idifference q (ileftshift un xx))
- (idifference 30 xx)))))
- (setq q nil)
- (if (igreaterp x 0) (dotimes (i x) (setq q (cons 0 q))))
- (setq q (cons un (cons vn q)))
- (setq q (cdr (reverse q)))
- (if (equal x -1) (setq q (cdr q)))
- % (printc (list "result = " q (cons '!~bignum q)))
- (if (or (null q) (equal q '(0))) (setq q '(1)))
- (return q)))
- % All the arithmetic comparisons can be expressed in terms of
- % a single basic case. Here I choose to make "greaterp" the
- % one that is actually coded.
- (de !~biggreaterp (u v)
- (if (!~bigminusp u)
- (if (!~bigminusp v) (!~biggreaterp1 (!~bigminus v) (!~bigminus u)) nil)
- (if (!~bigminusp v) t (!~biggreaterp1 u v))))
- (de !~biggreaterp1 (u v)
- (cond
- ((null u) nil)
- ((null v) t)
- ((equal (cdr u) (cdr v)) (igreaterp (car u) (car v)))
- (t (!~biggreaterp1 (cdr u) (cdr v)))))
- % Now for some one-argument arithmetic functions.
- % In these cases it does not seem worth having a macro
- % to dispatch between the various cases.
- (de add1 (u)
- (plus2 u 1))
- (de ceiling (u)
- (cond
- ((floatp u) (!~bigceiling u))
- (t u)))
- (de fix (u)
- (cond
- ((floatp u) (!~bigfix u))
- (t u)))
- (de float (u)
- (cond
- ((floatp u) u)
- ((inumberp u) (ifloat u))
- ((bignump u) (!~bigfloat (cdr u)))
- (t (error "bad arg to float" u))))
- (de floor (u)
- (cond
- ((floatp u) (!~bigfloor u))
- (t u)))
- (de lognot (u)
- (cond
- ((ifixp u) (!~biglognot (list '!~bignum u)))
- ((bignump u) (!~biglognot (cdr u)))
- (t (error "bad arg to lognot" u))))
- (de minus (u)
- (cond
- ((or (ifixp u) (floatp u)) (iminus u))
- ((bignump u) (!~sizecheck (!~bigminus (cdr u))))
- (t (error "bad arg to minus" u))))
- (de minusp (u)
- (cond
- ((or (floatp u) (inumberp u)) (iminusp u))
- ((bignump u) (and (cdr u) (iminusp (last (cdr u)))))
- (t nil)))
- (de sub1 (u)
- (plus2 u -1))
- (de !~bigceiling (u)
- (if (iminusp u)
- (minus (!~bigfloor (iminus u)))
- (!~bigfixer u 1)))
- (de !~bigfloor (u)
- (if (iminusp u)
- (minus (!~bigceiling (iminus u)))
- (!~bigfixer u -1)))
- (de !~bigfix (u)
- (if (iminusp u)
- (minus (!~bigfix (iminus u)))
- (!~bigfixer u 0)))
- (de !~bigfixer (u updown)
- (cond
- ((ilessp u !~fpradix)
- (cond
- ((zerop updown) (ifix u))
- ((onep updown) (iceiling u))
- (t (ifloor u))))
- (t (prog (w) % Now u is definitely large!
- (setq w (fix (iquotient u !~fpradix)))
- (setq u (idifference u (itimes !~fpradix (float w))))
- (return (plus (times w !~radix) (!~bigfixer u updown)))))))
-
- (de !~bigfloat (u)
- (cond
- ((null u) 0.0)
- (t (iplus (ifloat (car u))
- (itimes !~fpradix (!~bigfloat (cdr u)))))))
- (de !~biglognot (u)
- (cond
- ((null u) nil)
- ((null (cdr u)) (list (ilognot (car u))))
- (t (cons (ilogxor (isub1 !~radix) (car u))
- (!~biglognot (cdr u))))))
- (de !~bigminus (u)
- (cond
- ((null u) nil)
- ((zerop (car u)) (cons (car u) (!~bigminus (cdr u))))
- ((null (cdr u)) (list (iminus (car u))))
- (t (cons (ilogand (isub1 !~radix) (iminus (car u)))
- (!~biglognot (cdr u))))))
- (de !~bigminusp (u)
- (and u (iminusp (last u))))
- % onep and zerop are built-in, and although there is no real
- % merit in anybody using a function ionep or izerop I provide
- % both here just for completeness.
- (de ionep (u) (onep u))
- (de izerop (u) (zerop u))
- % A handy macro arranges that a big-number will evaluate to itself.
- (dm !~bignum (u) (list 'quote u))
- % If vsl finds a big-number it calls this function to turn it
- % into a string that it can then print. Again this is pretty
- % inefficient! I provide a flag !*rawbig that, when set, causes
- % big numbers to be displayed in terms of their internal representation
- % as well as "properly" because that is sometimes useful while debugging.
- % !*onlyraw is even more drastic and only shows the internal form,
- % thereby avoiding division etc in this code.
- (setq !*rawbig nil !*onlyraw nil)
- (de !~big2str (n)
- (prog (r neg)
- (when (null n) (return "0"))
- % In bad cases you may try to display a list whose first element is
- % "~bignum" but which is then badly formatted.
- (setq r n)
- (while (and (not (atom r))
- (inumberp (car r))) (setq r (cdr r)))
- (when r (return nil))
- (setq r '(!"))
- (when (or !*rawbig !*onlyraw)
- (setq r (cons '!] r))
- (dolist (c (reverse (explode n)))
- (setq r (cons c r)))
- (setq r (cons '!: (cons '![ r))))
- (when (not !*onlyraw)
- (when (!~bigminusp n) (setq n (!~bigminus n) neg t))
- (while (or (cdr n) (igreaterp (car n) 9))
- % !~shortdivide is an internal function to this code with a slightly
- % odd interface that involves numbers passed most significant digit
- % first.
- (setq n (!~shortdivide 0 (reverse n) 10))
- (setq r (cons (car (explodec (cdr n))) r))
- (setq n (car n))
- (while (eqcar n 0) (setq n (cdr n)))
- (setq n (reverse n)))
- (setq r (cons (car (explodec (!~sizecheck n))) r))
- (when neg (setq r (cons '!- r))))
- (return (compress (cons '!" r)))))
- (de list!-to!-vector (l)
- (prog (n v)
- (setq n (length l))
- (setq v (mkvect (sub1 n)))
- (setq n 0)
- (while l
- (putv v n (car l))
- (setq n (add1 n))
- (setq l (cdr l)))
- (return v)))
- (setq hexdigs
- (list!-to!-vector
- '(!0 !1 !2 !3 !4 !5 !6 !7 !8 !9 !a !b !c !d !e !f)))
- (de !~big2strhex (n)
- (prog (r neg)
- (when (null n) (return "0"))
- (setq r n)
- (while (and (not (atom r))
- (ifixnum (car r))) (setq r (cdr r)))
- (when r (return nil))
- (setq r '(!"))
- (when (minusp n) (setq n (minus n) neg t))
- (while (greaterp n 15)
- (setq n (divide n 16))
- (setq r (cons (getv hexdigs (cdr n)) r))
- (setq n (car n)))
- (setq r (cons (getv hexdigs n) r))
- (when neg (setq r (cons '!- r)))
- (return (compress (cons '!" r)))))
- % I want to define these two AFTER I have defined all of the rest
- % of the big-number support because they can be called by the vsl
- % kernel when it tries to read numbers.
- (de plus2 (u v)
- (!~bignum_dispatch2 u v iplus !~bigplus2))
- (de times2 (u v)
- (!~bignum_dispatch2 u v itimes !~bigtimes2))
- (de expt (a n)
- (cond
- ((zerop n) 1)
- ((onep n) a)
- ((minusp n) (expt (quotient 1.0 a) (minus n)))
- ((zerop (remainder n 2)) (expt (times a a) (quotient n 2)))
- (t (times a (expt (times a a) (quotient (sub1 n) 2))))))
- % Now arithmetic is all in place.
- (setq small!-modulus 3)
- (de set!-small!-modulus (n)
- (let!* ((r small!-modulus))
- (setq small!-modulus n)
- r))
- (de small!-modular!-number (n)
- (setq n (remainder n small!-modulus))
- (when (minusp n) (setq n (plus n small!-modulus)))
- n)
- (de small!-modular!-plus (a b)
- (small!-modular!-number (plus a b)))
- (de small!-modular!-difference (a b)
- (small!-modular!-number (difference a b)))
- (de small!-modular!-times (a b)
- (small!-modular!-number (times a b)))
- (de small!-modular!-minus (a)
- (small!-modular!-number (minus a)))
- (de small!-modular!-quotient (a b)
- (error "small-modular-quotient not implemented yet" (cons a b)))
- % "fluid" and "global" are concepts that mainly belong with
- % a compiler, but versions are provided here even if they
- % are not terribly useful.
- (de ensure_defined (v)
- (when (not (boundp v))
- (eval (list 'setq v nil))))
- (de fluid (x)
- (remflag x 'global)
- (flag x 'fluid)
- (dolist (v x) (ensure_defined v)))
- (de global (x)
- (remflag x 'fluid)
- (flag x 'global)
- (dolist (v x) (ensure_defined v)))
- (de unfluid (x)
- (remflag x 'fluid))
- (de unglobal (x)
- (remflag x 'global))
- (de fluidp (x) (flagp x 'fluid))
- (de globalp (x) (flagp x 'global))
- % Now some more general-purpose small functions. Including
- % cases that are alternative names for built-in ones that
- % it is convenient to have for the support of some historic
- % code.
- (de flag (l tag)
- (dolist (v l) (put v tag t)))
- (de remflag (l tag)
- (dolist (v l) (remprop v tag)))
- (de flagp (v tag) (get v tag))
- (de prin2 (x) (princ x))
- (de explode2 (x) (explodec x))
- (de mkquote (x) (list 'quote x))
- (de apply1 (fn a1) (apply fn (list a1)))
- (de apply2 (fn a1 a2) (apply fn (list a1 a2)))
- (de apply3 (fn a1 a2 a3) (apply fn (list a1 a2 a3)))
- (de special!-char (n)
- (cond
- ((equal n 0) (code!-char 32))
- ((equal n 1) (code!-char 10))
- ((equal n 2) (code!-char 8))
- ((equal n 3) (code!-char 9))
- ((equal n 4) (code!-char 11))
- ((equal n 5) (code!-char 12))
- ((equal n 6) (code!-char 13))
- ((equal n 7) (code!-char 127))
- ((equal n 8) !$eof!$)
- ((equal n 9) (code!-char 7))
- ((equal n 10) (code!-char 27))
- (t (error "special-char" n))))
- % Testing for letters and digits as done here makes
- % assumptions about the character-code that is in use.
- (de liter (x)
- (let!* ((c (char!-code x)))
- (or (and (leq 65 c) (leq c 90))
- (and (leq 97 c) (leq c 122)))))
- (de digit (x)
- (let!* ((c (char!-code x)))
- (and (leq 48 c) (leq c 57))))
- (de tolower (x)
- (let!* ((c (char!-code x)))
- (if (and (leq 65 c) (leq c 90))
- (code!-char (plus c 32))
- x)))
- (de char!-downcase (x) (tolower x))
- (de explode2lc (x)
- (mapcar (explodec x) 'tolower))
- (de intern (x)
- (if (stringp x)
- (compress (mapcan (explodec x)
- '(lambda (c) (list '!! c))))
- x))
- (setq !*raise nil)
- (setq !*lower t)
- (de putd (name type def)
- (cond
- ((eq type 'expr)
- (eval (cons 'de (cons name (cdr def)))))
- ((eq type 'macro)
- (eval (cons 'dm (cons name (cdr def)))))
- ((eq type 'subr)
- (error "putd/subr not supported" (list name type def)))
- (t (error "unknown type in putd" type))))
- (setq !*redefmsg nil)
- (de set!-print!-precision (n) n)
- (de constantp (x)
- (or (null x)
- (numberp x)
- (stringp x)
- (eq x t)))
- (dm declare (x) nil)
- % The code for ordering items that is given here is
- % required by Reduce, and the exact behaviour is
- % intended to support what is needed there.
- (de ordp (u v)
- (cond
- ((null u) (null v))
- ((vectorp u) (cond
- ((vectorp v) (ordpv u v))
- (t (atom v))))
- ((atom u) (cond
- ((atom v) (cond
- ((numberp u) (and (numberp v) (not (lessp u v))))
- ((idp v) (orderp u v))
- (t (numberp v))))
- (t nil)))
- ((atom v) t)
- ((equal (car u) (car v)) (ordpl (cdr u) (cdr v)))
- ((flagp (car u) 'noncom) (cond
- ((flagp (car v) 'noncom) (ordp (car u) (car v)))
- (t t)))
- ((flagp (car v) 'noncom) nil)
- (t (ordp (car u) (car v)))))
- (de ordpl (u v)
- (cond
- ((atom u) (ordp u v))
- ((equal (car u) (car v)) (ordpl (cdr u) (cdr v)))
- (t (ordp (car u) (car v)))))
- (de ordpv (u v)
- (error "ordpv not yet implemented" (cons u v)))
- (de orderp (u v)
- (prog ()
- (setq u (explodec u))
- (setq v (explodec v))
- (while (and u v (eq (car u) (car v)))
- (setq u (cdr u) v (cdr v)))
- (cond
- ((and u v)
- (return (lessp (char!-code (car u)) (char!-code (car v)))))
- (v (return t))
- (t (return nil)))))
- (dm function (x) (cons 'quote (cdr x)))
- (de sort (items fn)
- (prog (tree)
- (dolist (x items)
- (setq tree (sort_insert x tree fn)))
- (return (sort_flatten tree))))
- (de sort_insert (item tree fn)
- (cond
- ((null tree) (list!* item nil nil))
- ((apply2 fn item (car tree))
- (sort_insertleft item tree fn))
- (t (sort_insertright item tree fn))))
- (de sort_insertleft (item tree fn)
- (list!*
- (car tree)
- (sort_insert item (cadr tree) fn)
- (cddr tree)))
- (de sort_insertright (item tree fn)
- (list!*
- (car tree)
- (cadr tree)
- (sort_insert item (cddr tree) fn)))
- (de sort_flatten (x)
- (cond
- ((null x) nil)
- (t (append (sort_flatten (cadr x))
- (cons (car x) (sort_flatten (cddr x)))))))
- (de gcdn (a b)
- (cond
- ((minusp a) (gcdn (minus a) b))
- ((minusp b) (gcdn a (minus b)))
- ((greaterp b a) (gcdn b a))
- ((zerop b) a)
- (t (gcdn b (remainder a b)))))
- (de lcmn (u v)
- (cond
- ((onep u) v)
- ((onep v) u)
- (t (times u (quotient v (gcdn u v))))))
- (de abs (x)
- (if (minusp x) (minus x) x))
- (de max2 (a b)
- (if (greaterp a b) a b))
- (de min2 (a b)
- (if (lessp a b) a b))
- (de evenp (x) (zerop (remainder x 2)))
- (de msd (n)
- (prog (r)
- (setq r 0)
- (while (not (zerop n))
- (setq n (quotient n 2))
- (setq r (add1 r)))
- (return r)))
- (de lsd (n)
- (if (zerop n)
- 0
- (prog (r)
- (setq r 0)
- (while (zerop (remainder n 2))
- (setq n (quotient n 2))
- (setq r (add1 r)))
- (return r))))
- (de ash (a n) (leftshift a n))
- (de lsh (a n) (leftshift a n))
- (de ilsh (a n) (leftshift a n))
- (de lshift (a n) (leftshift a n))
- (de ash1 (a n)
- (if (minusp a) (minus (leftshift (minus a) n)) (leftshift a n)))
- (de remd (x) nil)
- % The "fasl" scheme here is used when building large programs.
- % Code gets put in files in a directory called "xxx.img.modules".
- (de filedate (x) 0)
- (de datelessp (a b) t)
- (fluid '(faslinfile!* faslinstack!* fasloutfile!* faslname!*))
- (de start!-module (x)
- (cond
- ((null x)
- (close fasloutfile!*)
- (setq fasloutfile!* nil)
- (princ "+++ FASLEND ")
- (printc faslname!*)
- t)
- (t
- (setq faslname!* x)
- (setq fasloutfile!* (open!-module x 'output))
- t)))
- (de faslread ()
- (let!* ((s (rds faslinfile!*)))
- (prog1
- (read)
- (rds s))))
- (de write!-module (x)
- (let!* ((s (wrs fasloutfile!*)))
- (prog1
- (print x)
- (wrs s))))
- (fluid '(dfprint!*))
- (de faslout (u)
- (prog nil
- (terpri)
- (princ "FASLOUT ")
- (prin u)
- (printc ": IN files; or type in expressions")
- (printc "When all done, execute FASLEND;")
- (cond
- ((not (atom u)) (setq u (car u))))
- (if (equal u 'rlsupport) (setq !*echo t)
- (setq !*echo nil)) % @@@
- (cond ((not (start!-module u))
- (progn
- (cond ((neq (posn) 0) (terpri)))
- (printc "+++ Failed to open FASL output file")
- (return nil))))
- (setq s!:faslmod_name (cons u nil))
- (setq s!:dfprintsave dfprint!*)
- (setq dfprint!* (quote s!:fslout0))
- (setq !*defn t)))
- (put (quote faslout) (quote stat) (quote rlis))
- (de faslend nil
- (prog ()
- (cond
- ((null s!:faslmod_name) (return nil)))
- (princ "Completed FASL files for ")
- (print (car s!:faslmod_name))
- (start!-module nil)
- (setq dfprint!* s!:dfprintsave)
- (setq !*defn nil)
- (setq s!:faslmod_name nil)
- (return nil)))
- (put (quote faslend) (quote stat) (quote endstat))
- (flag '(faslend) 'eval)
- (setq !*backtrace t)
- (setq !*debug nil)
- (de s!:fasl_supervisor nil
- (prog (u w !*echo)
- (setq !*echo !*debug)
- top
- (setq u (errorset (quote (read)) t !*backtrace))
- (cond
- ((atom u) (return nil)))
- (setq u (car u))
- (cond
- ((equal u !$eof!$) (return nil)))
- (cond ((not (atom u)) (setq u (macroexpand u))))
- (cond
- ((atom u) (go top))
- ((eqcar u (quote faslend))
- (return (apply (quote faslend) nil)))
- ((eqcar u (quote rdf))
- (setq w (open (setq u (eval (cadr u))) (quote input)))
- (cond (w (progn (terpri)
- (princ "Reading file ")
- (prin u)
- (terpri)
- (setq w (rds w))
- (s!:fasl_supervisor)
- (princ "End of file ")
- (prin u)
- (terpri)
- (close (rds w))))
- (t (progn (princ "Failed to open file ")
- (prin u)
- (terpri)))))
- (t (s!:fslout0 u)))
- (go top)))
- (de s!:fslout0 (u) (s!:fslout1 u nil))
- (de s!:fslout1 (u loadonly)
- (prog (w)
- % Note that I check for eval-when BEFORE I do any macro-expansion here
- % because otherwise eval-when gets expanded away. The consequence here is
- % that eval-when is only honoured at the top-level.
- (when (eqcar u 'eval!-when)
- (if (memq 'compile (cadr u)) (eval (cons 'progn (cddr u))))
- (if (memq 'load (cadr u))
- (s!:fslout1 (cons 'progn (cddr u)) loadonly))
- (return nil))
- (when (or (eqcar u 'compiletime)
- (eqcar u 'bothtimes))
- (eval (cons 'progn (cdr u))))
- (when (or (eqcar u 'loadtime)
- (eqcar u 'bothtimes))
- (s!:fslout1 (cons 'progn (cddr u)) loadonly))
- (cond
- ((not (atom u)) (setq u (macroexpand u))))
- (cond
- ((atom u) (return nil))
- ((eqcar u (quote progn))
- (prog (var1174)
- (setq var1174 (cdr u))
- lab1173 (cond
- ((null var1174) (return nil)))
- (prog (v)
- (setq v (car var1174))
- (s!:fslout1 v loadonly))
- (setq var1174 (cdr var1174))
- (go lab1173))
- (return nil))
- ((eqcar u (quote eval!-when))
- (return (prog nil
- (setq w (cadr u))
- (setq u (cons (quote progn) (cddr u)))
- (cond
- ((and (memq (quote compile) w)
- (not loadonly))
- (eval u)))
- (cond
- ((memq (quote load) w) (s!:fslout1 u t)))
- (return nil))))
- ((or (flagp (car u) (quote eval))
- (and (equal (car u) (quote setq))
- (not (atom (caddr u)))
- (flagp (caaddr u) (quote eval))))
- (cond
- ((not loadonly) (errorset u t !*backtrace)))))
- (cond
- ((eqcar u (quote rdf))
- (prog nil
- (setq w (open (setq u (eval (cadr u))) (quote input)))
- (cond
- (w (princ "Reading file ")
- (prin u)
- (terpri)
- (setq w (rds w))
- (s!:fasl_supervisor)
- (princ "End of file ")
- (prin u)
- (terpri)
- (close (rds w)))
- (t (princ "Failed to open file ")
- (prin u)
- (terpri)))))
- ((and (not (eqcar u (quote faslend)))
- (not (eqcar u (quote carcheck))))
- (write!-module u)))))))
- (de verbos (x) nil)
- (de linelength (n) (linelength!* n))
- (de getenv (x) nil)
- (de filep (x)
- (let!* ((h (errorset (list 'open x ''input) nil nil)))
- (if (atom h) nil
- (progn (close (car h)) t))))
- (de lengthc (x) (length (explodec x)))
- % Various of the functions defined here are needed by Reduce
- % and simplified or dummy versions are provided here so that the
- % program as a whole can be built.
- (de gctime () 0)
- (de eqn (a b) (equal a b))
- (de threevectorp (x)
- (and (vectorp x) (equal (upbv x) 2)))
- (de list!-to!-vector (l)
- (prog (n v)
- (setq n (length l))
- (setq v (mkvect (sub1 n)))
- (setq n 0)
- (while l
- (putv v n (car l))
- (setq n (add1 n))
- (setq l (cdr l)))
- (return v)))
- (de frexp (x)
- (prog (n)
- (if (zerop x) (return '(0 . 0.0)))
- (setq n 0)
- (while (geq x 1.0)
- (setq x (times x 0.5))
- (setq n (add1 n)))
- (while (lessp x 0.5)
- (setq x (times x 2.0))
- (setq n (sub1 n)))
- (return (cons n x))))
- (de verbos (x) nil)
- (de window!-heading (x) (print x))
- (de make!-special (x)
- (set x nil)
- (flag (list x) 'fluid))
- (de compile!-all () nil)
- (de library!-members () nil)
- (de delete!-module (x) nil)
- (de list!-directory (x) nil)
- (de checkpoint (a b) (preserve a))
- (de list!-to!-string (a)
- (prog (r)
- (setq r '(!"))
- (dolist (c a)
- (if (ifixp c) (setq c (code!-char c)))
- (if (eq c '!") (setq r (cons c r)))
- (setq r (cons c r)))
- (return (compress (reverse (cons '!" r))))))
- (de list2string (a) (list!-to!-string a))
- (de string2list (s)
- (setq s (mapcar (explodec s) 'char!-code)))
- (de string!-length (s) (length (explodec s)))
- (de id2string (a)
- (compress (cons '!" (append (explodec a) '(!")))))
- (de setpchar (x) (setpchar!* x))
- (de printprompt (u) nil)
- (flag '(id2string printprompt) 'lose)
- (de land (a b) (logand2 a b))
- (de lshift (a n) (rightshift a (iminus n)))
- (de allocate!-string (n)
- (prog (i l)
- (setq i 0)
- (while (lessp i n)
- (setq l (cons 0 l))
- (setq i (iplus i 1)))
- (return (list2string l))))
- (dm string!-store (x)
- `(prog (l)
- (setq l (string2list ,(cadr x)))
- (setq l (str!-store1 l ,(caddr x) ,(cadddr x)))
- (setq ,(cadr x) (list2string l))
- s))
- (de str!-store1 (charlis len what)
- (if (equal len 0)
- (cons what (cdr charlis))
- (cons (car charlis) (str!-store1 (cdr charlis) (iplus len -1) what))))
- (de gensym1 (x) (gensym))
- (de md60 (x) 123456789)
- (de error1 () (error 99 nil))
- (dm eval!-when (u)
- (if (member 'eval (cadr u))
- (cons 'progn (cddr u))
- nil))
- (de tmpnam () "./temporary-file.tmp")
- % arithmetic left shift
- (de ashift (n m)
- (cond
- ((equal n 0) 0)
- ((equal m 0) n)
- ((greaterp m 0) (leftshift n m))
- ((greaterp n 0) (rightshift n (minus m)))
- (t % arithmetic right shift of negative number
- (minus (rightshift (minus n) (minus m))))))
- (de prin1 (u) (prin u))
- (de carcheck (fff) nil)
- (de fp!-finite (x) t)
- (de complexp (x) nil)
- (dm nreverse (x) `(reversip ,(cadr x)))
- (dm unwind!-protect (u)
- (list
- (list 'lambda '(!*x!*)
- (cons 'progn (append (cddr u) '(!*x!*))))
- (cadr u)))
- (de widelengthc (u)
- (cond
- ((idp u) (length!-without!-followers (string2list (id2string u))))
- ((stringp u) (length!-without!-followers (string2list u)))
- (t (length (explode2 u)))))
- %(de get!-lisp!-directory () ".")
- (de smemql (u v)
- (cond
- ((null v) nil)
- ((smemq (car u) v) (cons (car u) (smemq (cdr u) v)))
- (t (smemql (cdr u) v))))
- (dm commentoutcode (u) nil)
- (de smember (u v)
- (cond
- ((eq u v) t)
- ((atom v) nil)
- (t (or (smember u (car v))
- (smember u (cdr v))))))
-
- (de smemqlp (u v)
- (cond
- ((or (null v) (numberp v)) nil)
- ((atom v) (memq v u))
- ((eq (car v) 'quote) nil)
- (t (or (smemqlp u (car v)) (smemqlp u (cdr v))))))
- (dm compiletime (x) (cons 'progn (cdr x)))
- (dm loadtime (x) (cons 'progn (cdr x)))
- (dm bothtimes (x) (cons 'progn (cdr x)))
- (de find!-gnuplot ()
- "gnuplot")
- (dm load (x)
- (terpri)
- (prin2 "++++ LOAD ")
- (prin (cdr x))
- (printc " called")
- nil)
- (de posn () 0)
- (de enable!-errorset (a b)
- (setq !*backtrace b))
- (de prin1 (x) (prin x))
- (de iequal (x y) (equal x y))
- % What follow is derived from reduce/packages/rlisp/rprintf.red
- (de list2widestring (x)
- (prog (r)
- (setq r '(!"))
- top
- (cond
- ((null x) (return (compress (reverse (cons '!" r))))))
- (setq r (cons (car x) r))
- (cond
- ((eq (car x) '!") (setq r (cons '!" r))))
- (setq x (cdr x))
- (go top)))
- (fluid '(bldmsg_chars!* !*ll!*))
- (setq bldmsg_chars!* nil)
- (de p_princ (u blankfirst)
- (prog (w)
- (setq w (explode2 u))
- (cond
- (bldmsg_chars!*
- (progn
- (cond
- (blankfirst (setq bldmsg_chars!* (cons '! bldmsg_chars!*))))
- (prog (c)
- (setq c w)
- lab (cond ((null c) (return nil)))
- ((lambda (c) (setq bldmsg_chars!* (cons c bldmsg_chars!*)))
- (car c))
- (setq c (cdr c))
- (go lab))))
- (t (progn
- (cond
- (blankfirst
- (progn
- (cond
- ((greaterp (plus (posn) (length w) 1) !*ll!*)
- (terpri)))
- (prin2 " ")))
- ((greaterp (plus (posn) (length w)) !*ll!*) (terpri)))
- (prin2 u)))) ))
- (de p_prin (u blankfirst)
- (prog (w)
- (setq w (explode u))
- (cond ((eqcar w '!_) (setq w (cons '!! w))))
- (cond
- (bldmsg_chars!*
- (progn
- (cond
- (blankfirst (setq bldmsg_chars!* (cons '! bldmsg_chars!*))))
- (prog (c)
- (setq c w)
- lab (cond ((null c) (return nil)))
- ((lambda (c) (setq bldmsg_chars!* (cons c bldmsg_chars!*)))
- (car c))
- (setq c (cdr c))
- (go lab))))
- (t (progn
- (cond
- (blankfirst
- (progn
- (cond
- ((greaterp (plus (posn) (length w) 1) !*ll!*)
- (terpri)))
- (prin2 " ")))
- ((greaterp (plus (posn) (length w)) !*ll!*) (terpri)))
- (prog (c)
- (setq c w)
- lab (cond ((null c) (return nil)))
- ((lambda (c) (prin2 c)) (car c))
- (setq c (cdr c))
- (go lab)))) )))
- (fluid '(!*print!-array!* !*print!-length!* !*print!-level!*))
- (setq !*print!-array!* t)
- (setq !*print!-length!* nil)
- (setq !*print!-level!* nil)
- (fluid '(!*prinl_visited_nodes!* !*prinl_index!*))
- (setq !*prinl_visited_nodes!* (mkhash 10 0 1.5))
- (de p_prinl0 (x escaped)
- (prog (!*prinl_index!*)
- (declare (special !*prinl_index!*))
- (setq !*prinl_index!* 0)
- (unwind!-protect
- (progn (p_prinl1 x 0) (p_prinl2 x 0 escaped nil))
- (clrhash !*prinl_visited_nodes!*))
- (return x)))
- (de p_prinl1 (x depth)
- (prog (w length)
- (cond
- ((and (fixp !*print!-level!*) (greaterp depth !*print!-level!*))
- (return nil)))
- (setq length 0)
- top (cond
- ((and (atom x) (not (vectorp x)) (not (gensymp x))) (return nil))
- ((setq w (gethash x !*prinl_visited_nodes!*))
- (progn
- (cond
- ((equal w 0)
- (progn
- (setq !*prinl_index!* (plus !*prinl_index!* 1))
- (puthash x !*prinl_visited_nodes!* !*prinl_index!*))))
- (return nil)))
- (t (progn
- (puthash x !*prinl_visited_nodes!* 0)
- (cond
- ((vectorp x)
- (progn
- (cond
- (!*print!-array!*
- (progn
- (setq length (upbv x))
- (cond
- ((and
- (fixp !*print!-length!*)
- (lessp !*print!-length!* length))
- (setq length !*print!-length!*)))
- (prog (i)
- (setq i 0)
- lab (cond
- ((minusp (difference length i))
- (return nil)))
- (p_prinl1 (getv x i) (plus depth 1))
- (setq i (plus2 i 1))
- (go lab)))) )))
- ((not (atom x))
- (progn
- (p_prinl1 (car x) (plus depth 1))
- (cond
- ((and
- (fixp !*print!-length!*)
- (greaterp
- (setq length (plus length 1))
- !*print!-length!*))
- (return nil)))
- (setq x (cdr x))
- (go top)))) ))) ))
- (de p_printref (w blankfirst ch)
- (prog (len)
- (setq len (length (explode w)))
- (cond (blankfirst (setq len (plus len 1))))
- (cond
- ((and (not bldmsg_chars!*) (greaterp (plus (posn) 2 len) !*ll!*))
- (progn (setq blankfirst nil) (terpri))))
- (p_princ "#" blankfirst)
- (p_princ w nil)
- (p_princ ch nil)))
- (de p_prinl2 (x depth escaped blankfirst)
- (cond
- ((and (fixp !*print!-level!*) (greaterp depth !*print!-level!*))
- (p_princ "#" blankfirst))
- ((and (atom x) (not (vectorp x)) (not (gensymp x)))
- (progn
- (cond (escaped (p_prin x blankfirst)) (t (p_princ x blankfirst)))) )
- (t (prog (w length)
- (setq w (gethash x !*prinl_visited_nodes!*))
- (cond
- ((and w (not (zerop w)))
- (progn
- (cond
- ((lessp w 0)
- (progn
- (p_printref (minus w) blankfirst "#")
- (return nil)))
- (t (progn
- (puthash x !*prinl_visited_nodes!* (minus w))
- (p_printref w blankfirst "=")
- (setq blankfirst nil)))) )))
- (cond
- ((vectorp x)
- (progn
- (p_princ "%(" blankfirst)
- (cond
- (!*print!-array!*
- (progn
- (setq length (upbv x))
- (cond
- ((and
- (fixp !*print!-length!*)
- (lessp !*print!-length!* length))
- (setq length !*print!-length!*)))
- (prog (i)
- (setq i 0)
- lab (cond
- ((minusp (difference length i))
- (return nil)))
- (p_prinl2
- (getv x i)
- (plus depth 1)
- escaped
- (neq i 0))
- (setq i (plus2 i 1))
- (go lab))))
- (t (p_princ "..." nil)))
- (p_princ ")" nil)
- (return nil)))
- ((atom x)
- (progn
- (cond
- (escaped (p_prin x blankfirst))
- (t (p_princ x blankfirst)))
- (return nil))))
- (p_princ "(" blankfirst)
- (p_prinl2 (car x) (plus depth 1) escaped nil)
- (setq x (cdr x))
- (setq length 0)
- loop (cond
- ((atom x)
- (progn
- (cond
- ((neq x nil)
- (progn
- (p_princ "." t)
- (p_prinl2 x depth escaped t))))
- (return (p_princ ")" nil)))) )
- (cond
- ((and
- (fixp !*print!-length!*)
- (greaterp (setq length (plus length 1)) !*print!-length!*))
- (progn (p_princ "..." t) (return (p_princ ")" nil)))) )
- (setq w (gethash x !*prinl_visited_nodes!*))
- (cond
- ((and w (not (zerop w)))
- (progn
- (cond
- ((lessp w 0)
- (progn
- (p_princ "." t)
- (p_printref (minus w) t "#")
- (return (p_princ ")" nil))))
- (t (progn
- (p_princ "." t)
- (p_prinl2 x (plus depth 1) escaped t)
- (return (p_princ ")" nil)))) ))) )
- (p_prinl2 (car x) (plus depth 1) escaped t)
- (setq x (cdr x))
- (go loop)))) )
- (de printl (x) (progn (prinl x) (terpri) x))
- (de printcl (x) (progn (princl x) (terpri) x))
- (de princl (x)
- (prog (!*ll!*)
- (declare (special !*ll!*))
- (setq !*ll!* (difference (linelength nil) 2))
- (p_prinl0 x nil)
- (return x)))
- (de prinl (x)
- (prog (!*ll!*)
- (declare (special !*ll!*))
- (setq !*ll!* (difference (linelength nil) 2))
- (p_prinl0 x t)
- (return x)))
- (de portable_print (x) (progn (portable_prin x) (terpri) x))
- (de portable_printc (x) (progn (portable_princ x) (terpri) x))
- (de portable_princ (x)
- (prog (!*ll!*)
- (declare (special !*ll!*))
- (setq !*ll!* (difference (linelength nil) 2))
- (p_prinl2 x 0 nil nil)
- (return x)))
- (de portable_prin (x)
- (prog (!*ll!*)
- (declare (special !*ll!*))
- (setq !*ll!* (difference (linelength nil) 2))
- (p_prinl2 x 0 t nil)
- (return x)))
- (de p_minus (u)
- (cond
- ((eqcar u 'minus) (cadr u))
- ((eqcar u 'plus)
- (cons
- 'plus
- (prog (v forall!-result forall!-endptr)
- (setq v (cdr u))
- (cond ((null v) (return nil)))
- (setq forall!-result
- (setq forall!-endptr
- (cons ((lambda (v) (p_minus v)) (car v)) nil)))
- looplabel
- (setq v (cdr v))
- (cond ((null v) (return forall!-result)))
- (rplacd
- forall!-endptr
- (cons ((lambda (v) (p_minus v)) (car v)) nil))
- (setq forall!-endptr (cdr forall!-endptr))
- (go looplabel))))
- ((eqcar u 'difference) (cons 'plus (cons (p_minus (cadr u)) (cddr u))))
- (t (list 'minus u))))
- (de p_diff2minus (u)
- (prog (r)
- (setq r (car u))
- (prog nil
- whilelabel
- (cond ((not (setq u (cdr u))) (return nil)))
- (setq r (cons (p_minus (car u)) r))
- (go whilelabel))
- (return (cons 'plus (reverse r)))) )
- (de p_prefix (u prec)
- (cond
- ((atom u) (p_princ u nil))
- ((eqcar u '!*sq) (p_prefix (prepsq (cadr u)) prec))
- (t (prog (op p1)
- (setq op (car u))
- (cond
- ((equal op 'expt)
- (progn
- (cond ((greaterp prec 3) (p_princ "(" nil)))
- (p_prefix (cadr u) 4)
- (p_princ "^" nil)
- (p_prefix (caddr u) 3)
- (cond ((greaterp prec 3) (p_princ ")" nil)))
- (return nil)))
- ((or (equal op 'times) (equal op 'quotient))
- (progn
- (cond ((greaterp prec 2) (p_princ "(" nil)))
- (p_prefix (car (setq u (cdr u))) 2)
- (cond
- ((equal op 'times) (progn (setq p1 2) (setq op "*")))
- (t (progn (setq p1 3) (setq op "/"))))
- (prog nil
- whilelabel
- (cond
- ((not (not (atom (setq u (cdr u)))) ) (return nil)))
- (progn (p_princ op nil) (p_prefix (car u) p1))
- (go whilelabel))
- (cond ((greaterp prec 2) (p_princ ")" nil)))
- (return nil))))
- (cond
- ((equal op 'difference)
- (return (p_prefix (p_diff2minus (cdr u)) prec)))
- ((equal op 'plus)
- (progn
- (cond ((greaterp prec 1) (p_princ "(" nil)))
- (p_prefix (car (setq u (cdr u))) 1)
- (prog nil
- whilelabel
- (cond
- ((not (not (atom (setq u (cdr u)))) ) (return nil)))
- (progn
- (setq p1 (car u))
- (cond
- ((eqcar p1 'minus)
- (progn
- (setq p1 (cadr p1))
- (p_princ " - " nil)))
- (t (p_princ " + " nil)))
- (p_prefix p1 1))
- (go whilelabel))
- (cond ((greaterp prec 1) (p_princ ")" nil)))
- (return nil)))
- ((equal op 'minus)
- (progn
- (p_princ "-" nil)
- (cond ((lessp prec 2) (setq prec 2)))
- (return (p_prefix (cadr u) prec)))) )
- (cond
- ((or (not (atom op)) (and (numberp op) (minusp op)))
- (progn (p_princ "(" nil) (p_prefix op 0) (p_princ ")" nil)))
- (t (p_princ op nil)))
- (setq op "(")
- (cond
- ((atom (setq u (cdr u))) (p_princ "(" nil))
- (t (prog (x)
- (setq x u)
- lab (cond ((null x) (return nil)))
- ((lambda (x)
- (progn (p_princ op nil) (setq op ",") (p_prefix x 0)))
- (car x))
- (setq x (cdr x))
- (go lab))))
- (return (p_princ ")" nil)))) ))
- (de prin_with_margin (u)
- (print_with_margin_sub
- u
- (posn)
- (difference (linelength nil) 2)
- (function explode)))
- (de princ_with_margin (u)
- (print_with_margin_sub
- u
- (posn)
- (difference (linelength nil) 2)
- (function explode2)))
- (de print_with_margin (u) (progn (prin_with_margin u) (terpri) u))
- (de printc_with_margin (u) (progn (princ_with_margin u) (terpri) u))
- (de print_with_margin_sub (u left right explfn)
- (prog (v)
- (cond ((lessp right 10) (setq right 10)))
- (cond
- ((greaterp left (difference right 10))
- (setq left (difference right 10))))
- (setq v u)
- (cond
- ((not (atom v))
- (progn
- (cond ((geq (posn) right) (progn (terpri) (ttab left))))
- (prin2 "(")
- (print_with_margin_sub (car v) left right explfn)
- (prog nil
- whilelabel
- (cond ((not (not (atom (setq v (cdr v)))) ) (return nil)))
- (progn
- (cond
- ((geq (posn) right) (progn (terpri) (ttab left)))
- (t (prin2 " ")))
- (print_with_margin_sub (car v) left right explfn))
- (go whilelabel))
- (cond
- ((not (null v))
- (progn
- (cond
- ((geq (posn) (difference right 1))
- (progn (terpri) (ttab left) (prin2 ". ")))
- (t (prin2 " .")))
- (print_with_margin_sub v left right explfn))))
- (cond ((geq (posn) right) (progn (terpri) (ttab left))))
- (prin2 ")")
- (return u))))
- (setq v (apply explfn (list u)))
- verylong
- (cond
- ((lessp (plus (posn) (length v)) right)
- (progn
- (prog (c)
- (setq c v)
- lab (cond ((null c) (return nil)))
- ((lambda (c) (prin2 c)) (car c))
- (setq c (cdr c))
- (go lab))
- (return u)))
- ((leq (length v) (difference right left))
- (progn
- (terpri)
- (ttab left)
- (prog (c)
- (setq c v)
- lab (cond ((null c) (return nil)))
- ((lambda (c) (prin2 c)) (car c))
- (setq c (cdr c))
- (go lab))
- (return u)))
- ((lessp (length v) right)
- (progn
- (terpri)
- (ttab (difference right (length v)))
- (prog (c)
- (setq c v)
- lab (cond ((null c) (return nil)))
- ((lambda (c) (prin2 c)) (car c))
- (setq c (cdr c))
- (go lab))
- (return u)))
- (t (progn
- (cond
- ((geq (posn) (difference right 5))
- (progn (terpri) (ttab left))))
- (prog nil
- whilelabel
- (cond
- ((not (lessp (posn) (difference right 1))) (return nil)))
- (progn (prin2 (car v)) (setq v (cdr v)))
- (go whilelabel))
- (prin2 "\")
- (terpri)
- (go verylong)))) ))
- (de bldmsg_internal (fmt args)
- (prog (bldmsg_chars!* u v)
- (declare (special bldmsg_chars!*))
- (setq bldmsg_chars!* t)
- (printf_internal fmt args)
- (prog nil
- whilelabel
- (cond ((not (not (atom bldmsg_chars!*))) (return nil)))
- (progn
- (setq u (cdr bldmsg_chars!*))
- (rplacd bldmsg_chars!* v)
- (setq v bldmsg_chars!*)
- (setq bldmsg_chars!* u))
- (go whilelabel))
- (return (list2widestring v))))
- (de p_posn nil
- (cond
- (bldmsg_chars!*
- (prog (w n)
- (setq n 0)
- (setq w bldmsg_chars!*)
- (prog nil
- whilelabel
- (cond
- ((not (and (not (atom w)) (not (equal (car w) !$eol!$))))
- (return nil)))
- (progn (setq n (plus n 1)) (setq w (cdr w)))
- (go whilelabel))
- (return n)))
- (t (posn))))
- (global '(p_hexdigits!*))
- (setq p_hexdigits!* (mkvect 15))
- (putv p_hexdigits!* 0 '!0)
- (putv p_hexdigits!* 1 '!1)
- (putv p_hexdigits!* 2 '!2)
- (putv p_hexdigits!* 3 '!3)
- (putv p_hexdigits!* 4 '!4)
- (putv p_hexdigits!* 5 '!5)
- (putv p_hexdigits!* 6 '!6)
- (putv p_hexdigits!* 7 '!7)
- (putv p_hexdigits!* 8 '!8)
- (putv p_hexdigits!* 9 '!9)
- (putv p_hexdigits!* 10 'a)
- (putv p_hexdigits!* 11 'b)
- (putv p_hexdigits!* 12 'c)
- (putv p_hexdigits!* 13 'd)
- (putv p_hexdigits!* 14 'e)
- (putv p_hexdigits!* 15 'f)
- (de p_prinhex (n)
- (cond
- ((not (fixp n)) (p_princ "<not-a-number>" nil))
- (t (prog (b w)
- (cond
- ((geq n 0)
- (progn
- (prog nil
- whilelabel
- (cond ((not (geq n 16)) (return nil)))
- (progn
- (setq b
- (cons (getv p_hexdigits!* (setq w (mod n 16))) b))
- (setq n (quotient (difference n w) 16)))
- (go whilelabel))
- (setq b (cons (getv p_hexdigits!* (mod n 16)) b))))
- (t (progn
- (prog nil
- whilelabel
- (cond ((not (lessp n (minus 1))) (return nil)))
- (progn
- (setq b
- (cons (getv p_hexdigits!* (setq w (mod n 16))) b))
- (setq n (quotient (difference n w) 16)))
- (go whilelabel))
- (setq b
- (cons '!~ (cons (getv p_hexdigits!* (mod n 16)) b)))) ))
- (cond
- ((and
- (null bldmsg_chars!*)
- (greaterp (plus (posn) (length b)) !*ll!*))
- (terpri)))
- (prog (c)
- (setq c b)
- lab (cond ((null c) (return nil)))
- ((lambda (c) (p_princ c nil)) (car c))
- (setq c (cdr c))
- (go lab)))) ))
- (de p_prinoctal (n)
- (cond
- ((not (fixp n)) (p_princ "<not-a-number>" nil))
- (t (prog (b w)
- (cond
- ((geq n 0)
- (progn
- (prog nil
- whilelabel
- (cond ((not (geq n 8)) (return nil)))
- (progn
- (setq b (cons (setq w (mod n 8)) b))
- (setq n (quotient (difference n w) 8)))
- (go whilelabel))
- (setq b (cons (mod n 8) b))))
- (t (progn
- (prog nil
- whilelabel
- (cond ((not (lessp n (minus 1))) (return nil)))
- (progn
- (setq b (cons (setq w (mod n 8)) b))
- (setq n (quotient (difference n w) 8)))
- (go whilelabel))
- (setq b (cons '!~ (cons (mod n 8) b)))) ))
- (cond
- ((and
- (null bldmsg_chars!*)
- (greaterp (plus (posn) (length b)) !*ll!*))
- (terpri)))
- (prog (c)
- (setq c b)
- lab (cond ((null c) (return nil)))
- ((lambda (c) (p_princ c nil)) (car c))
- (setq c (cdr c))
- (go lab)))) ))
- (de printf_internal (fmt args)
- (prog (a c !*ll!*)
- (declare (special !*ll!*))
- (setq !*ll!* (difference (linelength nil) 2))
- (setq fmt (explode2 fmt))
- (prog nil
- whilelabel
- (cond ((not fmt) (return nil)))
- (progn
- (setq c (car fmt))
- (setq fmt (cdr fmt))
- (cond
- ((neq c '!%) (p_princ c nil))
- (t (progn
- (setq c (car fmt))
- (setq fmt (cdr fmt))
- (cond
- ((equal c 'f)
- (progn
- (cond
- ((and
- (not bldmsg_chars!*)
- (not (zerop (posn))))
- (terpri)))) )
- ((or (equal c 'n) (equal c '!N)) (p_princ !$eol!$ nil))
- ((equal c '!%) (p_princ c nil))
- (t (progn
- (cond
- ((null args) (setq a nil))
- (t (progn
- (setq a (car args))
- (setq args (cdr args)))) )
- (cond
- ((and (or (equal c 'b) (equal c '!B)) (fixp a))
- (prog (i)
- (setq i 1)
- lab (cond
- ((minusp (difference a i))
- (return nil)))
- (p_princ " " nil)
- (setq i (plus2 i 1))
- (go lab)))
- ((or (equal c 'c) (equal c '!C))
- (progn
- (cond
- ((fixp a)
- (p_princ
- (list2widestring (list a))
- nil))
- (t (p_princ a nil)))) )
- ((or (equal c 'l) (equal c '!L))
- (progn
- (cond
- ((not (atom a))
- (progn
- (portable_princ (car a))
- (prog (x)
- (setq x (cdr a))
- lab (cond
- ((null x) (return nil)))
- ((lambda (x)
- (progn
- (p_princ " " nil)
- (portable_princ x)))
- (car x))
- (setq x (cdr x))
- (go lab)))) )))
- ((or (equal c 'o) (equal c '!O))
- (p_prinoctal a))
- ((or (equal c 'p) (equal c '!P))
- (portable_prin a))
- ((or (equal c 'q) (equal c '!Q))
- (prinl a))
- ((or (equal c 'r) (equal c '!R))
- (progn
- (p_princ "'" nil)
- (prinl a)
- (p_princ "'" nil)))
- ((and (or (equal c 't) (equal c '!T)) (fixp a))
- (progn
- (cond
- ((greaterp (p_posn) a)
- (p_princ !$eol!$ nil)))
- (prog nil
- whilelabel
- (cond
- ((not (lessp (p_posn) a))
- (return nil)))
- (p_princ " " nil)
- (go whilelabel))))
- ((or
- (equal c 'w)
- (equal c 'd)
- (equal c 's)
- (equal c '!W)
- (equal c '!D)
- (equal c '!S))
- (portable_princ a))
- ((or (equal c 'x) (equal c '!X)) (p_prinhex a))
- ((equal c '!@)
- (progn
- (setq c (car fmt))
- (setq fmt (cdr fmt))
- (cond
- ((or (equal c 'f) (equal c '!F))
- (p_prefix (prepf a) 0))
- ((or (equal c 'q) (equal c '!Q))
- (p_prefix (prepsq a) 0))
- ((or (equal c 'p) (equal c '!P))
- (p_prefix a 0))
- (t (progn
- (p_princ "%@" nil)
- (p_princ c nil)))) ))
- ((equal c 'e) (eval a))
- (t (progn
- (p_princ "%" nil)
- (p_princ c nil)))) ))) ))) )
- (go whilelabel))))
- (dm printf (u) (list 'printf_internal (cadr u) (cons 'list (cddr u))))
- (dm bldmsg (u) (list 'bldmsg_internal (cadr u) (cons 'list (cddr u))))
- (dm fprintf (u)
- (list 'prog '(oldout)
- (list 'setq 'oldout (list 'wrs (cadr u)))
- (list 'printf_internal (caddr u) (cons 'list (cdddr u)))
- '(wrs oldout)))
- (flag '(printf bldmsg fprintf) 'variadic)
- % End of vsl.lsp
|