guile-srfi-123

srfi-123.scm (9578B)

---

 ;;; 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)
   (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)
    )
   (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