Integrate into stak-r7rs

Gemfile.lock

@@ -36,7 +36,7 @@ GEM
     cucumber-messages (22.0.0)
     cucumber-tag-expressions (6.1.1)
     diff-lcs (1.5.1)
-    ffi (1.17.0-arm64-darwin)
+    ffi (1.17.0)
     mini_mime (1.1.5)
     multi_test (1.1.0)
     rspec-expectations (3.13.3)

prelude.scm

@@ -564,27 +564,27 @@
       ($$rib id '() procedure-type))
 
     (define rib $$rib)
-    (define cons (primitive 1))
-    (define close (primitive 2))
-    (define rib? (primitive 3))
-    (define rib-car (primitive 4))
-    (define rib-cdr (primitive 5))
-    (define rib-tag (primitive 7))
-    (define rib-set-car! (primitive 8))
-    (define rib-set-cdr! (primitive 9))
-    (define eq? (primitive 10))
-    (define $< (primitive 11))
-    (define $+ (primitive 12))
-    (define $- (primitive 13))
-    (define $* (primitive 14))
-    (define $/ (primitive 15))
-    (define remainder (primitive 16))
-    (define exp (primitive 17))
-    (define $log (primitive 18))
-    (define null? (primitive 20))
-    (define pair? (primitive 21))
-    (define memq (primitive 22))
-    (define assq (primitive 23))
+    (define close (primitive 1))
+    (define rib? (primitive 2))
+    (define rib-car (primitive 3))
+    (define rib-cdr (primitive 4))
+    (define rib-tag (primitive 6))
+    (define rib-set-car! (primitive 7))
+    (define rib-set-cdr! (primitive 8))
+    (define eq? (primitive 9))
+    (define $< (primitive 10))
+    (define $+ (primitive 11))
+    (define $- (primitive 12))
+    (define $* (primitive 13))
+    (define $/ (primitive 14))
+    (define remainder (primitive 15))
+    (define exp (primitive 16))
+    (define $log (primitive 17))
+    (define null? (primitive 50))
+    (define pair? (primitive 51))
+    (define assq (primitive 60))
+    (define cons (primitive 61))
+    (define memq (primitive 62))
 
     (define (data-rib type car cdr)
       (rib car cdr type))
@@ -1576,7 +1576,7 @@
   (import (stak base))
 
   (begin
-    (define $halt (primitive 19))
+    (define $halt (primitive 18))
     (define $read-input (primitive 100))
     (define $write-output (primitive 101))
     (define $write-error (primitive 102))
@@ -2377,7 +2377,7 @@
     (only (stak base) data-rib code-points->string primitive procedure-type))
 
   (begin
-    (define $halt (primitive 19))
+    (define $halt (primitive 18))
     (define $command-line (primitive 300))
     (define $get-environment-variables (primitive 301))
 

r7rs/Cargo.toml

@@ -12,6 +12,7 @@ repository.workspace = true
 libm = { version = "0.2.11", default-features = false }
 stak-device = { version = "0.2.86", path = "../device" }
 stak-file = { version = "0.5.0", path = "../file" }
+stak-native = { version = "0.1.0", path = "../native" }
 stak-process-context = { version = "0.2.44", path = "../process_context" }
 stak-time = { version = "0.1.27", path = "../time" }
 stak-vm = { version = "0.7.15", path = "../vm" }

r7rs/src/small.rs

@@ -6,6 +6,7 @@ use self::primitive::Primitive;
 use core::ops::{Add, Div, Mul, Rem, Sub};
 use stak_device::{Device, DevicePrimitiveSet};
 use stak_file::{FilePrimitiveSet, FileSystem};
+use stak_native::{ListPrimitiveSet, TypeCheckPrimitiveSet};
 use stak_process_context::{ProcessContext, ProcessContextPrimitiveSet};
 use stak_time::{Clock, TimePrimitiveSet};
 use stak_vm::{Memory, Number, NumberRepresentation, PrimitiveSet, Tag, Type, Value};
@@ -16,6 +17,8 @@ pub struct SmallPrimitiveSet<D: Device, F: FileSystem, P: ProcessContext, C: Clo
     file: FilePrimitiveSet<F>,
     process_context: ProcessContextPrimitiveSet<P>,
     time: TimePrimitiveSet<C>,
+    type_check: TypeCheckPrimitiveSet,
+    list: ListPrimitiveSet,
 }
 
 impl<D: Device, F: FileSystem, P: ProcessContext, C: Clock> SmallPrimitiveSet<D, F, P, C> {
@@ -26,6 +29,8 @@ impl<D: Device, F: FileSystem, P: ProcessContext, C: Clock> SmallPrimitiveSet<D,
             file: FilePrimitiveSet::new(file_system),
             process_context: ProcessContextPrimitiveSet::new(process_context),
             time: TimePrimitiveSet::new(clock),
+            type_check: Default::default(),
+            list: Default::default(),
         }
     }
 
@@ -110,19 +115,6 @@ impl<D: Device, F: FileSystem, P: ProcessContext, C: Clock> SmallPrimitiveSet<D,
                 .into()
         })
     }
-
-    fn check_type(memory: &mut Memory, r#type: Type) -> Result<(), Error> {
-        Self::operate_top(memory, |memory, value| {
-            memory
-                .boolean(
-                    value
-                        .to_cons()
-                        .map(|cons| memory.cdr(cons).tag() == r#type as _)
-                        .unwrap_or_default(),
-                )
-                .into()
-        })
-    }
 }
 
 impl<D: Device, F: FileSystem, P: ProcessContext, C: Clock> PrimitiveSet
@@ -137,12 +129,6 @@ impl<D: Device, F: FileSystem, P: ProcessContext, C: Clock> PrimitiveSet
 
                 Self::rib(memory, car, cdr, tag.assume_number().to_i64() as _)?;
             }
-            // Optimize a cons.
-            Primitive::CONS => {
-                let [car, cdr] = memory.pop_many();
-
-                Self::rib(memory, car, cdr, Type::Pair as _)?;
-            }
             Primitive::CLOSE => {
                 let closure = memory.pop();
 
@@ -178,44 +164,11 @@ impl<D: Device, F: FileSystem, P: ProcessContext, C: Clock> PrimitiveSet
                 Self::operate_unary(memory, |x| Number::from_f64(libm::log(x.to_f64())))?
             }
             Primitive::HALT => return Err(Error::Halt),
-            // TODO Add a `stak-optimal` crate.
-            Primitive::NULL => Self::operate_top(memory, |memory, value| {
-                memory.boolean(value == memory.null().into()).into()
-            })?,
-            Primitive::PAIR => Self::check_type(memory, Type::Pair)?,
-            Primitive::MEMQ => {
-                let [x, xs] = memory.pop_many();
-                let mut xs = xs.assume_cons();
-                let mut y = memory.boolean(false);
-
-                while xs != memory.null() {
-                    if x == memory.car(xs) {
-                        y = xs;
-                        break;
-                    }
-
-                    xs = memory.cdr(xs).assume_cons();
-                }
-
-                memory.push(y.into())?;
-            }
-            Primitive::ASSQ => {
-                let [x, xs] = memory.pop_many();
-                let mut xs = xs.assume_cons();
-                let mut y = memory.boolean(false);
-
-                while xs != memory.null() {
-                    let cons = memory.car(xs).assume_cons();
-
-                    if x == memory.car(cons) {
-                        y = cons;
-                        break;
-                    }
-
-                    xs = memory.cdr(xs).assume_cons();
-                }
-
-                memory.push(y.into())?;
+            Primitive::NULL | Primitive::PAIR => self
+                .type_check
+                .operate(memory, primitive - Primitive::NULL)?,
+            Primitive::ASSQ | Primitive::CONS | Primitive::MEMQ => {
+                self.list.operate(memory, primitive - Primitive::ASSQ)?
             }
             Primitive::READ | Primitive::WRITE | Primitive::WRITE_ERROR => {
                 self.device.operate(memory, primitive - Primitive::READ)?

r7rs/src/small/primitive.rs

@@ -1,7 +1,6 @@
 #[derive(Clone, Copy, Debug, Eq, PartialEq)]
 pub(super) enum Primitive {
     Rib,
-    Cons,
     Close,
     IsRib,
     Car,
@@ -21,10 +20,11 @@ pub(super) enum Primitive {
     Exponentiation,
     Logarithm,
     Halt,
-    Null,
+    Null = 50,
     Pair,
+    Assq = 60,
+    Cons,
     Memq,
-    Assq,
     Read = 100,
     Write,
     WriteError,
@@ -41,7 +41,6 @@ pub(super) enum Primitive {
 
 impl Primitive {
     pub const RIB: usize = Self::Rib as _;
-    pub const CONS: usize = Self::Cons as _;
     pub const CLOSE: usize = Self::Close as _;
     pub const IS_RIB: usize = Self::IsRib as _;
     pub const CAR: usize = Self::Car as _;
@@ -61,8 +60,9 @@ impl Primitive {
     pub const HALT: usize = Self::Halt as _;
     pub const NULL: usize = Self::Null as _;
     pub const PAIR: usize = Self::Pair as _;
-    pub const MEMQ: usize = Self::Memq as _;
     pub const ASSQ: usize = Self::Assq as _;
+    pub const CONS: usize = Self::Cons as _;
+    pub const MEMQ: usize = Self::Memq as _;
     pub const READ: usize = Self::Read as _;
     pub const WRITE: usize = Self::Write as _;
     pub const WRITE_ERROR: usize = Self::WriteError as _;