ADDED srfi-99.egg Index: srfi-99.egg ================================================================== --- /dev/null +++ srfi-99.egg @@ -0,0 +1,12 @@ +((version "1.4.5") + (category data) + (license "BSD") + (author "Thomas Chust") + (synopsis "SRFI-99 record types") + (dependencies srfi-1 srfi-69 miscmacros) + (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)))) DELETED srfi-99.meta Index: srfi-99.meta ================================================================== --- srfi-99.meta +++ /dev/null @@ -1,9 +0,0 @@ -;; -*- mode: Scheme; -*- -((category data) - (license "BSD") - (author "Thomas Chust") - (synopsis "SRFI-99 record types") - (doc-from-wiki) - (needs) - (test-depends test) - (files "srfi-99.scm")) Index: srfi-99.release-info ================================================================== --- srfi-99.release-info +++ srfi-99.release-info @@ -1,14 +1,5 @@ ;; -*- mode: Scheme; -*- (repo fossil "https://chust.org/repos/chicken-{egg-name}") (uri targz "https://chust.org/repos/chicken-{egg-name}/tarball/{egg-name}.tar.gz?uuid=v{egg-release}") -(release "1.4.4") -(release "1.4.3") -(release "1.4.2") -(release "1.4.1") -(release "1.4.0") -(release "1.3.0") -(release "1.2.0") -(release "1.1.1") -(release "1.1.0") -(release "1.0.0") +(release "1.4.5") Index: srfi-99.scm ================================================================== --- srfi-99.scm +++ srfi-99.scm @@ -21,22 +21,23 @@ ;; 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 + scheme + (chicken base) + (chicken fixnum) + (chicken plist) + (chicken gc) + miscmacros srfi-69) (define-values (%make-rtd %get-rtd) (letrec ((%link! (lambda (rtd) @@ -113,12 +114,13 @@ (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) + 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 @@ -253,12 +255,12 @@ (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) + 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)))) @@ -355,11 +357,11 @@ 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) + 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=) @@ -480,11 +482,11 @@ ) (module srfi-99-records () (import - scheme chicken) + scheme (chicken base) (chicken module)) (reexport srfi-99-records-procedural srfi-99-records-inspection srfi-99-records-syntactic) ) @@ -492,12 +494,15 @@ (module srfi-99-variants (define-variant-type define-variant-constructor variant-case) (import - scheme (except chicken define-record-type) - srfi-99-records lolevel) + scheme + (chicken module) + (except (chicken base) define-record-type) + (only (chicken memory representation) extend-procedure procedure-data) + miscmacros srfi-99-records) (define-syntax define-variant-type (syntax-rules () ((define-variant-type (rtd option ...) predicate (variant field ...) @@ -563,10 +568,10 @@ ) (module srfi-99 () (import - scheme chicken) + scheme (chicken base) (chicken module)) (reexport srfi-99-records srfi-99-variants) ) DELETED srfi-99.setup Index: srfi-99.setup ================================================================== --- srfi-99.setup +++ /dev/null @@ -1,46 +0,0 @@ -;; -*- mode: Scheme; -*- -(compile -s -O2 -d1 "srfi-99.scm" - -j srfi-99 - -j srfi-99-primitives - -j srfi-99-records - -j srfi-99-records-procedural - -j srfi-99-records-inspection - -j srfi-99-records-syntactic - -j srfi-99-variants) - -(cond-expand - (enable-static - (compile -c -O2 -d1 "srfi-99.scm" - -unit srfi-99)) - (else - )) - -(compile -s -O2 -d0 "srfi-99.import.scm") -(compile -s -O2 -d0 "srfi-99-primitives.import.scm") -(compile -s -O2 -d0 "srfi-99-records.import.scm") -(compile -s -O2 -d0 "srfi-99-records-procedural.import.scm") -(compile -s -O2 -d0 "srfi-99-records-inspection.import.scm") -(compile -s -O2 -d0 "srfi-99-records-syntactic.import.scm") -(compile -s -O2 -d0 "srfi-99-variants.import.scm") - -(install-extension - 'srfi-99 - `("srfi-99.so" - ,@(cond-expand - (enable-static - '("srfi-99.o")) - (else - '())) - "srfi-99.import.so" - "srfi-99-primitives.import.so" - "srfi-99-records.import.so" - "srfi-99-records-procedural.import.so" - "srfi-99-records-inspection.import.so" - "srfi-99-records-syntactic.import.so" - "srfi-99-variants.import.so") - `((version "1.4.4") - ,@(cond-expand - (enable-static - '((static "srfi-99.o"))) - (else - '())))) DELETED test/run.scm Index: test/run.scm ================================================================== --- test/run.scm +++ /dev/null @@ -1,127 +0,0 @@ -;; -*- mode: Scheme; -*- -;; -;; This file is part of SRFI-99 for CHICKEN -;; Copyright (c) 2011 by Thomas Chust. All rights reserved. -;; -;; Permission is hereby granted, free of charge, to any person -;; obtaining a copy of this software and associated documentation -;; files (the Software), to deal in the Software without restriction, -;; including without limitation the rights to use, copy, modify, -;; merge, publish, distribute, sublicense, and/or sell copies of the -;; Software, and to permit persons to whom the Software is furnished -;; to do so, subject to the following conditions: -;; -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; 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 '#())) - (test-error "bad fields" (make-rtd 'foo '#((murks quark)))) - (test-error "bad parent" (make-rtd 'foo '#() 'murks))) - - (test-group "RTD properties" - (test "type name" 'foo (rtd-name (make-rtd 'foo '#()))) - (test "type UID" 'bar (rtd-uid (make-rtd 'foo '#() #f #:uid 'bar))) - (test "unsealed type" #f (rtd-sealed? (make-rtd 'foo '#() #f))) - (test "sealed type" #t (rtd-sealed? (make-rtd 'foo '#() #f #:sealed #t))) - (test "transparent type" #f (rtd-opaque? (make-rtd 'foo '#() #f))) - (test "opaque type" #t (rtd-opaque? (make-rtd 'foo '#() #f #:opaque #t))) - (test "implicit immutable field" #f (rtd-field-mutable? (make-rtd 'foo '#(x)) 'x)) - (test "explicit immutable field" #f (rtd-field-mutable? (make-rtd 'foo '#((immutable x))) 'x)) - (test "implicit mutable field" #t (rtd-field-mutable? (make-rtd 'foo '#((x))) 'x)) - (test "explicit mutable field" #t (rtd-field-mutable? (make-rtd 'foo '#((mutable x))) 'x))) - - (test-group "RTD instances" - (let ((t (make-rtd 'foo '#(x (y))))) - (define make-t (rtd-constructor t)) - (define t? (rtd-predicate t)) - (define t-x (rtd-accessor t 'x)) - (define t-y (rtd-accessor t 'y)) - (test "instance detection" #t (t? (make-t 1 2))) - (test "non-instance detection" #f (t? 'foo)) - (test "field access" 42 (t-x (make-t 42 23))) - (test "field mutation" 23 (let ((r (make-t 42 0))) (set! (t-y r) 23) (t-y r))) - (test-error "disallowed field mutation" (set! (t-x (make-t 42 23)) 0)))) - - (test-group "RTD inheritance" - (let* ((t0 (make-rtd 'foo '#(x y))) - (t1 (make-rtd 'bar '#(z) t0 #:sealed #t))) - (define make-t1 (rtd-constructor t1 '#())) - (define t0? (rtd-predicate t0)) - (define t1? (rtd-predicate t1)) - (test "direct field enumeration" '#(z) (rtd-field-names t1)) - (test "full field enumeration" '#(x y z) (rtd-all-field-names t1)) - (test "direct instance detection" #t (t1? (make-t1))) - (test "indirect instance detection" #t (t0? (make-t1))) - (test-error "disallowed derivation" (make-rtd 'baz '#() t1)))) - - (test-group "properties" - (let* ((p0 (make-rtp 42)) - (p1 (make-rtp)) - (t0 (make-rtd 'foo '#(x) #:property p0 23)) - (t1 (make-rtd 'bar '#(y) t0 #:property p1 'y))) - (define make-t0 (rtd-constructor t0 '#(x))) - (define make-t1 (rtd-constructor t1 '#(y))) - (test "direct type property access" 23 (p0 #f t0)) - (test "derived type property access" 23 (p0 #f t1)) - (test "direct instance property access" 23 (p0 (make-t0 1))) - (test "derived instance property access" 23 (p0 (make-t1 1))) - (test-error "illegal field property access" (p1 #f t1)) - (test "field property access" 2 (p1 (make-t1 2))))) - -) - -(test-group "syntactic layer" (let () - - (define-record-type foo - #t #t - x (y)) - - (test-assert "RTD" (rtd? foo)) - (test-assert "constructor" (procedure? make-foo)) - (test-assert "predicate" (procedure? foo?)) - (test-assert "immutable accessor" (procedure? foo-x)) - (test-assert "mutable accessor" (procedure? foo-y)) - (test-assert "mutable mutator" (procedure? foo-y-set!)) - (test-assert "mutable accessor setter" (procedure? (setter foo-y))) - -)) - -(test-group "variants" (let () - - (define-variant-type foo - #t - (foobar x) - (foobaz x y)) - - (test-assert "RTD" (rtd? foo)) - (test-assert "predicate" (procedure? foo?)) - (test-assert "variant constructors" (every procedure? (list foobar foobaz))) - (test-assert "variant RTDs" (every rtd? (map procedure-data (list foobar foobaz)))) - (test "variant extraction" 2 (variant-case foo (foobaz 1 2) - ((foobar x) x) - ((foobaz y) y))) - (test "else clause" 42 (variant-case foo (foobaz 1 2) - ((foobar x) x) - (else 42))) - (test-error "match error" (variant-case foo (foobaz 1 2) - ((foobar x) x))) - -)) - -(test-exit) ADDED tests/run.scm Index: tests/run.scm ================================================================== --- /dev/null +++ tests/run.scm @@ -0,0 +1,128 @@ +;; -*- mode: Scheme; -*- +;; +;; This file is part of SRFI-99 for CHICKEN +;; Copyright (c) 2011 by Thomas Chust. All rights reserved. +;; +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the Software), to deal in the Software without restriction, +;; including without limitation the rights to use, copy, modify, +;; merge, publish, distribute, sublicense, and/or sell copies of the +;; Software, and to permit persons to whom the Software is furnished +;; to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; 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 + (only (chicken memory representation) procedure-data) + srfi-1 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 '#())) + (test-error "bad fields" (make-rtd 'foo '#((murks quark)))) + (test-error "bad parent" (make-rtd 'foo '#() 'murks))) + + (test-group "RTD properties" + (test "type name" 'foo (rtd-name (make-rtd 'foo '#()))) + (test "type UID" 'bar (rtd-uid (make-rtd 'foo '#() #f #:uid 'bar))) + (test "unsealed type" #f (rtd-sealed? (make-rtd 'foo '#() #f))) + (test "sealed type" #t (rtd-sealed? (make-rtd 'foo '#() #f #:sealed #t))) + (test "transparent type" #f (rtd-opaque? (make-rtd 'foo '#() #f))) + (test "opaque type" #t (rtd-opaque? (make-rtd 'foo '#() #f #:opaque #t))) + (test "implicit immutable field" #f (rtd-field-mutable? (make-rtd 'foo '#(x)) 'x)) + (test "explicit immutable field" #f (rtd-field-mutable? (make-rtd 'foo '#((immutable x))) 'x)) + (test "implicit mutable field" #t (rtd-field-mutable? (make-rtd 'foo '#((x))) 'x)) + (test "explicit mutable field" #t (rtd-field-mutable? (make-rtd 'foo '#((mutable x))) 'x))) + + (test-group "RTD instances" + (let ((t (make-rtd 'foo '#(x (y))))) + (define make-t (rtd-constructor t)) + (define t? (rtd-predicate t)) + (define t-x (rtd-accessor t 'x)) + (define t-y (rtd-accessor t 'y)) + (test "instance detection" #t (t? (make-t 1 2))) + (test "non-instance detection" #f (t? 'foo)) + (test "field access" 42 (t-x (make-t 42 23))) + (test "field mutation" 23 (let ((r (make-t 42 0))) (set! (t-y r) 23) (t-y r))) + (test-error "disallowed field mutation" (set! (t-x (make-t 42 23)) 0)))) + + (test-group "RTD inheritance" + (let* ((t0 (make-rtd 'foo '#(x y))) + (t1 (make-rtd 'bar '#(z) t0 #:sealed #t))) + (define make-t1 (rtd-constructor t1 '#())) + (define t0? (rtd-predicate t0)) + (define t1? (rtd-predicate t1)) + (test "direct field enumeration" '#(z) (rtd-field-names t1)) + (test "full field enumeration" '#(x y z) (rtd-all-field-names t1)) + (test "direct instance detection" #t (t1? (make-t1))) + (test "indirect instance detection" #t (t0? (make-t1))) + (test-error "disallowed derivation" (make-rtd 'baz '#() t1)))) + + (test-group "properties" + (let* ((p0 (make-rtp 42)) + (p1 (make-rtp)) + (t0 (make-rtd 'foo '#(x) #:property p0 23)) + (t1 (make-rtd 'bar '#(y) t0 #:property p1 'y))) + (define make-t0 (rtd-constructor t0 '#(x))) + (define make-t1 (rtd-constructor t1 '#(y))) + (test "direct type property access" 23 (p0 #f t0)) + (test "derived type property access" 23 (p0 #f t1)) + (test "direct instance property access" 23 (p0 (make-t0 1))) + (test "derived instance property access" 23 (p0 (make-t1 1))) + (test-error "illegal field property access" (p1 #f t1)) + (test "field property access" 2 (p1 (make-t1 2))))) + +) + +(test-group "syntactic layer" (let () + + (define-record-type foo + #t #t + x (y)) + + (test-assert "RTD" (rtd? foo)) + (test-assert "constructor" (procedure? make-foo)) + (test-assert "predicate" (procedure? foo?)) + (test-assert "immutable accessor" (procedure? foo-x)) + (test-assert "mutable accessor" (procedure? foo-y)) + (test-assert "mutable mutator" (procedure? foo-y-set!)) + (test-assert "mutable accessor setter" (procedure? (setter foo-y))) + +)) + +(test-group "variants" (let () + + (define-variant-type foo + #t + (foobar x) + (foobaz x y)) + + (test-assert "RTD" (rtd? foo)) + (test-assert "predicate" (procedure? foo?)) + (test-assert "variant constructors" (every procedure? (list foobar foobaz))) + (test-assert "variant RTDs" (every rtd? (map procedure-data (list foobar foobaz)))) + (test "variant extraction" 2 (variant-case foo (foobaz 1 2) + ((foobar x) x) + ((foobaz y) y))) + (test "else clause" 42 (variant-case foo (foobaz 1 2) + ((foobar x) x) + (else 42))) + (test-error "match error" (variant-case foo (foobaz 1 2) + ((foobar x) x))) + +)) + +(test-exit)