alisp update

- garbage collector is out (replaced with references and auto-free)
  - added serious test lisp code to detect memory leaks
  - fixme: alisp_snd.c code needs review (remove memory leaks)

alsalisp/hello.lisp

@@ -4,17 +4,23 @@
 
 (defun myprinc (o) (progn (princ o)))
 (myprinc "Printed via myprinc function!\n")
+(unsetq myprinc)
 
 (defun printnum (from to) (while (<= from to) (princ " " from) (setq from (+ from 1))))
 (princ "Numbers 1-10: ") (printnum 1 10) (princ "\n")
+(unsetq printnum)
 
 (defun factorial (n) (if (> n 1) (* n (factorial (- n 1))) 1))
 (princ "Factorial of 10: " (factorial 10) "\n")
-
 (princ "Float test 1.1 + 1.35 = " (+ 1.1 1.35) "\n")
 (princ "Factorial of 10.0: " (factorial 10.0) "\n")
+(princ "Factorial of 20.0: " (factorial 20.0) "\n")
+(unsetq factorial)
 
 (setq alist '((one . first) (two . second) (three . third)))
 (princ "alist = " alist "\n")
 (princ "alist assoc one = " (assoc 'one alist) "\n")
 (princ "alist rassoc third = " (rassoc 'third alist) "\n")
+(unsetq alist)
+
+(&stat-memory)

alsalisp/itest.lisp

@@ -0,0 +1 @@
+(princ "itest.lisp file included!\n")

alsalisp/test.lisp

@@ -0,0 +1,357 @@
+;
+; Test code for all basic alsa lisp commands.
+; The test is indended to find memory leaks.
+;
+; Copyright (c) 2003 Jaroslav Kysela <perex@suse.cz>
+; License: GPL
+;
+
+;
+; Basic commands
+;
+
+(!=)				(&check-memory)
+(!= 0)				(&check-memory)
+(!= 0 1)			(&check-memory)
+(!= 1 1)			(&check-memory)
+(!= 0 1 2)			(&check-memory)
+(!= 'aaaa 'bbbb)		(&check-memory)
+
+(%)				(&check-memory)
+(% 11)				(&check-memory)
+(% 11 5)			(&check-memory)
+(% 11.5 5.1)			(&check-memory)
+(% 11.5 5.1 2.2)		(&check-memory)
+(% 'aaaa 'bbbb)			(&check-memory)
+
+(&check-memory)			(&check-memory)
+(&check-memory "abcd")		(&check-memory)
+(&dump-memory "-")		(&check-memory)
+(&dump-memory)			(&check-memory)
+(&dump-objects "-")		(&check-memory)
+(&dump-objects)			(&check-memory)
+(&stat-memory)			(&check-memory)
+(&stat-memory "abcd")		(&check-memory)
+
+(*)				(&check-memory)
+(* 1)				(&check-memory)
+(* 1 2)				(&check-memory)
+(* 1.1 2.2)			(&check-memory)
+(* 1.1 2.2 3.3)			(&check-memory)
+(* 'aaaa)			(&check-memory)
+
+(+)				(&check-memory)
+(+ 1)				(&check-memory)
+(+ 1 2)				(&check-memory)
+(+ 1.1 2.2)			(&check-memory)
+(+ 1.1 2.2 3.3)			(&check-memory)
+(+ 'aaaa)			(&check-memory)
+(+ 'aaaa 'bbbb)			(&check-memory)
+
+(-)				(&check-memory)
+(- 1)				(&check-memory)
+(- 1 2)				(&check-memory)
+(- 1.1 2.2)			(&check-memory)
+(- 1.1 2.2 3.3)			(&check-memory)
+(- 'aaaa)			(&check-memory)
+(- 'aaaa 'bbbb)			(&check-memory)
+
+(/)				(&check-memory)
+(/ 1)				(&check-memory)
+(/ 1 2)				(&check-memory)
+(/ 1.1 2.2)			(&check-memory)
+(/ 1.1 2.2 3.3)			(&check-memory)
+(/ 'aaaa)			(&check-memory)
+(/ 'aaaa 'bbbb)			(&check-memory)
+
+(<)				(&check-memory)
+(< 0)				(&check-memory)
+(< 0 1)				(&check-memory)
+(< 1 0)				(&check-memory)
+(< 0 1 2)			(&check-memory)
+
+(<=)				(&check-memory)
+(<= 0)				(&check-memory)
+(<= 0 1)			(&check-memory)
+(<= 1 0)			(&check-memory)
+(<= 0 1 2)			(&check-memory)
+
+(=)				(&check-memory)
+(= 0)				(&check-memory)
+(= 0 1)				(&check-memory)
+(= 1 1)				(&check-memory)
+(= 0 1 2)			(&check-memory)
+
+(>)				(&check-memory)
+(> 0)				(&check-memory)
+(> 0 1)				(&check-memory)
+(> 1 0)				(&check-memory)
+(> 0 1 2)			(&check-memory)
+
+(>= 0)				(&check-memory)
+(>= 0 1)			(&check-memory)
+(>= 1 0)			(&check-memory)
+(>= 0 1 2)			(&check-memory)
+
+(and)				(&check-memory)
+(and 0)				(&check-memory)
+(and 1)				(&check-memory)
+(and 0 0 0)			(&check-memory)
+
+(quote a)			(&check-memory)
+
+(assoc)							(&check-memory)
+(assoc 'one)						(&check-memory)
+(assoc 'one '((one . first)))				(&check-memory)
+(assoc 'one '((two . second)))				(&check-memory)
+(assoc 'one '((one . first) (two . second)))		(&check-memory)
+
+(assq)							(&check-memory)
+(assq 'one)						(&check-memory)
+(assq "one" '(("one" . "first")))			(&check-memory)
+(assq "one" '(("two" . "second")))			(&check-memory)
+(assq "one" '(("one" . "first") ("two" . "second")))	(&check-memory)
+
+(atom)				(&check-memory)
+(atom 'one)			(&check-memory)
+(atom "one")			(&check-memory)
+(atom "one" 'two)		(&check-memory)
+
+(call)				(&check-memory)
+
+(car)				(&check-memory)
+(car '(one . two))		(&check-memory)
+
+(cdr)				(&check-memory)
+(cdr '(one . two))		(&check-memory)
+
+(cond)				(&check-memory)
+(cond 0)			(&check-memory)
+(cond 0 1)			(&check-memory)
+(cond 0 1 2)			(&check-memory)
+(cond 0 1 2 3)			(&check-memory)
+(cond (0 'a) (1 'b) (0 'd))	(&check-memory)
+(cond 1)			(&check-memory)
+(cond 1 1)			(&check-memory)
+(cond 1 1 2)			(&check-memory)
+(cond 1 1 2 3)			(&check-memory)
+
+(cons)				(&check-memory)
+(cons "a")			(&check-memory)
+(cons "a" "b")			(&check-memory)
+(cons "a" "b" "c")		(&check-memory)
+
+(eq)				(&check-memory)
+(eq 1)				(&check-memory)
+(eq 0 0)			(&check-memory)
+(eq "a" "b")			(&check-memory)
+(eq "a" "b" "c")		(&check-memory)
+
+(equal)				(&check-memory)
+(equal 1)			(&check-memory)
+(equal 0 0)			(&check-memory)
+(equal "a" "b")			(&check-memory)
+(equal "a" "b" "c")		(&check-memory)
+
+(exfun)				(&check-memory)
+(exfun 'abcd)			(&check-memory)
+(exfun 'abcd 'ijkl)		(&check-memory)
+
+(float)				(&check-memory)
+(float 1)			(&check-memory)
+(float 'a)			(&check-memory)
+(float "a" "b" "c")		(&check-memory)
+(float "1.2")			(&check-memory)
+
+(garbage-collect)		(&check-memory)
+(gc)				(&check-memory)
+
+(if)				(&check-memory)
+(if t)				(&check-memory)
+(if t 'a)			(&check-memory)
+(if t 'a 'b)			(&check-memory)
+(if nil)			(&check-memory)
+(if nil 'a)			(&check-memory)
+(if nil 'a 'b)			(&check-memory)
+
+(include "itest.lisp")		(&check-memory)
+
+(int)				(&check-memory)
+(int 1)				(&check-memory)
+(int 'a)			(&check-memory)
+(int "a" "b" "c")		(&check-memory)
+(int "1.2")			(&check-memory)
+
+(list)				(&check-memory)
+(list "a")			(&check-memory)
+(list "a" "b")			(&check-memory)
+(list "a" "b" "c")		(&check-memory)
+
+(not)				(&check-memory)
+(not 0)				(&check-memory)
+(not nil)			(&check-memory)
+(not t)				(&check-memory)
+(not 'a)			(&check-memory)
+(not 'a 'b 'c 'd)		(&check-memory)
+
+(nth)				(&check-memory)
+(nth 2)				(&check-memory)
+(nth 2 nil)			(&check-memory)
+(nth 2 '(('one 'two 'three)))	(&check-memory)
+
+(null)				(&check-memory)
+(null 0)			(&check-memory)
+(null nil)			(&check-memory)
+(null t)			(&check-memory)
+(null 'a)			(&check-memory)
+(null 'a 'b 'c 'd)		(&check-memory)
+
+(or)				(&check-memory)
+(or 0)				(&check-memory)
+(or 1)				(&check-memory)
+(or 0 0 0)			(&check-memory)
+
+(path)				(&check-memory)
+(path 0)			(&check-memory)
+(path 1)			(&check-memory)
+(path 0 0 0)			(&check-memory)
+(path "data")			(&check-memory)
+
+(princ)				(&check-memory)
+(princ "\nabcd\n")		(&check-memory)
+(princ "a" "b" "c\n")		(&check-memory)
+
+(prog1)				(&check-memory)
+(prog1 1)			(&check-memory)
+(prog1 1 2 3 4)			(&check-memory)
+
+(prog2)				(&check-memory)
+(prog2 1)			(&check-memory)
+(prog2 1 2 3 4)			(&check-memory)
+
+(progn)				(&check-memory)
+(progn 1)			(&check-memory)
+(progn 1 2 3 4)			(&check-memory)
+
+(quote)				(&check-memory)
+(quote a)			(&check-memory)
+
+(rassoc)						(&check-memory)
+(rassoc 'first)						(&check-memory)
+(rassoc 'first '((one . first)))			(&check-memory)
+(rassoc 'first '((two . second)))			(&check-memory)
+(rassoc 'first '((one . first) (two . second)))		(&check-memory)
+
+(rassq)							(&check-memory)
+(rassq "first")						(&check-memory)
+(rassq "first" '(("one" . "first")))			(&check-memory)
+(rassq "first" '(("two" . "second")))			(&check-memory)
+(rassq "first" '(("one" . "first") ("two" . "second")))	(&check-memory)
+
+(set)				(&check-memory)
+(set "a") (unset "a")		(&check-memory)
+(set "a" 1) (unset "a")		(&check-memory)
+(set a 1) (unset a)		(&check-memory)
+(set "a" 1 2) (unset "a")	(&check-memory)
+
+(setf)				(&check-memory)
+(setf a) (unsetf a)		(&check-memory)
+(setf a 1) (unsetf a)		(&check-memory)
+(setf a 1 2) (unsetf a)		(&check-memory)
+
+(setq)				(&check-memory)
+(setq a) (unsetq a)		(&check-memory)
+(setq a 1) (unsetq a)		(&check-memory)
+(setq a 1 2) (unsetq a)		(&check-memory)
+
+(str)				(&check-memory)
+(str 1)				(&check-memory)
+(str 1 2 3)			(&check-memory)
+(str 1.2 1.3)			(&check-memory)
+
+(string=)			(&check-memory)
+(string= 1)			(&check-memory)
+(string= "a")			(&check-memory)
+(string= "a" "a")		(&check-memory)
+(string= "a" "b")		(&check-memory)
+(string= "a" "b" "c")		(&check-memory)
+
+(string-equal)			(&check-memory)
+(string-equal 1)		(&check-memory)
+(string-equal "a")		(&check-memory)
+(string-equal "a" "a")		(&check-memory)
+(string-equal "a" "b")		(&check-memory)
+(string-equal "a" "b" "c")	(&check-memory)
+
+(unless)			(&check-memory)
+(unless 1)			(&check-memory)
+(unless 0 1 2)			(&check-memory)
+(unless t 2 3 4)		(&check-memory)
+(unless nil 2 3 4)		(&check-memory)
+
+(unset)				(&check-memory)
+(unset "a")			(&check-memory)
+
+(unsetf)			(&check-memory)
+(unsetf a)			(&check-memory)
+(unsetf a b)			(&check-memory)
+
+(unsetq)			(&check-memory)
+(unsetq a)			(&check-memory)
+(unsetq a b)			(&check-memory)
+
+(when)				(&check-memory)
+(when 0)			(&check-memory)
+(when 0 1)			(&check-memory)
+(when t 1)			(&check-memory)
+(when nil 1)			(&check-memory)
+
+(while)				(&check-memory)
+(while nil)			(&check-memory)
+(while nil 1)			(&check-memory)
+(while nil 1 2 3 4)		(&check-memory)
+
+;
+; more complex command sequences
+;
+
+(setq abcd "abcd")
+(unsetq abcd)
+(&check-memory)
+
+(defun myfun () (princ "a\n"))
+(exfun 'myfun)
+(unsetq myfun)
+(&check-memory)
+
+(defun myfun () (princ "a\n"))
+(call 'myfun)
+(call 'myfun 'aaaaa)
+(unsetq myfun)
+(&check-memory)
+
+(defun myfun (o) (princ o "a\n"))
+(call 'myfun)
+(call 'myfun 'aaaaa)
+(unsetq myfun)
+(&check-memory)
+
+(defun myfun (o p) (princ o p "\n"))
+(call 'myfun)
+(call 'myfun 'aaaaa)
+(call 'myfun 'aaaaa 'bbbbb)
+(unsetq myfun)
+(&check-memory)
+
+(defun printnum (from to) (while (<= from to) (princ " " from) (setq from (+ from 1))))
+(princ "Numbers 1-10:") (printnum 1 10) (princ "\n")
+(unsetq printnum)
+
+;
+; game over
+;
+
+(princ "*********************\n")
+(princ "OK, all tests passed!\n")
+(princ "*********************\n")
+(&stat-memory)

src/alisp/alisp_local.h

@@ -21,6 +21,8 @@
  *
  */
 
+#include "list.h"
+
 enum alisp_tokens {
 	ALISP_IDENTIFIER,
 	ALISP_INTEGER,
@@ -30,21 +32,31 @@ enum alisp_tokens {
 };
 
 enum alisp_objects {
-	ALISP_OBJ_NIL,
-	ALISP_OBJ_T,
 	ALISP_OBJ_INTEGER,
 	ALISP_OBJ_FLOAT,
 	ALISP_OBJ_IDENTIFIER,
 	ALISP_OBJ_STRING,
 	ALISP_OBJ_POINTER,
-	ALISP_OBJ_CONS
+	ALISP_OBJ_CONS,
+	ALISP_OBJ_LAST_SEARCH = ALISP_OBJ_CONS,
+	ALISP_OBJ_NIL,
+	ALISP_OBJ_T,
 };
 
+struct alisp_object;
+
+#define ALISP_MAX_REFS	0x0fffffff
+#define ALISP_MAX_REFS_LIMIT ((ALISP_MAX_REFS + 1) / 2)
+
+#define ALISP_TYPE_MASK	0xf0000000
+#define ALISP_TYPE_SHIFT 28
+#define ALISP_REFS_MASK 0x0fffffff
+#define ALISP_REFS_SHIFT 0
+
 struct alisp_object {
-	unsigned char	type;
+	struct list_head list;
-	unsigned char	gc;
+	unsigned int	type_refs;	/* type and count of references */
 	union {
-		char	*id;
 		char	*s;
 		long	i;
 		double	f;
@@ -54,16 +66,61 @@ struct alisp_object {
 			struct alisp_object *cdr;
 		} c;
 	} value;
-	struct alisp_object *next;
 };
 
+static inline enum alisp_objects alisp_get_type(struct alisp_object *p)
+{
+	return (p->type_refs >> ALISP_TYPE_SHIFT);
+}
+
+static inline void alisp_set_type(struct alisp_object *p, enum alisp_objects type)
+{
+	p->type_refs &= ~ALISP_TYPE_MASK;
+	p->type_refs |= (unsigned int)type << ALISP_TYPE_SHIFT;
+}
+
+static inline int alisp_compare_type(struct alisp_object *p, enum alisp_objects type)
+{
+	return ((unsigned int)type << ALISP_TYPE_SHIFT) ==
+	       (p->type_refs & ALISP_TYPE_MASK);
+}
+
+static inline void alisp_set_refs(struct alisp_object *p, unsigned int refs)
+{
+	p->type_refs &= ~ALISP_REFS_MASK;
+	p->type_refs |= refs & ALISP_REFS_MASK;
+}
+
+static inline unsigned int alisp_get_refs(struct alisp_object *p)
+{
+	return p->type_refs & ALISP_REFS_MASK;
+}
+
+static inline unsigned int alisp_inc_refs(struct alisp_object *p)
+{
+	unsigned r = alisp_get_refs(p) + 1;
+	alisp_set_refs(p, r);
+	return r;
+}
+
+static inline unsigned int alisp_dec_refs(struct alisp_object *p)
+{
+	unsigned r = alisp_get_refs(p) - 1;
+	alisp_set_refs(p, r);
+	return r;
+}
+
 struct alisp_object_pair {
-	struct alisp_object *name;
+	struct list_head list;
+	const char *name;
  	struct alisp_object *value;
-	struct alisp_object_pair *next;
 };
 
-#define ALISP_LEX_BUF_MAX 16
+#define ALISP_LEX_BUF_MAX	16
+#define ALISP_OBJ_PAIR_HASH_SHIFT 4
+#define ALISP_OBJ_PAIR_HASH_SIZE (1<<ALISP_OBJ_PAIR_HASH_SHIFT)
+#define ALISP_OBJ_PAIR_HASH_MASK (ALISP_OBJ_PAIR_HASH_SIZE-1)
+#define ALISP_FREE_OBJ_POOL	512	/* free objects above this pool */
 
 struct alisp_instance {
 	int verbose: 1,
@@ -84,15 +141,12 @@ struct alisp_instance {
 	char *token_buffer;
 	int token_buffer_max;
 	int thistoken;
-	/* object allocator */
+	/* object allocator / storage */
 	long free_objs;
 	long used_objs;
 	long max_objs;
-	long gc_thr_objs;
+	struct list_head free_objs_list;
-	struct alisp_object *free_objs_list;
+	struct list_head used_objs_list[ALISP_OBJ_PAIR_HASH_SIZE][ALISP_OBJ_LAST_SEARCH + 1];
-	struct alisp_object *used_objs_list;
 	/* set object */
-	struct alisp_object_pair *setobjs_list;
+	struct list_head setobjs_list[ALISP_OBJ_PAIR_HASH_SIZE];
-	/* garbage collect */
-	unsigned char gc_id;
 };

src/alisp/alisp_snd.c

@@ -32,14 +32,14 @@ struct acall_table {
 
 static inline int get_integer(struct alisp_object * obj)
 {
-	if (obj->type == ALISP_OBJ_INTEGER)
+	if (alisp_compare_type(obj, ALISP_OBJ_INTEGER))
 		return obj->value.i;
 	return 0;
 }
 
 static inline const void *get_pointer(struct alisp_object * obj)
 {
-	if (obj->type == ALISP_OBJ_POINTER)
+	if (alisp_compare_type(obj, ALISP_OBJ_POINTER))
 		return obj->value.ptr;
 	return NULL;
 }
@@ -48,10 +48,9 @@ static const char *get_string(struct alisp_object * obj, const char * deflt)
 {
 	if (obj == &alsa_lisp_t)
 		return "true";
-	if (obj->type == ALISP_OBJ_STRING)
+	if (alisp_compare_type(obj, ALISP_OBJ_STRING) ||
+	    alisp_compare_type(obj, ALISP_OBJ_IDENTIFIER))
 		return obj->value.s;
-	if (obj->type == ALISP_OBJ_IDENTIFIER)
-		return obj->value.id;
 	return deflt;
 }
 
@@ -343,7 +342,7 @@ static struct alisp_object * FA_int_intp(struct alisp_instance * instance, struc
 	int val, err;
 
 	args = eval(instance, car(args));
-	if (args->type != ALISP_OBJ_INTEGER)
+	if (!alisp_compare_type(args, ALISP_OBJ_INTEGER))
 		return &alsa_lisp_nil;
 	val = args->value.i;
 	err = ((snd_int_intp_t)item->xfunc)(&val);
@@ -355,7 +354,8 @@ static struct alisp_object * FA_int_str(struct alisp_instance * instance, struct
 	int err;
 
 	args = eval(instance, car(args));
-	if (args->type != ALISP_OBJ_STRING && args->type != ALISP_OBJ_IDENTIFIER)
+	if (!alisp_compare_type(args, ALISP_OBJ_STRING) &&
+	    !alisp_compare_type(args, ALISP_OBJ_IDENTIFIER))
 		return &alsa_lisp_nil;
 	err = ((snd_int_str_t)item->xfunc)(args->value.s);
 	return new_integer(instance, err);
@@ -367,7 +367,7 @@ static struct alisp_object * FA_int_int_strp(struct alisp_instance * instance, s
 	char *str;
 
 	args = eval(instance, car(args));
-	if (args->type != ALISP_OBJ_INTEGER)
+	if (!alisp_compare_type(args, ALISP_OBJ_INTEGER))
 		return &alsa_lisp_nil;
 	err = ((snd_int_int_strp_t)item->xfunc)(args->value.i, &str);
 	return new_result3(instance, err, str);
@@ -422,9 +422,8 @@ static int parse_ctl_elem_id(struct alisp_object * cons, snd_ctl_elem_id_t * id)
 	id->numid = 0;
 	do {
 		p1 = car(cons);
-		if (p1->type == ALISP_OBJ_CONS) {
+		if (alisp_compare_type(p1, ALISP_OBJ_CONS)) {
 			xid = get_string(p1->value.c.car, NULL);
-			printf("id  = '%s'\n", xid);
 			if (xid == NULL) {
 				/* noop */
 			} else if (!strcmp(xid, "numid")) {
@@ -723,7 +722,8 @@ static struct alisp_object * F_acall(struct alisp_instance *instance, struct ali
 	struct acall_table key, *item;
 
 	p1 = eval(instance, car(args));
-	if (p1->type != ALISP_OBJ_IDENTIFIER && p1->type != ALISP_OBJ_STRING)
+	if (!alisp_compare_type(p1, ALISP_OBJ_IDENTIFIER) &&
+	    !alisp_compare_type(p1, ALISP_OBJ_STRING))
 		return &alsa_lisp_nil;
 	p2 = cdr(args);
 	key.name = p1->value.s;
@@ -760,7 +760,7 @@ static int common_error(snd_output_t **rout, struct alisp_instance *instance, st
 
 	do {
 		p1 = eval(instance, car(p));
-		if (p1->type == ALISP_OBJ_STRING)
+		if (alisp_compare_type(p1, ALISP_OBJ_STRING))
 			snd_output_printf(out, "%s", p1->value.s);
 		else
 			princ_object(out, p1);