127 lines
5.4 KiB
Scheme
127 lines
5.4 KiB
Scheme
#!r6rs
|
|
;; SRFI-17 Chez Scheme helpers
|
|
;;
|
|
;; This file contains wrappers for some of the built-in setters used
|
|
;; by the generalized set! syntax.
|
|
;;
|
|
;; Copyright (c) 2018 - 2020 Andrew W. Keep
|
|
|
|
(library (srfi :17 helpers)
|
|
(export $list-set!
|
|
$hashtable-set! $eq-hashtable-set! $symbol-hashtable-set!
|
|
$set-caar! $set-cadr! $set-cdar! $set-cddr!
|
|
$set-caaar! $set-caadr! $set-cadar! $set-caddr!
|
|
$set-cdaar! $set-cdadr! $set-cddar! $set-cdddr!
|
|
$set-caaaar! $set-caaadr! $set-caadar! $set-caaddr!
|
|
$set-cadaar! $set-cadadr! $set-caddar! $set-cadddr!
|
|
$set-cdaaar! $set-cdaadr! $set-cdadar! $set-cdaddr!
|
|
$set-cddaar! $set-cddadr! $set-cdddar! $set-cddddr!
|
|
$bytevector-ieee-double-set! $bytevector-ieee-single-set!
|
|
$bytevector-s16-set! $bytevector-s24-set! $bytevector-s32-set!
|
|
$bytevector-s40-set! $bytevector-s48-set! $bytevector-s56-set!
|
|
$bytevector-s64-set! $bytevector-u16-set! $bytevector-u24-set!
|
|
$bytevector-u32-set! $bytevector-u40-set! $bytevector-u48-set!
|
|
$bytevector-u56-set! $bytevector-u64-set!
|
|
$bytevector-sint-set! $bytevector-uint-set!)
|
|
(import (chezscheme))
|
|
|
|
(define-syntax define-$set-c...r!
|
|
(lambda (x)
|
|
(define (build-defs-for-level k cnt defs)
|
|
(let ([ls (list "a" "d")])
|
|
(let loop ([i 1] [names ls])
|
|
(if (fx= i (fx- cnt 1))
|
|
(fold-left
|
|
(lambda (defs name)
|
|
(fold-left
|
|
(lambda (defs a)
|
|
(with-syntax ([base-getter (datum->syntax #'* (string->symbol (string-append "c" name "r")))]
|
|
[base-setter (datum->syntax #'* (string->symbol (string-append "set-c" a "r!")))]
|
|
[full-setter (datum->syntax k (string->symbol (string-append "$set-c" a name "r!")))])
|
|
(cons
|
|
#'(define full-setter
|
|
(lambda (x v)
|
|
(base-setter (base-getter x) v)))
|
|
defs)))
|
|
defs ls))
|
|
defs names)
|
|
(loop (fx+ i 1)
|
|
(fold-left
|
|
(lambda (new-names a)
|
|
(fold-left
|
|
(lambda (new-names name)
|
|
(cons (string-append a name) new-names))
|
|
new-names names))
|
|
'() ls))))))
|
|
(define (build-defs k s e)
|
|
(do ([i s (fx+ i 1)]
|
|
[defs '() (build-defs-for-level k i defs)])
|
|
((fx> i e) defs)))
|
|
(syntax-case x ()
|
|
[(k s e)
|
|
(and (and (integer? (datum s)) (exact? (datum s)))
|
|
(and (integer? (datum e)) (exact? (datum s))))
|
|
(with-syntax ([(defs ...) (build-defs #'k (datum s) (datum e))])
|
|
#'(begin defs ...))])))
|
|
|
|
(define-$set-c...r! 2 4)
|
|
|
|
(define-syntax define-hashtable-set!
|
|
(lambda (x)
|
|
(define (build-def k)
|
|
(lambda (name)
|
|
(with-syntax ([out-name (datum->syntax k (string->symbol (string-append "$" name "hashtable-set!")))]
|
|
[name (datum->syntax #'* (string->symbol (string-append name "hashtable-set!")))])
|
|
#'(define-syntax out-name
|
|
(syntax-rules ()
|
|
[(_ ht k dv v) (name ht k v)])))))
|
|
(syntax-case x ()
|
|
[(k name ...) (andmap string? (datum (name ...)))
|
|
(with-syntax ([(defs ...) (map (build-def #'k) (datum (name ...)))])
|
|
#'(begin defs ...))])))
|
|
|
|
(define-hashtable-set! "" "eq-" "symbol-")
|
|
|
|
(define $list-set!
|
|
(lambda (ls orig-idx v)
|
|
(let loop ([ls ls] [idx orig-idx])
|
|
(if (fx= idx 0)
|
|
(set-car! ls v)
|
|
(if (null? ls)
|
|
(errorf 'list-ref "~s index out of range" orig-idx)
|
|
(loop (cdr ls) (fx+ idx 1)))))))
|
|
|
|
(define-syntax define-$bv-set!
|
|
(lambda (x)
|
|
(define (build-defs k)
|
|
(lambda (name)
|
|
(let ([name (symbol->string (syntax->datum name))])
|
|
(with-syntax ([bv-set! (datum->syntax #'* (string->symbol (string-append "bytevector-" name "-set!")))]
|
|
[$bv-set! (datum->syntax k (string->symbol (string-append "$bytevector-" name "-set!")))])
|
|
#'(define-syntax $bv-set!
|
|
(syntax-rules ()
|
|
[(_ bv idx eness v) (bv-set! bv idx v eness)]))))))
|
|
(syntax-case x ()
|
|
[(k name ...)
|
|
(with-syntax ([(defs ...) (map (build-defs #'k) #'(name ...))])
|
|
#'(begin defs ...))])))
|
|
|
|
(define-$bv-set! ieee-double ieee-single s16 s24 s32 s40 s48 s56 s64 u16 u24 u32 u40 u48 u56 u64)
|
|
|
|
(define-syntax define-$bv-int-set!
|
|
(lambda (x)
|
|
(define (build-defs k)
|
|
(lambda (name)
|
|
(let ([name (symbol->string (syntax->datum name))])
|
|
(with-syntax ([bv-set! (datum->syntax #'* (string->symbol (string-append "bytevector-" name "-set!")))]
|
|
[$bv-set! (datum->syntax k (string->symbol (string-append "$bytevector-" name "-set!")))])
|
|
#'(define-syntax $bv-set!
|
|
(syntax-rules ()
|
|
[(_ bv idx eness size v) (bv-set! bv idx v eness size)]))))))
|
|
(syntax-case x ()
|
|
[(k name ...)
|
|
(with-syntax ([(defs ...) (map (build-defs #'k) #'(name ...))])
|
|
#'(begin defs ...))])))
|
|
|
|
(define-$bv-int-set! sint uint))
|