123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122 |
- /* Definitions for custom, native types.
- 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 <new>
- #include "custom.hpp"
- #include "memory.hpp"
- #include "str.hpp"
- #include "symbol.hpp"
- #include "types.hpp"
- #include "thread.hpp"
- KP_DECLS_BEGIN
- custom_base* custom_base::alloc_raw (size_t size)
- {
- /* We cannot use 'alloch', because it allocates and initializes a varobj,
- * disregarding any adjustments that must be made by a class with virtual
- * methods. So we inline the needed part here. */
- auto ret = (custom_base *)ensure_mask_impl (xmalloc (size), TYPE_SHIFT);
- ret->vo_size = (uint32_t)size;
- return (ret);
- }
- static result<void>
- check_custom_type (interpreter *interp, object *tp,
- object name, custom_base *bp)
- {
- if (!tp)
- return (interp->raise ("arg-error", "type descriptor must not be null"));
- object ty = *tp;
- valref parents (interp, NIL), slots (interp, NIL);
- if (ty != 0)
- {
- check:
- if (type_name (ty) != name)
- return (interp->raise ("arg-error", "different names used for "
- "the same custom type"));
- return (0);
- }
- bp->fill_type (interp, *parents, *slots);
- object rt = KP_TRY (type (interp, name, *parents, *slots));
- if (singlethr_p ())
- *tp = rt;
- else if (!atomic_cas_bool ((atomic_t *)tp, ty, rt))
- goto check;
- return (0);
- }
- result<custom_base*> custom_base::xalloc (interpreter *interp, object *tp,
- const char *name, custom_base *bp,
- constructor cfn)
- {
- valref tname = KP_TRY (intern (interp, name));
- return (custom_base::xalloc (interp, tp, *tname, bp, cfn));
- }
- result<custom_base*> custom_base::xalloc (interpreter *interp, object *tp,
- const char *name, uint32_t len,
- custom_base *bp, constructor cfn)
- {
- valref tname = KP_TRY (intern (interp, name, len));
- return (custom_base::xalloc (interp, tp, *tname, bp, cfn));
- }
- result<custom_base*> custom_base::xalloc (interpreter *interp, object *tp,
- object name, custom_base *ret,
- constructor cfn)
- {
- if (!symbol_p (name))
- return (interp->raise ("arg-error",
- "type name must be a string or symbol"));
- try
- {
- cfn (ret);
- }
- catch (...)
- {
- destroy (ret);
- xfree (ret);
- return (interp->raise ("runtime-error",
- "failed to construct custom object"));
- }
- auto rv = check_custom_type (interp, tp, name, ret);
- if (rv.error_p ())
- {
- destroy (ret);
- xfree (ret);
- return (exception ());
- }
- ret->vo_full = 0;
- ret->vo_type = typecode::CUSTOM;
- ret->fini = nullptr;
- ret->type_ptr = tp;
- interp->alval = ret->as_obj ();
- gc_register (interp, ret, ret->vo_size);
- return (ret);
- }
- KP_DECLS_END
|