func "equal"

Makefile

@@ -22,6 +22,7 @@ TEST_OUTS = \
 	tests/basic_data_structs.out \
 	tests/hello.out              \
 	tests/arcane.out             \
+	tests/equiv.out              \
 	tests/logic_ops.out          \
 	tests/syntax.out             \
 	tests/type_conv.out          \
@@ -39,6 +40,7 @@ test: arcane-scheme-lisp-test $(TEST_OUTS)
 	$(DIFF_Q) tests/basic_data_structs.txt tests/basic_data_structs.out
 	$(DIFF_Q) tests/hello.txt              tests/hello.out
 	$(DIFF_Q) tests/arcane.txt             tests/arcane.out
+	$(DIFF_Q) tests/equiv.txt              tests/equiv.out
 	$(DIFF_Q) tests/logic_ops.txt          tests/logic_ops.out
 	$(DIFF_Q) tests/syntax.txt             tests/syntax.out
 	$(DIFF_Q) tests/type_conv.txt          tests/type_conv.out

README.md

@@ -3,3 +3,4 @@ TODO
 
 * [ ] Garbage collector
 * [ ] Tail recursion (in C functions too)
+* [ ] Fix procedures on infinite data structs

src/builtins.c

@@ -29,6 +29,8 @@ static struct Object *func_pairQN(size_t args_count, struct Object **args_array)
 static struct Object *func_procedureQN(size_t args_count, struct Object **args_array);
 static struct Object *func_stringQN(size_t args_count, struct Object **args_array);
 static struct Object *func_symbolQN(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 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);
@@ -63,6 +65,8 @@ static struct Object builtins[] = {
     { .type = TYPE_PROCEDURE, .procedure = { "procedure?",      func_procedureQN           } },
     { .type = TYPE_PROCEDURE, .procedure = { "string?",         func_stringQN              } },
     { .type = TYPE_PROCEDURE, .procedure = { "symbol?",         func_symbolQN              } },
+    // Equivalence predicates
+    { .type = TYPE_PROCEDURE, .procedure = { "equal?",          func_equal_QN              } },
     // Type conversion
     { .type = TYPE_PROCEDURE, .procedure = { "number->string",  func_number_TO_string      } },
     { .type = TYPE_PROCEDURE, .procedure = { "string->symbol",  func_string_TO_symbol      } },
@@ -366,6 +370,68 @@ struct Object *func_symbolQN(
     return Object_new_boolean(object && object->type == TYPE_SYMBOL);
 }
 
+/**************************
+ * Equivalence predicates *
+ **************************/
+
+struct Object *func_equal_QN(
+    size_t args_count,
+    struct Object **const args_array
+) {
+    if (args_count <= 1) return Object_new_boolean(true);
+
+    struct Object *const first = args_array[0];
+    struct Object *const result = Object_new_boolean(true);
+
+    for (size_t index = 1; result->boolean && index < args_count; ++index) {
+        struct Object *const curr = args_array[index];
+
+        if (OBJECT_IS_NULL(first)) {
+            if (!OBJECT_IS_NULL(curr)) result->boolean = false;
+        } else {
+            if (curr->type != first->type) {
+                result->boolean = false;
+                break;
+            }
+
+            switch (first->type) {
+            case TYPE_PROCEDURE:
+                result->boolean =
+                    !strcmp(first->procedure.name, curr->procedure.name);
+                break;
+            case TYPE_PAIR:
+            {
+                struct Object *car_args[2] =
+                    { first->pair.car, curr->pair.car };
+                struct Object *cdr_args[2] =
+                    { first->pair.cdr, curr->pair.cdr };
+                struct Object *car_obj = func_equal_QN(2, car_args);
+                struct Object *cdr_obj = func_equal_QN(2, cdr_args);
+                assert(Object_is_boolean(car_obj));
+                assert(Object_is_boolean(cdr_obj));
+                result->boolean = car_obj->boolean && cdr_obj->boolean;
+                break;
+            }
+            case TYPE_BOOLEAN:
+                result->boolean = first->boolean == curr->boolean;
+                break;
+            case TYPE_CHAR:
+                result->boolean = first->chr == curr->chr;
+                break;
+            case TYPE_SYMBOL:
+            case TYPE_STRING:
+                result->boolean = !strcmp(first->s, curr->s);
+                break;
+            case TYPE_NUMBER:
+                result->boolean = first->number.i64 == curr->number.i64;
+                break;
+            }
+        }
+    }
+
+    return result;
+}
+
 /*******************
  * Type conversion *
  *******************/

src/lexer.c

@@ -416,6 +416,7 @@ void Lexer_lex(const Lexer self, const char chr)
         } else if (chr == '#') {
             self->state = STATE_SHARP;
         } else if (is_space(chr)) {
+            self->state = STATE_WHITESPACE;
             buffer_add(self, chr);
         } else if (is_ident_head(chr)) {
             self->state = STATE_IDENT;

tests/equiv.scm

@@ -0,0 +1,55 @@
+(begin
+  (displayln "--- TEST: equal? -----------------------------------------------")
+  ; No args
+  (displayln (equal?))
+  ; A single arg
+  (displayln (equal? '()))
+  (displayln (equal? +))
+  (displayln (equal? (cons 123 456)))
+  (displayln (equal? #false))
+  (displayln (equal? #true))
+  ;(displayln (equal? #\n))
+  (displayln (equal? 'foo))
+  (displayln (equal? "foo"))
+  (displayln (equal? 123))
+  ; Two equal args
+  (displayln (equal? '() '()))
+  (displayln (equal? + +))
+  (displayln (equal? (cons 123 456) (cons 123 456)))
+  (displayln (equal? #false #false))
+  (displayln (equal? #true #true))
+  ;(displayln (equal? #\n #\n))
+  (displayln (equal? 'foo 'foo))
+  (displayln (equal? "foo" "foo"))
+  (displayln (equal? 123 123))
+  ; Two different args
+  (displayln (equal? '() '(1)))
+  (displayln (equal? + -))
+  (displayln (equal? (cons 123 456) (cons 123 789)))
+  (displayln (equal? #false #true))
+  (displayln (equal? #true #false))
+  ;(displayln (equal? #\n #\t))
+  (displayln (equal? 'foo 'bar))
+  (displayln (equal? "foo" "bar"))
+  (displayln (equal? 123 789))
+  ; Three equal args
+  (displayln (equal? '() '() '()))
+  (displayln (equal? + + +))
+  (displayln (equal? (cons 123 456) (cons 123 456) (cons 123 456)))
+  (displayln (equal? #false #false #false))
+  (displayln (equal? #true #true #true))
+  ;(displayln (equal? #\n #\n #\n))
+  (displayln (equal? 'foo 'foo 'foo))
+  (displayln (equal? "foo" "foo" "foo"))
+  (displayln (equal? 123 123 123))
+  ; Three different args
+  (displayln (equal? '() '() '(1)))
+  (displayln (equal? + + -))
+  (displayln (equal? (cons 123 456) (cons 123 456) (cons 123 789)))
+  (displayln (equal? #false #false #true))
+  (displayln (equal? #true #true #false))
+  ;(displayln (equal? #\n #\n #\t))
+  (displayln (equal? 'foo 'foo 'bar))
+  (displayln (equal? "foo" "foo" "bar"))
+  (displayln (equal? 123 123 789))
+)

tests/equiv.txt

@@ -0,0 +1,42 @@
+"--- TEST: equal? -----------------------------------------------"
+#true
+#true
+#true
+#true
+#true
+#true
+#true
+#true
+#true
+#true
+#true
+#true
+#true
+#true
+#true
+#true
+#true
+#false
+#false
+#false
+#false
+#false
+#false
+#false
+#false
+#true
+#true
+#true
+#true
+#true
+#true
+#true
+#true
+#false
+#false
+#false
+#false
+#false
+#false
+#false
+#false