Implemented eqv?

example.scm

@@ -35,7 +35,6 @@
              (list-tail (cdr x) (- k 1)))))
 
 
-
 ; Math
 
 (define (zero?     x) (= x 0))
@@ -114,6 +113,16 @@
 (set! x 10)
 (display x) (newline)
 
+(newline)
+(display "* R5RS: Testing booleans *")
+(newline)
+
+(display "Testing not\n\tExpect: #f #t #f #f\n\tGotten: ")
+(display (not #t))   (display " ")
+(display (not #f))   (display " ")
+(display (not "hi")) (display " ")
+(display (not 6))    (newline)
+
 (newline)
 (display "* R5RS: Testing numerical operators *")
 (newline)
@@ -229,6 +238,17 @@
 (display "* Testing syntax-rules (move to macro once implemented) *")
 (newline)
 
+(display "Attempting to define true using syntax rules.\n\tExpect: #t #f\n\tGotten: ")
+
+(define-syntax true
+ (syntax-rules ()
+    ((true) #t)))
+
+(display (true))
+(display " ")
+(display (not (true)))
+
+
 (display "Attempting to define and using syntax rules.\n\tExpect: #t #f #f #f\n\tGotten: ")
 
 (define-syntax and

tigerscheme.tig

@@ -260,6 +260,9 @@ let /* Booleans */
     function is_symbol (e: scheme_value): bool =
       e <> nil &e.typ = type_symbol
 
+    function is_boolean (e: scheme_value): bool =
+      e <> nil & (e.typ = type_true | e.typ = type_false)
+
     function int_val (i: int): scheme_value =
       scheme_value { typ   = type_integer
                    , val_i = i
@@ -346,6 +349,79 @@ let /* Booleans */
                     , pos_l = pos_unknown
                     , pos_r = pos_unknown }
 
+
+    function scheme_number_equal (a: scheme_value, b: scheme_value): bool =
+        a.typ = type_integer
+      & b.typ = type_integer
+      & a.val_i = b.val_i
+
+    /* evq? See for definition:
+     * https://people.csail.mit.edu/jaffer/r5rs/Equivalence-predicates.html
+     * */
+
+    function scheme_value_evq (a: scheme_value, b: scheme_value): bool =
+      /* The eqv? procedure defines a useful equivalence relation on
+       * objects. Briefly, it returns #t if obj1 and obj2 should
+       * normally be regarded as the same object. */
+       let
+
+       in if false then false
+
+
+          /* Different types:
+             - #f  iff a and b are of different types
+             - #f  iff one of a and b is the empty list but the other is not.
+             - #f  iff one of a and b is #t but the other is #f */
+          else if a.typ <> b.typ
+               then false
+
+          /* Booleans
+             - #t  iff a and b are both #t or both #f */
+          else if is_boolean(a)
+               then a.val_i = b.val_i
+
+          /* Integers
+             - #t  iff a and b are both numbers, (= a b), and are
+               either both exact or both inexact.
+             - #f  iff one of a and b is an exact number but the other
+               is an inexact number.
+             - #f  iff both a and b are numbers for which the =
+               procedure returns #f */
+          else if a.typ = type_integer
+               then scheme_number_equal(a, b)
+
+          /* TODO: Characters
+             - Delegated to (char=? a b) */
+          else if false
+               then false
+
+          /* Empty lists
+             - #t  iff both a and b are the empty list */
+          else if a.typ = type_nil
+               then true
+
+          /* Symbols:
+             - Delegate to (string=? (symbol->string a) (symbol->string b)) */
+          else if a.typ = type_symbol
+               then a.val_s = b.val_s /* TODO: symbol->string */
+
+          /* Pairs, vectors, strings:
+             - #t  iff a and b are pairs, vectors, or strings that denote the same locations in the store
+             - #f  iff a and b are pairs, vectors, or strings that denote distinct locations. */
+          else if a.typ = type_pair | a.typ = type_string /* TODO: Vector */
+               then a = b
+
+          /* Procedures:
+             - a and b are procedures whose location tags are equal.
+             - a and b are procedures that would behave differently.
+          */
+          else if a.typ = type_closure
+               then a = b
+
+          else ( print("Undefined eqv application")
+               ; true )
+       end
+
     var VALUE_UNSPECIFIED := nil_val()
 
     /* Parsing */
@@ -654,6 +730,7 @@ let /* Booleans */
    var OPCODE_NUMEQ  := 25
    var OPCODE_TYPEOF := 26
    var OPCODE_EXIT   := 27
+   var OPCODE_EQV    := 28
 
    var vm_insn_num_opcodes  := 0
    var vm_insn_info :=
@@ -681,7 +758,7 @@ let /* Booleans */
       ; code(OPCODE_PUSH,   "PUSH",    0, 0, 1)
       ; code(OPCODE_GOTO,   "GOTO",    1, 0, 0)
       ; code(OPCODE_DGOTO,  "DGOTO",   1, 0, 0)
-      ; code(OPCODE_CSKIP,  "CSKIP",   0, 0, 0)
+      ; code(OPCODE_CSKIP,  "CSKIP",   1, 0, 0)
       ; code(OPCODE_DUPL,   "DUPL",    1, 0, 0)
       ; code(OPCODE_SWITCH, "SWITCH",  0, 0, 0)
       ; code(OPCODE_MULT,   "MULT",    0, 0, 0)
@@ -711,6 +788,7 @@ let /* Booleans */
       ; code(OPCODE_COMPILE,"COMPILE",  0, 0, 0)
       ; code(OPCODE_SETENV, "SETENV",   0, 0, 0)
       ; code(OPCODE_EXIT,   "EXIT",     1, 0, 0)
+      ; code(OPCODE_EQV,    "EQV",      0, 0, 0)
 
       ; for i := 1 to expected_number_opcodes - 1
         do if a[i] <> nil & a[i-1] = nil
@@ -886,6 +964,31 @@ let /* Booleans */
                    ; STD_LIB_ID_FUNCTION := fun_val(tape_pos(), nil)
                    ; app(OPCODE_RET,    1, "")
 
+                    /* R5RS: Boolean */
+
+                   ; stdfun("not")
+                   ; app(OPCODE_TYPEOF,  0, "")
+                   ; app2(OPCODE_PUSH,  bool_val(false))
+                   ; app(OPCODE_EQV,     0, "")
+                   ; app(OPCODE_RET,     1, "")
+
+                   ; stdfun("boolean?")
+                   /* Test for false */
+                   ; app(OPCODE_TYPEOF,  0, "")
+                   ; app(OPCODE_DUPL,  0, "")
+                   ; app2(OPCODE_PUSH,  bool_val(false))
+                   ; app(OPCODE_EQV,     0, "")
+                   ; app(OPCODE_CSKIP,   2, "")
+
+                   /* Not false, maybe true? */
+                   ; app2(OPCODE_PUSH,  bool_val(true))
+                   ; app(OPCODE_EQV,     0, "")
+                   ; app(OPCODE_RET,     1, "")
+
+                   /* Is true, remove top and return */
+                   ; app(OPCODE_POP,     0, "")
+                   ; app(OPCODE_RET,     1, "")
+
                     /* R5RS: Pairs and Lists */
 
                    ; stdfun("pair?")
@@ -978,7 +1081,7 @@ let /* Booleans */
                    ; app(OPCODE_TYPEOF, 0, "")
                    ; app2(OPCODE_PUSH, int_val(type_string))
                    ; app(OPCODE_NUMEQ,  0, "")
-                   ; app(OPCODE_CSKIP,  0, "")
+                   ; app(OPCODE_CSKIP,  2, "")
                    ; app(OPCODE_DGOTO,  2, "")
                    ; app(OPCODE_TOSTR,  0, "")
                    ; app(OPCODE_OUTPUT, 0, "")
@@ -1523,7 +1626,7 @@ let /* Booleans */
                       var pos_l := ast.pos_l
                       var pos_r := ast.pos_r
 
-                 in app_insn(insns_test, OPCODE_CSKIP, 0, "" , pos_l, pos_r)
+                 in app_insn(insns_test, OPCODE_CSKIP, 2, "" , pos_l, pos_r)
                   ; app_insn(insns_test, OPCODE_DGOTO, jump_else, "" , pos_l, pos_r)
                   ; concat_lists(insns_test, insns_else)
                   ; app_insn(insns_test, OPCODE_DGOTO, jump_then, "" , pos_l, pos_r)
@@ -1816,6 +1919,10 @@ let /* Booleans */
                                    , ": "
                                    , value_to_string(value)))
 
+         function expect_value(value: scheme_value, name: string) =
+           if value = nil
+             then run_error(concat("stack underflow: ", name))
+
          function vm_update () =
             if not(continue)
               then ()
@@ -1861,7 +1968,7 @@ let /* Booleans */
                   then let var arg1 := stack_pop(stack)
                        in ip := ip + if is_truthy(arg1)
                                      then 1
-                                     else 2
+                                     else tape[ip].arg1
                        end
 
             else if tape[ip].opcode = OPCODE_GOTO
@@ -2017,36 +2124,32 @@ let /* Booleans */
 
             else if tape[ip].opcode = OPCODE_COMPILE
                   then let var ast := stack_pop(stack)
-                       in if ast = nil
+                       in expect_value(ast, "abstract-syntax-tree to compile")
-                              then run_error("Stack too shallow!")
+                        ; let var pos_of_fun := tape_append(tape_info, compile_to_vm(ast, nil, nil, nil)) /* TODO: env_macro */
-                          else
+                          in stack_push(stack, fun_val(pos_of_fun, ENV_EMPTY))
-                            let var pos_of_fun :=
+                           ; ip := ip + 1
-                            tape_append(tape_info, compile_to_vm(ast, nil, nil, nil)) /* TODO: env_macro */
+                          end
-                            in stack_push(stack, fun_val(pos_of_fun, ENV_EMPTY))
-                             ; ip := ip + 1
-                            end
                        end
 
             else if tape[ip].opcode = OPCODE_SETENV
                   then let var stack_fun := stack_pop(stack)
                            var stack_env := stack_pop(stack)
-                       in if stack_fun = nil | stack_env = nil
+                       in expect_value(stack_fun, "function")
-                              then run_error("Stack too shallow!")
+                        ; expect_value(stack_fun, "environment")
-                          else if stack_fun.typ <> type_closure
+                        ; if stack_fun.typ <> type_closure
                               then run_error(concat("Cannot set environment of non-function value ", value_to_string(stack_fun)))
                           else if stack_env.typ <> type_pair
                               then run_error(concat("Cannot use non-list value as environment: ", env_to_string(stack_env)))
 
-                          else ( stack_push(stack, fun_val( stack_fun.val_i, stack_env ))
+                        ; stack_push(stack, fun_val( stack_fun.val_i, stack_env ))
-                               ; ip := ip + 1 )
+                        ; ip := ip + 1
                        end
 
             else if tape[ip].opcode = OPCODE_TYPEOF
                   then let var value := stack_pop(stack)
-                       in if value = nil
+                       in expect_value(value, "")
-                              then run_error("Stack too shallow!")
+                        ; stack_push(stack, int_val(value.typ))
-                          else ( stack_push(stack, int_val(value.typ))
+                        ; ip := ip + 1
-                               ; ip := ip + 1 )
                        end
 
             else if tape[ip].opcode = OPCODE_EXIT
@@ -2054,6 +2157,16 @@ let /* Booleans */
                          then TRIGGERED_EXIT := true
                        ; continue       := false )
 
+            else if tape[ip].opcode = OPCODE_EQV
+                  then let var arg1 := stack_pop(stack)
+                           var arg2 := stack_pop(stack)
+
+                       in expect_value(arg1, "argument #1")
+                        ; expect_value(arg2, "argument #2")
+                        ; stack_push(stack, bool_val(scheme_value_evq(arg1, arg2)))
+                        ; ip := ip + 1
+                       end
+
             else run_error(concat("Encountered unknown opcode "
                                  , int_to_string(tape[ip].opcode)))