diff --git a/Makefile b/Makefile index 791dc79..7167146 100644 --- a/Makefile +++ b/Makefile @@ -39,6 +39,7 @@ test: arcana-lisp $(CAT) tests/logic_ops.scm | ./arcana-lisp $(LIBS) $(CAT) tests/syntax.scm | ./arcana-lisp $(LIBS) $(CAT) tests/type_conv.scm | ./arcana-lisp $(LIBS) + $(CAT) tests/type_equiv_preds.scm | ./arcana-lisp $(LIBS) $(CAT) tests/type_preds.scm | ./arcana-lisp $(LIBS) clean: diff --git a/src/builtins.c b/src/builtins.c index 82e13f4..56b8ae6 100644 --- a/src/builtins.c +++ b/src/builtins.c @@ -27,6 +27,9 @@ static struct Object *func_cons(size_t args_count, struct Object **args_array); static struct Object *func_list(size_t args_count, struct Object **args_array); // Equivalence predicates static struct Object *func_equal_QN(size_t args_count, struct Object **args_array); +// Type equivalence predicates +static struct Object *func_boolean_EQ_QN(size_t args_count, struct Object **args_array); +static struct Object *func_symbol_EQ_QN(size_t args_count, struct Object **args_array); // Type conversion static struct Object *func_number_TO_string(size_t args_count, struct Object **args_array); static struct Object *func_string_TO_symbol(size_t args_count, struct Object **args_array); @@ -56,6 +59,9 @@ static struct Object builtins[] = { { .type = TYPE_PROCEDURE, .procedure = { "list", func_list } }, // Equivalence predicates { .type = TYPE_PROCEDURE, .procedure = { "equal?", func_equal_QN } }, + // Type equivalence predicates + { .type = TYPE_PROCEDURE, .procedure = { "boolean=?", func_boolean_EQ_QN } }, + { .type = TYPE_PROCEDURE, .procedure = { "symbol=?", func_symbol_EQ_QN } }, // Type conversion { .type = TYPE_PROCEDURE, .procedure = { "number->string", func_number_TO_string } }, { .type = TYPE_PROCEDURE, .procedure = { "string->symbol", func_string_TO_symbol } }, @@ -332,7 +338,7 @@ struct Object *func_list( **************************/ struct Object *func_equal_QN( - size_t args_count, + const size_t args_count, struct Object **const args_array ) { if (args_count <= 1) return Object_new_boolean(true); @@ -389,6 +395,56 @@ struct Object *func_equal_QN( return result; } +/******************************* + * Type equivalence predicates * + *******************************/ + +struct Object *func_boolean_EQ_QN( + const size_t args_count, + struct Object **const args_array +) { + assert(args_count > 0); + + struct Object *const first = args_array[0]; + assert(Object_is_boolean(first)); + + struct Object *const result = Object_new_boolean(true); + + for (size_t index = 1; result->boolean && index < args_count; ++index) { + assert(Object_is_boolean(args_array[index])); + } + + for (size_t index = 1; result->boolean && index < args_count; ++index) { + struct Object *const curr = args_array[index]; + if (curr->boolean != first->boolean) result->boolean = false; + } + + return result; +} + +struct Object *func_symbol_EQ_QN( + const size_t args_count, + struct Object **const args_array +) { + assert(args_count > 0); + + struct Object *const first = args_array[0]; + assert(Object_is_symbol(first)); + + struct Object *const result = Object_new_boolean(true); + + for (size_t index = 1; result->boolean && index < args_count; ++index) { + assert(Object_is_symbol(args_array[index])); + } + + for (size_t index = 1; result->boolean && index < args_count; ++index) { + struct Object *const curr = args_array[index]; + if (strcmp(curr->s, first->s)) result->boolean = false; + } + + return result; +} + /******************* * Type conversion * *******************/ diff --git a/tests/type_equiv_preds.scm b/tests/type_equiv_preds.scm new file mode 100644 index 0000000..e681d4d --- /dev/null +++ b/tests/type_equiv_preds.scm @@ -0,0 +1,39 @@ +;;; boolean=? ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(assert-true (boolean=? #false)) +(assert-true (boolean=? #true)) +(assert-true (boolean=? #false #false)) +(assert-true (boolean=? #true #true)) +(assert-true (boolean=? #false #false #false)) +(assert-true (boolean=? #true #true #true)) +(assert-true (boolean=? #false #false #false #false)) +(assert-true (boolean=? #true #true #true #true)) +(assert-true (boolean=? #false #false #false #false #false)) +(assert-true (boolean=? #true #true #true #true #true)) +(assert-false (boolean=? #false #true)) +(assert-false (boolean=? #true #false)) +(assert-false (boolean=? #false #false #true)) +(assert-false (boolean=? #false #true #false)) +(assert-false (boolean=? #false #true #true)) +(assert-false (boolean=? #true #false #false)) +(assert-false (boolean=? #true #false #true)) +(assert-false (boolean=? #true #true #false)) + +;;; symbol=? ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(assert-true (symbol=? 'foo)) +(assert-true (symbol=? 'bar)) +(assert-true (symbol=? 'foo 'foo)) +(assert-true (symbol=? 'bar 'bar)) +(assert-true (symbol=? 'foo 'foo 'foo)) +(assert-true (symbol=? 'bar 'bar 'bar)) +(assert-true (symbol=? 'foo 'foo 'foo 'foo)) +(assert-true (symbol=? 'bar 'bar 'bar 'bar)) +(assert-true (symbol=? 'foo 'foo 'foo 'foo 'foo)) +(assert-true (symbol=? 'bar 'bar 'bar 'bar 'bar)) +(assert-false (symbol=? 'foo 'bar)) +(assert-false (symbol=? 'bar 'foo)) +(assert-false (symbol=? 'foo 'foo 'bar)) +(assert-false (symbol=? 'foo 'bar 'foo)) +(assert-false (symbol=? 'foo 'bar 'bar)) +(assert-false (symbol=? 'bar 'foo 'foo)) +(assert-false (symbol=? 'bar 'foo 'bar)) +(assert-false (symbol=? 'bar 'bar 'foo))