diff --git a/native/src/equal.rs b/native/src/equal.rs index ce67a615a..140e6fa03 100644 --- a/native/src/equal.rs +++ b/native/src/equal.rs @@ -4,10 +4,13 @@ use stak_vm::{Error, Memory, PrimitiveSet, Type}; pub enum EqualPrimitive { /// An `eqv` procedure. Eqv, + /// A primitive to check equality of rib inners. + EqualInner, } impl EqualPrimitive { const EQV: usize = Self::Eqv as _; + const EQUAL_INNER: usize = Self::EqualInner as _; } /// An equality primitive set. @@ -44,6 +47,25 @@ impl PrimitiveSet for EqualPrimitiveSet { .into(), )?; } + EqualPrimitive::EQUAL_INNER => { + let [x, y] = memory.pop_many(); + + memory.push( + memory + .boolean(if let (Some(x), Some(y)) = (x.to_cons(), y.to_cons()) { + // - Optimize checks for unique values. + // - Optimize checks for strings and vectors where `car`s are integers. + memory.cdr(x).tag() == memory.cdr(y).tag() + && ![Type::Boolean as _, Type::Null as _, Type::Symbol as _] + .contains(&memory.cdr(x).tag()) + && (memory.car(x).is_cons() || memory.car(x) == memory.car(y)) + } else { + false + }) + .into(), + )?; + } + _ => return Err(Error::IllegalPrimitive), } diff --git a/prelude.scm b/prelude.scm index ed65c1117..d9e503b06 100644 --- a/prelude.scm +++ b/prelude.scm @@ -602,6 +602,7 @@ (define cons (primitive 61)) (define memq (primitive 62)) (define eqv? (primitive 70)) + (define equal-inner? (primitive 71)) (define (data-rib type car cdr) (rib car cdr type)) @@ -626,15 +627,7 @@ (boolean-or (eq? x y) (and - (rib? x) - (rib? y) - (eq? (rib-tag x) (rib-tag y)) - ; Avoid checking values in global variables. - (not (eq? (rib-tag x) symbol-type)) - ; Optimize for the cases of strings and vectors where `car`s are integers. - (boolean-or - (rib? (rib-car x)) - (eq? (rib-car x) (rib-car y))) + (equal-inner? x y) (equal? (rib-car x) (rib-car y)) (equal? (rib-cdr x) (rib-cdr y))))) diff --git a/r7rs/src/small.rs b/r7rs/src/small.rs index 21b70b3c7..27db9ae40 100644 --- a/r7rs/src/small.rs +++ b/r7rs/src/small.rs @@ -146,7 +146,9 @@ impl PrimitiveSet Primitive::ASSQ | Primitive::CONS | Primitive::MEMQ => { self.list.operate(memory, primitive - Primitive::ASSQ)? } - Primitive::EQV => self.equal.operate(memory, primitive - Primitive::EQV)?, + Primitive::EQV | Primitive::EQUAL_INNER => { + self.equal.operate(memory, primitive - Primitive::EQV)? + } Primitive::READ | Primitive::WRITE | Primitive::WRITE_ERROR => { self.device.operate(memory, primitive - Primitive::READ)? } diff --git a/r7rs/src/small/primitive.rs b/r7rs/src/small/primitive.rs index 0dde64aa1..358b51289 100644 --- a/r7rs/src/small/primitive.rs +++ b/r7rs/src/small/primitive.rs @@ -24,6 +24,7 @@ pub(super) enum Primitive { Cons, Memq, Eqv = 70, + EqualInner, Read = 100, Write, WriteError, @@ -63,6 +64,7 @@ impl Primitive { pub const CONS: usize = Self::Cons as _; pub const MEMQ: usize = Self::Memq as _; pub const EQV: usize = Self::Eqv as _; + pub const EQUAL_INNER: usize = Self::EqualInner as _; pub const READ: usize = Self::Read as _; pub const WRITE: usize = Self::Write as _; pub const WRITE_ERROR: usize = Self::WriteError as _;