bitfield.scm

(use gauche.collection)
(use gauche.uvector)
(use gauche.array)
(use test.procedure+)

(define (%bin->string width v)
  (format #f #`"~,width,,'0,,,,b" v ) )

(define (%calc-bit-fields bit-widths)
  ($ coerce-to <vector>
    $ map-accum (^[bw s] (let1 end (+ s bw) (values `(,s ,end) end ) ) ) 0 bit-widths ) )

(define (bitfield . bit-widths)
  (let1 bit-fields (%calc-bit-fields bit-widths)
    (getter-with-setter
      (^[bits i]
        ($ bit-field (bits) $* ref bit-fields i) )
      (^[bits i v]
        (update! (bits) (^n ($ copy-bit-field n v $* ref bit-fields i) ) ) ) ) ) )

(define (name-map . names)
  (let1 nt ($ alist->hash-table $ map cons names ($ iota $ length names) )
    (^x (~ nt x) ) ) )

(define (mutable-field . flags)
  (let1 mt (coerce-to <vector> flags)
    (getter-with-setter
      (^[f i] (f i) )
      (^[f i v]
        (if (~ mt i)
          (set! (f i) v)
          (errorf "(~a ~a) is immutable" f i) ) ) ) ) )

;----------------------------
; compose test
(define (make-matrix2 :optional (init 0 ) )
  (let1 mat (make-array (shape 0 2 0 2) init )
    (getter-with-setter
      (^[i j]   (array-ref  mat i j)  )
      (^[i j v] (array-set! mat i j v) ) ) ) )

(define (taikaku i)
  (values i i) )

(define x  (make-matrix2 0))
(define tx (.$ x taikaku))
#?=(tx 0)
#?=(x 0 0)
(set! (tx 0) 111)
(set! (tx 1) 222)
#?=(x 0 0)
#?=(x 0 1)
#?=(x 1 0)
#?=(x 1 1)

(exit)
;----------------------------
(define l '(111 222 333))
(define xyz-110 (.$ (pa$ (mutable-field #t #t #f) (pa$ ~ l) ) (name-map 'x 'y 'z) ) )

#?=(xyz-110 'x)
#?=(xyz-110 'y)
#?=(xyz-110 'z)
#?=(setter xyz-110)
;(exit)
(set! (xyz-110 'x) 123)
(set! (xyz-110 'y) 456)
;(set! (xyz-110 'z) 456) ;---> error immutable!
#?=(xyz-110 'x)
#?=(xyz-110 'y)
#?=(xyz-110 'z)

;

(define u8 (u8vector #b11101111 #b11101011 #b01101101 ) )

(define (wrap-val v)
  (getter-with-setter
    (^[]  v)
    (^x (set! v x) ) ) )

(define b (pa$ ~ u8 1))
(define bf-xyz-123 (.$ (pa$ (mutable-field #t #f #t ) (pa$ (bitfield 1 2 3) (pa$ ~ u8 1))) (name-map 'x 'y 'z) ) )
(define bf-xyz-321 (.$ (pa$ (mutable-field #t #f #t ) (pa$ (bitfield 3 2 1) (pa$ ~ u8 1))) (name-map 'x 'y 'z) ) )

#?=(%bin->string (integer-length (b)) (b) )
#?=(bf-xyz-123 'x)
#?=(bf-xyz-123 'y)
#?=(bf-xyz-123 'z)
;(set! (bf-xyz-123 'x) 0)
;(set! (bf-xyz-123 'y) 0) ; --> error immutable
;(set! (bf-xyz-123 'z) 0)
#?=(bf-xyz-123 'x)
#?=(bf-xyz-123 'y)
#?=(bf-xyz-123 'z)
#?=(%bin->string (integer-length (b)) (b))

;(exit)
#?=(%bin->string (integer-length (b)) (b) )
#?=(bf-xyz-321 'x)
#?=(bf-xyz-321 'y)
#?=(bf-xyz-321 'z)
(set! (bf-xyz-321 'x) 0)
;(set! (bf-xyz-321 'y) 0) ; --> error immutable
(set! (bf-xyz-321 'z) 0)
#?=(bf-xyz-321 'x)
#?=(bf-xyz-321 'y)
#?=(bf-xyz-321 'z)
#?=(%bin->string (integer-length (b)) (b))

procedure+.scm

(define-module test.procedure+
  (use gauche.record)
  (export
    pa$ .$ compose
    wrap box box? unbox set-box!) )
(select-module test.procedure+)

(define (pa$ proc . arg)
  (let1 %pa$ (with-module gauche pa$)
    (if (has-setter? proc)
      (getter-with-setter (apply %pa$ proc arg) (apply %pa$ (setter proc) arg))
      (apply %pa$ proc arg) ) ) )

(define (compose f . fs)
  (let1 %compose (with-module gauche compose)
    (if (has-setter? f)
      (getter-with-setter
        (apply %compose f fs)
        (^ arg
          (receive [loc v] (split-at arg ($ + -1 $ length arg)) ; v must be singleton
            (receive loc (apply (apply %compose fs) loc )
              (apply (setter f) (append loc v ) ) ) ) ) )
      (apply %compose f fs) ) ) )
(define .$ compose)

(define (wrap . arg)
  (getter-with-setter
    (^[] (apply values arg))
    (^ x (set! arg x)) ) )

(define-record-type <box> %make-box box? (%fn %fn) )
(define (box . arg) (%make-box (apply wrap arg) ) )
(define-method unbox    ((x <box>)) ((%fn x)) )
(define-method set-box! ((x <box>) . arg ) (apply (setter (%fn x)) arg) )