123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717 |
- /* Definitions for the cons type.
- 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 "khipu.hpp"
- KP_DECLS_BEGIN
- static inline exception
- raise_circular (interpreter *interp)
- {
- return (interp->raise ("arg-error", "argument must not be circular"));
- }
- static inline exception
- raise_dotted (interpreter *interp)
- {
- return (interp->raise ("arg-error", "argument must not be dotted"));
- }
- int32_t len_L (interpreter *, object lst, object& dotc)
- {
- int ret = 0;
- cons::unsafe_iter it (lst);
- for (; it.valid (); ++it, ++ret);
- if (it.circular ())
- return (-1);
- dotc = it.node ();
- return (ret);
- }
- result<int32_t> len_L (interpreter *interp, object lst)
- {
- object tail;
- int ret = len_L (interp, lst, tail);
- if (tail != NIL && ret > 0)
- return (raise_dotted (interp));
- return (ret);
- }
- result<object> cons::make (interpreter *interp, object car, object cdr)
- {
- object ret = KP_TRY (alloc_cons (interp));
- cons *p = as_cons (ret);
- p->car = car, p->cdr = cdr;
- kp_return (ret);
- }
- result<object> nputcar (interpreter *interp, object lst, object obj)
- {
- xcar(lst) = obj;
- KP_VTRY (gc_wbarrier (interp, lst, obj));
- kp_return (lst);
- }
- result<object> nputcdr (interpreter *interp, object lst, object obj)
- {
- xcdr(lst) = obj;
- KP_VTRY (gc_wbarrier (interp, lst, obj));
- kp_return (lst);
- }
- static result<object>
- cons_ref (interpreter *interp, int idx, object& obj)
- {
- cons::unsafe_iter it (obj);
- if (idx < 0)
- {
- object tail;
- int rl = len_L (interp, obj, tail);
- if (rl < 0)
- return (raise_circular (interp));
- else if ((idx += rl) < 0)
- return (interp->raise_oob (0, -1));
- }
- for (; idx > 0 && it.valid (); --idx, ++it);
- if (!it.valid ())
- return (interp->raise_oob (0, -1));
- return (obj = it.node ());
- }
- result<object> nthcdr (interpreter *interp, object idx, object obj)
- {
- int iv;
- if (!as<int> (idx, iv))
- return (interp->raise ("type-error", "first argument must be an integer"));
- else if (!xcons_p (obj))
- return (interp->raise ("type-error", "second argument must be a cons"));
- object ret = KP_TRY (cons_ref (interp, iv, obj));
- kp_return (ret);
- }
- result<object> get_L (interpreter *interp, object obj, object idx, object dfl)
- {
- int iv;
- if (kp_unlikely (dfl != UNBOUND))
- return (interp->raise_nargs (2, 2, 3));
- else if (!as<int> (idx, iv))
- return (interp->raise ("type-error", "index is not an integer"));
- object ret = KP_TRY (cons_ref (interp, iv, obj));
- kp_return (xcar (ret));
- }
- result<object> nput_L (interpreter *interp, object obj, object idx, object val)
- {
- int iv;
- if (kp_unlikely (!as<int> (idx, iv)))
- return (interp->raise ("type-error", "index is not an integer"));
- object ret = KP_TRY (cons_ref (interp, iv, obj));
- KP_VTRY (nputcar (interp, ret, val));
- kp_return (val);
- }
- result<object> last_L (interpreter *interp, object lst)
- {
- cons::unsafe_iter it (lst);
- for (; cons_p (xcdr (it.node ())); ++it)
- if (it.circular ())
- return (raise_circular (interp));
- kp_return (it.node ());
- }
- static result<int>
- adjust_idx (interpreter *interp, object obj, int& ix, int *p)
- {
- object tail;
- int rl = len_L (interp, obj, tail);
- if (rl < 0)
- return (raise_circular (interp));
- ix += rl;
- if (p)
- *p += rl;
- return (0);
- }
- result<object> subseq_L (interpreter *interp, object obj,
- object ix1, object ix2)
- {
- if (ix2 == UNBOUND)
- {
- valref tmp = KP_TRY (nthcdr (interp, ix1, obj));
- return (copy (interp, *tmp, false));
- }
- int i1, i2;
- if (kp_unlikely (!as<int> (ix1, i1) || !as<int> (ix2, i2)))
- return (interp->raise ("type-error", "indices must be integers"));
- else if (i1 < 0)
- KP_VTRY (adjust_idx (interp, obj, i1, i2 < 0 ? &i2 : nullptr));
- else if (i2 < 0)
- KP_VTRY (adjust_idx (interp, obj, i2, nullptr));
- if ((i1 | i2) < 0 || i1 > i2)
- return (interp->raise ("index-error", "indices out of bounds"));
- int rlen = i2 - i1;
- object ret = KP_TRY (alloc_cons (interp, rlen));
- cons::unsafe_iter it (obj);
- for (int i = 0; i < i1 && it.valid (); ++i, ++it);
- for (; i1 < i2 && it.valid (); ++i1, ++it)
- {
- xcar(ret) = *it;
- ret = xcdr (ret);
- }
- xcdr(ret) = NIL;
- kp_return (interp->alval);
- }
- static inline result<int>
- revcopy (interpreter *interp, object& acc, cons::iterator& it)
- {
- for (; it.valid (); ++it)
- {
- object obj = KP_TRY (copy (interp, *it, true));
- acc = KP_TRY (cons::make (interp, obj, acc));
- }
- return (0);
- }
- static inline result<int>
- revcopy_shallow (interpreter *interp, object& acc, cons::iterator& it)
- {
- for (; it.valid (); ++it)
- { acc = KP_TRY (cons::make (interp, *it, acc)); }
- return (0);
- }
- result<object> copy_L (interpreter *interp, object obj, bool deep)
- {
- if (obj == NIL)
- kp_return (obj);
- valref acc (interp, NIL);
- cons::iterator it (interp, obj);
- KP_VTRY (revcopy (interp, *acc, it));
- interp->aux = KP_TRY (nreverse_L (interp, *acc));
- if (it.circular ())
- KP_VTRY (nputcdr (interp, *acc, it.prev_node ()));
- else if (!xcons_p (it.node ()))
- KP_VTRY (nputcdr (interp, *acc, it.node ()));
- kp_return (interp->aux);
- }
- static const uint32_t CONS_HASH_SEED = 1936617315;
- result<uint32_t> hash_L (interpreter *interp, object obj)
- {
- uint32_t ret = CONS_HASH_SEED;
- if (obj == NIL)
- return (ret);
- cons::iterator it (interp, obj);
- while (true)
- {
- uint32_t tmp = KP_TRY (xhash (interp, *it));
- ret = mix_hash (ret, tmp);
- if (!(++it).valid ())
- {
- object pt = it.node ();
- if (pt != UNBOUND && pt != NIL)
- { // Dotted list - Hash the tail and mix it again.
- tmp = KP_TRY (xhash (interp, pt));
- ret = mix_hash (ret, tmp);
- }
- break;
- }
- }
- return (ret);
- }
- result<object> iter_L (interpreter *interp, object obj, object token, bool adv)
- {
- if (token == UNBOUND)
- kp_return (obj);
- else if (!cons_p (token))
- return (interp->raise ("arg-error", "invalid token"));
- else if (!adv)
- kp_return (xcar (token));
- if (!xcons_p (interp->retval = xcdr (token)))
- return (raise_dotted (interp));
- return (interp->retval);
- }
- result<object> nreverse_L (interpreter *interp, object obj)
- {
- object prev = NIL, tmp = obj;
- object *pp = &prev;
- while (tmp != NIL)
- {
- object qx = xcdr (tmp);
- if (!xcons_p (qx))
- return (raise_dotted (interp));
- /* Write barriers shouldn't be necessary here, since we are rearranging
- * an existing list; that is the responsibility of other mutators. */
- xcdr(tmp) = *pp;
- *pp = tmp, tmp = qx;
- }
- kp_return (prev);
- }
- result<object> reverse_L (interpreter *interp, object obj)
- {
- valref ret (interp, NIL);
- cons::iterator it (interp, obj);
- for (; it.valid (); ++it)
- { *ret = KP_TRY (cons::make (interp, *it, *ret)); }
- if (!xcons_p (it.node ()))
- return (interp->raise ("arg-error", "argument is not a proper list"));
- kp_return (*ret);
- }
- result<object> concat_L (interpreter *interp, object *argv, int argc)
- {
- if (argc == 1)
- kp_return (*argv);
- valref acc (interp, NIL);
- for (int i = 0; i < argc - 1; ++i)
- {
- if (xcons_p (argv[i]))
- {
- cons::iterator it (interp, argv[i]);
- KP_VTRY (revcopy_shallow (interp, *acc, it));
- if (it.node () == NIL)
- continue;
- }
- return (interp->raise ("arg-error", "arguments must be proper lists"));
- }
- if (*acc == NIL)
- kp_return (argv[argc - 1]);
- KP_VTRY (nreverse_L (interp, *acc));
- xcdr(*acc) = argv[argc - 1];
- return (interp->retval);
- }
- result<object> add_LL (interpreter *interp, object l1, object l2)
- {
- object args[] = { l1, l2 };
- return (concat_L (interp, args, 2));
- }
- result<object> nsort_L (interpreter *interp, object obj, comparator& cmp)
- {
- valref nm (interp);
- cons::iterator it (interp, obj), tmp (interp, NIL);
- for (; it.valid (); ++it)
- {
- tmp.reset (it);
- *nm = it.node ();
- while ((++tmp).valid ())
- {
- bool rv = KP_TRY (cmp (*tmp, xcar (*nm)));
- if (rv)
- *nm = tmp.node ();
- }
- if (tmp.circular ())
- return (raise_circular (interp));
- else if (it.node () != *nm)
- swap (xcar (it.node ()), xcar (*nm));
- }
- kp_return (obj);
- }
- result<object> nconcat (interpreter *interp, object *argv, int argc)
- {
- if (!argc)
- kp_return (NIL);
- else if (argc == 1)
- kp_return (*argv);
- int i;
- for (i = 0; i < argc; ++i)
- if (!xcons_p (argv[i]))
- {
- if (i == argc - 1)
- kp_return (argv[i]);
- return (interp->raise ("type-error", "arguments must be lists"));
- }
- else if (argv[i] != NIL)
- break;
- if (i == argc)
- kp_return (argv[i - 1]);
- valref ret (interp, argv[i++]), tail = KP_TRY (last_L (interp, *ret));
- for (; i < argc - 1; ++i)
- {
- if (argv[i] == NIL)
- continue;
- else if (!xcons_p (argv[i]))
- return (interp->raise ("type-error", "arguments must be lists"));
- KP_VTRY (nputcdr (interp, *tail, argv[i]));
- *tail = KP_TRY (last_L (interp, argv[i]));
- }
- KP_VTRY (nputcdr (interp, *tail, argv[argc - 1]));
- kp_return (*ret);
- }
- result<object> nrevconc (interpreter *interp, object lst, object tail)
- {
- if (!xcons_p (lst))
- return (interp->raise ("type-error", "first argument must be a list"));
- valref sl (interp, lst), rv = KP_TRY (nreverse_L (interp, *sl));
- KP_VTRY (nputcdr (interp, *sl, tail));
- kp_return (*rv);
- }
- result<bool> eq_LL (interpreter *interp, object l1, object l2)
- {
- cons::iterator l_it (interp, l1), r_it (interp, l2);
- for (; l_it.valid () && r_it.valid (); ++l_it, ++r_it)
- {
- bool rv = KP_TRY (equal (interp, *l_it, *r_it));
- if (!rv)
- return (rv);
- }
- if (l_it.node () == NIL)
- return (r_it.node () == NIL);
- bool rv = !l_it.circular () && !r_it.circular ();
- if (rv)
- { rv = KP_TRY (equal (interp, l_it.node (), r_it.node ())); }
- return (rv);
- }
- result<int> cmp_LL (interpreter *interp, object l1, object l2)
- {
- cons::iterator l_it (interp, l1), r_it (interp, l2);
- for (; l_it.valid () && r_it.valid (); ++l_it, ++r_it)
- {
- int rv = KP_TRY (xcmp (interp, *l_it, *r_it));
- if (rv != 0)
- return (rv);
- }
- if (l_it.circular () || r_it.circular ())
- return (-1);
- else if (r_it.node () == NIL)
- return (l_it.node () != r_it.node ());
- else if (l_it.node () == NIL)
- return (-(r_it.node () != l_it.node ()));
- int rv = KP_TRY (xcmp (interp, l_it.node (), r_it.node ()));
- return (rv);
- }
- result<object> nzap_L (interpreter *interp, object obj, object key,
- uint32_t flags, object fn, object *argv, int argc)
- {
- int iv;
- if (kp_unlikely (!as<int> (key, iv)))
- return (interp->raise ("type-error", "index is not an integer"));
- else if (kp_unlikely (flags & NZAP_DFL))
- return (interp->raise ("arg-error", "default argument not supported"));
- KP_VTRY (interp->growstk (argc + 2));
- *interp->stkend++ = fn;
- *interp->stkend++ = fixint (0); // Placeholder.
- int stack_idx = interp->stklen () - 1;
- for (int i = 0; i < argc; ++i)
- *interp->stkend++ = argv[i];
- valref prev (interp), ref = KP_TRY (cons_ref (interp, iv, obj));
- atomic_t *ref_ptr = (atomic_t *)&xcar(*ref);
- if (flags & NZAP_NOMT)
- {
- interp->stack[stack_idx] = *prev = *ref_ptr;
- KP_VTRY (call_n (interp, argc + 1),
- nputcar (interp, *ref, interp->retval));
- interp->retval = xcar (interp->retval);
- }
- else
- while (true)
- {
- *prev = xcar (*ref);
- interp->stack[stack_idx] = *prev;
- KP_VTRY (call_n (interp, argc + 1));
- if (atomic_cas_bool (ref_ptr,
- (atomic_t)*prev, (atomic_t)interp->retval))
- {
- KP_VTRY (gc_wbarrier (interp, *ref, interp->retval));
- break;
- }
- atomic_spin_nop ();
- }
- if (flags & NZAP_PREV)
- interp->retval = *prev;
- return (interp->retval);
- }
- result<object> find_L (interpreter *interp, object obj, object key,
- object start, object end, object test)
- {
- int istart = start == UNBOUND ? as_int (start) : 0;
- int iend = end == UNBOUND ? FIXINT_MAX : as_int (end);
- if (istart < 0)
- KP_VTRY (adjust_idx (interp, obj, istart, iend < 0 ? &iend : nullptr));
- else if (iend < 0)
- KP_VTRY (adjust_idx (interp, obj, iend, nullptr));
- if (istart > iend)
- kp_return (NIL);
- else if ((istart | iend) < 0)
- return (interp->raise ("index-error", "indices out of bounds"));
- cons::unsafe_iter it (obj);
- for (int i = 0; i < istart && it.valid (); ++it) ;
- if (test == UNBOUND)
- {
- valref tmp (interp);
- for (; istart < iend && it.valid (); ++it, ++istart)
- {
- bool rv = KP_TRY (equal (interp, key, *it));
- if (rv)
- kp_return (it.node ());
- }
- }
- else
- {
- KP_VTRY (interp->growstk (3));
- for (; istart < iend && it.valid (); ++it, ++istart)
- {
- *interp->stkend++ = test;
- *interp->stkend++ = key;
- *interp->stkend++ = *it;
- KP_VTRY (call_n (interp, 2));
- if (interp->retval != NIL)
- kp_return (it.node ());
- }
- }
- kp_return (NIL);
- }
- result<int64_t> write_L (interpreter *interp, stream *strm,
- object obj, io_info& info)
- {
- if (obj == NIL)
- return (strm->write (interp, "nil", 3));
- else if (xcar (obj) == symbol::quote &&
- xcons_p (xcdr (obj)) && xcddr (obj) == NIL)
- {
- valref prev (interp, xcadr (obj));
- int64_t ret = KP_TRY (strm->putb (interp, '\''));
- ret += KP_TRY (xwrite (interp, strm, *prev));
- return (ret);
- }
- int64_t ret = KP_TRY (strm->putb (interp, '('));
- cons::iterator it (interp, obj);
- while (true)
- {
- ret += KP_TRY (xwrite (interp, strm, *it, info));
- if ((++it).valid ())
- {
- ret += KP_TRY (strm->putb (interp, ' '));
- continue;
- }
- else if (it.circular ())
- { ret += KP_TRY (strm->write (interp, " ...", 4)); }
- else if (!xcons_p (it.node ()))
- {
- ret += KP_TRY (strm->write (interp, " . ", 3));
- ret += KP_TRY (xwrite (interp, strm, it.node (), info));
- }
- break;
- }
- ret += KP_TRY (strm->putb (interp, ')'));
- return (ret);
- }
- result<int64_t> pack_L (interpreter *interp, stream *strm,
- object obj, pack_info& info)
- {
- pack_info::eviction_guard eg { info, true };
- cons::iterator it (interp, obj);
- int64_t ret = KP_TRY (xpack (interp, strm, *it, info));
- for (++it; it.valid (); ++it)
- { /* Here we inline part of the packing routine to avoid
- * pathological cases of very deep recursion, which can
- * lead to a stack overflow. */
- object off = info.get (interp, it.node ());
- 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));
- break;
- }
- valref tmp = KP_TRY (strm->tell (interp));
- KP_VTRY (info.add_mapping (interp, it.node (), *tmp));
- ret += KP_TRY (strm->putb (interp, typecode::CONS));
- ret += KP_TRY (xpack (interp, strm, *it, info));
- }
- if (it.node () == NIL)
- { ret += KP_TRY (strm->putb (interp, PACK_NIL)); }
- else if (!it.circular ())
- { ret += KP_TRY (xpack (interp, strm, it.node (), info)); }
- return (ret);
- }
- result<object> unpack_L (interpreter *interp, stream *strm,
- pack_info& info, bool save)
- {
- valref pos (interp, *info.offset), out (interp, NIL);
- while (true)
- {
- object tmp = KP_TRY (xunpack (interp, strm, info));
- *out = KP_TRY (cons::make (interp, tmp, *out));
- if (save)
- KP_VTRY (info.add_mapping (interp, *pos, *out));
- *pos = KP_TRY (strm->tell (interp));
- int tp = KP_TRY (strm->peekb (interp));
- if (tp < 0)
- return (info.error ("invalid typecode"));
- save = (tp & 0x80) != 0;
- tp &= ~0x80;
- if (tp != typecode::CONS)
- {
- if (tp != PACK_NIL)
- {
- *pos = KP_TRY (xunpack (interp, strm, info));
- *out = KP_TRY (nrevconc (interp, *out, *pos));
- }
- else
- {
- *out = KP_TRY (nreverse_L (interp, *out));
- KP_VTRY (strm->getb (interp));
- }
- kp_return (*out);
- }
- KP_VTRY (strm->getb (interp));
- }
- }
- // External definitions.
- static const cons C_NIL =
- {
- #ifdef KP_ARCH_WIDE
- ((object)typecode::CONS << TYPE_SHIFT) | (object)&C_NIL,
- ((object)typecode::CONS << TYPE_SHIFT) | (object)&C_NIL
- #else
- (object)&C_NIL | 2,
- (object)&C_NIL | 2
- #endif
- };
- const object NIL =
- #ifdef KP_ARCH_WIDE
- ((object)typecode::CONS << TYPE_SHIFT) | (object)&C_NIL;
- #else
- (object)&C_NIL | 2;
- #endif
- static int
- do_init_cons (interpreter *)
- {
- ensure_mask_impl ((void *)&C_NIL);
- return (init_op::result_ok);
- }
- init_op init_cons (do_init_cons, "cons");
- KP_DECLS_END
|