commit 9bc9e556cd159f382927e9712aa24f2c55285fef
parent 736cf9c89accb9c4bd818732a717d354ac712820
Author: Ryan Sepassi <rsepassi@gmail.com>
Date: Tue, 28 Apr 2026 11:41:04 -0700
scheme1: add list traversal primitives
Diffstat:
6 files changed, 190 insertions(+), 27 deletions(-)
diff --git a/cc/cc.scm b/cc/cc.scm
@@ -49,18 +49,8 @@
;; --------------------------------------------------------------------
;; lists / alists
;; --------------------------------------------------------------------
-(define (alist-ref key al)
- ;; equal? compare (intended for bv keys). The prelude's `assoc` uses
- ;; eq?, so we roll our own for the equal? case.
- (cond ((null? al) #f)
- ((equal? (car (car al)) key) (cdr (car al)))
- (else (alist-ref key (cdr al)))))
-
-(define (alist-ref/eq key al)
- ;; eq? compare (for symbol keys). Reuses the prelude's assoc, which
- ;; is eq?-based.
- (let ((p (assoc key al)))
- (if p (cdr p) #f)))
+(define (alist-ref key al) (let ((p (assoc key al))) (and p (cdr p))))
+(define (alist-ref/eq key al) (let ((p (assq key al))) (and p (cdr p))))
(define (alist-set key val al) (cons (cons key val) al))
diff --git a/docs/SCHEME1.md b/docs/SCHEME1.md
@@ -143,7 +143,10 @@ these.
`symbol?`, `string?` (≡ `bytevector?`), `procedure?`, `zero?`, `eof?`.
**Pairs**
-`cons`, `car`, `cdr`, `set-car!`, `set-cdr!`, `length`, `list-ref`.
+`cons`, `car`, `cdr`, `set-car!`, `set-cdr!`, `length`, `list-ref`,
+`assq`, `assoc`, `reverse`. `assq` compares alist keys by `eq?`;
+`assoc` compares keys by `equal?`; both return the matching alist pair
+or `#f`. `reverse` returns a fresh reversed list.
**Integers** (word-size; overflow / divide-by-zero are UB)
`+ - *`, `quotient`, `remainder`, `=`, `<`, `>`, `bit-and`, `bit-or`,
@@ -231,10 +234,11 @@ convention) when failure needs to be observable.
- **Arithmetic**: `<=`, `>=`, `negative?`, `positive?`, `abs`, `min`,
`max`, `modulo`.
- **Equivalence chains**: `boolean=?`, `symbol=?`.
-- **List helpers**: `list`, `list?`, `reverse`, `append`, `make-list`,
- `list-tail`, `list-set!`, `list-copy`, `memq` / `memv` / `member`,
- `assq` / `assv` / `assoc`, `map`, `for-each`, `filter`, `fold`, plus
- the full `c[ad]+r` family up to four levels.
+- **List helpers**: `list`, `list?`, `append`, `make-list`, `list-tail`,
+ `list-set!`, `list-copy`, `memq` / `memv` / `member`, `assv` (alias
+ of primitive `assq`), `map`, `for-each`, `filter`, `fold`, plus the
+ full `c[ad]+r` family up to four levels. Primitive list helpers
+ available before the prelude are listed above.
- **Characters as fixnums**: `char?`, `char->integer`,
`integer->char` (identity), `char-upper-case?`, `char-lower-case?`,
`char-alphabetic?`, `char-numeric?`, `char-whitespace?`,
diff --git a/scheme1/prelude.scm b/scheme1/prelude.scm
@@ -90,10 +90,6 @@
#t
(if (pair? x) (list? (cdr x)) #f)))
-(define (reverse xs)
- (let loop ((xs xs) (acc (quote ())))
- (if (null? xs) acc (loop (cdr xs) (cons (car xs) acc)))))
-
(define (append-pair a b)
(if (null? a) b (cons (car a) (append-pair (cdr a) b))))
@@ -126,13 +122,7 @@
(if (null? xs) #f
(if (equal? (car xs) x) xs (member x (cdr xs)))))
-(define (assq x alist)
- (if (null? alist) #f
- (if (eq? (car (car alist)) x) (car alist) (assq x (cdr alist)))))
(define assv assq)
-(define (assoc x alist)
- (if (null? alist) #f
- (if (equal? (car (car alist)) x) (car alist) (assoc x (cdr alist)))))
;; --- map / filter / fold / for-each --------------------------------
;; map and for-each accept N parallel lists per R7RS; iteration stops
diff --git a/scheme1/scheme1.P1pp b/scheme1/scheme1.P1pp
@@ -3363,6 +3363,95 @@
%ret
%endscope
+# (assq key alist) -> matching pair or #f. Walks alist, comparing
+# car of each pair to key by identity (eq?); first match wins. Pure
+# leaf -- no allocation, no calls. Replaces the interpreted prelude
+# define so file-scope alist lookups (e.g. cc.scm scope-bind!'s
+# redecl check) don't pay bind_params env-cons cost per step.
+:prim_assq_entry
+%scope prim_assq
+ %args2(t0, t1, a0) ; t0=key, t1=alist
+ ::loop
+ %if_nil(t2, t1, &::miss)
+ %car(t2, t1) ; pair = (car alist)
+ %car(a0, t2) ; (car pair)
+ %beq(a0, t0, &::hit)
+ %cdr(t1, t1)
+ %b(&::loop)
+ ::hit
+ %mov(a0, t2)
+ %ret
+ ::miss
+ %li(a0, %imm_val(%IMM.FALSE))
+ %ret
+%endscope
+
+# (assoc key alist) -> matching pair or #f. Same shape as assq but
+# the key compare goes through equal_recurse, which means we need a
+# frame to preserve the key/cursor/current-pair across the call.
+#
+# Locals:
+# key
+# cursor
+# pair (saved across equal_recurse so we can return it on hit)
+%fn2(prim_assoc_entry, {key cursor pair}, {
+ %args2(t0, t1, a0)
+ %stl(t0, key)
+ %stl(t1, cursor)
+
+ ::loop
+ %ldl(t1, cursor)
+ %if_nil(t2, t1, &::miss)
+ %car(t2, t1) ; pair = (car cursor)
+ %stl(t2, pair)
+ %car(a0, t2) ; (car pair)
+ %ldl(a1, key)
+ %call(&equal_recurse)
+ %li(t0, %imm_val(%IMM.FALSE))
+ %beq(a0, t0, &::next)
+ %ldl(a0, pair)
+ %eret
+
+ ::next
+ %ldl(t1, cursor)
+ %cdr(t1, t1)
+ %stl(t1, cursor)
+ %b(&::loop)
+
+ ::miss
+ %li(a0, %imm_val(%IMM.FALSE))
+})
+
+# (reverse list) -> fresh reversed list. Walks the input forward,
+# consing each element onto an accumulator; result is the accumulator.
+# One fresh PAIR per input element, no intermediates. Frame needed
+# because cons is a leaf and %call clobbers lr.
+#
+# Locals:
+# xs (cursor; advanced each iteration)
+# acc
+%fn2(prim_reverse_entry, {xs acc}, {
+ %car(t0, a0) ; t0 = list arg
+ %stl(t0, xs)
+ %li(t0, %imm_val(%IMM.NIL))
+ %stl(t0, acc)
+
+ ::loop
+ %ldl(t0, xs)
+ %if_nil(t1, t0, &::done)
+ %car(a0, t0)
+ %ldl(a1, acc)
+ %call(&cons)
+ %stl(a0, acc)
+ %ldl(t0, xs)
+ %cdr(t0, t0)
+ %stl(t0, xs)
+ %b(&::loop)
+
+ ::done
+ %ldl(a0, acc)
+})
+
# (bytevector-append bv ...) -- variadic concatenation. Two passes:
# the first sums the bv lengths so we can size the result up front; the
# second walks the args again and memcpy's each src into the result.
@@ -5975,6 +6064,9 @@
:name_set_cdr "set-cdr!" '00000000000000'
:name_length "length" '00'
:name_list_ref "list-ref" '00000000000000'
+:name_assq "assq" '000000'
+:name_assoc "assoc" '0000'
+:name_reverse "reverse"
:name_str_to_sym "string->symbol" '00'
:name_sym_to_str "symbol->string" '00'
:name_num_to_str "number->string" '00'
@@ -6065,6 +6157,9 @@
&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_assq %(0) $(4) &prim_assq_entry %(0)
+&name_assoc %(0) $(5) &prim_assoc_entry %(0)
+&name_reverse %(0) $(7) &prim_reverse_entry %(0)
&name_str_to_sym %(0) $(14) &prim_string_to_symbol_entry %(0)
&name_sym_to_str %(0) $(14) &prim_symbol_to_string_entry %(0)
&name_num_to_str %(0) $(14) &prim_number_to_string_entry %(0)
diff --git a/tests/scheme1/120-list-prims.expected-exit b/tests/scheme1/120-list-prims.expected-exit
@@ -0,0 +1 @@
+0
diff --git a/tests/scheme1/120-list-prims.scm b/tests/scheme1/120-list-prims.scm
@@ -0,0 +1,83 @@
+; List-traversal primitives: assq, assoc, reverse.
+; Locks down the prim contract that replaced the interpreted prelude
+; defines (see docs/SCHEME1-LIST-PRIMS.md).
+
+; ---- assq: eq? key compare ----
+
+(define al-sym (list (cons 'a 1) (cons 'b 2) (cons 'c 3)))
+
+; hit
+(if (equal? (cons 'b 2) (assq 'b al-sym)) 0 (sys-exit 1))
+(if (equal? (cons 'a 1) (assq 'a al-sym)) 0 (sys-exit 2))
+(if (equal? (cons 'c 3) (assq 'c al-sym)) 0 (sys-exit 3))
+
+; miss
+(if (not (assq 'z al-sym)) 0 (sys-exit 4))
+
+; empty
+(if (not (assq 'a (quote ()))) 0 (sys-exit 5))
+
+; identity preservation: assq returns the actual pair from the alist
+(let* ((p (cons 'k 99)) (al (list p)))
+ (if (eq? p (assq 'k al)) 0 (sys-exit 6)))
+
+; assq with bv keys -- distinct bv objects with same contents are NOT
+; eq?, so a freshly-built lookup key must miss.
+(if (not (assq "foo" (list (cons "foo" 1)))) 0 (sys-exit 7))
+
+; ---- assoc: equal? key compare ----
+
+; hit on symbol keys (eq? would also match)
+(if (equal? (cons 'b 2) (assoc 'b al-sym)) 0 (sys-exit 10))
+
+; hit on bv keys -- distinct objects, equal contents
+(define al-bv (list (cons "alpha" 1) (cons "beta" 2) (cons "gamma" 3)))
+(if (equal? (cons "beta" 2) (assoc "beta" al-bv)) 0 (sys-exit 11))
+(if (equal? (cons "alpha" 1) (assoc "alpha" al-bv)) 0 (sys-exit 12))
+(if (equal? (cons "gamma" 3) (assoc "gamma" al-bv)) 0 (sys-exit 13))
+
+; miss
+(if (not (assoc "delta" al-bv)) 0 (sys-exit 14))
+
+; empty
+(if (not (assoc "x" (quote ()))) 0 (sys-exit 15))
+
+; nested-equal? key (list compared structurally)
+(define al-list (list (cons (list 1 2) 'a) (cons (list 3 4) 'b)))
+(if (eq? 'b (cdr (assoc (list 3 4) al-list))) 0 (sys-exit 16))
+
+; identity preservation: assoc returns the actual pair from the alist
+(let* ((p (cons "k" 99)) (al (list p)))
+ (if (eq? p (assoc "k" al)) 0 (sys-exit 17)))
+
+; ---- reverse ----
+
+; empty
+(if (null? (reverse (quote ()))) 0 (sys-exit 20))
+
+; single element
+(if (equal? (list 1) (reverse (list 1))) 0 (sys-exit 21))
+
+; typical
+(if (equal? (list 4 3 2 1) (reverse (list 1 2 3 4))) 0 (sys-exit 22))
+
+; mixed types
+(if (equal? (list "c" 'b 1) (reverse (list 1 'b "c"))) 0 (sys-exit 23))
+
+; double-reverse is identity (structurally; fresh allocation)
+(let ((xs (list 1 2 3 4 5)))
+ (if (equal? xs (reverse (reverse xs))) 0 (sys-exit 24)))
+
+; reverse does not mutate the input
+(let* ((xs (list 1 2 3))
+ (ys (reverse xs)))
+ (if (equal? (list 1 2 3) xs) 0 (sys-exit 25))
+ (if (equal? (list 3 2 1) ys) 0 (sys-exit 26)))
+
+; reverse allocates fresh pairs (head of result is not eq? to any
+; input pair, since the elements themselves get re-consed)
+(let* ((xs (list 1 2 3))
+ (ys (reverse xs)))
+ (if (eq? xs ys) (sys-exit 27) 0))
+
+(sys-exit 0)
