commit 99b03a2e38d9ec97d8ba3b5a8e837b2bf8deb11a
parent 51f2496aa8075ec8e66f9eaa14e18420991fbfaf
Author: Ryan Sepassi <rsepassi@gmail.com>
Date: Mon, 27 Apr 2026 12:28:19 -0700
scheme1 prelude: various extensions
Diffstat:
| M | scheme1/prelude.scm | | | 334 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++------- |
1 file changed, 308 insertions(+), 26 deletions(-)
diff --git a/scheme1/prelude.scm b/scheme1/prelude.scm
@@ -1,11 +1,13 @@
; scheme1 prelude. catm'd in front of the user .scm before invoking the
-; scheme1 binary (see scripts/boot-run-scheme1.sh). Defines list helpers,
-; the shell.scm process-management wrappers, and the shell.scm file-I/O
-; layer (port record + buffered reads/writes).
+; scheme1 binary (see scripts/boot-run-scheme1.sh). Defines the R7RS
+; surface that's expressible over scheme1's existing primitives --
+; equivalence aliases, list helpers, characters as fixnum bytes,
+; strings as NUL-terminated bytevectors -- plus the shell.scm process-
+; management and file-I/O layer (port record + buffered reads/writes).
;
-; Items that depend on primitives scheme1 doesn't yet have (>, the
-; vector-* family, the string-* family) stay here as commented
-; placeholders for re-enabling once those primitives land.
+; Items that depend on primitives scheme1 doesn't yet have (the
+; vector-* family) stay here as commented placeholders for re-enabling
+; once those primitives land. See docs/SCHEME1-R7RS-TODO.md.
;; --- Arithmetic helpers (derivable from <, =, -) --------------------
(define (<= x y) (if (< y x) #f #t))
@@ -35,14 +37,52 @@
r
(+ r b)))))
-;; --- Common c*r compositions ---------------------------------------
+;; --- R7RS equivalence / equality predicates ------------------------
+;; eqv? collapses to eq? for our value set: fixnums are immediate-
+;; tagged, symbols are interned, and pairs/strings/closures use
+;; pointer identity.
+(define eqv? eq?)
+
+(define (%all-eq? a xs)
+ (if (null? xs) #t
+ (if (eq? (car xs) a) (%all-eq? a (cdr xs)) #f)))
+
+(define (boolean=? a b . rest) (and (eq? a b) (%all-eq? a rest)))
+(define (symbol=? a b . rest) (and (eq? a b) (%all-eq? a rest)))
+
+;; --- c*r compositions ----------------------------------------------
(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
-(define (caddr x) (car (cdr (cdr x))))
-;; --- List helpers (derivable from cons/car/cdr/null?/pair?/eq?) -----
+(define (caaar x) (car (caar x)))
+(define (caadr x) (car (cadr x)))
+(define (cadar x) (car (cdar x)))
+(define (caddr x) (car (cddr x)))
+(define (cdaar x) (cdr (caar x)))
+(define (cdadr x) (cdr (cadr x)))
+(define (cddar x) (cdr (cdar x)))
+(define (cdddr x) (cdr (cddr x)))
+
+(define (caaaar x) (car (caaar x)))
+(define (caaadr x) (car (caadr x)))
+(define (caadar x) (car (cadar x)))
+(define (caaddr x) (car (caddr x)))
+(define (cadaar x) (car (cdaar x)))
+(define (cadadr x) (car (cdadr x)))
+(define (caddar x) (car (cddar x)))
+(define (cadddr x) (car (cdddr x)))
+(define (cdaaar x) (cdr (caaar x)))
+(define (cdaadr x) (cdr (caadr x)))
+(define (cdadar x) (cdr (cadar x)))
+(define (cdaddr x) (cdr (caddr x)))
+(define (cddaar x) (cdr (cdaar x)))
+(define (cddadr x) (cdr (cdadr x)))
+(define (cdddar x) (cdr (cddar x)))
+(define (cddddr x) (cdr (cdddr x)))
+
+;; --- List helpers --------------------------------------------------
(define (list . xs) xs)
(define (list? x)
@@ -62,23 +102,61 @@
((null? (cdr lists)) (car lists))
(else (append-pair (car lists) (apply append (cdr lists))))))
-(define (assoc key alist)
- (if (null? alist)
- #f
- (if (eq? (car (car alist)) key)
- (car alist)
- (assoc key (cdr alist)))))
+(define (make-list n . fill)
+ (let ((v (if (null? fill) #f (car fill))))
+ (let loop ((i 0) (acc (quote ())))
+ (if (= i n) acc (loop (+ i 1) (cons v acc))))))
-(define (member x xs)
- (if (null? xs)
- #f
- (if (eq? (car xs) x)
- xs
- (member x (cdr xs)))))
+(define (list-tail xs k)
+ (if (zero? k) xs (list-tail (cdr xs) (- k 1))))
-;; --- map / filter / fold / for-each ---------------------------------
-(define (map f xs)
- (if (null? xs) (quote ()) (cons (f (car xs)) (map f (cdr xs)))))
+(define (list-set! xs k v)
+ (if (zero? k) (set-car! xs v) (list-set! (cdr xs) (- k 1) v)))
+
+(define (list-copy xs)
+ (if (pair? xs)
+ (cons (car xs) (list-copy (cdr xs)))
+ xs))
+
+(define (memq x xs)
+ (if (null? xs) #f
+ (if (eq? (car xs) x) xs (memq x (cdr xs)))))
+(define memv memq)
+(define (member x xs)
+ (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
+;; at the shortest list. The %any-null?/%list-cars/%list-cdrs helpers
+;; back the multi-list path.
+(define (%any-null? xss)
+ (if (null? xss) #f
+ (if (null? (car xss)) #t (%any-null? (cdr xss)))))
+(define (%list-cars xss)
+ (if (null? xss) (quote ())
+ (cons (car (car xss)) (%list-cars (cdr xss)))))
+(define (%list-cdrs xss)
+ (if (null? xss) (quote ())
+ (cons (cdr (car xss)) (%list-cdrs (cdr xss)))))
+
+(define (map f xs . rest)
+ (if (null? rest)
+ (let m ((xs xs))
+ (if (null? xs) (quote ())
+ (cons (f (car xs)) (m (cdr xs)))))
+ (let m ((xss (cons xs rest)))
+ (if (%any-null? xss) (quote ())
+ (cons (apply f (%list-cars xss))
+ (m (%list-cdrs xss)))))))
(define (filter p xs)
(if (null? xs)
@@ -92,8 +170,206 @@
acc
(fold f (f acc (car xs)) (cdr xs))))
-(define (for-each f xs)
- (if (null? xs) (quote ()) (begin (f (car xs)) (for-each f (cdr xs)))))
+(define (for-each f xs . rest)
+ (if (null? rest)
+ (let m ((xs xs))
+ (if (null? xs) (quote ())
+ (begin (f (car xs)) (m (cdr xs)))))
+ (let m ((xss (cons xs rest)))
+ (if (%any-null? xss) (quote ())
+ (begin (apply f (%list-cars xss))
+ (m (%list-cdrs xss)))))))
+
+;; --- R7RS character procedures (ASCII over fixnum bytes) -----------
+;; Chars are plain fixnums; char? is a 0..255 range check rather than
+;; a disjoint type. char->integer / integer->char are the identity.
+(define (char? x)
+ (if (integer? x)
+ (if (< x 0) #f (< x 256))
+ #f))
+
+(define (char->integer c) c)
+(define (integer->char n) n)
+
+(define (char-upper-case? c) (and (>= c 65) (<= c 90)))
+(define (char-lower-case? c) (and (>= c 97) (<= c 122)))
+(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
+(define (char-numeric? c) (and (>= c 48) (<= c 57)))
+(define (char-whitespace? c)
+ (or (= c 32) (= c 9) (= c 10) (= c 11) (= c 12) (= c 13)))
+
+(define (digit-value c) (if (char-numeric? c) (- c 48) #f))
+
+(define (char-upcase c) (if (char-lower-case? c) (- c 32) c))
+(define (char-downcase c) (if (char-upper-case? c) (+ c 32) c))
+(define char-foldcase char-downcase)
+
+(define (%chain-rel rel a b rest)
+ (if (rel a b)
+ (if (null? rest) #t (%chain-rel rel b (car rest) (cdr rest)))
+ #f))
+
+(define (char=? a b . rest) (%chain-rel = a b rest))
+(define (char<? a b . rest) (%chain-rel < a b rest))
+(define (char>? a b . rest) (%chain-rel > a b rest))
+(define (char<=? a b . rest) (%chain-rel <= a b rest))
+(define (char>=? a b . rest) (%chain-rel >= a b rest))
+
+;; --- R7RS string procedures (over NUL-terminated bytevectors) ------
+;; A scheme1 "string" is a bytevector whose first NUL byte marks the
+;; logical end. Constructors allocate (n+1) bytes and store 0 at index
+;; n. string-ref / string-set! are thin aliases over the bytevector
+;; primitives; bounds against string-length aren't enforced (the user
+;; can clobber the NUL terminator).
+(define (make-string n . fill)
+ (let ((c (if (null? fill) 32 (car fill))))
+ (let ((bv (make-bytevector (+ n 1) c)))
+ (bytevector-u8-set! bv n 0)
+ bv)))
+
+(define (string . cs)
+ (let* ((n (length cs))
+ (bv (make-bytevector (+ n 1) 0)))
+ (let loop ((xs cs) (i 0))
+ (if (null? xs) bv
+ (begin
+ (bytevector-u8-set! bv i (car xs))
+ (loop (cdr xs) (+ i 1)))))))
+
+(define string-ref bytevector-u8-ref)
+(define string-set! bytevector-u8-set!)
+
+(define (substring s start end)
+ (let* ((n (- end start))
+ (out (make-bytevector (+ n 1) 0)))
+ (bytevector-copy! out 0 s start end)
+ out))
+
+(define (string-append . ss)
+ (let ((total (let sum ((xs ss) (n 0))
+ (if (null? xs) n
+ (sum (cdr xs) (+ n (string-length (car xs))))))))
+ (let ((out (make-bytevector (+ total 1) 0)))
+ (let loop ((xs ss) (off 0))
+ (if (null? xs) out
+ (let ((len (string-length (car xs))))
+ (bytevector-copy! out off (car xs) 0 len)
+ (loop (cdr xs) (+ off len))))))))
+
+(define (string-copy s . args)
+ (let* ((start (if (null? args) 0 (car args)))
+ (rs (if (null? args) (quote ()) (cdr args)))
+ (end (if (null? rs) (string-length s) (car rs))))
+ (substring s start end)))
+
+(define (string-copy! dst at src . args)
+ (let* ((start (if (null? args) 0 (car args)))
+ (rs (if (null? args) (quote ()) (cdr args)))
+ (end (if (null? rs) (string-length src) (car rs))))
+ (bytevector-copy! dst at src start end)))
+
+(define (string-fill! s ch . args)
+ (let* ((start (if (null? args) 0 (car args)))
+ (rs (if (null? args) (quote ()) (cdr args)))
+ (end (if (null? rs) (string-length s) (car rs))))
+ (let loop ((i start))
+ (if (>= i end) s
+ (begin (bytevector-u8-set! s i ch) (loop (+ i 1)))))))
+
+(define (string->list s . args)
+ (let* ((start (if (null? args) 0 (car args)))
+ (rs (if (null? args) (quote ()) (cdr args)))
+ (end (if (null? rs) (string-length s) (car rs))))
+ (let loop ((i (- end 1)) (acc (quote ())))
+ (if (< i start) acc
+ (loop (- i 1) (cons (bytevector-u8-ref s i) acc))))))
+
+(define (list->string cs) (apply string cs))
+
+(define (%string-cmp a b)
+ (let ((alen (string-length a))
+ (blen (string-length b)))
+ (let loop ((i 0))
+ (cond ((and (= i alen) (= i blen)) 0)
+ ((= i alen) -1)
+ ((= i blen) 1)
+ (else
+ (let ((d (- (bytevector-u8-ref a i) (bytevector-u8-ref b i))))
+ (if (zero? d) (loop (+ i 1)) d)))))))
+
+(define (%string-ci-cmp a b)
+ (let ((alen (string-length a))
+ (blen (string-length b)))
+ (let loop ((i 0))
+ (cond ((and (= i alen) (= i blen)) 0)
+ ((= i alen) -1)
+ ((= i blen) 1)
+ (else
+ (let ((d (- (char-foldcase (bytevector-u8-ref a i))
+ (char-foldcase (bytevector-u8-ref b i)))))
+ (if (zero? d) (loop (+ i 1)) d)))))))
+
+(define (%chain-cmp cmp rel a b rest)
+ (if (rel (cmp a b) 0)
+ (if (null? rest) #t (%chain-cmp cmp rel b (car rest) (cdr rest)))
+ #f))
+
+(define (string=? a b . rest) (%chain-cmp %string-cmp = a b rest))
+(define (string<? a b . rest) (%chain-cmp %string-cmp < a b rest))
+(define (string>? a b . rest) (%chain-cmp %string-cmp > a b rest))
+(define (string<=? a b . rest) (%chain-cmp %string-cmp <= a b rest))
+(define (string>=? a b . rest) (%chain-cmp %string-cmp >= a b rest))
+
+(define (string-ci=? a b . rest) (%chain-cmp %string-ci-cmp = a b rest))
+(define (string-ci<? a b . rest) (%chain-cmp %string-ci-cmp < a b rest))
+(define (string-ci>? a b . rest) (%chain-cmp %string-ci-cmp > a b rest))
+(define (string-ci<=? a b . rest) (%chain-cmp %string-ci-cmp <= a b rest))
+(define (string-ci>=? a b . rest) (%chain-cmp %string-ci-cmp >= a b rest))
+
+(define (string-upcase s)
+ (let* ((n (string-length s))
+ (out (make-bytevector (+ n 1) 0)))
+ (let loop ((i 0))
+ (if (= i n) out
+ (begin
+ (bytevector-u8-set! out i (char-upcase (bytevector-u8-ref s i)))
+ (loop (+ i 1)))))))
+
+(define (string-downcase s)
+ (let* ((n (string-length s))
+ (out (make-bytevector (+ n 1) 0)))
+ (let loop ((i 0))
+ (if (= i n) out
+ (begin
+ (bytevector-u8-set! out i (char-downcase (bytevector-u8-ref s i)))
+ (loop (+ i 1)))))))
+
+(define string-foldcase string-downcase)
+
+(define (string-map f s)
+ (let* ((n (string-length s))
+ (out (make-bytevector (+ n 1) 0)))
+ (let loop ((i 0))
+ (if (= i n) out
+ (begin
+ (bytevector-u8-set! out i (f (bytevector-u8-ref s i)))
+ (loop (+ i 1)))))))
+
+(define (string-for-each f s)
+ (let ((n (string-length s)))
+ (let loop ((i 0))
+ (if (= i n) (quote ())
+ (begin (f (bytevector-u8-ref s i)) (loop (+ i 1)))))))
+
+;; --- R7RS bytevector constructor -----------------------------------
+(define (bytevector . bytes)
+ (let* ((n (length bytes))
+ (bv (make-bytevector n 0)))
+ (let loop ((xs bytes) (i 0))
+ (if (null? xs) bv
+ (begin
+ (bytevector-u8-set! bv i (car xs))
+ (loop (cdr xs) (+ i 1)))))))
;; --- Vector <-> list -- need make-vector / vector-ref / vector-set! /
;; vector-length, none of which are yet primitives. ------------------
@@ -146,6 +422,7 @@
(sys-exit (if (null? rest) 0 (car rest))))
(define (argv) (sys-argv))
+(define (command-line) (sys-argv))
(define (spawn prog . args)
(let ((r (sys-clone)))
@@ -172,6 +449,11 @@
(define NL-BYTE 10)
(define NL-BV (make-bytevector 1 10))
+(define (file-exists? path)
+ (let ((r (sys-openat AT_FDCWD path O_RDONLY 0)))
+ (cond ((car r) (sys-close (cdr r)) #t)
+ (else #f))))
+
;; --- shell.scm port record + handles -------------------------------
(define-record-type port
(%port fd buf pos end)
