length primitive (#3259)

Author: raviqqe

native/src/list.rs

@@ -1,4 +1,4 @@
-use stak_vm::{Error, Heap, Memory, PrimitiveSet, Type};
+use stak_vm::{Error, Heap, Memory, Number, PrimitiveSet, Type};
 use winter_maybe_async::maybe_async;
 
 /// A list primitive.
@@ -11,13 +11,16 @@ pub enum ListPrimitive {
     Memq,
     /// A `list-tail` procedure.
     Tail,
+    /// A `length` procedure.
+    Length,
 }
 
 impl ListPrimitive {
     const ASSQ: usize = Self::Assq as _;
     const CONS: usize = Self::Cons as _;
     const MEMQ: usize = Self::Memq as _;
     const TAIL: usize = Self::Tail as _;
+    const LENGTH: usize = Self::Length as _;
 }
 
 /// A list primitive set.
@@ -97,6 +100,11 @@ impl<H: Heap> PrimitiveSet<H> for ListPrimitiveSet {
 
                 memory.push(xs)?;
             }
+            ListPrimitive::LENGTH => {
+                let xs = memory.pop()?;
+
+                memory.push(Number::from_i64(memory.list_length(xs.assume_cons())? as _).into())?;
+            }
             _ => return Err(Error::IllegalPrimitive),
         }
 

prelude.scm

@@ -627,6 +627,7 @@
     (define cons (primitive 61))
     (define memq (primitive 62))
     (define list-tail (primitive 63))
+    (define length (primitive 64))
     (define eqv? (primitive 70))
     (define equal-inner? (primitive 71))
     (define sqrt (primitive 504))
@@ -901,11 +902,6 @@
           '()
           (cons fill (loop (- length 1))))))
 
-    (define (length xs)
-      (do ((xs xs (cdr xs)) (y 0 (+ y 1)))
-        ((null? xs)
-          y)))
-
     (define (map* f xs)
       (if (null? xs)
         xs

r7rs/src/small.rs

@@ -147,7 +147,11 @@ impl<H: Heap, D: Device, F: FileSystem, P: ProcessContext, C: Clock> PrimitiveSe
             Primitive::NULL | Primitive::PAIR => {
                 maybe_await!(self.type_check.operate(memory, primitive - Primitive::NULL))?
             }
-            Primitive::ASSQ | Primitive::CONS | Primitive::MEMQ | Primitive::TAIL => {
+            Primitive::ASSQ
+            | Primitive::CONS
+            | Primitive::MEMQ
+            | Primitive::TAIL
+            | Primitive::LENGTH => {
                 maybe_await!(self.list.operate(memory, primitive - Primitive::ASSQ))?
             }
             Primitive::EQV | Primitive::EQUAL_INNER => {

r7rs/src/small/primitive.rs

@@ -24,6 +24,7 @@ pub(super) enum Primitive {
     Cons,
     Memq,
     Tail,
+    Length,
     Eqv = 70,
     EqualInner,
     Read = 100,
@@ -78,6 +79,7 @@ impl Primitive {
     pub const CONS: usize = Self::Cons as _;
     pub const MEMQ: usize = Self::Memq as _;
     pub const TAIL: usize = Self::Tail as _;
+    pub const LENGTH: usize = Self::Length as _;
     pub const EQV: usize = Self::Eqv as _;
     pub const EQUAL_INNER: usize = Self::EqualInner as _;
     pub const READ: usize = Self::Read as _;

snapshots/bench/src/eval/main.md

@@ -136,6 +136,9 @@
 - constant 63
 - call 1 #f primitive
 - set list-tail
+- constant 64
+- call 1 #f primitive
+- set length
 - constant 70
 - call 1 #f primitive
 - set eqv?
@@ -676,25 +679,6 @@
   - get 3
   - call 1 #f 1
 - set make-list
-- constant procedure 1 #f
-  - constant #f
-  - constant procedure 2 #f
-    - get 1
-    - call 1 #f null?
-    - if
-      - get 0
-    - get 1
-    - call 1 #f cdr
-    - get 1
-    - constant 1
-    - call 2 #f ||
-    - call 2 #f 5
-  - call 1 #f $$close
-  - set 1
-  - get 1
-  - constant 0
-  - call 2 #f 2
-- set length
 - constant procedure 2 #f
   - get 0
   - call 1 #f null?

snapshots/bench/src/fibonacci/main.md

@@ -91,6 +91,9 @@
 - constant 63
 - call 1 #f ||
 - set ||
+- constant 64
+- call 1 #f ||
+- set ||
 - constant 71
 - call 1 #f ||
 - set ||
@@ -318,25 +321,6 @@
 - constant procedure 0 #t
   - get 0
 - set ||
-- constant procedure 1 #f
-  - constant #f
-  - constant procedure 2 #f
-    - get 1
-    - call 1 #f ||
-    - if
-      - get 0
-    - get 1
-    - call 1 #f ||
-    - get 1
-    - constant 1
-    - call 2 #f ||
-    - call 2 #f 5
-  - call 1 #f ||
-  - set 1
-  - get 1
-  - constant 0
-  - call 2 #f 2
-- set ||
 - constant procedure 2 #f
   - get 0
   - call 1 #f ||

snapshots/bench/src/hello/main.md

@@ -88,6 +88,9 @@
 - constant 63
 - call 1 #f ||
 - set ||
+- constant 64
+- call 1 #f ||
+- set ||
 - constant procedure 3 #f
   - get 1
   - get 1
@@ -242,25 +245,6 @@
   - call 1 #f ||
   - call 1 #f ||
 - set ||
-- constant procedure 1 #f
-  - constant #f
-  - constant procedure 2 #f
-    - get 1
-    - call 1 #f ||
-    - if
-      - get 0
-    - get 1
-    - call 1 #f ||
-    - get 1
-    - constant 1
-    - call 2 #f ||
-    - call 2 #f 5
-  - call 1 #f ||
-  - set 1
-  - get 1
-  - constant 0
-  - call 2 #f 2
-- set ||
 - constant procedure 2 #f
   - get 0
   - call 1 #f ||

snapshots/bench/src/read/main.md

@@ -88,6 +88,9 @@
 - constant 63
 - call 1 #f ||
 - set ||
+- constant 64
+- call 1 #f ||
+- set ||
 - constant 70
 - call 1 #f ||
 - set ||
@@ -299,25 +302,6 @@
 - constant procedure 0 #t
   - get 0
 - set ||
-- constant procedure 1 #f
-  - constant #f
-  - constant procedure 2 #f
-    - get 1
-    - call 1 #f ||
-    - if
-      - get 0
-    - get 1
-    - call 1 #f ||
-    - get 1
-    - constant 1
-    - call 2 #f ||
-    - call 2 #f 5
-  - call 1 #f ||
-  - set 1
-  - get 1
-  - constant 0
-  - call 2 #f 2
-- set ||
 - constant procedure 2 #f
   - get 0
   - call 1 #f ||

snapshots/bench/src/sum/main.md

@@ -91,6 +91,9 @@
 - constant 63
 - call 1 #f ||
 - set ||
+- constant 64
+- call 1 #f ||
+- set ||
 - constant 71
 - call 1 #f ||
 - set ||
@@ -318,25 +321,6 @@
 - constant procedure 0 #t
   - get 0
 - set ||
-- constant procedure 1 #f
-  - constant #f
-  - constant procedure 2 #f
-    - get 1
-    - call 1 #f ||
-    - if
-      - get 0
-    - get 1
-    - call 1 #f ||
-    - get 1
-    - constant 1
-    - call 2 #f ||
-    - call 2 #f 5
-  - call 1 #f ||
-  - set 1
-  - get 1
-  - constant 0
-  - call 2 #f 2
-- set ||
 - constant procedure 2 #f
   - get 0
   - call 1 #f ||

snapshots/bench/src/tak/main.md

@@ -91,6 +91,9 @@
 - constant 63
 - call 1 #f ||
 - set ||
+- constant 64
+- call 1 #f ||
+- set ||
 - constant 71
 - call 1 #f ||
 - set ||
@@ -318,25 +321,6 @@
 - constant procedure 0 #t
   - get 0
 - set ||
-- constant procedure 1 #f
-  - constant #f
-  - constant procedure 2 #f
-    - get 1
-    - call 1 #f ||
-    - if
-      - get 0
-    - get 1
-    - call 1 #f ||
-    - get 1
-    - constant 1
-    - call 2 #f ||
-    - call 2 #f 5
-  - call 1 #f ||
-  - set 1
-  - get 1
-  - constant 0
-  - call 2 #f 2
-- set ||
 - constant procedure 2 #f
   - get 0
   - call 1 #f ||