commit 5ca7208adfe3fd071dfd87536b7a0d7c0ab5a5f5
parent 702dd20cdbf4dd4d3ea4ed9805593864e90c9310
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Fri, 24 Jan 2025 07:47:05 +0200
Add files that would hold the GOOPS based implementation related files.
Diffstat:
| A | run-tests-goops.scm | | | 117 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | srfi/srfi-123/goops.scm | | | 282 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
2 files changed, 399 insertions(+), 0 deletions(-)
diff --git a/run-tests-goops.scm b/run-tests-goops.scm
@@ -0,0 +1,117 @@
+;;; 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.
+
+(use-modules
+ ((scheme base) #:select (bytevector))
+ (rnrs hashtables)
+ (srfi srfi-4)
+ (srfi srfi-64)
+ (srfi srfi-111)
+ (srfi srfi-123 goops)
+ (rnrs records syntactic)
+ (rnrs records procedural)
+ (rnrs records inspection)
+ (rnrs exceptions)
+)
+
+(define using-broken-srfi99 #f)
+
+(define-record-type foo
+ (fields
+ (mutable a)
+ (immutable b))
+ )
+
+(define (run-tests)
+ (let ((runner (test-runner-create)))
+ (parameterize ((test-runner-current runner))
+ (test-begin "SRFI-123-GOOPS")
+
+ (test-begin "ref")
+ (test-assert "bytevector" (= 1 (ref (bytevector 0 1 2) 1)))
+ (test-assert "hashtable" (let ((table (make-eqv-hashtable)))
+ (hashtable-set! table 'foo 0)
+ (= 0 (ref table 'foo))))
+ (test-assert "hashtable default" (let ((table (make-eqv-hashtable)))
+ (= 1 (ref table 0 1))))
+ (test-assert "pair" (= 1 (ref (cons 0 1) 'cdr)))
+ (test-assert "list" (= 1 (ref (list 0 1 2) 1)))
+ (test-assert "string" (char=? #\b (ref "abc" 1)))
+ (test-assert "vector" (= 1 (ref (vector 0 1 2) 1)))
+ (test-assert "record" (= 1 (ref (make-foo 0 1) 'b)))
+ (values)
+ (test-assert "srfi-4" (= 1 (ref (s16vector 0 1 2) 1)))
+ (values)
+ (test-assert "srfi-111" (= 1 (ref (box 1) '*)))
+ (test-end "ref")
+
+ (test-assert "ref*" (= 1 (ref* '(_ #(_ (0 . 1) _) _) 1 1 'cdr)))
+
+ (test-begin "ref setter")
+ (test-assert "bytevector" (let ((bv (bytevector 0 1 2)))
+ (set! (ref bv 1) 3)
+ (= 3 (ref bv 1))))
+ (test-assert "hashtable" (let ((ht (make-eqv-hashtable)))
+ (set! (ref ht 'foo) 0)
+ (= 0 (ref ht 'foo))))
+ (test-assert "pair" (let ((p (cons 0 1)))
+ (set! (ref p 'cdr) 2)
+ (= 2 (ref p 'cdr))))
+ (test-assert "list" (let ((l (list 0 1 2)))
+ (set! (ref l 1) 3)
+ (= 3 (ref l 1))))
+ (test-assert "string" (let ((s (string #\a #\b #\c)))
+ (set! (ref s 1) #\d)
+ (char=? #\d (ref s 1))))
+ (test-assert "vector" (let ((v (vector 0 1 2)))
+ (set! (ref v 1) 3)
+ (= 3 (ref v 1))))
+ (test-assert "record" (let ((r (make-foo 0 1)))
+ (set! (ref r 'a) 2)
+ (= 2 (ref r 'a))))
+ (when using-broken-srfi99
+ (test-expect-fail 1))
+ (test-assert "bad record assignment"
+ (not (guard (err (else #f)) (set! (ref (make-foo 0 1) 'b) 2) #t)))
+ (values)
+ (test-assert "srfi-4" (let ((s16v (s16vector 0 1 2)))
+ (set! (ref s16v 1) 3)
+ (= 3 (ref s16v 1))))
+ (values)
+ (test-assert "srfi-111" (let ((b (box 0)))
+ (set! (ref b '*) 1)
+ (= 1 (ref b '*))))
+ (test-end "ref setter")
+
+ (test-assert "ref* setter"
+ (let ((obj (list '_ (vector '_ (cons 0 1) '_) '_)))
+ (set! (ref* obj 1 1 'cdr) 2)
+ (= 2 (ref* obj 1 1 'cdr))))
+
+ (test-end "SRFI-123-GOOPS")
+ (and (= 0 (test-runner-xpass-count runner))
+ (= 0 (test-runner-fail-count runner))))))
+
+(if (run-tests)
+ (exit 0)
+ (exit 1))
diff --git a/srfi/srfi-123/goops.scm b/srfi/srfi-123/goops.scm
@@ -0,0 +1,282 @@
+;;; 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.
+
+(define-library (srfi srfi-123 goops)
+ (export ref ref* ~ register-getter-with-setter! $bracket-apply$ set! setter getter-with-setter)
+ (import
+ (scheme base)
+ (scheme case-lambda)
+
+ (rnrs hashtables)
+ (rnrs records inspection)
+ (rnrs records procedural)
+ (rnrs records syntactic)
+
+ (srfi 1)
+ (srfi 4)
+ (srfi 17)
+ (srfi 26)
+ (srfi 31)
+ (srfi 43)
+ (srfi 111)
+
+ (oop goops)
+ )
+ (begin
+
+;;; 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-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
+
+;;; 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)))
+ ))
+
+;;; srfi-123.scm ends here
