Optimize eqv? procedure (#2092)

native/src/equal.rs

@@ -0,0 +1,52 @@
+use stak_vm::{Error, Memory, PrimitiveSet, Type};
+
+/// An equality primitive.
+pub enum EqualPrimitive {
+    /// An `eqv` procedure.
+    Eqv,
+}
+
+impl EqualPrimitive {
+    const EQV: usize = Self::Eqv as _;
+}
+
+/// An equality primitive set.
+#[derive(Debug, Default)]
+pub struct EqualPrimitiveSet {}
+
+impl EqualPrimitiveSet {
+    /// Creates a primitive set.
+    pub fn new() -> Self {
+        Self::default()
+    }
+}
+
+impl PrimitiveSet for EqualPrimitiveSet {
+    type Error = Error;
+
+    fn operate(&mut self, memory: &mut Memory, primitive: usize) -> Result<(), Self::Error> {
+        match primitive {
+            EqualPrimitive::EQV => {
+                let [x, y] = memory.pop_many();
+
+                memory.push(
+                    memory
+                        .boolean(
+                            x == y
+                                || if let (Some(x), Some(y)) = (x.to_cons(), y.to_cons()) {
+                                    memory.cdr(x).tag() == Type::Character as _
+                                        && memory.cdr(y).tag() == Type::Character as _
+                                        && memory.car(x) == memory.car(y)
+                                } else {
+                                    false
+                                },
+                        )
+                        .into(),
+                )?;
+            }
+            _ => return Err(Error::IllegalPrimitive),
+        }
+
+        Ok(())
+    }
+}

native/src/lib.rs

@@ -2,8 +2,10 @@
 
 #![no_std]
 
+mod equal;
 mod list;
 mod type_check;
 
+pub use equal::*;
 pub use list::*;
 pub use type_check::*;

native/src/list.rs

@@ -2,7 +2,7 @@ use stak_vm::{Error, Memory, PrimitiveSet, Type};
 
 /// A list primitive.
 pub enum ListPrimitive {
-    /// A `assq` procedure.
+    /// An `assq` procedure.
     Assq,
     /// A `cons` procedure.
     Cons,

prelude.scm

@@ -593,6 +593,7 @@
     (define assq (primitive 60))
     (define cons (primitive 61))
     (define memq (primitive 62))
+    (define eqv? (primitive 70))
 
     (define (data-rib type car cdr)
       (rib car cdr type))
@@ -613,14 +614,6 @@
           (rib? x)
           (eq? (rib-tag x) type))))
 
-    (define (eqv? x y)
-      (boolean-or
-        (eq? x y)
-        (and
-          (char? x)
-          (char? y)
-          (eq? (char->integer x) (char->integer y)))))
-
     (define (equal? x y)
       (boolean-or
         (eq? x y)

r7rs/src/small.rs

@@ -7,7 +7,7 @@ use core::ops::{Add, Div, Mul, Rem, Sub};
 use stak_device::{Device, DevicePrimitiveSet};
 use stak_file::{FilePrimitiveSet, FileSystem};
 use stak_inexact::InexactPrimitiveSet;
-use stak_native::{ListPrimitiveSet, TypeCheckPrimitiveSet};
+use stak_native::{EqualPrimitiveSet, ListPrimitiveSet, TypeCheckPrimitiveSet};
 use stak_process_context::{ProcessContext, ProcessContextPrimitiveSet};
 use stak_time::{Clock, TimePrimitiveSet};
 use stak_vm::{Memory, Number, NumberRepresentation, PrimitiveSet, Tag, Type, Value};
@@ -19,6 +19,7 @@ pub struct SmallPrimitiveSet<D: Device, F: FileSystem, P: ProcessContext, C: Clo
     process_context: ProcessContextPrimitiveSet<P>,
     time: TimePrimitiveSet<C>,
     inexact: InexactPrimitiveSet,
+    equal: EqualPrimitiveSet,
     type_check: TypeCheckPrimitiveSet,
     list: ListPrimitiveSet,
 }
@@ -32,6 +33,7 @@ impl<D: Device, F: FileSystem, P: ProcessContext, C: Clock> SmallPrimitiveSet<D,
             process_context: ProcessContextPrimitiveSet::new(process_context),
             time: TimePrimitiveSet::new(clock),
             inexact: Default::default(),
+            equal: Default::default(),
             type_check: Default::default(),
             list: Default::default(),
         }
@@ -144,6 +146,7 @@ impl<D: Device, F: FileSystem, P: ProcessContext, C: Clock> PrimitiveSet
             Primitive::ASSQ | Primitive::CONS | Primitive::MEMQ => {
                 self.list.operate(memory, primitive - Primitive::ASSQ)?
             }
+            Primitive::EQV => self.equal.operate(memory, primitive - Primitive::EQV)?,
             Primitive::READ | Primitive::WRITE | Primitive::WRITE_ERROR => {
                 self.device.operate(memory, primitive - Primitive::READ)?
             }

r7rs/src/small/primitive.rs

@@ -23,6 +23,7 @@ pub(super) enum Primitive {
     Assq = 60,
     Cons,
     Memq,
+    Eqv = 70,
     Read = 100,
     Write,
     WriteError,
@@ -61,6 +62,7 @@ impl Primitive {
     pub const ASSQ: usize = Self::Assq as _;
     pub const CONS: usize = Self::Cons as _;
     pub const MEMQ: usize = Self::Memq as _;
+    pub const EQV: usize = Self::Eqv as _;
     pub const READ: usize = Self::Read as _;
     pub const WRITE: usize = Self::Write as _;
     pub const WRITE_ERROR: usize = Self::WriteError as _;