commit 4f7e4d164b8c56ea310d17a6edea0b4d70080a3a
parent 45d37fe483077504458b32ab4fab0121dc8a3af3
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Sat, 4 Jan 2025 00:49:18 +0200
Convert R7RS library syntax to a GNU Guile module syntax.
Diffstat:
| D | srfi/123.body.scm | | | 245 | ------------------------------------------------------------------------------- |
| M | srfi/srfi-123.scm | | | 277 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++----- |
2 files changed, 262 insertions(+), 260 deletions(-)
diff --git a/srfi/123.body.scm b/srfi/123.body.scm
@@ -1,245 +0,0 @@
-;;; generic-ref-set --- Generic accessor and modifier operators.
-
-;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
-
-;; Permission is hereby granted, free of charge, to any person obtaining
-;; a copy of this software and associated documentation files (the
-;; "Software"), to deal in the Software without restriction, including
-;; without limitation the rights to use, copy, modify, merge, publish,
-;; distribute, sublicense, and/or sell copies of the Software, and to
-;; permit persons to whom the Software is furnished to do so, subject to
-;; the following conditions:
-
-;; The above copyright notice and this permission notice shall be
-;; included in all copies or substantial portions of the Software.
-
-;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-
-;;; Helpers
-
-(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?))
-
-;;; SRFI-4 support
-
-;;; In some implementations, SRFI-4 vectors are also bytevectors. We accomodate
-;;; for those implementations by using generic bytevector-ref/set! procedures
-;;; 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)))
-
-;;; 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?))
-
-;;; 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
diff --git a/srfi/srfi-123.scm b/srfi/srfi-123.scm
@@ -1,20 +1,267 @@
-(define-library (srfi srfi-123)
- (export ref ref* ~ register-getter-with-setter! $bracket-apply$ set! setter getter-with-setter)
+;;; generic-ref-set --- Generic accessor and modifier operators.
- (import
- (except (scheme base) set! define-record-type)
+;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
- (scheme case-lambda)
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
- (rnrs hashtables)
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
- (srfi 1)
- (srfi 4)
- (srfi 17)
- (srfi 111)
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
- (rnrs records inspection)
- (rnrs records procedural)
- (rnrs records syntactic)
- )
- (include "123.body.scm"))
+(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)
+ )
+
+;;; 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))))
+
+;;; 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?))
+
+;;; SRFI-4 support
+
+;;; In some implementations, SRFI-4 vectors are also bytevectors. We accomodate
+;;; for those implementations by using generic bytevector-ref/set! procedures
+;;; 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)))
+
+;;; 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?))
+
+;;; 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
