commit 82c6a330b5de3aaeb5f7ec8aa79fa97f957e3d9d
parent 80d020d670c6ae7d9443d603301d7a989b1a7c7a
Author: Ryan Sepassi <rsepassi@gmail.com>
Date: Sat, 25 Apr 2026 14:13:18 -0700
scheme1: string? / set-car! / set-cdr! / length / list-ref primitives
Adds five leaf primitives backing R7RS pair- and predicate-level
operations. string? / bytevector? share an entry (HEAP-tagged HDR.BV
test); set-car! / set-cdr! mutate in place and return UNSPEC with no
type check (consistent with car/cdr's lax stance); length forwards to
the existing list_length helper and tags the result; list-ref untags
the index, walks via cdr, and cars the final pair. Length and list-ref
shadowed prelude defines, so those entries are deleted to ensure the
tests exercise the new primitives.
Diffstat:
10 files changed, 156 insertions(+), 7 deletions(-)
diff --git a/scheme1/prelude.scm b/scheme1/prelude.scm
@@ -31,10 +31,6 @@
#t
(if (pair? x) (list? (cdr x)) #f)))
-(define (length xs)
- (let loop ((xs xs) (n 0))
- (if (null? xs) n (loop (cdr xs) (+ n 1)))))
-
(define (reverse xs)
(let loop ((xs xs) (acc (quote ())))
(if (null? xs) acc (loop (cdr xs) (cons (car xs) acc)))))
@@ -47,9 +43,6 @@
((null? (cdr lists)) (car lists))
(else (append-pair (car lists) (apply append (cdr lists))))))
-(define (list-ref xs n)
- (if (= n 0) (car xs) (list-ref (cdr xs) (- n 1))))
-
(define (assoc key alist)
(if (null? alist)
#f
diff --git a/scheme1/scheme1.P1pp b/scheme1/scheme1.P1pp
@@ -2191,6 +2191,64 @@
%ret
%endscope
+# (string? x) -- #t iff x is a HEAP-tagged HDR.BV. Bytevectors back the
+# string type until characters get a distinct repr; this prim is also
+# the bytevector? predicate.
+:prim_stringq_entry
+%scope prim_stringq
+ %car(t0, a0)
+ %li(a0, %imm_val(%IMM.FALSE))
+ %tagof(t1, t0)
+ %li(t2, %TAG.HEAP)
+ %bne(t1, t2, &::end)
+ %hdr_type(t1, t0)
+ %li(t2, %HDR.BV)
+ %bne(t1, t2, &::end)
+ %li(a0, %imm_val(%IMM.TRUE))
+ ::end
+ %ret
+%endscope
+
+# (set-car! pair val) / (set-cdr! pair val) -- in-place pair mutation.
+# No type check (matches car/cdr's lax stance); both return UNSPEC.
+:prim_set_car_entry
+ %args2(t0, t1, a0)
+ %st(t1, t0, -1)
+ %li(a0, %imm_val(%IMM.UNSPEC))
+ %ret
+
+:prim_set_cdr_entry
+ %args2(t0, t1, a0)
+ %st(t1, t0, 7)
+ %li(a0, %imm_val(%IMM.UNSPEC))
+ %ret
+
+# (length xs) -- count of pairs in a proper list. Forwards to the
+# list_length helper (which clobbers a0 as the cursor) and tags the
+# resulting count as a fixnum.
+:prim_length_entry
+ %car(a0, a0)
+ %call(&list_length)
+ %mkfix(a0, a0)
+ %ret
+
+# (list-ref xs n) -- 0-indexed nth element. n is a fixnum; we untag,
+# advance via cdr, then car. Out-of-range is undefined behavior, same
+# as car/cdr on '().
+:prim_list_ref_entry
+%scope prim_list_ref
+ %args2(t0, t1, a0)
+ %sari(t1, t1, 3)
+ ::loop
+ %beqz(t1, &::done)
+ %cdr(t0, t0)
+ %addi(t1, t1, -1)
+ %b(&::loop)
+ ::done
+ %car(a0, t0)
+ %ret
+%endscope
+
:prim_zeroq_entry
%scope prim_zeroq
%car(t0, a0)
@@ -4146,6 +4204,11 @@
:name_cdr "cdr"
:name_nullq "null?"
:name_pairq "pair?"
+:name_stringq "string?"
+:name_set_car "set-car!"
+:name_set_cdr "set-cdr!"
+:name_length "length"
+:name_list_ref "list-ref"
:name_zeroq "zero?"
:name_not "not"
:name_eqq "eq?"
@@ -4215,6 +4278,11 @@
&name_cdr %(0) $(3) &prim_cdr_entry %(0)
&name_nullq %(0) $(5) &prim_nullq_entry %(0)
&name_pairq %(0) $(5) &prim_pairq_entry %(0)
+&name_stringq %(0) $(7) &prim_stringq_entry %(0)
+&name_set_car %(0) $(8) &prim_set_car_entry %(0)
+&name_set_cdr %(0) $(8) &prim_set_cdr_entry %(0)
+&name_length %(0) $(6) &prim_length_entry %(0)
+&name_list_ref %(0) $(8) &prim_list_ref_entry %(0)
&name_zeroq %(0) $(5) &prim_zeroq_entry %(0)
&name_not %(0) $(3) &prim_not_entry %(0)
&name_eqq %(0) $(3) &prim_eqq_entry %(0)
diff --git a/tests/scheme1/59-stringq.expected-exit b/tests/scheme1/59-stringq.expected-exit
@@ -0,0 +1 @@
+0
diff --git a/tests/scheme1/59-stringq.scm b/tests/scheme1/59-stringq.scm
@@ -0,0 +1,18 @@
+; (string? x) -- #t iff x is a bytevector. scheme1 uses bytevectors as
+; the underlying string representation, so string? and bytevector? are
+; the same predicate (LISP.md:strings; we'll split if/when characters
+; gain a distinct repr).
+
+(if (string? "abc") 0 (sys-exit 1))
+(if (string? "") 0 (sys-exit 2))
+(if (string? (make-bytevector 4 0)) 0 (sys-exit 3))
+
+(if (not (string? 42)) 0 (sys-exit 4))
+(if (not (string? 'foo)) 0 (sys-exit 5))
+(if (not (string? '())) 0 (sys-exit 6))
+(if (not (string? '(1 2))) 0 (sys-exit 7))
+(if (not (string? #t)) 0 (sys-exit 8))
+(if (not (string? #f)) 0 (sys-exit 9))
+(if (not (string? car)) 0 (sys-exit 10))
+
+(sys-exit 0)
diff --git a/tests/scheme1/60-set-pair-bang.expected-exit b/tests/scheme1/60-set-pair-bang.expected-exit
@@ -0,0 +1 @@
+0
diff --git a/tests/scheme1/60-set-pair-bang.scm b/tests/scheme1/60-set-pair-bang.scm
@@ -0,0 +1,26 @@
+; (set-car! pair val) and (set-cdr! pair val) -- in-place pair mutation.
+; Both return unspecified; the visible effect is via car/cdr.
+
+(define p (cons 1 2))
+(set-car! p 10)
+(if (= (car p) 10) 0 (sys-exit 1))
+(if (= (cdr p) 2) 0 (sys-exit 2))
+
+(set-cdr! p 20)
+(if (= (car p) 10) 0 (sys-exit 3))
+(if (= (cdr p) 20) 0 (sys-exit 4))
+
+; Mutation visible through aliases.
+(define q p)
+(set-car! q 99)
+(if (= (car p) 99) 0 (sys-exit 5))
+
+; cdr can be a non-pair, a pair, or '().
+(set-cdr! p (cons 7 '()))
+(if (= (car (cdr p)) 7) 0 (sys-exit 6))
+(if (null? (cdr (cdr p))) 0 (sys-exit 7))
+
+(set-cdr! p '())
+(if (null? (cdr p)) 0 (sys-exit 8))
+
+(sys-exit 0)
diff --git a/tests/scheme1/61-length.expected-exit b/tests/scheme1/61-length.expected-exit
@@ -0,0 +1 @@
+0
diff --git a/tests/scheme1/61-length.scm b/tests/scheme1/61-length.scm
@@ -0,0 +1,19 @@
+; (length xs) -- count of pairs in a proper list. Behavior on improper
+; / circular lists is unspecified; we just check the proper-list cases
+; that LISP.md commits to.
+
+(if (= (length '()) 0) 0 (sys-exit 1))
+(if (= (length '(a)) 1) 0 (sys-exit 2))
+(if (= (length '(a b c d e)) 5) 0 (sys-exit 3))
+(if (= (length (cons 1 (cons 2 (cons 3 '())))) 3) 0 (sys-exit 4))
+
+; Same length, different element types.
+(if (= (length (list 1 'two "three" '(4))) 4) 0 (sys-exit 5))
+
+; Built dynamically.
+(define (range n)
+ (let loop ((i 0) (acc '()))
+ (if (= i n) acc (loop (+ i 1) (cons i acc)))))
+(if (= (length (range 17)) 17) 0 (sys-exit 6))
+
+(sys-exit 0)
diff --git a/tests/scheme1/62-list-ref.expected-exit b/tests/scheme1/62-list-ref.expected-exit
@@ -0,0 +1 @@
+0
diff --git a/tests/scheme1/62-list-ref.scm b/tests/scheme1/62-list-ref.scm
@@ -0,0 +1,21 @@
+; (list-ref xs n) -- 0-indexed nth element. Out-of-range is undefined
+; behavior (consistent with car/cdr policy); we only test the in-range
+; cases here.
+
+(define xs '(a b c d e))
+
+(if (eq? (list-ref xs 0) 'a) 0 (sys-exit 1))
+(if (eq? (list-ref xs 1) 'b) 0 (sys-exit 2))
+(if (eq? (list-ref xs 4) 'e) 0 (sys-exit 3))
+
+; Mixed types.
+(define ys (list 1 "two" 'three '(4 5)))
+(if (= (list-ref ys 0) 1) 0 (sys-exit 4))
+(if (bytevector=? (list-ref ys 1) "two") 0 (sys-exit 5))
+(if (eq? (list-ref ys 2) 'three) 0 (sys-exit 6))
+(if (equal? (list-ref ys 3) '(4 5)) 0 (sys-exit 7))
+
+; Independently of `length` (don't entangle the tests).
+(if (= (list-ref (cons 10 (cons 20 (cons 30 '()))) 2) 30) 0 (sys-exit 8))
+
+(sys-exit 0)
