SRFI-99

Check-in [97be4921f0]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Setter support for record properties
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:97be4921f01d5391dd474276c8aa01464952beb8
User & Date: murphy 2015-02-11 17:57:32
Context
2015-02-11
17:58
Bumped .setup version to 1.4.4 check-in: 5d1b310418 user: murphy tags: trunk, v1.4.4
17:57
Setter support for record properties check-in: 97be4921f0 user: murphy tags: trunk
2015-02-06
01:18
Updated release information check-in: a2aea2a704 user: murphy tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to srfi-99.scm.

297
298
299
300
301
302
303







304
305
306
307
308
309
310

311
312
313
314








315
316
317
318
319
320
321
    (do ((names (make-vector n-all)) (i 0 (fx+ i 1))) ((>= i n-all) names)
      (vector-set! names i (cadr (%rtd-field-ref rtd i))))))

(define (rtd-field-mutable? rtd name)
  (##sys#check-structure rtd 'rtd 'rtd-field-mutable?)
  (let-values (((i access field) (%rtd-field-find rtd name)))
    (eq? access 'mutable)))








(define (make-rtp #!optional default)
  (unless (procedure? default)
    (set! default (constantly default)))
  (rec (rtp v #!optional (rtd (record-rtd v)))
    (let ((accessor (let next ((rtd (and (##sys#structure? rtd 'rtd) rtd)))
		      (if rtd

			  (hash-table-ref (%rtd-properties rtd) rtp
					  (cut next (%rtd-parent rtd)))
			  default))))
      (accessor v))))









(define (rtd-properties rtd)
  (if (##sys#structure? rtd 'rtd)
      (hash-table-keys (%rtd-properties rtd))
      '()))

(define (rtd-all-properties rtd)







>
>
>
>
>
>
>




|
<
|
>
|
|
|
|
>
>
>
>
>
>
>
>







297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315

316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
    (do ((names (make-vector n-all)) (i 0 (fx+ i 1))) ((>= i n-all) names)
      (vector-set! names i (cadr (%rtd-field-ref rtd i))))))

(define (rtd-field-mutable? rtd name)
  (##sys#check-structure rtd 'rtd 'rtd-field-mutable?)
  (let-values (((i access field) (%rtd-field-find rtd name)))
    (eq? access 'mutable)))

(define (%rtp-accessor rtd rtp default)
  (let next ((rtd (and (##sys#structure? rtd 'rtd) rtd)))
    (if rtd
	(hash-table-ref (%rtd-properties rtd) rtp
			(cut next (%rtd-parent rtd)))
	default)))

(define (make-rtp #!optional default)
  (unless (procedure? default)
    (set! default (constantly default)))
  (letrec ((rtp-get

            (lambda (v rtd)
             ((%rtp-accessor rtd rtp default) v)))
           (rtp-set!
            (lambda (v pv rtd)
             ((setter (%rtp-accessor rtd rtp default)) v pv)))
	   (rtp
	    (getter-with-setter
	     (case-lambda
	       ((v) (rtp-get v (record-rtd v)))
	       ((v rtd) (rtp-get v rtd)))
	     (case-lambda
	       ((v pv) (rtp-set! v pv (record-rtd v)))
	       ((v rtd pv) (rtp-set! v pv rtd))))))
    rtp))

(define (rtd-properties rtd)
  (if (##sys#structure? rtd 'rtd)
      (hash-table-keys (%rtd-properties rtd))
      '()))

(define (rtd-all-properties rtd)