122 lines
6.0 KiB
Scheme
122 lines
6.0 KiB
Scheme
#!r6rs
|
|
;; SRFI-17 implementation for Chez Scheme
|
|
;;
|
|
;; Generalized getter and setter for built-in Chez Scheme types.
|
|
;; Uses Chez Scheme's define-proprety and syntactic environment to
|
|
;; provide generalized reference and set! syntax. Relies on helpers
|
|
;;
|
|
;; Copyright (c) 2018 - 2020 Andrew W. Keep
|
|
|
|
(library (srfi :17 generalized-set!)
|
|
(export getter-with-setter set!
|
|
car cdr
|
|
caar cadr cdar cddr
|
|
caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
|
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
|
|
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
|
|
string-ref vector-ref
|
|
bytevector-ieee-double-native-ref bytevector-ieee-double-ref
|
|
bytevector-ieee-single-native-ref bytevector-ieee-single-ref
|
|
bytevector-s16-native-ref bytevector-s16-ref bytevector-s24-ref
|
|
bytevector-s32-native-ref bytevector-s32-ref bytevector-s40-ref
|
|
bytevector-s48-ref bytevector-s56-ref bytevector-s64-native-ref
|
|
bytevector-s64-ref bytevector-s8-ref bytevector-sint-ref
|
|
bytevector-u16-native-ref bytevector-u16-ref bytevector-u24-ref
|
|
bytevector-u32-native-ref bytevector-u32-ref bytevector-u40-ref
|
|
bytevector-u48-ref bytevector-u56-ref bytevector-u64-native-ref
|
|
bytevector-u64-ref bytevector-u8-ref bytevector-uint-ref
|
|
foreign-ref fxvector-ref hashtable-ref eq-hashtable-ref
|
|
symbol-hashtable-ref list-ref)
|
|
(import (rename (chezscheme) (set! cs:set!)) (srfi :17 helpers))
|
|
|
|
(define getter-with-setter-prop)
|
|
|
|
(define-syntax getter-with-setter
|
|
(syntax-rules ()
|
|
[(_ getter setter)
|
|
(define-property getter getter-with-setter-prop #'setter)]))
|
|
|
|
(define-syntax getters-and-setters
|
|
(syntax-rules ()
|
|
[(_ [getter setter] ...)
|
|
(begin (getter-with-setter getter setter) ...)]))
|
|
|
|
(define-syntax set!
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ (getter e0 e1 ...) v)
|
|
(lambda (r)
|
|
(with-syntax ([setter (r #'getter #'getter-with-setter-prop)])
|
|
(if (datum setter)
|
|
#'(setter e0 e1 ... v)
|
|
(syntax-violation 'set! "no setter configured for getter" #'getter x))))]
|
|
[(_ x v) (identifier? #'x) #'(cs:set! x v)])))
|
|
|
|
(getters-and-setters
|
|
[car set-car!]
|
|
[cdr set-cdr!]
|
|
[caar $set-caar!]
|
|
[cadr $set-cadr!]
|
|
[cdar $set-cdar!]
|
|
[cddr $set-cddr!]
|
|
[caaar $set-caaar!]
|
|
[caadr $set-caadr!]
|
|
[cadar $set-cadar!]
|
|
[caddr $set-caddr!]
|
|
[cdaar $set-cdaar!]
|
|
[cdadr $set-cdadr!]
|
|
[cddar $set-cddar!]
|
|
[cdddr $set-cdddr!]
|
|
[caaaar $set-caaaar!]
|
|
[caaadr $set-caaadr!]
|
|
[caadar $set-caadar!]
|
|
[caaddr $set-caaddr!]
|
|
[cadaar $set-cadaar!]
|
|
[cadadr $set-cadadr!]
|
|
[caddar $set-caddar!]
|
|
[cadddr $set-cadddr!]
|
|
[cdaaar $set-cdaaar!]
|
|
[cdaadr $set-cdaadr!]
|
|
[cdadar $set-cdadar!]
|
|
[cdaddr $set-cdaddr!]
|
|
[cddaar $set-cddaar!]
|
|
[cddadr $set-cddadr!]
|
|
[cdddar $set-cdddar!]
|
|
[cddddr $set-cddddr!]
|
|
[string-ref string-set!]
|
|
[vector-ref vector-set!]
|
|
[bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!]
|
|
[bytevector-ieee-double-ref $bytevector-ieee-double-set!]
|
|
[bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!]
|
|
[bytevector-ieee-single-ref $bytevector-ieee-single-set!]
|
|
[bytevector-s16-native-ref bytevector-s16-native-set!]
|
|
[bytevector-s16-ref $bytevector-s16-set!]
|
|
[bytevector-s24-ref $bytevector-s24-set!]
|
|
[bytevector-s32-native-ref bytevector-s32-native-set!]
|
|
[bytevector-s32-ref $bytevector-s32-set!]
|
|
[bytevector-s40-ref $bytevector-s40-set!]
|
|
[bytevector-s48-ref $bytevector-s48-set!]
|
|
[bytevector-s56-ref $bytevector-s56-set!]
|
|
[bytevector-s64-native-ref bytevector-s64-native-set!]
|
|
[bytevector-s64-ref $bytevector-s64-set!]
|
|
[bytevector-s8-ref bytevector-s8-set!]
|
|
[bytevector-sint-ref $bytevector-sint-set!]
|
|
[bytevector-u16-native-ref bytevector-u16-native-set!]
|
|
[bytevector-u16-ref $bytevector-u16-set!]
|
|
[bytevector-u24-ref $bytevector-u24-set!]
|
|
[bytevector-u32-native-ref bytevector-u32-native-set!]
|
|
[bytevector-u32-ref $bytevector-u32-set!]
|
|
[bytevector-u40-ref $bytevector-u40-set!]
|
|
[bytevector-u48-ref $bytevector-u48-set!]
|
|
[bytevector-u56-ref $bytevector-u56-set!]
|
|
[bytevector-u64-native-ref bytevector-u64-native-set!]
|
|
[bytevector-u64-ref $bytevector-u64-set!]
|
|
[bytevector-u8-ref bytevector-u8-set!]
|
|
[bytevector-uint-ref $bytevector-uint-set!]
|
|
[foreign-ref foreign-set!]
|
|
[fxvector-ref fxvector-set!]
|
|
[hashtable-ref $hashtable-set!]
|
|
[eq-hashtable-ref $eq-hashtable-set!]
|
|
[symbol-hashtable-ref $symbol-hashtable-set!]
|
|
[list-ref $list-set!]))
|