SRFI-99

Check-in [adfc004653]
Login

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

Overview
Comment:Port the egg to CHICKEN 5
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | chicken-5
Files: files | file ages | folders
SHA1:adfc0046533ca3210d59fe2728a458a094997541
User & Date: kooda 2018-06-19 21:29:30
Context
2018-06-21
10:32
Add a dependency to miscmacros check-in: 37af701d95 user: kooda tags: chicken-5
2018-06-19
21:29
Port the egg to CHICKEN 5 check-in: adfc004653 user: kooda tags: chicken-5
2017-09-01
11:58
Point release-info to main repository Leaf check-in: d3622ab6b3 user: murphy tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added srfi-99.egg.

























>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
((version "1.5.0")
 (category data)
 (license "BSD")
 (author "Thomas Chust")
 (synopsis "SRFI-99 record types")
 (dependencies srfi-1 srfi-69)
 (test-dependencies test)
 (components
   (extension srfi-99
     (modules srfi-99-primitives srfi-99-records-procedural
              srfi-99-records-inspection srfi-99-records-syntactic
              srfi-99-records srfi-99-variants srfi-99))))

Changes to srfi-99.scm.

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37





38
39
40
41
42
43
44
...
111
112
113
114
115
116
117
118

119
120
121
122
123
124
125
126
...
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
...
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
...
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497

498
499
500
501
502
503
504
505
...
561
562
563
564
565
566
567
568
569
570
571
572
;; 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.

(require-library
 srfi-1 srfi-69
 data-structures lolevel)

(module srfi-99-primitives
  (%make-rtd %get-rtd rtd? record?
   %rtd-name %rtd-uid %rtd-child-uids %rtd-fields %rtd-parent %rtd-properties
   %rtd-child-uid?
   %rtd-count-fields %rtd-count-all-fields
   %rtd-field-ref %rtd-field-find)
  (import
   scheme chicken





   srfi-69)

(define-values (%make-rtd %get-rtd)
  (letrec ((%link!
	    (lambda (rtd)
	      (do ((rtd rtd (%rtd-parent rtd)) (uid (%rtd-uid rtd))) ((not rtd))
		(cond
................................................................................

)

(module srfi-99-records-procedural
  (make-rtd rtd?
   rtd-constructor rtd-predicate rtd-accessor rtd-mutator)
  (import
   scheme chicken

   srfi-1 srfi-69 srfi-99-primitives data-structures)

(define (make-rtd name fields . args)
  (let-values (((fields)
		(list->vector
		 (map
		  (lambda (field)
		    (cond
................................................................................

(module srfi-99-records-inspection
  (record? record-rtd
   rtd-name rtd-uid rtd-sealed? rtd-opaque? rtd-parent
   rtd-field-names rtd-all-field-names rtd-field-mutable?
   make-rtp rtd-properties rtd-all-properties)
  (import
   scheme chicken
   srfi-1 srfi-69 srfi-99-primitives srfi-99-records-procedural data-structures)

(define (record-rtd v)
  (and (record? v)
       (%get-rtd (##sys#slot v 0))))

(define (rtd-name rtd)
  (##sys#check-structure rtd 'rtd 'rtd-name)
................................................................................
   define-record-predicate
   %define-record-predicate/default
   define-record-field
   %define-record-field/mutable-default %define-record-field/immutable-default
   define-record-property
   define-record-printer)
  (import
   scheme (except chicken define-record-type define-record-printer)
   srfi-99-records-procedural)

(define-syntax %define-record-constructor/default
  (ir-macro-transformer
   (lambda (stx inject id=)
     (let* ((rtd (cadr stx))
	    (name (symbol-append 'make- (strip-syntax rtd))))
................................................................................
     (##sys#register-record-printer (rtd-uid rtd) expr))))

)

(module srfi-99-records
  ()
  (import
   scheme chicken)
  (reexport
   srfi-99-records-procedural srfi-99-records-inspection
   srfi-99-records-syntactic)

)

(module srfi-99-variants
  (define-variant-type
   define-variant-constructor
   variant-case)
  (import
   scheme (except chicken define-record-type)

   srfi-99-records lolevel)

(define-syntax define-variant-type
  (syntax-rules ()
    ((define-variant-type (rtd option ...) predicate
       (variant field ...)
       ...)
     (begin
................................................................................
	(error "no matching variant"))))))

)

(module srfi-99
  ()
  (import
   scheme chicken)
  (reexport
   srfi-99-records srfi-99-variants)

)







<
<
<
<







|
>
>
>
>
>







 







|
>
|







 







|
|







 







|







 







|











|
>
|







 







|




19
20
21
22
23
24
25




26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
...
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
...
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
...
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
...
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
...
564
565
566
567
568
569
570
571
572
573
574
575
;; 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.





(module srfi-99-primitives
  (%make-rtd %get-rtd rtd? record?
   %rtd-name %rtd-uid %rtd-child-uids %rtd-fields %rtd-parent %rtd-properties
   %rtd-child-uid?
   %rtd-count-fields %rtd-count-all-fields
   %rtd-field-ref %rtd-field-find)
  (import
   scheme
   (chicken base)
   (chicken fixnum)
   (chicken plist)
   (chicken gc)
   miscmacros
   srfi-69)

(define-values (%make-rtd %get-rtd)
  (letrec ((%link!
	    (lambda (rtd)
	      (do ((rtd rtd (%rtd-parent rtd)) (uid (%rtd-uid rtd))) ((not rtd))
		(cond
................................................................................

)

(module srfi-99-records-procedural
  (make-rtd rtd?
   rtd-constructor rtd-predicate rtd-accessor rtd-mutator)
  (import
   scheme (chicken base) (chicken fixnum)
   miscmacros
   srfi-1 srfi-69 srfi-99-primitives)

(define (make-rtd name fields . args)
  (let-values (((fields)
		(list->vector
		 (map
		  (lambda (field)
		    (cond
................................................................................

(module srfi-99-records-inspection
  (record? record-rtd
   rtd-name rtd-uid rtd-sealed? rtd-opaque? rtd-parent
   rtd-field-names rtd-all-field-names rtd-field-mutable?
   make-rtp rtd-properties rtd-all-properties)
  (import
   scheme (chicken base) (chicken fixnum)
   srfi-1 srfi-69 srfi-99-primitives srfi-99-records-procedural)

(define (record-rtd v)
  (and (record? v)
       (%get-rtd (##sys#slot v 0))))

(define (rtd-name rtd)
  (##sys#check-structure rtd 'rtd 'rtd-name)
................................................................................
   define-record-predicate
   %define-record-predicate/default
   define-record-field
   %define-record-field/mutable-default %define-record-field/immutable-default
   define-record-property
   define-record-printer)
  (import
   scheme (except (chicken base) define-record-type define-record-printer)
   srfi-99-records-procedural)

(define-syntax %define-record-constructor/default
  (ir-macro-transformer
   (lambda (stx inject id=)
     (let* ((rtd (cadr stx))
	    (name (symbol-append 'make- (strip-syntax rtd))))
................................................................................
     (##sys#register-record-printer (rtd-uid rtd) expr))))

)

(module srfi-99-records
  ()
  (import
   scheme (chicken base) (chicken module))
  (reexport
   srfi-99-records-procedural srfi-99-records-inspection
   srfi-99-records-syntactic)

)

(module srfi-99-variants
  (define-variant-type
   define-variant-constructor
   variant-case)
  (import
   scheme (except (chicken base) define-record-type)
   (chicken module)
   miscmacros srfi-99-records)

(define-syntax define-variant-type
  (syntax-rules ()
    ((define-variant-type (rtd option ...) predicate
       (variant field ...)
       ...)
     (begin
................................................................................
	(error "no matching variant"))))))

)

(module srfi-99
  ()
  (import
   scheme (chicken base) (chicken module))
  (reexport
   srfi-99-records srfi-99-variants)

)

Changes to test/run.scm.

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
;; 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.

(require-extension
 srfi-99 test)

(test-group "procedural layer"

  (test-group "RTD creation"
    (test-assert "null record" (rtd? (make-rtd 'foo '#())))
    (test-error "bad name" (make-rtd 42 '#()))







|







19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
;; 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.

(import
 srfi-99 test)

(test-group "procedural layer"

  (test-group "RTD creation"
    (test-assert "null record" (rtd? (make-rtd 'foo '#())))
    (test-error "bad name" (make-rtd 42 '#()))