From f9e1e189613ac38207f43b1cf290d99f3125a489 Mon Sep 17 00:00:00 2001 From: Jon Michael Aanes Date: Fri, 28 Dec 2018 16:42:37 +0100 Subject: [PATCH] Implemented eqv? --- example.scm | 22 ++++++- tigerscheme.tig | 155 +++++++++++++++++++++++++++++++++++++++++------- 2 files changed, 155 insertions(+), 22 deletions(-) diff --git a/example.scm b/example.scm index 8ae4499..5d0e25e 100644 --- a/example.scm +++ b/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 diff --git a/tigerscheme.tig b/tigerscheme.tig index bfb1634..3b74f16 100644 --- a/tigerscheme.tig +++ b/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 - then run_error("Stack too shallow!") - else - let var pos_of_fun := - tape_append(tape_info, compile_to_vm(ast, nil, nil, nil)) /* TODO: env_macro */ - in stack_push(stack, fun_val(pos_of_fun, ENV_EMPTY)) - ; ip := ip + 1 - end + in expect_value(ast, "abstract-syntax-tree to compile") + ; let var pos_of_fun := tape_append(tape_info, compile_to_vm(ast, nil, nil, nil)) /* TODO: env_macro */ + 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 - then run_error("Stack too shallow!") - else if stack_fun.typ <> type_closure + in expect_value(stack_fun, "function") + ; expect_value(stack_fun, "environment") + ; 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 )) - ; ip := ip + 1 ) + ; stack_push(stack, fun_val( stack_fun.val_i, stack_env )) + ; ip := ip + 1 end else if tape[ip].opcode = OPCODE_TYPEOF then let var value := stack_pop(stack) - in if value = nil - then run_error("Stack too shallow!") - else ( stack_push(stack, int_val(value.typ)) - ; ip := ip + 1 ) + in expect_value(value, "") + ; stack_push(stack, int_val(value.typ)) + ; 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)))