goops.scm (8245B)
1 ;;; goops.scm --- Part of the guile-srfi-123 generic accessor and modifier operators library. 2 3 ;; Copyright © 2025 Yuval Langer <yuval.langer@gmail.com> 4 ;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> 5 6 ;; This program is free software: you can redistribute it and/or modify 7 ;; it under the terms of the GNU Affero General Public License as 8 ;; published by the Free Software Foundation, either version 3 of the 9 ;; License, or (at your option) any later version. 10 11 ;; This program is distributed in the hope that it will be useful, 12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ;; GNU Affero General Public License for more details. 15 16 ;; You should have received a copy of the GNU Affero General Public License 17 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 18 19 ;; Permission is hereby granted, free of charge, to any person obtaining 20 ;; a copy of this software and associated documentation files (the 21 ;; "Software"), to deal in the Software without restriction, including 22 ;; without limitation the rights to use, copy, modify, merge, publish, 23 ;; distribute, sublicense, and/or sell copies of the Software, and to 24 ;; permit persons to whom the Software is furnished to do so, subject to 25 ;; the following conditions: 26 27 ;; The above copyright notice and this permission notice shall be 28 ;; included in all copies or substantial portions of the Software. 29 30 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 31 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 32 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 33 ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 34 ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 35 ;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 36 ;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 37 38 (define-library (srfi srfi-123 goops) 39 (export 40 ref 41 ref* 42 ~ 43 register-getter-with-setter! 44 $bracket-apply$ 45 set! 46 setter 47 getter-with-setter 48 ) 49 (import 50 (scheme base) 51 (scheme case-lambda) 52 53 (rnrs hashtables) 54 (rnrs records inspection) 55 (rnrs records procedural) 56 (rnrs records syntactic) 57 58 (srfi srfi-1) 59 (srfi srfi-4) 60 (srfi srfi-4 gnu) 61 (srfi srfi-17) 62 (srfi srfi-26) 63 (srfi srfi-31) 64 (srfi srfi-43) 65 (srfi srfi-111) 66 67 (ice-9 match) 68 69 (oop goops) 70 ) 71 (begin 72 73 ;;; Record inspection support 74 75 (define (rtd-field-index rtd field) 76 "Find the index of a FIELD in the Record Type Descriptor RTD. 77 78 Raise an error if the field does not exist." 79 (let* ((fields (record-type-field-names rtd)) 80 (field-index (vector-index (cut eq? field <>) fields))) 81 (unless field-index 82 (error "Field does not exist in Record Type Descriptor (wanted field, existing fields):" 83 field-index 84 fields)) 85 field-index)) 86 (define rtd-accessor record-accessor) 87 (define rtd-mutator record-mutator) 88 (define (record-ref record field) 89 (let* ((rtd (record-rtd record)) 90 (field-index (rtd-field-index rtd field)) 91 (accessor (rtd-accessor rtd field-index))) 92 (accessor record))) 93 (define (record-set! record field value) 94 (let* ((rtd (record-rtd record)) 95 (field-index (rtd-field-index rtd field)) 96 (mutator (rtd-mutator rtd field-index))) 97 (mutator record value))) 98 (define record-getter 99 (list (cons record? record-ref))) 100 (define record-setter 101 (list (cons record? record-set!))) 102 (define record-type 103 (list record?)) 104 105 ;;; SRFI-4 support 106 107 ;;; In some implementations, SRFI-4 vectors are also bytevectors. We accomodate 108 ;;; for those implementations by using generic bytevector-ref/set! procedures 109 ;;; which possibly dispatch to an SRFI-4 type's getter/setter, but also 110 ;;; inserting the SRFI-4 getters/setters into the top-level dispatch tables. 111 112 ;; XXX: (class-of (make-u8vector 0)) is the same as (class-of (make-u16vector 0)) or any of the rest. 113 (define-method (ref (object <uvec>) field) 114 (match object 115 ((? u8vector?) (u8vector-ref object field)) 116 ((? s8vector?) (s8vector-ref object field)) 117 ((? u16vector?) (u16vector-ref object field)) 118 ((? s16vector?) (s16vector-ref object field)) 119 ((? u32vector?) (u32vector-ref object field)) 120 ((? s32vector?) (s32vector-ref object field)) 121 ((? u64vector?) (u64vector-ref object field)) 122 ((? s64vector?) (s64vector-ref object field)) 123 ((? f32vector?) (f32vector-ref object field)) 124 ((? f64vector?) (f64vector-ref object field)) 125 ((? c32vector?) (c32vector-ref object field)) 126 ((? c64vector?) (c64vector-ref object field)) 127 ((? bytevector?) (bytevector-u8-ref object field)))) 128 129 (define-method ((setter ref) (object <uvec>) field value) 130 (match object 131 ((? u8vector?) (u8vector-set! object field value)) 132 ((? s8vector?) (s8vector-set! object field value)) 133 ((? u16vector?) (u16vector-set! object field value)) 134 ((? s16vector?) (s16vector-set! object field value)) 135 ((? u32vector?) (u32vector-set! object field value)) 136 ((? s32vector?) (s32vector-set! object field value)) 137 ((? u64vector?) (u64vector-set! object field value)) 138 ((? s64vector?) (s64vector-set! object field value)) 139 ((? f32vector?) (f32vector-set! object field value)) 140 ((? f64vector?) (f64vector-set! object field value)) 141 ((? c32vector?) (c32vector-set! object field value)) 142 ((? c64vector?) (c64vector-set! object field value)) 143 ((? bytevector?) (bytevector-u8-set! object field value)))) 144 145 ;;; pairs support. 146 147 (let ((type-class (class-of (cons '() '())))) 148 (define-method (ref (object type-class) field) 149 (cond 150 ((eqv? 'car field) 151 (car object)) 152 ((eqv? 'cdr field) 153 (cdr object)) 154 (else 155 (list-ref object field)))) 156 157 (define-method (ref (object type-class) field value) 158 (cond 159 ((eqv? 'car field) 160 (set-car! object value)) 161 ((eqv? 'cdr field) 162 (set-cdr! object value)) 163 (else 164 (list-set! object field value))))) 165 166 ;;; string support. 167 168 (define-method (ref (object <string>) field) 169 (string-ref object field)) 170 171 (define-method ((setter ref) (object <string>) field value) 172 (string-set! object field value)) 173 ;; Wrong type argument in position 1 (expecting symbol): (setter ref) 174 175 ;;; bytevector support. 176 177 (define-method (ref (object <bytevector>) field) 178 (bytevector-u8-ref object field)) 179 180 (define-method ((setter ref) (object <bytevector>) field value) 181 (bytevector-u8-set! object field value)) 182 183 ;;; vector support. 184 185 (define-method (ref (object <vector>) field) 186 (vector-ref object field)) 187 188 (define-method ((setter ref) (object <vector>) field value) 189 (vector-set! object field value)) 190 191 ;; hashtable support. 192 193 (define-method (ref (object <hashtable>) field default) 194 (hashtable-ref object field default)) 195 196 (define-method ((setter ref) (object <hashtable>) field default) 197 (hashtable-ref object field default)) 198 199 ;;; box support 200 201 (let ((type-class (class-of (box '())))) 202 (define-method (ref (object type-class) field) 203 (unbox object)) 204 (define-method ((setter ref) (object type-class) field value) 205 (set-box! object value))) 206 207 ;; TODO: 208 ;; record? 209 ;; record-getter 210 211 (define ref* 212 (getter-with-setter 213 (let () 214 (define (%ref* object field . fields) 215 (if (null? fields) 216 (ref object field) 217 (apply %ref* (ref object field) fields))) 218 %ref*) 219 (let () 220 (define (set!* object field rest0 . rest) 221 (match (cons rest0 rest) 222 ((last-field new-value) 223 (set! (ref object last-field) new-value)) 224 ((rest0 rest ooo) 225 (apply set!* (ref object field) rest0 rest)))) 226 set!*))) 227 228 (define ~ ref*) 229 230 (define $bracket-apply$ ref*) 231 ))