commit 0a45141ddcec74067b739cf848367fb2753e63bf
parent 70f7c95cdcd2a25e770b8131d38e6a027de3f9a0
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Fri, 3 Jan 2025 08:14:00 +0200
Remove cond-expand, rename some library paths being imported, fix some `find` calls, and replace `rec` of SRFI-31 with something less fancy.
Diffstat:
| M | srfi/123.body.scm | | | 208 | ++++++++++++++++++++++++++++---------------------------------------------------- |
| M | srfi/srfi-123.scm | | | 47 | ++++++++++++++--------------------------------- |
2 files changed, 86 insertions(+), 169 deletions(-)
diff --git a/srfi/123.body.scm b/srfi/123.body.scm
@@ -55,33 +55,22 @@
;;; Record inspection support
-(cond-expand
- ((or (library (srfi 99))
- (library (rnrs records inspection))
- (library (r6rs records inspection)))
- (cond-expand
- ((not (library (srfi 99)))
- (define rtd-accessor record-accessor)
- (define rtd-mutator record-mutator))
- (else))
- (define (record-ref record field)
- (let* ((rtd (record-rtd record))
- (accessor (rtd-accessor rtd field)))
- (accessor record)))
- (define (record-set! record field value)
- (let* ((rtd (record-rtd record))
- (mutator (rtd-mutator rtd field)))
- (mutator record value)))
- (define record-getter
- (list (cons record? record-ref)))
- (define record-setter
- (list (cons record? record-set!)))
- (define record-type
- (list record?)))
- (else
- (define record-getter '())
- (define record-setter '())
- (define record-type '())))
+(define rtd-accessor record-accessor)
+(define rtd-mutator record-mutator)
+(define (record-ref record field)
+ (let* ((rtd (record-rtd record))
+ (accessor (rtd-accessor rtd field)))
+ (accessor record)))
+(define (record-set! record field value)
+ (let* ((rtd (record-rtd record))
+ (mutator (rtd-mutator rtd field)))
+ (mutator record value)))
+(define record-getter
+ (list (cons record? record-ref)))
+(define record-setter
+ (list (cons record? record-set!)))
+(define record-type
+ (list record?))
;;; SRFI-4 support
@@ -90,65 +79,51 @@
;;; which possibly dispatch to an SRFI-4 type's getter/setter, but also
;;; inserting the SRFI-4 getters/setters into the top-level dispatch tables.
-(cond-expand
- ((library (srfi 4))
- (define srfi-4-getters
- (list (cons s8vector? s8vector-ref)
- (cons u8vector? u8vector-ref)
- (cons s16vector? s16vector-ref)
- (cons u16vector? u16vector-ref)
- (cons s32vector? s32vector-ref)
- (cons u32vector? u32vector-ref)
- (cons s64vector? s64vector-ref)
- (cons u64vector? u64vector-ref)))
- (define srfi-4-setters
- (list (cons s8vector? s8vector-set!)
- (cons u8vector? u8vector-set!)
- (cons s16vector? s16vector-set!)
- (cons u16vector? u16vector-set!)
- (cons s32vector? s32vector-set!)
- (cons u32vector? u32vector-set!)
- (cons s64vector? s64vector-set!)
- (cons u64vector? u64vector-set!)))
- (define srfi-4-types
- (list s8vector? u8vector? s16vector? u16vector? s32vector? u32vector?
- s64vector? u64vector?))
- (define srfi-4-getters-table (alist->hashtable srfi-4-getters))
- (define srfi-4-setters-table (alist->hashtable srfi-4-setters))
- (define (bytevector-ref bytevector index)
- (let* ((type (find (lambda (pred) (pred bytevector))) srfi-4-types)
- (getter (if type
- (ref srfi-4-getters-table type)
- bytevector-u8-ref)))
- (getter bytevector index)))
- (define (bytevector-set! bytevector index value)
- (let* ((type (find (lambda (pred) (pred bytevector))) srfi-4-types)
- (setter (if type
- (ref srfi-4-setters-table type)
- bytevector-u8-set!)))
- (setter bytevector index value))))
- (else
- (define srfi-4-getters '())
- (define srfi-4-setters '())
- (define srfi-4-types '())
- (define bytevector-ref bytevector-u8-ref)
- (define bytevector-set! bytevector-u8-set!)))
+(define srfi-4-getters
+ (list (cons s8vector? s8vector-ref)
+ (cons u8vector? u8vector-ref)
+ (cons s16vector? s16vector-ref)
+ (cons u16vector? u16vector-ref)
+ (cons s32vector? s32vector-ref)
+ (cons u32vector? u32vector-ref)
+ (cons s64vector? s64vector-ref)
+ (cons u64vector? u64vector-ref)))
+(define srfi-4-setters
+ (list (cons s8vector? s8vector-set!)
+ (cons u8vector? u8vector-set!)
+ (cons s16vector? s16vector-set!)
+ (cons u16vector? u16vector-set!)
+ (cons s32vector? s32vector-set!)
+ (cons u32vector? u32vector-set!)
+ (cons s64vector? s64vector-set!)
+ (cons u64vector? u64vector-set!)))
+(define srfi-4-types
+ (list s8vector? u8vector? s16vector? u16vector? s32vector? u32vector?
+ s64vector? u64vector?))
+(define srfi-4-getters-table (alist->hashtable srfi-4-getters))
+(define srfi-4-setters-table (alist->hashtable srfi-4-setters))
+(define (bytevector-ref bytevector index)
+ (let* ((type (find (lambda (pred) (pred bytevector)) srfi-4-types))
+ (getter (if type
+ (ref srfi-4-getters-table type)
+ bytevector-u8-ref)))
+ (getter bytevector index)))
+(define (bytevector-set! bytevector index value)
+ (let* ((type (find (lambda (pred) (pred bytevector)) srfi-4-types))
+ (setter (if type
+ (ref srfi-4-setters-table type)
+ bytevector-u8-set!)))
+ (setter bytevector index value)))
;;; SRFI-111 boxes support
-(cond-expand
- ((library (srfi 111))
- (define (box-ref box _field)
- (unbox box))
- (define (box-set! box _field value)
- (set-box! box value))
- (define box-getter (list (cons box? box-ref)))
- (define box-setter (list (cons box? box-set!)))
- (define box-type (list box?)))
- (else
- (define box-getter '())
- (define box-setter '())
- (define box-type '())))
+(define (box-ref box _field)
+ (unbox box))
+(define (box-set! box _field value)
+ (set-box! box value))
+(define box-getter (list (cons box? box-ref)))
+(define box-setter (list (cons box? box-set!)))
+(define box-type (list box?))
;;; Main
@@ -186,10 +161,20 @@
(define ref*
(getter-with-setter
%ref*
- (rec (set!* object field rest0 . rest)
- (if (null? rest)
- (%set! object field rest0)
- (apply set!* (ref object field) rest0 rest)))))
+ ;; XXX: Originally it used the SRFI-31 rec construct, but it just would not compile!
+ ;;
+ ;; (rec (set!* object field rest0 . rest)
+ ;; (if (null? rest)
+ ;; (%set! object field rest0)
+ ;; (apply set!* (ref object field) rest0 rest)))
+ ;;
+ ;;
+ (let ()
+ (define (set!* object field rest0 . rest)
+ (if (null? rest)
+ (%set! object field rest0)
+ (apply set!* (ref object field) rest0 rest)))
+ set!*)))
(define ~ ref*)
@@ -257,53 +242,4 @@
(when sparse?
(push! sparse-types type)))
-(cond-expand
- ((not (or (library (srfi 99))
- (library (rnrs records inspection))
- (library (r6rs records inspection))))
- (define-syntax define-record-type
- (syntax-rules ()
- ((_ <name> <constructor> <pred> <field> ...)
- (begin
- (%define-record-type <name> <constructor> <pred> <field> ...)
- ;; Throw-away definition to not disturb an internal definitions
- ;; sequence.
- (define __throwaway
- (begin
- (register-getter-with-setter!
- <pred>
- (getter-with-setter (record-getter <field> ...)
- (record-setter <field> ...))
- #f)
- ;; Return the implementation's preferred "unspecified" value.
- (if #f #f)))))))
-
- (define-syntax record-getter
- (syntax-rules ()
- ((_ (<field> <getter> . <rest>) ...)
- (let ((getters (alist->hashtable (list (cons '<field> <getter>) ...))))
- (lambda (record field)
- (let ((getter (or (ref getters field #f)
- (error "No such field of record." record field))))
- (getter record)))))))
-
- (define-syntax record-setter
- (syntax-rules ()
- ((_ . <rest>)
- (%record-setter () . <rest>))))
-
- (define-syntax %record-setter
- (syntax-rules ()
- ((_ <setters> (<field> <getter>) . <rest>)
- (%record-setter <setters> . <rest>))
- ((_ <setters> (<field> <getter> <setter>) . <rest>)
- (%record-setter ((<field> <setter>) . <setters>) . <rest>))
- ((_ ((<field> <setter>) ...))
- (let ((setters (alist->hashtable (list (cons '<field> <setter>) ...))))
- (lambda (record field value)
- (let ((setter (or (ref setters field #f)
- (error "No such assignable field of record."
- record field))))
- (setter record value)))))))))
-
;;; generic-ref-set.body.scm ends here
diff --git a/srfi/srfi-123.scm b/srfi/srfi-123.scm
@@ -1,39 +1,20 @@
-(define-library (srfi 123)
- (export
- ref ref* ~ register-getter-with-setter!
- $bracket-apply$
- set! setter getter-with-setter)
+(define-library (srfi srfi-123)
+ (export ref ref* ~ register-getter-with-setter! $bracket-apply$ set! setter getter-with-setter)
+
(import
(except (scheme base) set! define-record-type)
+
(scheme case-lambda)
- (r6rs hashtables)
+
+ (rnrs hashtables)
+
(srfi 1)
+ (srfi 4)
(srfi 17)
- (srfi 31))
- (cond-expand
- ;; Favor SRFI-99.
- ((library (srfi 99))
- (import (srfi 99)))
- ;; We assume that if there's the inspection library, there's also the
- ;; syntactic and procedural libraries.
- ((library (rnrs records inspection))
- (import (rnrs records syntactic))
- (import (rnrs records procedural))
- (import (rnrs records inspection)))
- ((library (r6rs records inspection))
- (import (r6rs records syntactic))
- (import (r6rs records procedural))
- (import (r6rs records inspection)))
- (else
- (import (rename (only (scheme base) define-record-type)
- (define-record-type %define-record-type)))
- (export define-record-type)))
- (cond-expand
- ((library (srfi 4))
- (import (srfi 4)))
- (else))
- (cond-expand
- ((library (srfi 111))
- (import (srfi 111)))
- (else))
+ (srfi 111)
+
+ (rnrs records inspection)
+ (rnrs records procedural)
+ (rnrs records syntactic)
+ )
(include "123.body.scm"))
