commit d1064d06171fdf477d2c1aa0004f7282d366c193
parent cd2366665df545ba5c10ab8d2819de9d2100dbbf
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Thu, 23 Jan 2025 15:08:26 +0200
Define SRFI-123 within a r7rs-small kind library.
Diffstat:
2 files changed, 244 insertions(+), 235 deletions(-)
diff --git a/run-tests.scm b/run-tests.scm
@@ -22,7 +22,7 @@
;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
(use-modules
- ;; (import (except (scheme base) define-record-type set!))
+ ((scheme base) #:select (bytevector))
(rnrs hashtables)
(srfi srfi-4)
(srfi srfi-64)
@@ -32,20 +32,18 @@
;; base), I get only 2 failures. I am too tired to figure what is
;; what right now.
;;
- ;; (rnrs records syntactic)
- ;; (rnrs records procedural)
- ;; (rnrs records inspection)
- ;; (rnrs exceptions)
- (scheme base)
+ (rnrs records syntactic)
+ (rnrs records procedural)
+ (rnrs records inspection)
+ (rnrs exceptions)
)
(define using-broken-srfi99 #f)
-(define-record-type <foo>
- (make-foo a b)
- foo?
- (a foo-a set-foo-a!)
- (b foo-b)
+(define-record-type foo
+ (fields
+ (mutable a)
+ (immutable b))
)
(define (run-tests)
diff --git a/srfi/srfi-123.scm b/srfi/srfi-123.scm
@@ -21,78 +21,88 @@
;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-(define-module (srfi srfi-123)
- #:export (ref ref* ~ register-getter-with-setter! $bracket-apply$ set! setter getter-with-setter)
-
-
- #:use-module ((scheme base)
- #:select (bytevector?
- bytevector-u8-ref
- bytevector-u8-set!))
-
- #:use-module (rnrs hashtables)
-
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-4)
- #:use-module (srfi srfi-111)
-
- #:use-module (rnrs records inspection)
- #:use-module (rnrs records procedural)
- #:use-module (rnrs records syntactic)
- )
+(define-library (srfi srfi-123)
+ (export ref ref* ~ register-getter-with-setter! $bracket-apply$ set! setter getter-with-setter)
+ (import
+ (scheme base)
+ (rnrs hashtables)
+ (rnrs records inspection)
+ (rnrs records procedural)
+ (rnrs records syntactic)
+ (scheme case-lambda)
+ (srfi 1)
+ (srfi 4)
+ (srfi 17)
+ (srfi 26)
+ (srfi 31)
+ (srfi 43)
+ (srfi 111)
+ )
+ (begin
;;; Helpers
-(define getter-with-setter make-procedure-with-setter)
-
-(define-syntax push!
- (syntax-rules ()
- ((_ <list-var> <x>)
- (set! <list-var> (cons <x> <list-var>)))))
-
-(define (alist->hashtable alist)
- (let ((table (make-eqv-hashtable 100)))
- (for-each (lambda (entry)
- (hashtable-set! table (car entry) (cdr entry)))
- alist)
- table))
-
-(define (pair-ref pair key)
- (cond
- ((eqv? 'car key)
- (car pair))
- ((eqv? 'cdr key)
- (cdr pair))
- (else
- (list-ref pair key))))
-
-(define (pair-set! pair key value)
- (cond
- ((eqv? 'car key)
- (set-car! pair value))
- ((eqv? 'cdr key)
- (set-cdr! pair value))
- (else
- (list-set! pair key value))))
+ (define-syntax push!
+ (syntax-rules ()
+ ((_ <list-var> <x>)
+ (set! <list-var> (cons <x> <list-var>)))))
+
+ (define (alist->hashtable alist)
+ (let ((table (make-eqv-hashtable 100)))
+ (for-each (lambda (entry)
+ (hashtable-set! table (car entry) (cdr entry)))
+ alist)
+ table))
+
+ (define (pair-ref pair key)
+ (cond
+ ((eqv? 'car key)
+ (car pair))
+ ((eqv? 'cdr key)
+ (cdr pair))
+ (else
+ (list-ref pair key))))
+
+ (define (pair-set! pair key value)
+ (cond
+ ((eqv? 'car key)
+ (set-car! pair value))
+ ((eqv? 'cdr key)
+ (set-cdr! pair value))
+ (else
+ (list-set! pair key value))))
;;; Record inspection support
-(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?))
+ (define (rtd-field-index rtd field)
+ "Find the index of a FIELD in the Record Type Descriptor RTD.
+
+Raise an error if the field does not exist."
+ (let* ((fields (record-type-field-names rtd))
+ (field-index (vector-index (cut eq? field <>) fields)))
+ (unless field-index
+ (error "Field does not exist in Record Type Descriptor (wanted field, existing fields):"
+ field-index
+ fields))
+ field-index))
+ (define rtd-accessor record-accessor)
+ (define rtd-mutator record-mutator)
+ (define (record-ref record field)
+ (let* ((rtd (record-rtd record))
+ (field-index (rtd-field-index rtd field))
+ (accessor (rtd-accessor rtd field-index)))
+ (accessor record)))
+ (define (record-set! record field value)
+ (let* ((rtd (record-rtd record))
+ (field-index (rtd-field-index rtd field))
+ (mutator (rtd-mutator rtd field-index)))
+ (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
@@ -101,167 +111,168 @@
;;; 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.
-(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)))
+ (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
-(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?))
+ (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
-(define %ref
- (case-lambda
- ((object field)
- (let ((getter (lookup-getter object))
- (sparse? (sparse-type? object)))
- (if sparse?
- (let* ((not-found (cons #f #f))
- (result (getter object field not-found)))
- (if (eqv? result not-found)
- (error "Object has no entry for field." object field)
- result))
- (getter object field))))
- ((object field default)
- (let ((getter (lookup-getter object)))
- (getter object field default)))))
-
-(define (%ref* object field . fields)
- (if (null? fields)
- (%ref object field)
- (apply %ref* (%ref object field) fields)))
-
-(define (%set! object field value)
- (let ((setter (lookup-setter object)))
- (setter object field value)))
-
-(define ref
- (getter-with-setter
- %ref
- (lambda (object field value)
- (%set! object field value))))
-
-(define ref*
- (getter-with-setter
- %ref*
- ;; 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*)
-
-(define $bracket-apply$ ref*)
-
-(define (lookup-getter object)
- (or (hashtable-ref getter-table (type-of object) #f)
- (error "No generic getter for object's type." object)))
-
-(define (lookup-setter object)
- (or (hashtable-ref setter-table (type-of object) #f)
- (error "No generic setter for object's type." object)))
-
-(define (sparse-type? object)
- (memv (type-of object) sparse-types))
-
-(define (type-of object)
- (find (lambda (pred) (pred object)) type-list))
-
-(define getter-table
- (alist->hashtable
- (append
- (list (cons bytevector? bytevector-ref)
- (cons hashtable? hashtable-ref)
- (cons pair? pair-ref)
- (cons string? string-ref)
- (cons vector? vector-ref))
- record-getter
- srfi-4-getters
- box-getter)))
-
-(define setter-table
- (alist->hashtable
- (append
- (list (cons bytevector? bytevector-set!)
- (cons hashtable? hashtable-set!)
- (cons pair? pair-set!)
- (cons string? string-set!)
- (cons vector? vector-set!))
- record-setter
- srfi-4-setters
- box-setter)))
-
-(define sparse-types
- (list hashtable?))
-
-(define type-list
- ;; Although the whole SRFI intrinsically neglects performance, we still use
- ;; the micro-optimization of ordering this list roughly according to most
- ;; likely match.
- (append
- (list hashtable? vector? pair? bytevector? string?)
- srfi-4-types
- box-type
- ;; The record type must be placed last so specific record types (e.g. box)
- ;; take precedence.
- record-type
- ;; Place those types we don't support really last.
- (list boolean? char? eof-object? null? number? port? procedure? symbol?)))
-
-(define (register-getter-with-setter! type getter sparse?)
- (push! type-list type)
- (set! (~ getter-table type) getter)
- (set! (~ setter-table type) (setter getter))
- (when sparse?
- (push! sparse-types type)))
-
-;;; generic-ref-set.body.scm ends here
+ (define %ref
+ (case-lambda
+ ((object field)
+ (let ((getter (lookup-getter object))
+ (sparse? (sparse-type? object)))
+ (if sparse?
+ (let* ((not-found (cons #f #f))
+ (result (getter object field not-found)))
+ (if (eqv? result not-found)
+ (error "Object has no entry for field." object field)
+ result))
+ (getter object field))))
+ ((object field default)
+ (let ((getter (lookup-getter object)))
+ (getter object field default)))))
+
+ (define (%ref* object field . fields)
+ (if (null? fields)
+ (%ref object field)
+ (apply %ref* (%ref object field) fields)))
+
+ (define (%set! object field value)
+ (let ((setter (lookup-setter object)))
+ (setter object field value)))
+
+ (define ref
+ (getter-with-setter
+ %ref
+ (lambda (object field value)
+ (%set! object field value))))
+
+ (define ref*
+ (getter-with-setter
+ %ref*
+ ;; 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*)
+
+ (define $bracket-apply$ ref*)
+
+ (define (lookup-getter object)
+ (or (hashtable-ref getter-table (type-of object) #f)
+ (error "No generic getter for object's type." object)))
+
+ (define (lookup-setter object)
+ (or (hashtable-ref setter-table (type-of object) #f)
+ (error "No generic setter for object's type." object)))
+
+ (define (sparse-type? object)
+ (memv (type-of object) sparse-types))
+
+ (define (type-of object)
+ (find (lambda (pred) (pred object)) type-list))
+
+ (define getter-table
+ (alist->hashtable
+ (append
+ (list (cons bytevector? bytevector-ref)
+ (cons hashtable? hashtable-ref)
+ (cons pair? pair-ref)
+ (cons string? string-ref)
+ (cons vector? vector-ref))
+ record-getter
+ srfi-4-getters
+ box-getter)))
+
+ (define setter-table
+ (alist->hashtable
+ (append
+ (list (cons bytevector? bytevector-set!)
+ (cons hashtable? hashtable-set!)
+ (cons pair? pair-set!)
+ (cons string? string-set!)
+ (cons vector? vector-set!))
+ record-setter
+ srfi-4-setters
+ box-setter)))
+
+ (define sparse-types
+ (list hashtable?))
+
+ (define type-list
+ ;; Although the whole SRFI intrinsically neglects performance, we still use
+ ;; the micro-optimization of ordering this list roughly according to most
+ ;; likely match.
+ (append
+ (list hashtable? vector? pair? bytevector? string?)
+ srfi-4-types
+ box-type
+ ;; The record type must be placed last so specific record types (e.g. box)
+ ;; take precedence.
+ record-type
+ ;; Place those types we don't support really last.
+ (list boolean? char? eof-object? null? number? port? procedure? symbol?)))
+
+ (define (register-getter-with-setter! type getter sparse?)
+ (push! type-list type)
+ (set! (~ getter-table type) getter)
+ (set! (~ setter-table type) (setter getter))
+ (when sparse?
+ (push! sparse-types type)))
+ ))
+
+;;; srfi-123.scm ends here
