Implemented eqv?
This commit is contained in:
parent
e14eaa1dd1
commit
f9e1e18961
22
example.scm
22
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
|
||||
|
|
|
|||
149
tigerscheme.tig
149
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
|
||||
|
|
@ -884,6 +962,31 @@ let /* Booleans */
|
|||
; stdfun("syntax->datum")
|
||||
; stdfun("datum->syntax")
|
||||
; 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 */
|
||||
|
|
@ -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,11 +2124,8 @@ 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 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
|
||||
|
|
@ -2030,23 +2134,22 @@ let /* Booleans */
|
|||
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)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user