diff --git a/lib/exec.c b/lib/exec.c index 93fff2a..964ef8f 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -2266,6 +2266,32 @@ static hcl_oop_block_t find_cmethod_noseterr (hcl_t* hcl, hcl_oop_class_t _class return find_imethod_in_class_noseterr(hcl, (hcl_oop_class_t)HCL_CLASSOF(hcl, _class), &name, ivaroff, owner); } +int hcl_class_responds_to (hcl_t* hcl, hcl_oop_t rcv, hcl_oop_t msg) +{ + hcl_oop_block_t mth_blk; + hcl_oop_class_t owner; + hcl_ooi_t ivaroff; + + HCL_ASSERT (hcl, HCL_IS_CLASS(hcl, rcv)); + mth_blk = find_cmethod_noseterr(hcl, (hcl_oop_class_t)rcv, msg, 0, &ivaroff, &owner); + + return mth_blk != HCL_NULL; +} + +int hcl_inst_responds_to (hcl_t* hcl, hcl_oop_t rcv, hcl_oop_t msg) +{ + hcl_oop_block_t mth_blk; + hcl_oop_class_t _class, owner; + hcl_ooi_t ivaroff; + + _class = (hcl_oop_class_t)HCL_CLASSOF(hcl, rcv); + HCL_ASSERT (hcl, _class != HCL_NULL); + HCL_ASSERT (hcl, HCL_IS_CLASS(hcl, _class)); + mth_blk = find_imethod_noseterr(hcl, _class, msg, 0, &ivaroff, &owner); + + return mth_blk != HCL_NULL; +} + static HCL_INLINE int send_message (hcl_t* hcl, hcl_oop_t rcv, hcl_oop_t msg, int to_super, hcl_ooi_t nargs, hcl_ooi_t nrvars) { hcl_oop_block_t mth_blk; diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index ccc910d..5b7b289 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -1992,6 +1992,9 @@ int hcl_is_binop_char (hcl_ooci_t c); /* ========================================================================= */ /* exec.c */ /* ========================================================================= */ +int hcl_class_responds_to (hcl_t* hcl, hcl_oop_t rcv, hcl_oop_t msg); +int hcl_inst_responds_to (hcl_t* hcl, hcl_oop_t rcv, hcl_oop_t msg); + hcl_pfrc_t hcl_pf_process_current (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs); hcl_pfrc_t hcl_pf_process_fork (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs); hcl_pfrc_t hcl_pf_process_resume (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs); diff --git a/lib/read.c b/lib/read.c index ef9f6c9..aff2b6c 100644 --- a/lib/read.c +++ b/lib/read.c @@ -2239,6 +2239,7 @@ static int flx_hmarked_token (hcl_t* hcl, hcl_ooci_t c) * #b[ ] byte array * #( ) qlist * #{ } dictionary + * #"..." symbol literal */ switch (c) @@ -2300,7 +2301,13 @@ static int flx_hmarked_token (hcl_t* hcl, hcl_ooci_t c) case '{': /* #{ */ FEED_WRAP_UP_WITH_CHAR (hcl, c, HCL_TOK_DLPAREN); - goto consumed; + goto consumed; + +#if 0 + case '"': /* #" */ + FEED_CONTINUE_WITH_CHAR (hcl, c, HCL_TOK_HMARKED_SYMBOL); /* symbol lieral */ + goto consumed; +#endif /* --------------------------- */ default: diff --git a/mod/core.c b/mod/core.c index 65a14ed..f30f72d 100644 --- a/mod/core.c +++ b/mod/core.c @@ -26,6 +26,7 @@ #include "_core.h" +#include "../lib/hcl-prv.h" static hcl_pfrc_t pf_core_basic_new (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs) { @@ -53,7 +54,7 @@ static hcl_pfrc_t pf_core_basic_new (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs return HCL_PF_FAILURE; } - inst = hcl_instantiate(hcl, obj, HCL_NULL, nsize); + inst = hcl_instantiate(hcl, (hcl_oop_class_t)obj, HCL_NULL, nsize); if (HCL_UNLIKELY(!inst)) return HCL_PF_FAILURE; HCL_STACK_SETRET (hcl, nargs, inst); @@ -69,7 +70,7 @@ static hcl_pfrc_t pf_core_get_class_name (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t if (!HCL_IS_CLASS(hcl, obj)) { #if 0 - hcl_seterrbfmt (hcl, HCL_EINVAL, "parameter not a class - %O", obj); + hcl_seterrbfmt (hcl, HCL_EINVAL, "receiver not class - %O", obj); return HCL_PF_FAILURE; #else obj = (hcl_oop_t)HCL_CLASSOF(hcl, obj); @@ -81,22 +82,48 @@ static hcl_pfrc_t pf_core_get_class_name (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t return HCL_PF_SUCCESS; } -#if 0 -static hcl_pfrc_t pf_arr_new (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs) +static hcl_pfrc_t pf_core_cresp_to (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs) { - hcl_oop_t sz, arr; - hcl_oow_t size; + hcl_oop_t obj; + hcl_oop_t msg; + int x; - sz = (hcl_oop_t)HCL_STACK_GETARG(hcl, nargs, 0); - if (hcl_inttooow(hcl, sz, &size) == 0) return HCL_PF_FAILURE; + obj = HCL_STACK_GETARG(hcl, nargs, 0); + msg = HCL_STACK_GETARG(hcl, nargs, 1); + if (!HCL_IS_CLASS(hcl, obj)) + { + hcl_seterrbfmt (hcl, HCL_EINVAL, "receiver not class - %O", msg); + return HCL_PF_FAILURE; + } + if (!HCL_OBJ_IS_CHAR_POINTER(msg)) + { + hcl_seterrbfmt (hcl, HCL_EINVAL, "invalid message - %O", msg); + return HCL_PF_FAILURE; + } - arr = hcl_makearray(hcl, size, 0); - if (HCL_UNLIKELY(!arr)) return HCL_PF_FAILURE; - - HCL_STACK_SETRET (hcl, nargs, arr); + x = hcl_class_responds_to(hcl, obj, msg); + HCL_STACK_SETRET (hcl, nargs, (x? hcl->_true: hcl->_false)); + return HCL_PF_SUCCESS; +} + +static hcl_pfrc_t pf_core_iresp_to (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs) +{ + hcl_oop_t obj; + hcl_oop_t msg; + int x; + + obj = HCL_STACK_GETARG(hcl, nargs, 0); + msg = HCL_STACK_GETARG(hcl, nargs, 1); + if (!HCL_OBJ_IS_CHAR_POINTER(msg)) + { + hcl_seterrbfmt (hcl, HCL_EINVAL, "invalid message - %O", msg); + return HCL_PF_FAILURE; + } + + x = hcl_inst_responds_to(hcl, obj, msg); + HCL_STACK_SETRET (hcl, nargs, (x? hcl->_true: hcl->_false)); return HCL_PF_SUCCESS; } -#endif static hcl_pfrc_t pf_core_size (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs) { @@ -350,13 +377,15 @@ static hcl_pfrc_t pf_core_put (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs) static hcl_pfinfo_t pfinfos[] = { - { { 'b','a','s','i','c','_','n','e','w','\0' }, { HCL_PFBASE_FUNC, pf_core_basic_new, 2, 2 } }, - { { 'c','l','a','s','s','_','n','a','m','e','\0' }, { HCL_PFBASE_FUNC, pf_core_get_class_name, 1, 1 } }, - { { 'g','e','t','\0' }, { HCL_PFBASE_FUNC, pf_core_get, 2, 2 } }, - { { 'l','e','n','g','t','h','\0' }, { HCL_PFBASE_FUNC, pf_core_size, 1, 1 } }, - { { 'p','u','t','\0' }, { HCL_PFBASE_FUNC, pf_core_put, 3, 3 } }, - { { 's','i','z','e','\0' }, { HCL_PFBASE_FUNC, pf_core_size, 1, 1 } }, - { { 's','l','i','c','e','\0' }, { HCL_PFBASE_FUNC, pf_core_slice, 3, 3 } } + { { 'b','a','s','i','c','_','n','e','w','\0' }, { HCL_PFBASE_FUNC, pf_core_basic_new, 2, 2 } }, + { { 'c','l','a','s','s','_','n','a','m','e','\0' }, { HCL_PFBASE_FUNC, pf_core_get_class_name, 1, 1 } }, + { { 'c','r','e','s','p','_','t','o', '\0' }, { HCL_PFBASE_FUNC, pf_core_cresp_to, 2, 2 } }, + { { 'g','e','t','\0' }, { HCL_PFBASE_FUNC, pf_core_get, 2, 2 } }, + { { 'i','r','e','s','p','_','t','o', '\0' }, { HCL_PFBASE_FUNC, pf_core_iresp_to, 2, 2 } }, + { { 'l','e','n','g','t','h','\0' }, { HCL_PFBASE_FUNC, pf_core_size, 1, 1 } }, + { { 'p','u','t','\0' }, { HCL_PFBASE_FUNC, pf_core_put, 3, 3 } }, + { { 's','i','z','e','\0' }, { HCL_PFBASE_FUNC, pf_core_size, 1, 1 } }, + { { 's','l','i','c','e','\0' }, { HCL_PFBASE_FUNC, pf_core_slice, 3, 3 } } }; /* ------------------------------------------------------------------------ */ diff --git a/src/kernel.hcl b/src/kernel.hcl index 19b317c..9ef6f65 100644 --- a/src/kernel.hcl +++ b/src/kernel.hcl @@ -1,67 +1,105 @@ class Apex { - fun :: basicNew(size) { + fun ::basicNew(size) { return (core.basic_new self size) } + + fun ::respondsTo(mth) { + return (core.cresp_to self mth) + } + + fun respondsTo(mth) { + return (core.iresp_to self mth) + } + + fun basicAt(pos) { + return (core.get self index) + } + + fun basicAtPut(index value) { + return (core.put self index value) + } } class Object :: Apex { } +class Class :: Apex [ + _name + _mdic + _spec + _selfspec + _superclass + _nivars_super + _ibrand + _ivarnames + _cvarnames +] { + fun name() { + ##return (core.class_name self) + return _class + } + + fun instanceVariableNames() { + ## TODO: this still returns nil as the acutal manipulation of the field has not been implemented + return _ivarnames + } + + fun classVariableNames() { + ## TODO: this still returns nil as the acutal manipulation of the field has not been implemented + return _cvarnames + } +} + class Collection :: Object { + fun length() { + return (core.length self) + } } class IndexedCollection :: Collection { + fun slice(index count) { + return (core.slice self index count) + } + + fun at(index) { + return (core.get self index) + } + + fun atPut(index value) { + return (core.put self index value) + } } class FixedSizedCollection :: IndexedCollection { + fun ::new(size) { + | obj iv | + obj := (core.basic_new self size) + if (self:respondsTo "initValue") { ## TODO: change "initValue" to a symbol once supported + i := 0 + iv := (self:initValue) + while (i < size) { + core.put obj i iv + i := (i + 1) + } + } + return obj + } + + ##fun ::initValue() { + ## return nil + ##} } class Array :: FixedSizedCollection { - fun :: new(size) { - return (core.basic_new self size) - } } class String :: FixedSizedCollection { + fun ::initValue() { + ##return '\0' + return ' ' + } } -fun Collection:length() { - return (core.length self) -} - -fun Collection:slice(index count) { - return (core.slice self index count) -} - -fun Collection:at(index) { - return (core.get self index) -} - -fun Collection:atPut(index value) { - return (core.put self index value) -} - -fun Class:name() { - return (core.class_name self) -} - -##class String:: Array [a b c] { -##} - -##class String:: Array [ -## monaco -## duncan -## falcon -## deuce -## canival -## pebble -## godzilla -##] { -## fun Collection:slice(index count) { -## return (arr.slice self index count) -## } -##} - k := "abcdefghijklmn" printf "string length %d\n" ("aaaa":length) @@ -96,3 +134,16 @@ try { k := (Array:new 10) k:atPut 3 "hello" printf "%O\n" k + +printf "[%O]\n" (String:new 5) +printf "[%O]\n" (String:basicNew 5) + +printf "[%O]\n" (String:respondsTo "new") +printf "[%O]\n" (String:respondsTo "newx") +printf "[%O]\n" (" ":respondsTo "new") +printf "[%O]\n" (" ":respondsTo "length") + +##printf "[%O]\n" (String:classVariableNames) +##printf "[%O]\n" (String:instanceVariableNames) + +printf "%O\n" #"abcdefg"