1
0

Implemented eqv?

This commit is contained in:
Jon Michael Aanes 2018-12-28 16:42:37 +01:00
parent e14eaa1dd1
commit f9e1e18961
2 changed files with 155 additions and 22 deletions

View File

@ -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

View File

@ -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)))