diff --git a/include/xo/procedure2/ObjectPrimitives.hpp b/include/xo/procedure2/ObjectPrimitives.hpp index 2fc3176..696fc29 100644 --- a/include/xo/procedure2/ObjectPrimitives.hpp +++ b/include/xo/procedure2/ObjectPrimitives.hpp @@ -24,16 +24,20 @@ namespace xo { public: /** create primitive: report current working directory **/ - static DPrimitive_gco_0 * make_cwd_pm(obj mm); + static DPrimitive_gco_0 * make_cwd_pm(obj mm, + StringTable * stbl); /** create primitive: fetch nth element of a sequence **/ - static DPrimitive_gco_2_gco_gco * make_nth_pm(obj mm); + static DPrimitive_gco_2_gco_gco * make_nth_pm(obj mm, + StringTable * stbl); /** create primitive: create cons cell **/ - static DPrimitive_gco_2_gco_gco * make_cons_pm(obj mm); + static DPrimitive_gco_2_gco_gco * make_cons_pm(obj mm, + StringTable * stbl); /** create primitive for creating a dictionary instance **/ - static DPrimitive_gco_0 * make_dict_make_pm(obj mm); + static DPrimitive_gco_0 * make_dict_make_pm(obj mm, + StringTable * stbl); /** create primitive for creating a dictionary instance **/ static DPrimitive_gco_2_dict_string * make_dict_lookup_pm(obj mm); diff --git a/include/xo/procedure2/PrimitiveRegistry.hpp b/include/xo/procedure2/PrimitiveRegistry.hpp index 6f1f67e..a4e24e2 100644 --- a/include/xo/procedure2/PrimitiveRegistry.hpp +++ b/include/xo/procedure2/PrimitiveRegistry.hpp @@ -61,6 +61,7 @@ namespace xo { * to InstallSink sink. **/ using InstallSource = std::function mm, + StringTable * stbl, InstallSink sink, InstallFlags flags)>; @@ -72,9 +73,11 @@ namespace xo { void register_primitives(InstallSource source_fn); /** create primitives using memory from @p mm, + * with global strings in @p stbl. * delivering each primitive to @p sink. **/ bool install_primitives(obj mm, + StringTable * stbl, InstallSink sink, InstallFlags flags); diff --git a/include/xo/procedure2/procedure2_register_primitives.hpp b/include/xo/procedure2/procedure2_register_primitives.hpp index 6923769..396f645 100644 --- a/include/xo/procedure2/procedure2_register_primitives.hpp +++ b/include/xo/procedure2/procedure2_register_primitives.hpp @@ -12,6 +12,7 @@ namespace xo { namespace scm { /** Register primitive-factories **/ bool procedure2_register_primitives(obj gc, + StringTable * stbl, InstallSink sink, InstallFlags flags); } diff --git a/src/procedure2/ObjectPrimitives.cpp b/src/procedure2/ObjectPrimitives.cpp index c247ab8..d52c530 100644 --- a/src/procedure2/ObjectPrimitives.cpp +++ b/src/procedure2/ObjectPrimitives.cpp @@ -9,6 +9,10 @@ #include #include #include +#include +#include +#include +#include #include #include #include // for getcwd() @@ -35,9 +39,15 @@ namespace xo { } DPrimitive_gco_0 * - ObjectPrimitives::make_cwd_pm(obj mm) + ObjectPrimitives::make_cwd_pm(obj mm, StringTable * stbl) { - return DPrimitive_gco_0::_make(mm, "cwd", &xfer_cwd); + (void)stbl; + + auto str_ty = DAtomicType::make(mm, Metatype::t_str()); + auto cwd_ty + = obj(DFunctionType::_make(mm, str_ty)); + + return DPrimitive_gco_0::_make(mm, "cwd", cwd_ty, &xfer_cwd); } // ----- nth ----- @@ -59,9 +69,20 @@ namespace xo { } DPrimitive_gco_2_gco_gco * - ObjectPrimitives::make_nth_pm(obj mm) + ObjectPrimitives::make_nth_pm(obj mm, StringTable * stbl) { - return DPrimitive_gco_2_gco_gco::_make(mm, "nth", &xfer_nth); + auto T_ty = DTypeVarRef::make(mm, stbl->intern("T")); + auto list_T_ty = DListType::make(mm, T_ty); + auto int_ty = DAtomicType::make(mm, Metatype::t_integer()); + /** nth_ty: list x int -> T **/ + auto nth_ty + = obj + (DFunctionType::_make(mm, + T_ty, + list_T_ty, + int_ty)); + + return DPrimitive_gco_2_gco_gco::_make(mm, "nth", nth_ty, &xfer_nth); } // ----- cons ----- @@ -75,17 +96,24 @@ namespace xo { auto cdr_list = obj::from(cdr); - //auto T = DTypeVarRef::_make(rcx.allocator(), "T"); - return DList::cons(rcx.allocator(), car, cdr_list.data()); } DPrimitive_gco_2_gco_gco * - ObjectPrimitives::make_cons_pm(obj mm) + ObjectPrimitives::make_cons_pm(obj mm, StringTable * stbl) { - return DPrimitive_gco_2_gco_gco::_make(mm, "cons", &xfer_cons); + auto T_ty = DTypeVarRef::make(mm, stbl->intern("T")); + auto list_T_ty = DListType::make(mm, T_ty); + /** cons_ty: T x list -> list **/ + auto cons_ty + = obj(DFunctionType::_make(mm, + list_T_ty, + T_ty, + list_T_ty)); + + return DPrimitive_gco_2_gco_gco::_make(mm, "cons", cons_ty, &xfer_cons); } // ----- dict_make ----- @@ -98,9 +126,17 @@ namespace xo { } DPrimitive_gco_0 * - ObjectPrimitives::make_dict_make_pm(obj mm) + ObjectPrimitives::make_dict_make_pm(obj mm, + StringTable * stbl) { - return DPrimitive_gco_0::_make(mm, "dict_make", &xfer_dict_make); + (void)stbl; + + // nit: technically better to use empty struct type here + auto dict_ty = DAtomicType::make(mm, Metatype::t_dict()); + auto pm_ty = obj(DFunctionType::_make(mm, + dict_ty)); + + return DPrimitive_gco_0::_make(mm, "dict_make", pm_ty, &xfer_dict_make); } // ----- dict_at ----- diff --git a/src/procedure2/PrimitiveRegistry.cpp b/src/procedure2/PrimitiveRegistry.cpp index e62b679..420a435 100644 --- a/src/procedure2/PrimitiveRegistry.cpp +++ b/src/procedure2/PrimitiveRegistry.cpp @@ -26,6 +26,7 @@ namespace xo { bool PrimitiveRegistry::install_primitives(obj mm, + StringTable * stbl, InstallSink sink, InstallFlags flags) { @@ -40,7 +41,7 @@ namespace xo { for (const auto & fn : init_seq_v_) { log && log("do install fn (", i+1, "/", n, ")"); - ok = ok & fn(mm, sink, flags); + ok = ok & fn(mm, stbl, sink, flags); ++i; } diff --git a/src/procedure2/procedure2_register_primitives.cpp b/src/procedure2/procedure2_register_primitives.cpp index fee0bd9..eed4cf5 100644 --- a/src/procedure2/procedure2_register_primitives.cpp +++ b/src/procedure2/procedure2_register_primitives.cpp @@ -54,6 +54,7 @@ namespace xo { bool procedure2_register_primitives(obj mm, + StringTable * stbl, InstallSink sink, InstallFlags flags) { @@ -61,10 +62,10 @@ namespace xo { bool ok = true; - ok = ok & install_aux(sink, ObjectPrimitives::make_cwd_pm(mm), flags); - ok = ok & install_aux(sink, ObjectPrimitives::make_nth_pm(mm), flags); - ok = ok & install_aux(sink, ObjectPrimitives::make_cons_pm(mm), flags); - ok = ok & install_aux(sink, ObjectPrimitives::make_dict_make_pm(mm), flags); + ok = ok & install_aux(sink, ObjectPrimitives::make_cwd_pm(mm, stbl), flags); + ok = ok & install_aux(sink, ObjectPrimitives::make_nth_pm(mm, stbl), flags); + ok = ok & install_aux(sink, ObjectPrimitives::make_cons_pm(mm, stbl), flags); + ok = ok & install_aux(sink, ObjectPrimitives::make_dict_make_pm(mm, stbl), flags); ok = ok & install_aux(sink, ObjectPrimitives::make_dict_lookup_pm(mm), flags); ok = ok & install_aux(sink, ObjectPrimitives::make_dict_upsert_pm(mm), flags); ok = ok & install_aux(sink, ObjectPrimitives::make_fn_n_args_pm(mm), flags);