added respondsTo and related functions

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;

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);

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:

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_core_cresp_to (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
-static hcl_pfrc_t pf_arr_new (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
 {
-	hcl_oop_t sz, arr;
+	hcl_oop_t obj;
-	hcl_oow_t size;
+	hcl_oop_t msg;
+	int x;
 
-	sz = (hcl_oop_t)HCL_STACK_GETARG(hcl, nargs, 0);
+	obj = HCL_STACK_GETARG(hcl, nargs, 0);
-	if (hcl_inttooow(hcl, sz, &size) == 0) return HCL_PF_FAILURE;
+	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);
+	x = hcl_class_responds_to(hcl, obj, msg);
-	if (HCL_UNLIKELY(!arr)) return HCL_PF_FAILURE;
+	HCL_STACK_SETRET (hcl, nargs, (x? hcl->_true: hcl->_false));
-
+	return HCL_PF_SUCCESS;
-	HCL_STACK_SETRET (hcl, nargs, arr);
+}
+
+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 } },
+	{ { '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','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 } },
+	{ { 'c','r','e','s','p','_','t','o', '\0' },             { HCL_PFBASE_FUNC, pf_core_cresp_to,        2,  2 } },
-	{ { 'l','e','n','g','t','h','\0' },  { HCL_PFBASE_FUNC, pf_core_size,      1,  1 } },
+	{ { 'g','e','t','\0' },                                  { HCL_PFBASE_FUNC, pf_core_get,             2,  2 } },
-	{ { 'p','u','t','\0' },              { HCL_PFBASE_FUNC, pf_core_put,       3,  3 } },
+	{ { 'i','r','e','s','p','_','t','o', '\0' },             { HCL_PFBASE_FUNC, pf_core_iresp_to,        2,  2 } },
-	{ { 's','i','z','e','\0' },          { HCL_PFBASE_FUNC, pf_core_size,      1,  1 } },
+	{ { 'l','e','n','g','t','h','\0' },                      { HCL_PFBASE_FUNC, pf_core_size,            1,  1 } },
-	{ { 's','l','i','c','e','\0' },      { HCL_PFBASE_FUNC, pf_core_slice,     3,  3 } }
+	{ { '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 } }
 };
 
 /* ------------------------------------------------------------------------ */

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 Collection :: Object {
+class Class :: Apex [
-}
+	_name
+	_mdic
+	_spec
+	_selfspec
+	_superclass
+	_nivars_super
+	_ibrand
+	_ivarnames
+	_cvarnames
+] {
+	fun name() {
+		##return (core.class_name self)
+		return _class
+	}
 
-class IndexedCollection :: Collection {
+	fun instanceVariableNames() {
-}
+		## TODO: this still returns nil as the acutal manipulation of the field has not been implemented
+		return _ivarnames
+	}
 
-class FixedSizedCollection :: IndexedCollection {
+	fun classVariableNames() {
-}
+		## TODO: this still returns nil as the acutal manipulation of the field has not been implemented
-
+		return _cvarnames
-class Array :: FixedSizedCollection {
-	fun :: new(size) {
-		return (core.basic_new self size)
 	}
 }
 
+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 {
+}
+
 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"