added some code to handle defclass

hcl/lib/comp.c

@@ -1587,6 +1587,90 @@ static HCL_INLINE int compile_else (hcl_t* hcl)
 	return patch_nearest_post_if_body(hcl, cmd);
 }
 
+/* ========================================================================= */
+static int compile_defclass (hcl_t* hcl, hcl_cnode_t* src)
+{
+	/*
+	(defclass A
+		| x y | ; instance variables
+		| ::: x y z | ; class variables <--- how to initialize the class variables???
+
+		
+		(defcmethod new (a b c)
+(printf "%O\n" self) ; self is A
+			(set obj super.new)
+			(obj.init a b c)
+			;(obj.x 10)
+			;(obj.y 20)
+			(return obj)
+		)
+	)
+ 
+	(defclass B ::: A ; A is a parent class
+		| p q |
+ 
+		....
+	)
+
+	*/
+	hcl_cnode_t* cmd, * obj, * args;
+	hcl_cnode_t* defun_name;
+
+	cmd = HCL_CNODE_CONS_CAR(src);
+	obj = HCL_CNODE_CONS_CDR(src);
+
+	HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_DEFUN));
+
+	if (!obj)
+	{
+		hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(src), HCL_NULL, "no name in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd));
+		return -1;
+	}
+	else if (!HCL_CNODE_IS_CONS(obj))
+	{
+		hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd));
+		return -1;
+	}
+
+	class_name = HCL_CNODE_CONS_CAR(obj);
+	if (HCL_CNODE_IS_SYMBOL(class_name))
+	{
+		/* defclass followed by a class name */
+		if (HCL_CNODE_SYMBOL_SYNCODE(class_name)) /*|| HCL_OBJ_GET_FLAGS_KERNEL(class_name) >= 1) */
+		{
+			hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_CNODE_GET_LOC(class_name), HCL_CNODE_GET_TOK(class_name), "special symbol not to be used as a defun name");
+			return -1;
+		}
+
+		obj = HCL_CNODE_CONS_CDR(obj);
+	}
+	else
+	{
+		/* no class name specified */
+		class_name = HCL_NULL;
+	}
+
+	if (HCL_CNODE_IS_ELLIPSIS(arg))
+	{
+		/* superclass */
+	}
+
+	if (!obj)
+	{
+		hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(src), HCL_NULL, "no argument list in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd));
+		return -1;
+	}
+	else if (!HCL_CNODE_IS_CONS(obj))
+	{
+		hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in argument list in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd));
+		return -1;
+	}
+	HCL_CNODE_CONS_CAR(obj);
+
+
+	return 0;
+}
+
 /* ========================================================================= */
 
 static int collect_local_vardcl (hcl_t* hcl, hcl_cnode_t* obj, hcl_cnode_t** nextobj, hcl_oow_t tv_dup_check_start, hcl_oow_t* nvardcls)
@@ -2573,6 +2657,10 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj, int nret
 				if (compile_continue(hcl, obj) <= -1) return -1;
 				break;
 
+			case HCL_SYNCODE_DEFCLASS:
+				if (compile_defclass(hcl, obj) <= -1) return -1;
+				break;
+
 			case HCL_SYNCODE_DEFUN:
 				if (compile_lambda(hcl, obj, 1) <= -1) return -1;
 				break;

hcl/lib/exec.c

@@ -3729,15 +3729,22 @@ static int execute (hcl_t* hcl)
 
 			case HCL_CODE_MAKE_CLASS:
 			{
+				/* push nivars
+				   push ncvars
+				   push superclass
+				   //push ivarnames
+				   //push cvarnames
+				   make_classs
+				 */
 				hcl_oop_t t, sc, nivars, ncvars;
 
 				LOG_INST_0 (hcl, "make_class");
 
 				sc = HCL_STACK_GETTOP(hcl); HCL_STACK_POP(hcl);
-				nivars = HCL_STACK_GETTOP(hcl); HCL_STACK_POP(hcl);
 				ncvars = HCL_STACK_GETTOP(hcl); HCL_STACK_POP(hcl);
-				HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(nivars));
+				nivars = HCL_STACK_GETTOP(hcl); HCL_STACK_POP(hcl);
 				HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(ncvars));
+				HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(nivars));
 				t = hcl_makeclass(hcl, sc, HCL_OOP_TO_SMOOI(nivars), HCL_OOP_TO_SMOOI(ncvars));
 
 				if (HCL_UNLIKELY(!t)) 
@@ -3749,6 +3756,11 @@ static int execute (hcl_t* hcl)
 				HCL_STACK_PUSH (hcl, t); /* push the class created */
 				break;
 			}
+
+			/*case HCL_CODE_MAKE_METHOD:
+			{
+			}*/
+
 			/* -------------------------------------------------------- */
 
 			case HCL_CODE_DUP_STACKTOP:

hcl/lib/gc.c

@@ -43,6 +43,7 @@ static struct
 	{  5, { 'b','r','e','a','k' },              HCL_SYNCODE_BREAK,     HCL_OFFSETOF(hcl_t,_break)  },
 	{  5, { 'c','a','t','c','h' },              HCL_SYNCODE_CATCH,     HCL_OFFSETOF(hcl_t,_catch)  },
 	{  8, { 'c','o','n','t','i','n','u','e' },  HCL_SYNCODE_CONTINUE,  HCL_OFFSETOF(hcl_t,_continue)  },
+	{  8, { 'd','e','f','c','l','a','s','s' },  HCL_SYNCODE_DEFCLASS,  HCL_OFFSETOF(hcl_t,_defclass)  },
 	{  5, { 'd','e','f','u','n' },              HCL_SYNCODE_DEFUN,     HCL_OFFSETOF(hcl_t,_defun)  },
 	{  2, { 'd','o' },                          HCL_SYNCODE_DO,        HCL_OFFSETOF(hcl_t,_do)  },
 	{  4, { 'e','l','i','f' },                  HCL_SYNCODE_ELIF,      HCL_OFFSETOF(hcl_t,_elif)   },

hcl/lib/hcl.h

@@ -1505,6 +1505,7 @@ struct hcl_t
 	hcl_oop_t _break;  /* symbol */
 	hcl_oop_t _catch; /* symbol */
 	hcl_oop_t _continue; /* symbol */
+	hcl_oop_t _defclass; /* symbol */
 	hcl_oop_t _defun;  /* symbol */
 	hcl_oop_t _do;     /* symbol */
 	hcl_oop_t _elif;   /* symbol */
@@ -1784,6 +1785,7 @@ enum hcl_syncode_t
 	HCL_SYNCODE_BREAK,
 	HCL_SYNCODE_CATCH,
 	HCL_SYNCODE_CONTINUE,
+	HCL_SYNCODE_DEFCLASS,
 	HCL_SYNCODE_DEFUN,
 	HCL_SYNCODE_DO,
 	HCL_SYNCODE_ELIF,