1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134 |
- /* Definitions for builtin functions.
- This file is part of khipu.
- khipu is free software: you can redistribute it and/or modify
- it under the terms of the GNU Lesser General Public License as published by
- the Free Software Foundation; either version 3 of the License, or
- (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU Lesser General Public License for more details.
- You should have received a copy of the GNU Lesser General Public License
- along with this program. If not, see <https://www.gnu.org/licenses/>. */
- #include <cstdio>
- #include <new>
- #include "khipu.hpp"
- #include "utils/lazy.hpp"
- KP_DECLS_BEGIN
- static exception
- invalid_arg (interpreter *interp, const char *name)
- {
- char buf[128];
- sprintf (buf, "invalid argument(s) passed to '%s'", name);
- return (interp->raise ("arg-error", buf));
- }
- static result<int64_t>
- write_generic (interpreter *interp, stream *strm,
- object obj, io_info& info)
- {
- char buf[64];
- int64_t ret = KP_TRY (strm->write (interp, "#<", 2));
- ret += KP_TRY (write_S (interp, strm, type_name (type (obj)), info));
- ret += KP_TRY (strm->write (interp, " object at ", 11));
- ret += KP_TRY (strm->write (interp, buf, sprintf (buf, "%p", unmask (obj))));
- ret += KP_TRY (strm->putb (interp, '>'));
- return (ret);
- }
- #define INTERN(name) \
- intern (interp, name, sizeof (name) - 1, as_package (root_package))
- #define INTERN_N(name) \
- intern (interp, name, as_package (root_package))
- static inline object
- safe_symval (result<object> obj)
- {
- return (symbol_p (*obj) ? symval (*obj) : UNBOUND);
- }
- static result<object>
- call_binary (interpreter *interp, object x, object y,
- result<object> (*fn) (interpreter *, object , object),
- const char *method)
- {
- object ret = KP_TRY (fn (interp, x, y));
- if (ret != UNBOUND)
- return (interp->retval);
- KP_PUSH_ALL (interp, safe_symval (INTERN_N (method)), x, y);
- bool rv = KP_TRY (method_call (interp, 2));
- if (rv)
- return (interp->retval);
- valref sub_x (interp, builtin_member (x));
- valref sub_y (interp, builtin_member (y));
- if (*sub_x != UNBOUND && *sub_y != UNBOUND)
- {
- ret = KP_TRY (fn (interp, *sub_x, *sub_y));
- if (ret != UNBOUND)
- return (interp->retval);
- }
- return (interp->raise ("type-error",
- KP_SPRINTF (interp, "invalid types: got %Q and %Q",
- type (x), type (y))));
- }
- static result<int64_t>
- write_any (interpreter *interp, stream *strm,
- object obj, io_info& info)
- {
- KP_PUSH_ALL (interp, safe_symval (INTERN ("g-write")), obj, strm->as_obj ());
- bool rv = KP_TRY (method_call (interp, 2));
- if (rv)
- return (0);
- object tname = type_name (obj);
- if (tname == NIL)
- return (write_generic (interp, strm, obj, info));
- int64_t ret = KP_TRY (strm->write (interp, "#<type ", 7));
- ret += KP_TRY (xwrite (interp, strm, tname, info));
- ret += KP_TRY (strm->putb (interp, '>'));
- return (ret);
- }
- result<int64_t> xwrite (interpreter *interp, stream *strm,
- object obj, io_info& info)
- {
- int64_t ret;
- int itp = itype (obj);
- switch (itp)
- {
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- ret = KP_TRY (write_##suffix (interp, strm, obj, info)); \
- break
- DISPATCH (INT, i);
- DISPATCH (CHAR, c);
- DISPATCH (CONS, L);
- DISPATCH (BIGINT, I);
- DISPATCH (FLOAT, f);
- DISPATCH (BIGFLOAT, F);
- DISPATCH (BVECTOR, b);
- DISPATCH (STR, s);
- DISPATCH (ARRAY, a);
- DISPATCH (TABLE, u);
- DISPATCH (TUPLE, o);
- DISPATCH (SYMBOL, S);
- DISPATCH (FCT, x);
- DISPATCH (PKG, P);
- default:
- if (obj == UNBOUND)
- { ret = KP_TRY (strm->write (interp, "#<unbound>", 10)); }
- else if (itp == typecode::CORO || itp == typecode::STREAM ||
- (info.flags & io_info::FLG_SAFE))
- { ret = KP_TRY (write_generic (interp, strm, obj, info)); }
- else
- { ret = KP_TRY (write_any (interp, strm, obj, info)); }
- #undef DISPATCH
- }
- return (strm->err_p () ? -1 : ret);
- }
- static inline bool
- ref_obj_p (object obj, int tp)
- {
- switch (tp)
- {
- case typecode::INT:
- case typecode::CHAR:
- return (false);
- case typecode::PKG:
- return (obj != root_package && obj != kword_package);
- case typecode::FCT:
- return (!as_varobj(obj)->flagged_p (function::artificial_flag));
- default:
- return (true);
- }
- }
- result<int64_t> xpack (interpreter *interp, stream *strm,
- object obj, pack_info& info)
- {
- int64_t ret = 0;
- int tp = itype (obj);
- if (nil_p (obj))
- return (strm->putb (interp, PACK_NIL));
- else if (array_p (obj) && len_a (obj) == 0)
- return (strm->putb (interp, PACK_EMPTY_ARRAY));
- else if ((str_p (obj) || bvector_p (obj)) && as_bvector(obj)->nbytes == 0)
- return (strm->putb (interp, str_p (obj) ?
- PACK_EMPTY_STR : PACK_EMPTY_BVECTOR));
- else if (tp == typecode::CHAR && as_char (obj) <= 0xff)
- {
- unsigned char data[] = { PACK_CHAR8, (unsigned char)as_char (obj) };
- return (strm->write (interp, data, sizeof (data)));
- }
- else if (tp == typecode::INT && as_int (obj) <= 0x7f && as_int (obj) >= -128)
- {
- unsigned char data[] = { PACK_INT8, (unsigned char)as_int (obj) };
- return (strm->write (interp, data, sizeof (data)));
- }
- else if (tp == typecode::INSTANCE && builtin_typespec_p (obj))
- {
- unsigned char data[] = { PACK_TYPESPEC,
- (unsigned char)as_instance(obj)->type_code () };
- return (strm->write (interp, data, sizeof (data)));
- }
- {
- object off = info.get (interp, obj);
- if (off != UNBOUND)
- {
- int ioff = as_int (off);
- info.touch (interp, ioff);
- ret += KP_TRY (strm->putb (interp, PACK_REF_INT32));
- ret += KP_TRY (strm->write (interp, &ioff));
- return (ret);
- }
- }
- if (ref_obj_p (obj, tp))
- {
- object pos = KP_TRY (strm->tell (interp));
- KP_VTRY (info.add_mapping (interp, obj, pos));
- }
- ret += KP_TRY (strm->putb (interp, tp));
- switch (tp)
- {
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- ret += KP_TRY (pack_##suffix (interp, strm, obj, info)); \
- break
- DISPATCH (INT, i);
- DISPATCH (CHAR, c);
- DISPATCH (CONS, L);
- DISPATCH (BIGINT, I);
- DISPATCH (FLOAT, f);
- DISPATCH (BIGFLOAT, F);
- DISPATCH (BVECTOR, b);
- DISPATCH (STR, s);
- DISPATCH (ARRAY, a);
- DISPATCH (TABLE, u);
- DISPATCH (TUPLE, o);
- DISPATCH (SYMBOL, S);
- DISPATCH (FCT, x);
- DISPATCH (CORO, G);
- DISPATCH (PKG, P);
- DISPATCH (INSTANCE, w);
- default:
- // XXX: Other objects.
- return (invalid_arg (interp, "pack"));
- #undef DISPATCH
- }
- return (strm->err_p () ? -1 : ret);
- }
- result<object> xunpack (interpreter *interp, stream *strm, pack_info& info)
- {
- object ret = KP_TRY (strm->tell (interp));
- *info.offset = KP_TRY (copy (interp, ret));
- int tp = KP_TRY (strm->getb (interp));
- if (tp < 0)
- return (info.error ("failed to read typecode"));
- bool save = (tp & 0x80) != 0;
- tp &= ~0x80;
- switch (tp)
- {
- case PACK_NIL:
- kp_return (NIL);
- case PACK_EMPTY_ARRAY:
- kp_return (deref (alloc_array (interp, 0)));
- case PACK_EMPTY_BVECTOR:
- kp_return (deref (alloc_bvector (interp, 0)));
- case PACK_EMPTY_STR:
- kp_return (deref (alloc_str (interp, 0)));
- case PACK_INT8:
- case PACK_CHAR8:
- {
- int b = KP_TRY (strm->getb (interp));
- if (b < 0)
- return (info.error ("failed to read byte"));
- kp_return (tp == PACK_INT8 ? fixint ((int8_t)b) :
- charobj ((uint8_t)b));
- }
- case PACK_REF_INT32:
- {
- int off;
- bool rv = KP_TRY (strm->sread (interp, &off));
- if (!rv)
- return (info.error ("failed to read integer"));
- interp->retval = info.get (interp, intobj (interp, off));
- if (interp->retval == UNBOUND)
- return (info.error ("invalid back reference to object"));
- return (interp->retval);
- }
- case PACK_REF_OBJ:
- {
- object rv = KP_TRY (xunpack (interp, strm, info));
- if ((interp->retval = info.get (interp, rv)) == UNBOUND)
- return (info.error ("invalid back reference to object"));
- return (interp->retval);
- }
- case PACK_TYPESPEC:
- tp = KP_TRY (strm->getb (interp));
- if (tp < 0)
- return (info.error ("failed to read typespec code"));
- else if ((interp->retval = builtin_type (tp)) == UNBOUND)
- return (info.error ("invalid typespec"));
- return (interp->retval);
-
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- ret = KP_TRY (unpack_##suffix (interp, strm, info, save)); \
- break
- DISPATCH (INT, i);
- DISPATCH (CHAR, c);
- DISPATCH (CONS, L);
- DISPATCH (BIGINT, I);
- DISPATCH (FLOAT, f);
- DISPATCH (BIGFLOAT, F);
- DISPATCH (BVECTOR, b);
- DISPATCH (STR, s);
- DISPATCH (ARRAY, a);
- DISPATCH (TABLE, u);
- DISPATCH (TUPLE, o);
- DISPATCH (SYMBOL, S);
- DISPATCH (FCT, x);
- DISPATCH (CORO, G);
- DISPATCH (PKG, P);
- DISPATCH (INSTANCE, w);
- default:
- // XXX: Other objects.
- return (invalid_arg (interp, "unpack"));
- #undef DISPATCH
- }
- kp_return (ret);
- }
- result<object> copy (interpreter *interp, object obj, bool deep)
- {
- if (immediate_p (obj) || (varobj_p (obj) &&
- (as_varobj(obj)->flagged_p (FLAGS_CONST))))
- kp_return (obj);
- switch (itype (obj))
- {
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- KP_VTRY (copy_##suffix (interp, obj, deep)); \
- return (interp->retval)
- DISPATCH (CONS, L);
- DISPATCH (BVECTOR, b);
- DISPATCH (ARRAY, a);
- DISPATCH (TABLE, u);
- DISPATCH (TUPLE, o);
- DISPATCH (SYMBOL, S);
- default:
- return (invalid_arg (interp, "copy"));
- #undef DISPATCH
- }
- }
- uint32_t hash_addr (object obj)
- {
- #ifndef KP_ARCH_WIDE
- return ((uint32_t)obj >> 3);
- #else
- return (mix_hash (obj >> 32, obj & 0xffffffff));
- #endif
- }
- static result<uint32_t>
- hash_helper (interpreter *interp, object obj, bool& got)
- {
- uint32_t ret;
- got = true;
- switch (itype (obj))
- {
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- ret = KP_TRY (hash_##suffix (interp, obj)); \
- return (ret)
- #define hash_w(ip, x) (bool)(got = false)
- DISPATCH (CONS, L);
- DISPATCH (BIGINT, I);
- DISPATCH (FLOAT, f);
- DISPATCH (BIGFLOAT, F);
- DISPATCH (BVECTOR, b);
- DISPATCH (STR, s);
- DISPATCH (ARRAY, a);
- DISPATCH (TABLE, u);
- DISPATCH (TUPLE, o);
- DISPATCH (SYMBOL, S);
- DISPATCH (PKG, P);
- DISPATCH (INSTANCE, w);
- #undef DISPATCH
- #undef hash_w
- default:
- return (hash_addr (obj));
- }
- }
- result<uint32_t> xhash (interpreter *interp, object obj)
- {
- bool got;
- uint32_t ret = KP_TRY (hash_helper (interp, obj, got));
- if (got)
- return (ret);
- KP_PUSH_ALL (interp, safe_symval (INTERN ("g-hash")), obj);
- got = KP_TRY (method_call (interp, 1));
- if (got)
- {
- int iv;
- if (as<int> (interp->retval, iv))
- return (iv);
- else if (bigint *lp = as<bigint> (interp->retval))
- return (hash_I (interp, lp->as_obj ()));
- return (interp->raise ("type-error",
- "hash function must return an integer"));
- }
- valref sub_obj (interp, builtin_member (obj));
- if (*sub_obj != UNBOUND)
- return (hash_helper (interp, *sub_obj, got));
- return (ret);
- }
- result<object> length (interpreter *interp, object obj)
- {
- switch (itype (obj))
- {
- case typecode::ARRAY:
- return (fixint (len_a (obj)));
- case typecode::TUPLE:
- return (fixint (len_o (obj)));
- case typecode::BVECTOR:
- return (fixint (len_b (obj)));
- case typecode::STR:
- return (fixint (len_s (obj)));
- case typecode::TABLE:
- return (fixint (len_u (obj)));
- case typecode::CONS:
- {
- auto ret = KP_TRY (len_L (interp, obj));
- return (fixint (ret));
- }
- default:
- {
- KP_PUSH_ALL (interp, safe_symval (INTERN ("g-len")), obj);
- bool rv = KP_TRY (method_call (interp, 1));
- if (rv)
- return (interp->raise ("dispatch-error",
- "no applicable method found for g-len"));
- int out;
- if (as<int> (interp->retval, out) || as<bigint> (interp->retval))
- return (interp->retval);
- return (interp->raise ("type-error", "len must return an integer"));
- }
- }
- }
- // Binary operations.
- #define MIX(t1, t2) ((t1) + ((t2) * typecode::LAST))
- static result<object>
- add_helper (interpreter *interp, object x, object y)
- {
- object ret;
- switch (MIX (itype (x), itype (y)))
- {
- #define DISPATCH_1(type, suffix) \
- case MIX (typecode::type, typecode::type): \
- ret = KP_TRY (add_##suffix##suffix (interp, x, y)); \
- return (ret)
- #define DISPATCH_2(t1, t2, s1, s2) \
- case MIX (typecode::t1, typecode::t2): \
- ret = KP_TRY (add_##s1##s2 (interp, x, y)); \
- return (ret); \
- case MIX (typecode::t2, typecode::t1): \
- ret = KP_TRY (add_##s1##s2 (interp, y, x)); \
- return (ret)
- DISPATCH_1 (INT, i);
- DISPATCH_2 (INT, BIGINT, i, I);
- DISPATCH_2 (INT, FLOAT, i, f);
- DISPATCH_2 (INT, BIGFLOAT, i, F);
- DISPATCH_1 (BIGINT, I);
- DISPATCH_2 (BIGINT, FLOAT, I, f);
- DISPATCH_2 (BIGINT, BIGFLOAT, I, F);
- DISPATCH_1 (FLOAT, f);
- DISPATCH_2 (FLOAT, BIGFLOAT, f, F);
-
- DISPATCH_1 (BIGFLOAT, F);
- DISPATCH_1 (CHAR, c);
- DISPATCH_1 (STR, s);
- // Need to handle this case manually, since addition is not commutative.
- case MIX (typecode::STR, typecode::CHAR):
- return (add_sc (interp, x, y));
- case MIX (typecode::CHAR, typecode::STR):
- return (add_cs (interp, x, y));
- DISPATCH_1 (BVECTOR, b);
- DISPATCH_1 (ARRAY, a);
- DISPATCH_1 (CONS, L);
- default:
- return (UNBOUND);
- #undef DISPATCH_1
- #undef DISPATCH_2
- }
- }
- result<object> add (interpreter *interp, object x, object y)
- {
- return (call_binary (interp, x, y, add_helper, "g-add"));
- }
- #ifndef KP_ARCH_WIDE
- template <typename T>
- static inline void inplace_neg (T& val)
- {
- val = -val;
- }
- #endif
- static result<object>
- sub_helper (interpreter *interp, object x, object y)
- {
- object ret;
- switch (MIX (itype (x), itype (y)))
- {
- #define DISPATCH_1(type, suffix) \
- case MIX (typecode::type, typecode::type): \
- ret = KP_TRY (sub_##suffix##suffix (interp, x, y)); \
- return (ret)
- #define DISPATCH_2(t1, t2, s1, s2) \
- case MIX (typecode::t1, typecode::t2): \
- ret = KP_TRY (sub_##s1##s2 (interp, x, y)); \
- return (ret); \
- case MIX (typecode::t2, typecode::t1): \
- ret = KP_TRY (sub_##s1##s2 (interp, y, x)); \
- break
- DISPATCH_1 (INT, i);
- DISPATCH_2 (INT, BIGINT, i, I);
- DISPATCH_2 (INT, FLOAT, i, f);
- DISPATCH_2 (INT, BIGFLOAT, i, F);
- DISPATCH_1 (BIGINT, I);
- DISPATCH_2 (BIGINT, FLOAT, I, f);
- DISPATCH_2 (BIGINT, BIGFLOAT, I, F);
- DISPATCH_1 (FLOAT, f);
- DISPATCH_2 (FLOAT, BIGFLOAT, f, F);
- DISPATCH_1 (BIGFLOAT, F);
- default:
- return (UNBOUND);
- }
- #undef DISPATCH_1
- #undef DISPATCH_2
- /* Instead of doing (x - y), we performed (y - x), so we now have to
- * negate the result. We can do this in-place, since the return value
- * can only be seen by us. */
- if (fixint_p (ret))
- (void)neg_i (interp, ret);
- else if (varobj_p (ret))
- #ifdef KP_ARCH_WIDE
- ret ^= SIGN_BIT;
- #else
- switch (itype (ret))
- {
- case typecode::BIGINT:
- inplace_neg (as_bigint(ret)->len);
- break;
- case typecode::FLOAT:
- inplace_neg (as_fltobj(ret)->val);
- break;
- case typecode::BIGFLOAT:
- inplace_neg (as_bigfloat(ret)->len);
- break;
- }
- #endif
- kp_return (ret);
- }
- result<object> sub (interpreter *interp, object x, object y)
- {
- return (call_binary (interp, x, y, sub_helper, "g-sub"));
- }
- static result<object>
- mul_helper (interpreter *interp, object x, object y)
- {
- object ret;
- switch (MIX (itype (x), itype (y)))
- {
- #define DISPATCH_1(type, suffix) \
- case MIX (typecode::type, typecode::type): \
- ret = KP_TRY (mul_##suffix##suffix (interp, x, y)); \
- return (ret)
- #define DISPATCH_2(t1, t2, s1, s2) \
- case MIX (typecode::t1, typecode::t2): \
- ret = KP_TRY (mul_##s1##s2 (interp, x, y)); \
- return (ret); \
- case MIX (typecode::t2, typecode::t1): \
- ret = KP_TRY (mul_##s1##s2 (interp, y, x)); \
- return (ret)
- DISPATCH_1 (INT, i);
- DISPATCH_2 (INT, BIGINT, i, I);
- DISPATCH_2 (INT, FLOAT, i, f);
- DISPATCH_2 (INT, BIGFLOAT, i, F);
- DISPATCH_2 (INT, CHAR, i, c);
- DISPATCH_2 (INT, ARRAY, i, a);
- DISPATCH_2 (INT, BVECTOR, i, b);
- DISPATCH_2 (INT, STR, i, s);
- DISPATCH_1 (BIGINT, I);
- DISPATCH_2 (BIGINT, FLOAT, I, f);
- DISPATCH_2 (BIGINT, BIGFLOAT, I, F);
- DISPATCH_1 (FLOAT, f);
- DISPATCH_2 (FLOAT, BIGFLOAT, f, F);
- DISPATCH_1 (BIGFLOAT, F);
- default:
- return (UNBOUND);
- }
- #undef DISPATCH_1
- #undef DISPATCH_2
- }
- result<object> mul (interpreter *interp, object x, object y)
- {
- return (call_binary (interp, x, y, mul_helper, "g-mul"));
- }
- static result<object>
- div_helper (interpreter *interp, object x, object y)
- {
- object ret;
- switch (MIX (itype (x), itype (y)))
- {
- #define DISPATCH_1(type, suffix) \
- case MIX (typecode::type, typecode::type): \
- ret = KP_TRY (div_##suffix##suffix (interp, x, y)); \
- return (ret)
- #define DISPATCH_2(t1, t2, s1, s2) \
- case MIX (typecode::t1, typecode::t2): \
- ret = KP_TRY (div_##s1##s2 (interp, x, y)); \
- return (ret); \
- case MIX (typecode::t2, typecode::t1): \
- ret = KP_TRY (div_##s2##s1 (interp, x, y)); \
- return (ret)
- DISPATCH_1 (INT, i);
- DISPATCH_2 (INT, BIGINT, i, I);
- DISPATCH_2 (INT, FLOAT, i, f);
- DISPATCH_2 (INT, BIGFLOAT, i, F);
- DISPATCH_1 (BIGINT, I);
- DISPATCH_2 (BIGINT, FLOAT, I, f);
- DISPATCH_2 (BIGINT, BIGFLOAT, I, F);
- DISPATCH_1 (FLOAT, f);
- DISPATCH_2 (FLOAT, BIGFLOAT, f, F);
- DISPATCH_1 (BIGFLOAT, F);
- default:
- return (UNBOUND);
- }
- #undef DISPATCH_1
- #undef DISPATCH_2
- }
- result<object> div (interpreter *interp, object x, object y)
- {
- return (call_binary (interp, x, y, div_helper, "g-div"));
- }
- result<object> modulo (interpreter *interp, object x, object y)
- {
- object ret;
- switch (MIX (itype (x), itype (y)))
- {
- #define DISPATCH_1(type, suffix) \
- case MIX (typecode::type, typecode::type): \
- ret = KP_TRY (mod_##suffix##suffix (interp, x, y)); \
- return (ret)
- #define DISPATCH_2(t1, t2, s1, s2) \
- case MIX (typecode::t1, typecode::t2): \
- ret = KP_TRY (mod_##s1##s2 (interp, x, y)); \
- return (ret); \
- case MIX (typecode::t2, typecode::t1): \
- ret = KP_TRY (mod_##s2##s1 (interp, x, y)); \
- return (ret)
- DISPATCH_1 (INT, i);
- DISPATCH_2 (INT, BIGINT, i, I);
- DISPATCH_2 (INT, FLOAT, i, f);
- DISPATCH_2 (INT, BIGFLOAT, i, F);
- DISPATCH_1 (BIGINT, I);
- DISPATCH_2 (BIGINT, FLOAT, I, f);
- DISPATCH_2 (BIGINT, BIGFLOAT, I, F);
- DISPATCH_1 (FLOAT, f);
- DISPATCH_2 (FLOAT, BIGFLOAT, f, F);
- DISPATCH_1 (BIGFLOAT, F);
- default:
- return (invalid_arg (interp, "mod"));
- }
- #undef DISPATCH_1
- #undef DISPATCH_2
- }
- result<bool> equal (interpreter *interp, object x, object y)
- {
- if (x == y)
- // Identical objects compare equal iff they're not NaN or INF.
- return (x != FLT_QNAN && x != FLT_PINF && x != FLT_NINF);
- #define eq_ii(interp, x, y) false
- #define eq_cc(interp, x, y) false
- bool ret = false;
- switch (MIX (itype (x), itype (y)))
- {
- #define DISPATCH_1(type, suffix) \
- case MIX (typecode::type, typecode::type): \
- ret = KP_TRY (eq_##suffix##suffix (interp, x, y)); \
- return (ret)
- #define DISPATCH_2(t1, t2, s1, s2) \
- case MIX (typecode::t1, typecode::t2): \
- ret = KP_TRY (eq_##s1##s2 (interp, x, y)); \
- return (ret); \
- case MIX (typecode::t2, typecode::t1): \
- ret = KP_TRY (eq_##s1##s2 (interp, y, x)); \
- return (ret)
- DISPATCH_1 (INT, i);
- DISPATCH_2 (INT, FLOAT, i, f);
- DISPATCH_1 (BIGINT, I);
- DISPATCH_2 (BIGINT, FLOAT, I, f);
- DISPATCH_2 (BIGINT, BIGFLOAT, I, F);
- DISPATCH_1 (FLOAT, f);
- DISPATCH_1 (BIGFLOAT, F);
- DISPATCH_1 (BVECTOR, b);
- DISPATCH_2 (BVECTOR, STR, b, s);
- DISPATCH_1 (STR, s);
- DISPATCH_1 (ARRAY, a);
- DISPATCH_1 (CONS, L);
- DISPATCH_1 (CHAR, c);
- DISPATCH_1 (FCT, x);
- default:
- // XXX: Custom types.
- return (invalid_arg (interp, "equal"));
- }
- #undef eq_ii
- #undef eq_cc
- #undef DISPATCH_1
- #undef DISPATCH_2
- }
- result<int> xcmp (interpreter *interp, object x, object y)
- {
- if (x == y)
- return (x != FLT_QNAN ? 0 : -1);
- int ret;
- switch (MIX (itype (x), itype (y)))
- {
- #define DISPATCH_1(type, suffix) \
- case MIX (typecode::type, typecode::type): \
- ret = KP_TRY (cmp_##suffix##suffix (interp, x, y)); \
- return (ret)
- #define DISPATCH_2(t1, t2, s1, s2) \
- case MIX (typecode::t1, typecode::t2): \
- ret = KP_TRY (cmp_##s1##s2 (interp, x, y)); \
- return (ret); \
- case MIX (typecode::t2, typecode::t1): \
- ret = KP_TRY (cmp_##s1##s2 (interp, y, x)); \
- return (-ret)
- DISPATCH_1 (INT, i);
- DISPATCH_2 (INT, BIGINT, i, I);
- DISPATCH_2 (INT, FLOAT, i, f);
- DISPATCH_2 (INT, BIGFLOAT, i, F);
- DISPATCH_1 (BIGINT, I);
- DISPATCH_2 (BIGINT, FLOAT, I, f);
- DISPATCH_2 (BIGINT, BIGFLOAT, I, F);
- DISPATCH_1 (FLOAT, f);
- DISPATCH_2 (FLOAT, BIGFLOAT, f, F);
- DISPATCH_1 (BIGFLOAT, F);
- DISPATCH_1 (ARRAY, a);
- DISPATCH_1 (CONS, L);
- DISPATCH_1 (BVECTOR, b);
- DISPATCH_2 (BVECTOR, STR, b, s);
- DISPATCH_1 (STR, s);
- default:
- // XXX: Custom types.
- return (x < y ? -1 : 1);
- }
- #undef DISPATCH_1
- #undef DISPATCH_2
- }
- #define DEFBUILTIN(name) \
- result<object> name (interpreter *interp, object *argv, int argc)
- // (car arg)
- static DEFBUILTIN (car_fct)
- {
- cons *cnp = as<cons> (*argv);
- if (!cnp)
- return (interp->raise ("type-error", "car: value is not a cons"));
- kp_return (cnp->car);
- }
- // (cdr arg)
- static DEFBUILTIN (cdr_fct)
- {
- cons *cnp = as<cons> (*argv);
- if (!cnp)
- return (interp->raise ("type-error", "cdr: value is not a cons"));
- kp_return (cnp->cdr);
- }
- // (cons arg1 arg2)
- static DEFBUILTIN (cons_fct)
- {
- return (cons::make (interp, argv[0], argv[1]));
- }
- // (list [...args])
- DEFBUILTIN (list_fct)
- {
- if (argc == 0)
- kp_return (NIL);
- KP_VTRY (alloc_cons (interp, argc, argv, nullptr));
- kp_return (interp->alval);
- }
- // (list* arg1 [...args])
- DEFBUILTIN (list_star)
- {
- if (argc == 1)
- kp_return (*argv);
- object *tail, lst = KP_TRY (alloc_cons (interp, argc - 1, argv, &tail));
- *tail = argv[argc - 1];
- kp_return (lst);
- }
- // (+ [...args])
- DEFBUILTIN (add_fct)
- {
- if (argc == 0)
- kp_return (fixint (0));
- else if (argc == 1)
- {
- object tmp = *argv;
- switch (itype (tmp))
- {
- case typecode::INT:
- case typecode::FLOAT:
- case typecode::BIGINT:
- case typecode::BIGFLOAT:
- kp_return (tmp);
- default:
- // XXX: Custom types.
- return (invalid_arg (interp, "+"));
- }
- }
- valref rv (interp, *argv);
- for (int i = 1; i < argc; ++i)
- { *rv = KP_TRY (add (interp, *rv, argv[i])); }
- kp_return (*rv);
- }
- // (- arg1 [...args])
- DEFBUILTIN (sub_fct)
- {
- if (argc == 1)
- {
- object tmp = *argv;
- switch (itype (tmp))
- {
- case typecode::INT:
- return (neg_i (interp, tmp));
- #ifdef KP_ARCH_WIDE
- case typecode::BIGINT:
- case typecode::FLOAT:
- case typecode::BIGFLOAT:
- kp_return (tmp ^ SIGN_BIT);
- #else
- case typecode::BIGINT:
- return (neg_I (interp, tmp));
- case typecode::FLOAT:
- return (neg_f (interp, tmp));
- case typecode::BIGFLOAT:
- return (neg_F (interp, tmp));
- #endif
- // XXX: Custom types.
- default:
- return (invalid_arg (interp, "-"));
- }
- }
- valref rv (interp, *argv);
- for (int i = 1; i < argc; ++i)
- { *rv = KP_TRY (sub (interp, *rv, argv[i])); }
- kp_return (*rv);
- }
- // (* [...args])
- DEFBUILTIN (mul_fct)
- {
- if (argc == 0)
- kp_return (fixint (1));
- valref rv (interp, *argv);
- for (int i = 1; i < argc; ++i)
- { *rv = KP_TRY (mul (interp, *rv, argv[i])); }
- kp_return (*rv);
- }
- // (/ arg1 [...args])
- DEFBUILTIN (div_fct)
- {
- if (argc == 1)
- return (div (interp, fixint (1), *argv));
- valref rv (interp, *argv);
- for (int i = 1; i < argc; ++i)
- { *rv = KP_TRY (div (interp, *rv, argv[i])); }
- kp_return (*rv);
- }
- // (lsh x shift)
- DEFBUILTIN (lsh_fct)
- {
- switch (itype (*argv))
- {
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- return (lsh_##suffix##i (interp, argv[0], argv[1]))
- DISPATCH (INT, i);
- DISPATCH (BIGINT, I);
- DISPATCH (FLOAT, f);
- DISPATCH (BIGFLOAT, F);
- default:
- if (bigint_p (argv[1]))
- return (interp->raise ("arith-error", "shift overflow"));
- return (invalid_arg (interp, "lsh"));
- }
- #undef DISPATCH
- }
- // (rsh x shift)
- DEFBUILTIN (rsh_fct)
- {
- switch (itype (*argv))
- {
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- return (rsh_##suffix##i (interp, argv[0], argv[1]))
- DISPATCH (INT, i);
- DISPATCH (BIGINT, I);
- DISPATCH (FLOAT, f);
- DISPATCH (BIGFLOAT, F);
- default:
- if (bigint_p (argv[1]))
- return (interp->raise ("arith-error", "shift overflow"));
- return (invalid_arg (interp, "rsh"));
- }
- #undef DISPATCH
- }
- // (< arg1 [...args])
- DEFBUILTIN (lt_fct)
- {
- for (int i = 0; i < argc - 1; ++i)
- {
- int c = KP_TRY (xcmp (interp, argv[i], argv[i + 1]));
- if (c >= 0)
- kp_return (NIL);
- }
- kp_return (symbol::t);
- }
- // (> arg1 [...args])
- DEFBUILTIN (gt_fct)
- {
- for (int i = 0; i < argc - 1; ++i)
- {
- int c = KP_TRY (xcmp (interp, argv[i], argv[i + 1]));
- if (c <= 0)
- kp_return (NIL);
- }
- kp_return (symbol::t);
- }
- // (<= arg1 [...args])
- DEFBUILTIN (lte_fct)
- {
- for (int i = 0; i < argc - 1; ++i)
- {
- int c = KP_TRY (xcmp (interp, argv[i], argv[i + 1]));
- if (c > 0)
- kp_return (NIL);
- }
- kp_return (symbol::t);
- }
- // (>= arg1 [...args])
- DEFBUILTIN (gte_fct)
- {
- for (int i = 0; i < argc - 1; ++i)
- {
- int c = KP_TRY (xcmp (interp, argv[i], argv[i + 1]));
- if (c < 0)
- kp_return (NIL);
- }
- kp_return (symbol::t);
- }
- // (!= arg1 [...args])
- DEFBUILTIN (ne_fct)
- {
- for (int i = 0; i < argc - 1; ++i)
- {
- int c = KP_TRY (xcmp (interp, argv[i], argv[i + 1]));
- if (c == 0)
- kp_return (NIL);
- }
- kp_return (symbol::t);
- }
- // (nputcar val lst)
- static DEFBUILTIN (nputcar_fct)
- {
- cons *cnp = as<cons> (argv[1]);
- if (!cnp || cnp == as_cons (NIL))
- return (interp->raise ("type-error", "value is not a cons"));
- return (nputcar (interp, cnp->as_obj (), argv[0]));
- }
- // (nputcdr val lst)
- static DEFBUILTIN (nputcdr_fct)
- {
- cons *cnp = as<cons> (argv[1]);
- if (!cnp || cnp == as_cons (NIL))
- return (interp->raise ("type-error", "value is not a cons"));
- return (nputcdr (interp, cnp->as_obj (), argv[0]));
- }
- // (is x y)
- static DEFBUILTIN (is_fct)
- {
- kp_return (argv[0] == argv[1] ? symbol::t : NIL);
- }
- // (= x y [...args])
- static DEFBUILTIN (eq_fct)
- {
- for (int i = 0; i < argc - 1; ++i)
- {
- bool rv = KP_TRY (equal (interp, argv[i], argv[i + 1]));
- if (!rv)
- kp_return (NIL);
- }
- kp_return (symbol::t);
- }
- // (array [...args])
- DEFBUILTIN (array_fct)
- {
- object ret = KP_TRY (alloc_array (interp, argc));
- copy_objs (&xaref(ret, 0), argv, argc);
- kp_return (ret);
- }
- // (tuple test_fn [...args])
- DEFBUILTIN (tuple_fct)
- {
- valref ret = KP_TRY (alloc_tuple (interp, *argv));
- for (int i = 1; i < argc; ++i)
- KP_VTRY (tuple_put (interp, *ret, argv[i], false));
- kp_return (*ret);
- }
- // (%putd symbol code definition)
- DEFBUILTIN (p_putd)
- {
- if (!fixint_p (argv[1]))
- return (interp->raise ("type-error", "second argument must be an integer"));
- else if (!symbol_p (*argv))
- return (interp->raise ("type-error", "first argument must be a symbol"));
- else if (as_symbol(*argv)->flagged_p (FLAGS_CONST))
- return (interp->raise ("const-error", "cannot assign to a constant"));
- uint32_t eflags = 0;
- int type = as_int (argv[1]);
- switch (type)
- {
- case 0: // function.
- case 5: // regular symbol.
- break;
- case 6: // literal.
- eflags |= symbol::literal_flag;
- // FALLTHROUGH.
- case 1: // constant.
- eflags |= FLAGS_CONST;
- break;
- case 2: // special variable.
- eflags |= symbol::special_flag;
- break;
- case 3: // macro.
- eflags |= symbol::ctv_flag;
- break;
- case 4: // alias.
- eflags |= symbol::alias_flag;
- break;
- default:
- return (interp->raise ("arg-error", "invalid code specified"));
- }
- if (type == 0 || type == 3)
- {
- function *fp = as<function> (argv[2]);
- if (!fp)
- return (interp->raise ("type-error", "argument must be a function"));
- if (nil_p (fp->name))
- // Mutate the argument and set the name.
- fp->name = *argv;
- else
- { // Copy the function with the new name.
- KP_VTRY (alloc_fct (interp));
- function *f2 = as_fct (interp->alval);
- fp->copy_into (f2);
- f2->name = *argv;
- argv[2] = f2->as_obj ();
- }
- }
- symval(*argv) = argv[2];
- if (eflags)
- {
- symbol *sp = as_symbol (*argv);
- sp->cas_flag (symbol::special_flag | symbol::ctv_flag |
- symbol::alias_flag, eflags);
- if ((eflags & symbol::special_flag) && !sp->tl_idx)
- { sp->tl_idx = KP_TRY (symbol::alloc_tl_idx (interp)); }
- }
- kp_return (argv[2]);
- }
- static inline object
- strm_out (interpreter *interp)
- {
- object obj = find_sym (interp, "*out*", 5);
- return (symbol_p (obj) ? symval (interp, obj) : out_stream);
- }
- static result<object>
- print_helper (interpreter *interp, object strm,
- object *argv, int argc, bool nl)
- {
- stream *out = as<stream> (strm);
- stream_guard sg { interp, nullptr };
- auto lg = KP_TRY (lock_guard::make (interp));
- if (out)
- ;
- else if (string *sp = as<string> (strm))
- {
- *sg = out = KP_TRY (strstream (interp, sp->as_obj (),
- STRM_WRITE | STRM_APP | STRM_NOLOCK));
- }
- else
- return (interp->raise ("type-error",
- "output argument must be a string or stream"));
- if (!singlethr_p () && !sg.strmp)
- KP_VTRY (lg.set (as_lock (out->ilock)));
- io_info info { io_info::FLG_RAW };
- interp->retval = symbol::t;
- for (int i = 0; i < argc; ++i)
- {
- int64_t rv = KP_TRY (xwrite (interp, out, argv[i], info));
- if (rv < 0)
- {
- interp->retval = NIL;
- break;
- }
- }
- if (nl && !nil_p (interp->retval))
- {
- int b = KP_TRY (out->putb (interp, '\n'));
- if (b < 0)
- interp->retval = NIL;
- }
- if (sg.strmp)
- KP_VTRY (sstream_get (interp, sg.strmp));
- return (interp->retval);
- }
- // (print-to stream arg1 [...args])
- static DEFBUILTIN (print_to_fct)
- {
- return (print_helper (interp, *argv, argv + 1, argc - 1, false));
- }
- // (say-to stream [...args])
- static DEFBUILTIN (say_to_fct)
- {
- return (print_helper (interp, *argv, argv + 1, argc - 1, true));
- }
- // (print arg1 [...args])
- static DEFBUILTIN (print_fct)
- {
- return (print_helper (interp, strm_out (interp), argv, argc, false));
- }
- // (say [...args])
- static DEFBUILTIN (say_fct)
- {
- return (print_helper (interp, strm_out (interp), argv, argc, true));
- }
- // (copy obj [deep])
- static DEFBUILTIN (copy_fct)
- {
- return (copy (interp, *argv, argc == 2 && !nil_p (argv[1])));
- }
- // (reverse obj)
- DEFBUILTIN (reverse_fct)
- {
- object ret;
- switch (itype (*argv))
- {
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- ret = KP_TRY (reverse_##suffix (interp, *argv)); \
- return (ret)
- DISPATCH (ARRAY, a);
- DISPATCH (BVECTOR, b);
- DISPATCH (STR, s);
- DISPATCH (CONS, L);
- default:
- return (invalid_arg (interp, "reverse"));
- #undef DISPATCH
- }
- }
- // (nreverse obj)
- DEFBUILTIN (nreverse_fct)
- {
- object ret;
- switch (itype (*argv))
- {
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- ret = KP_TRY (nreverse_##suffix (interp, *argv)); \
- return (ret)
- DISPATCH (ARRAY, a);
- DISPATCH (BVECTOR, b);
- DISPATCH (CONS, L);
- default:
- return (invalid_arg (interp, "nreverse"));
- #undef DISPATCH
- }
- }
- // (nput sequence key value)
- DEFBUILTIN (nput_fct)
- {
- object ret;
- switch (itype (*argv))
- {
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- ret = KP_TRY (nput_##suffix (interp, argv[0], argv[1], argv[2])); \
- return (ret)
- DISPATCH (ARRAY, a);
- DISPATCH (BVECTOR, b);
- DISPATCH (CONS, L);
- DISPATCH (TABLE, u);
- DISPATCH (TUPLE, o);
- DISPATCH (PKG, P);
- DISPATCH (INSTANCE, w);
- default:
- return (invalid_arg (interp, "nput"));
- #undef DISPATCH
- }
- }
- // (disasm function [stream])
- static DEFBUILTIN (disasm_fct)
- {
- object out;
- bool allocated = false;
- if (argc < 2)
- {
- out = strm_out (interp);
- if (str_p (out))
- {
- auto tmp = KP_TRY (strstream (interp, out, STRM_WRITE |
- STRM_APP | STRM_NOLOCK));
- out = tmp->as_obj ();
- allocated = true;
- }
- }
- else
- out = argv[1];
- KP_VTRY (disasm (interp, *argv, out));
- if (allocated)
- {
- stream *ostr = as_stream (out);
- KP_VTRY (sstream_get (interp, ostr));
- deref (ostr->close (interp));
- }
- else
- interp->retval = symbol::t;
- return (interp->retval);
- }
- // (not obj)
- static DEFBUILTIN (not_fct)
- {
- kp_return (nil_p (*argv) ? *argv : symbol::t);
- }
- // (len obj)
- static DEFBUILTIN (len_fct)
- {
- interp->retval = KP_TRY (length (interp, *argv));
- return (interp->retval);
- }
- struct custom_comparator : public comparator
- {
- object cb;
- custom_comparator (interpreter *ip, object obj) : comparator (ip), cb (obj)
- {
- }
- result<bool> operator() (object x, object y)
- {
- KP_VTRY (this->interp->growstk (3));
- *this->interp->stkend++ = this->cb;
- *this->interp->stkend++ = x;
- *this->interp->stkend++ = y;
- KP_VTRY (call_n (this->interp, 2));
- return (interp->retval != NIL);
- }
- };
- // (nsort seq [comparison])
- DEFBUILTIN (nsort_fct)
- {
- lazy<comparator> c1;
- lazy<custom_comparator> c2;
- comparator *cx;
- if (argc == 1)
- cx = new (c1.ptr ()) comparator (interp);
- else
- cx = new (c2.ptr ()) custom_comparator (interp, argv[1]);
- switch (itype (*argv))
- {
- case typecode::CONS:
- KP_VTRY (nsort_L (interp, *argv, *cx));
- case typecode::ARRAY:
- KP_VTRY (nsort_a (interp, *argv, *cx));
- case typecode::TUPLE:
- kp_return (*argv);
- default:
- return (invalid_arg (interp, "nsort"));
- }
- return (interp->retval);
- }
- // (subseq seq arg-1 [arg-2])
- DEFBUILTIN (subseq_fct)
- {
- object i2 = argc == 3 ? argv[2] : UNBOUND, ret;
- switch (itype (*argv))
- {
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- ret = KP_TRY (subseq_##suffix (interp, argv[0], argv[1], i2)); \
- return (ret)
- DISPATCH (CONS, L);
- DISPATCH (ARRAY, a);
- DISPATCH (BVECTOR, b);
- DISPATCH (STR, s);
- default:
- return (invalid_arg (interp, "subseq"));
- #undef DISPATCH
- }
- }
- // (concat [...args])
- DEFBUILTIN (concat_fct)
- {
- if (argc == 0)
- kp_return (NIL);
- object ret;
- switch (itype (*argv))
- {
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- ret = KP_TRY (concat_##suffix (interp, argv, argc)); \
- return (ret)
- DISPATCH (CONS, L);
- DISPATCH (ARRAY, a);
- DISPATCH (BVECTOR, b);
- DISPATCH (STR, s);
- default:
- return (invalid_arg (interp, "concat"));
- #undef DISPATCH
- }
- }
- // (nrevconc obj)
- static DEFBUILTIN (nrevconc_fct)
- {
- return (nrevconc (interp, *argv, argv[1]));
- }
- // (load path)
- DEFBUILTIN (load_fct)
- {
- object path = *argv;
- if (!str_p (path))
- return (interp->raise ("type-error", "path must be a string"));
- auto fptr = KP_TRY (fstream_open (interp, str_cdata (path), "r"));
- if (!fptr)
- // XXX: Report why the file couldn't be opened.
- return (interp->raise ("load-error",
- KP_SPRINTF (interp,
- "could not open file '%Q'", path)));
- stream_guard sg { interp, fptr };
- reader rd (interp, sg.as_obj ());
- while (true)
- {
- object expr = KP_TRY (rd.read_sexpr ());
- if (expr == EOS)
- break;
- KP_VTRY (eval (interp, expr));
- }
- kp_return (symbol::t);
- }
- // (macroexp-1 expr)
- static DEFBUILTIN (macroexp_1_fct)
- {
- return (macroexp_1 (interp, *argv));
- }
- // (macroexp expr)
- static DEFBUILTIN (macroexp_fct)
- {
- return (macroexp (interp, *argv));
- }
- // (coro-val coroutine)
- static DEFBUILTIN (coro_val)
- {
- auto cnp = as<coroutine> (*argv);
- if (!cnp)
- return (interp->raise ("type-error", "argument must be a coroutine"));
- kp_return (cnp->value);
- }
- // (symname symbol)
- static DEFBUILTIN (symname_fct)
- {
- symbol *sym = as<symbol> (*argv);
- if (!sym)
- return (interp->raise ("type-error", "argument must be a symbol"));
- kp_return (sym->name);
- }
- // (symval symbol [default-value])
- static DEFBUILTIN (symval_fct)
- {
- symbol *sym = as<symbol> (*argv);
- if (!sym)
- return (interp->raise ("type-error", "first argument must be a symbol"));
- object ret = sym->value;
- if (ret != UNBOUND)
- kp_return (ret);
- else if (argc == 2)
- kp_return (argv[1]);
- else
- return (interp->raise ("unbound-error",
- KP_SPRINTF (interp, "symbol %Q has no value",
- sym->as_obj ())));
- }
- // (sympkg symbol)
- static DEFBUILTIN (sympkg_fct)
- {
- symbol *sym = as<symbol> (*argv);
- if (!sym)
- return (interp->raise ("type-error", "argument must be a symbol or nil"));
- kp_return (sym->pkg);
- }
- // (%use name (:as alias) (:pull (:all symbols...)))
- static DEFBUILTIN (p_use_fct)
- {
- object a1 = argc < 2 ? NIL : argv[1];
- object a2 = argc < 3 ? NIL : argv[2];
- return (pull_pkg (interp, *argv, a1, a2));
- }
- // (%gc)
- static DEFBUILTIN (p_gc)
- {
- KP_VTRY (gc (false));
- kp_return (NIL);
- }
- // (%iter sequence token [advance])
- static DEFBUILTIN (p_iter)
- {
- object token = argc < 2 ? UNBOUND : argv[1], ret;
- bool adv = argc == 3 && !nil_p (argv[2]);
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- ret = KP_TRY (iter_##suffix (interp, *argv, token, adv)); \
- return (ret)
- switch (itype (*argv))
- {
- DISPATCH (ARRAY, a);
- DISPATCH (CONS, L);
- DISPATCH (BVECTOR, b);
- DISPATCH (STR, s);
- DISPATCH (TABLE, u);
- DISPATCH (TUPLE, o);
- default:
- // XXX: Custom types
- return (invalid_arg (interp, "%iter"));
- }
- #undef DISPATCH
- }
- // (macro-fct symbol)
- static DEFBUILTIN (macro_fct)
- {
- object sym = *argv;
- if (!symbol_p (sym))
- return (interp->raise ("type-error", "argument must be a symbol"));
- else if (!as_symbol(sym)->flagged_p (symbol::ctv_flag))
- kp_return (NIL);
- sym = symval (sym);
- kp_return (fct_p (sym) ? sym : NIL);
- }
- // (nzap sequence key flags fn [...args])
- DEFBUILTIN (nzap_fct)
- {
- uint32_t flags = (fixint_p (argv[2]) ? as_int (argv[2]) : 0) |
- (singlethr_p () ? NZAP_NOMT : 0);
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- KP_VTRY (nzap_##suffix (interp, argv[0], argv[1], flags, \
- argv[3], &argv[4], argc - 4)); \
- return (interp->retval)
- switch (itype (*argv))
- {
- DISPATCH (ARRAY, a);
- DISPATCH (CONS, L);
- DISPATCH (TABLE, u);
- DISPATCH (TUPLE, o);
- DISPATCH (PKG, P);
- default:
- return (invalid_arg (interp, "nzap"));
- }
- #undef DISPATCH
- }
- // (intern string [package])
- static DEFBUILTIN (intern_fct)
- {
- string *name = as<string> (*argv);
- if (!name)
- return (interp->raise ("type-error", "first argument must be a string"));
- package *p = nullptr;
- if (argc == 1)
- ;
- else if (!(p = as<package> (argv[1])))
- return (interp->raise ("type-error", "second argument must be a package"));
- return (intern (interp, name, p));
- }
- // (fct-name function)
- static DEFBUILTIN (fct_name_fct)
- {
- object fn = *argv;
- if (!fct_p (fn))
- return (interp->raise ("type-error", "argument must be a function"));
- kp_return (fct_name (fn));
- }
- // (type object [parents slot-definitions])
- static DEFBUILTIN (type_fct)
- {
- if (argc == 1)
- kp_return (type (argv[0]));
- else if (argc == 2)
- return (type (interp, argv[0], argv[1], NIL));
- else
- return (type (interp, argv[0], argv[1], argv[2]));
- }
- // (make type [...args])
- DEFBUILTIN (make_fct)
- {
- KP_VTRY (alloc_inst (interp, *argv, argv + 1, argc - 1));
- kp_return (interp->alval);
- }
- // (isa object type1 [...types])
- static DEFBUILTIN (isa_fct)
- {
- for (int i = 1; i < argc; ++i)
- {
- int rv = instanceof (*argv, argv[i]);
- if (rv < 0)
- return (interp->raise ("type-error", "argument must be a typespec"));
- else if (rv)
- kp_return (symbol::t);
- }
- kp_return (NIL);
- }
- // (%symtst symbol code)
- static DEFBUILTIN (p_symtst)
- {
- int code;
- const symbol *sym = as<symbol> (*argv);
- if (!sym)
- return (interp->raise ("type-error", "first argument must be a symbol"));
- else if (!as<int> (argv[1], code))
- return (interp->raise ("type-error", "second argument must be an integer"));
- else if (code == 6)
- kp_return (sym->value != UNBOUND &&
- !sym->flagged_p (symbol::ctv_flag | symbol::alias_flag) ?
- symbol::t : NIL);
- const uint32_t flags[] =
- {
- FLAGS_CONST,
- symbol::specform_flag,
- symbol::special_flag,
- symbol::ctv_flag,
- symbol::alias_flag,
- symbol::literal_flag
- };
- if (code < 0 || code >= (int)KP_NELEM (flags))
- return (interp->raise ("arg-error", "invalid code"));
- kp_return (sym->flagged_p (flags[code]) ? symbol::t : NIL);
- }
- // (last sequence)
- static DEFBUILTIN (last_fct)
- {
- object obj = *argv, ret;
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- ret = KP_TRY (last_##suffix (interp, obj)); \
- return (ret)
- switch (itype (obj))
- {
- DISPATCH (CONS, L);
- DISPATCH (ARRAY, a);
- DISPATCH (BVECTOR, b);
- DISPATCH (STR, s);
- default:
- return (invalid_arg (interp, "last"));
- }
- #undef DISPATCH
- }
- // (last-err [include-traceback])
- static DEFBUILTIN (last_err_fct)
- {
- if (argc == 1 && !nil_p (*argv) && !nil_p (interp->last_err))
- {
- object ret = KP_TRY (alloc_cons (interp, 2));
- xcar(ret) = interp->last_err;
- xcar(xcdr (ret)) = interp->last_tb;
- kp_return (ret);
- }
- kp_return (interp->last_err);
- }
- static DEFBUILTIN (find_fct)
- {
- object obj = argv[0], key = argv[1], ret;
- object start = UNBOUND, end = UNBOUND, test = UNBOUND;
- KP_VTRY (kwargs_parse (interp, argv + 2, argc - 2, "start", &start,
- "end", &end, "test", &test));
- #define DISPATCH(type, suffix) \
- case typecode::type: \
- ret = KP_TRY (find_##suffix (interp, obj, key, start, end, test)); \
- return (ret)
- switch (itype (obj))
- {
- DISPATCH (CONS, L);
- DISPATCH (ARRAY, a);
- DISPATCH (BVECTOR, b);
- DISPATCH (STR, s);
- default:
- return (invalid_arg (interp, "find"));
- }
- #undef DISPATCH
- }
- // Names for the builtins.
- static const char BUILTIN_NAMES[] =
- "car\0"
- "cdr\0"
- "cons\0"
- "list\0"
- "list*\0"
- "+\0-\0*\0/\0"
- "<\0>\0<=\0>=\0!=\0"
- "lsh\0"
- "rsh\0"
- "nputcar\0"
- "nputcdr\0"
- "apply\0"
- "is\0=\0"
- "array\0"
- "table\0"
- "tuple\0"
- "%putd\0"
- "gensym\0"
- "print-to\0"
- "say-to\0"
- "print\0"
- "say\0"
- "copy\0"
- "reverse\0"
- "nreverse\0"
- "nput\0"
- "disasm\0"
- "not\0"
- "len\0"
- "%fmt-str\0"
- "nsort\0"
- "subseq\0"
- "concat\0"
- "nconcat\0"
- "nrevconc\0"
- "load\0"
- "macroexp-1\0"
- "macroexp\0"
- "coro-val\0"
- "coro-next\0"
- "symname\0"
- "symval\0"
- "sympkg\0"
- "%use\0"
- "%gc\0"
- "%iter\0"
- "exit\0"
- "macro-fct\0"
- "nzap\0"
- "intern\0"
- "fct-name\0"
- "type\0"
- "make\0"
- "isa\0"
- "%symtst\0"
- "last\0"
- "last-err\0"
- "%meth-ctl\0"
- "find\0"
- ;
- // List of builtins.
- struct builtin_entry
- {
- native_function::fn_type fn;
- int8_t min_argc;
- int8_t max_argc;
- };
- static const builtin_entry BUILTINS[] =
- {
- { car_fct, 1, 1 },
- { cdr_fct, 1, 1 },
- { cons_fct, 2, 2 },
- { list_fct, 0, -1 },
- { list_star, 1, -1 },
- { add_fct, 0, -1 },
- { sub_fct, 1, -1 },
- { mul_fct, 0, -1 },
- { div_fct, 0, -1 },
- { lt_fct, 1, -1 },
- { gt_fct, 1, -1 },
- { lte_fct, 1, -1 },
- { gte_fct, 1, -1 },
- { ne_fct, 1, -1 },
- { lsh_fct, 2, 2 },
- { rsh_fct, 2, 2 },
- { nputcar_fct, 2, 2 },
- { nputcdr_fct, 2, 2 },
- { apply_fct, 2, -1 },
- { is_fct, 2, 2 },
- { eq_fct, 2, -1 },
- { array_fct, 0, -1 },
- { table_fct, 2, -1 },
- { tuple_fct, 1, -1 },
- { p_putd, 3, 3 },
- { gensym, 0, 0 },
- { print_to_fct, 2, -1 },
- { say_to_fct, 1, -1 },
- { print_fct, 1, -1 },
- { say_fct, 0, -1 },
- { copy_fct, 1, 2 },
- { reverse_fct, 1, 1 },
- { nreverse_fct, 1, 1 },
- { nput_fct, 3, 3 },
- { disasm_fct, 1, 2 },
- { not_fct, 1, 1 },
- { len_fct, 1, 1 },
- { p_fmt_str, 1, -1 },
- { nsort_fct, 1, 2 },
- { subseq_fct, 2, 3 },
- { concat_fct, 0, -1 },
- { nconcat, 0, -1 },
- { nrevconc_fct, 2, 2 },
- { load_fct, 1, 1 },
- { macroexp_1_fct, 1, 1 },
- { macroexp_fct, 1, 1 },
- { coro_val, 1, 1 },
- { coro_next, 1, 2 },
- { symname_fct, 1, 1 },
- { symval_fct, 1, 2 },
- { sympkg_fct, 1, 1 },
- { p_use_fct, 1, 3 },
- { p_gc, 0, -1 },
- { p_iter, 1, 3 },
- { exit_fct, 0, 1 },
- { macro_fct, 1, 1 },
- { nzap_fct, 4, -1 },
- { intern_fct, 1, 2 },
- { fct_name_fct, 1, 1 },
- { type_fct, 1, 3 },
- { make_fct, 1, -1 },
- { isa_fct, 2, -1 },
- { p_symtst, 2, 2 },
- { last_fct, 1, 1 },
- { last_err_fct, 0, 1 },
- { p_meth_ctl, 1, -1 },
- { find_fct, 2, 6 },
- };
- static native_function global_builtins[KP_NELEM (BUILTINS)];
- object symbol::fast_global_syms[KP_NELEM (BUILTINS) + symbol::N_SPECFORMS + 1];
- indexer_t index_seq (object seq)
- {
- switch (itype (seq))
- {
- case typecode::CONS:
- return (get_L);
- case typecode::ARRAY:
- return (get_a);
- case typecode::BVECTOR:
- return (get_b);
- case typecode::STR:
- return (get_s);
- case typecode::TABLE:
- return (get_u);
- case typecode::TUPLE:
- return (get_o);
- case typecode::PKG:
- return (get_P);
- case typecode::INSTANCE:
- return (get_w);
- default:
- return (nullptr);
- }
- }
- builtin_iter::builtin_iter () : curp (BUILTIN_NAMES)
- {
- }
- void builtin_iter::adv ()
- {
- this->curp += strlen (this->curp) + 1;
- }
- bool builtin_iter::valid () const
- {
- return (*this->curp != 0);
- }
- int builtin_idx (interpreter *interp, const char *name)
- {
- int ix = 0;
- for (builtin_iter it; it.valid (); it.adv (), ++ix)
- if (strcmp (it.name (), name) == 0)
- return (ix + symbol::N_SPECFORMS);
- return (-1);
- }
- object builtin_fct (interpreter *interp, const char *name)
- {
- int ix = builtin_idx (interp, name) - symbol::N_SPECFORMS;
- return (ix < 0 ? UNBOUND : global_builtins[ix].as_obj ());
- }
- object builtin_fct (interpreter *interp, int ix)
- {
- return (ix < 0 || ix >= (int)KP_NELEM (BUILTINS) ?
- UNBOUND : global_builtins[ix].as_obj ());
- }
- static int
- do_init_builtins (interpreter *interp)
- {
- int ret = init_op::call_deps (interp, &init_symbols);
- if (ret != init_op::result_ok)
- return (ret);
- int ix = 0;
- for (builtin_iter it; it.valid (); it.adv (), ++ix)
- {
- auto *outp = ensure_mask (&global_builtins[ix]);
- outp->vo_full = function_base::native_flag;
- outp->vo_type = typecode::FCT;
- outp->fct = BUILTINS[ix].fn;
- outp->min_argc = BUILTINS[ix].min_argc;
- outp->max_argc = BUILTINS[ix].max_argc;
- auto rs = INTERN_N (it.name ());
- if (rs.error_p ())
- return (init_op::result_failed);
- object sym = outp->name = *rs;
- symval(sym) = outp->as_obj ();
- symbol::fast_global_syms[ix + symbol::N_SPECFORMS] = sym;
- }
- // Mark the end of the builtin symbols.
- symbol::fast_global_syms[KP_NELEM (BUILTINS) + symbol::N_SPECFORMS] = UNBOUND;
- return (ret);
- }
- init_op init_builtins (do_init_builtins, "builtins");
- #undef INTERN
- #undef INTERN_N
- KP_DECLS_END
|