diff options
-rw-r--r-- | module/Makefile.am | 1 | ||||
-rw-r--r-- | module/rnrs/6/conditions.scm | 2 | ||||
-rw-r--r-- | module/rnrs/6/enums.scm | 153 | ||||
-rw-r--r-- | test-suite/Makefile.am | 1 | ||||
-rw-r--r-- | test-suite/tests/r6rs-enums.test | 257 |
5 files changed, 413 insertions, 1 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index 6e6b0cddd..b498a915d 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -259,6 +259,7 @@ RNRS_SOURCES = \ rnrs/6/base.scm \ rnrs/6/conditions.scm \ rnrs/6/control.scm \ + rnrs/6/enums.scm \ rnrs/6/exceptions.scm \ rnrs/6/files.scm \ rnrs/6/hashtables.scm \ diff --git a/module/rnrs/6/conditions.scm b/module/rnrs/6/conditions.scm index 8ff2f347b..678dc1aec 100644 --- a/module/rnrs/6/conditions.scm +++ b/module/rnrs/6/conditions.scm @@ -207,7 +207,7 @@ make-lexical-violation lexical-violation?) (define-condition-type &syntax &violation - make-syntax-violation syntax-violation + make-syntax-violation syntax-violation? (form syntax-violation-form) (subform syntax-violation-subform)) diff --git a/module/rnrs/6/enums.scm b/module/rnrs/6/enums.scm new file mode 100644 index 000000000..cd7e346ba --- /dev/null +++ b/module/rnrs/6/enums.scm @@ -0,0 +1,153 @@ +;;; enums.scm --- The R6RS enumerations library + +;; Copyright (C) 2010 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(library (rnrs enums (6)) + (export make-enumeration enum-set-universe enum-set-indexer + enum-set-constructor enum-set->list enum-set-member? enum-set-subset? + enum-set=? enum-set-union enum-set-intersection enum-set-difference + enum-set-complement enum-set-projection define-enumeration) + (import (only (guile) and=>) + (rnrs base (6)) + (rnrs conditions (6)) + (rnrs exceptions (6)) + (rnrs records procedural (6)) + (rnrs syntax-case (6)) + (srfi :1)) + + (define enum-set-rtd (make-record-type-descriptor + 'enum-set #f #f #f #f '#((mutable universe) + (immutable set)))) + + (define make-enum-set + (record-constructor + (make-record-constructor-descriptor enum-set-rtd #f #f))) + + (define enum-set-universe-internal (record-accessor enum-set-rtd 0)) + (define enum-set-universe-set! (record-mutator enum-set-rtd 0)) + + (define enum-set-set (record-accessor enum-set-rtd 1)) + + (define (make-enumeration symbol-list) + (let ((es (make-enum-set #f symbol-list))) + (enum-set-universe-set! es es))) + + (define (enum-set-universe enum-set) + (or (enum-set-universe-internal enum-set) + enum-set)) + + (define (enum-set-indexer enum-set) + (let* ((symbols (enum-set->list (enum-set-universe enum-set))) + (cardinality (length symbols))) + (lambda (x) + (and=> (memq x symbols) + (lambda (probe) (- cardinality (length probe))))))) + + (define (enum-set-constructor enum-set) + (lambda (symbol-list) + (make-enum-set (enum-set-universe enum-set) + (list-copy symbol-list)))) + + (define (enum-set->list enum-set) + (lset-intersection eq? + (enum-set-set (enum-set-universe enum-set)) + (enum-set-set enum-set))) + + (define (enum-set-member? symbol enum-set) + (and (memq symbol (enum-set-set enum-set)) #t)) + + (define (enum-set-subset? enum-set-1 enum-set-2) + (and (lset<= eq? + (enum-set-set (enum-set-universe enum-set-1)) + (enum-set-set (enum-set-universe enum-set-2))) + (lset<= eq? (enum-set-set enum-set-1) (enum-set-set enum-set-2)))) + + (define (enum-set=? enum-set-1 enum-set-2) + (and (enum-set-subset? enum-set-1 enum-set-2) + (enum-set-subset? enum-set-2 enum-set-1))) + + (define (enum-set-union enum-set-1 enum-set-2) + (if (eq? (enum-set-universe enum-set-1) + (enum-set-universe enum-set-2)) + (make-enum-set (enum-set-universe enum-set-1) + (lset-union eq? + (enum-set-set enum-set-1) + (enum-set-set enum-set-2))) + (raise (make-assertion-violation)))) + + (define (enum-set-intersection enum-set-1 enum-set-2) + (if (eq? (enum-set-universe enum-set-1) + (enum-set-universe enum-set-2)) + (make-enum-set (enum-set-universe enum-set-1) + (lset-intersection eq? + (enum-set-set enum-set-1) + (enum-set-set enum-set-2))) + (raise (make-assertion-violation)))) + + (define (enum-set-difference enum-set-1 enum-set-2) + (if (eq? (enum-set-universe enum-set-1) + (enum-set-universe enum-set-2)) + (make-enum-set (enum-set-universe enum-set-1) + (lset-difference eq? + (enum-set-set enum-set-1) + (enum-set-set enum-set-2))) + (raise (make-assertion-violation)))) + + (define (enum-set-complement enum-set) + (let ((universe (enum-set-universe enum-set))) + (make-enum-set universe + (lset-difference + eq? (enum-set->list universe) (enum-set-set enum-set))))) + + (define (enum-set-projection enum-set-1 enum-set-2) + (make-enum-set (enum-set-universe enum-set-2) + (lset-intersection eq? + (enum-set-set enum-set-1) + (enum-set->list + (enum-set-universe enum-set-2))))) + + (define-syntax define-enumeration + (syntax-rules () + ((_ type-name (symbol ...) constructor-syntax) + (begin + (define-syntax type-name + (lambda (s) + (syntax-case s () + ((type-name sym) + (if (memq (syntax->datum #'sym) '(symbol ...)) + #'(quote sym) + (syntax-violation (symbol->string 'type-name) + "not a member of the set" + #f)))))) + (define-syntax constructor-syntax + (lambda (s) + (syntax-case s () + ((_) (syntax #f)) + ((_ sym (... ...)) + (let* ((universe '(symbol ...)) + (syms (syntax->datum #'(sym (... ...)))) + (quoted-universe + (datum->syntax s (list 'quote universe))) + (quoted-syms (datum->syntax s (list 'quote syms)))) + (or (every (lambda (x) (memq x universe)) syms) + (syntax-violation (symbol->string 'constructor-syntax) + "not a subset of the universe" + #f)) + #`((enum-set-constructor (make-enumeration #,quoted-universe)) + #,quoted-syms)))))))))) +) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 01727ce8d..6ca980aaf 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -79,6 +79,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/r6rs-arithmetic-bitwise.test \ tests/r6rs-conditions.test \ tests/r6rs-control.test \ + tests/r6rs-enums.test \ tests/r6rs-exceptions.test \ tests/r6rs-files.test \ tests/r6rs-hashtables.test \ diff --git a/test-suite/tests/r6rs-enums.test b/test-suite/tests/r6rs-enums.test new file mode 100644 index 000000000..d91de1c35 --- /dev/null +++ b/test-suite/tests/r6rs-enums.test @@ -0,0 +1,257 @@ +;;; r6rs-enums.test --- Test suite for R6RS (rnrs enums) + +;; Copyright (C) 2010 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(define-module (test-suite test-rnrs-enums) + :use-module ((rnrs conditions) :version (6)) + :use-module ((rnrs enums) :version (6)) + :use-module ((rnrs exceptions) :version (6)) + :use-module (test-suite lib)) + +(define-enumeration foo-enumeration (foo bar baz) make-foo-set) + +(with-test-prefix "enum-set-universe" + (pass-if "universe of an enumeration is itself" + (let ((et (make-enumeration '(a b c)))) + (eq? (enum-set-universe et) et))) + + (pass-if "enum-set-universe returns universe" + (let* ((et (make-enumeration '(a b c))) + (es ((enum-set-constructor et) '(a b)))) + (eq? (enum-set-universe es) et)))) + +(with-test-prefix "enum-set-indexer" + (pass-if "indexer returns index of symbol in universe" + (let* ((universe (make-enumeration '(a b c))) + (set ((enum-set-constructor universe) '(a c))) + (indexer (enum-set-indexer set))) + (and (eqv? (indexer 'a) 0) (eqv? (indexer 'c) 2)))) + + (pass-if "indexer returns index of symbol in universe but not set" + (let* ((universe (make-enumeration '(a b c))) + (set ((enum-set-constructor universe) '(a c))) + (indexer (enum-set-indexer set))) + (eqv? (indexer 'b) 1))) + + (pass-if "indexer returns #f for symbol not in universe" + (let* ((universe (make-enumeration '(a b c))) + (set ((enum-set-constructor universe) '(a b c))) + (indexer (enum-set-indexer set))) + (eqv? (indexer 'd) #f)))) + +(with-test-prefix "enum-set->list" + (pass-if "enum-set->list returns members in universe order" + (let* ((universe (make-enumeration '(a b c d e))) + (set ((enum-set-constructor universe) '(d a e c)))) + (equal? (enum-set->list set) '(a c d e))))) + +(with-test-prefix "enum-set-member?" + (pass-if "enum-set-member? is #t for set members" + (let* ((universe (make-enumeration '(a b c))) + (set ((enum-set-constructor universe) '(a b c)))) + (enum-set-member? 'a set))) + + (pass-if "enum-set-member? is #f for set non-members" + (let* ((universe (make-enumeration '(a b c))) + (set ((enum-set-constructor universe) '(a b c)))) + (not (enum-set-member? 'd set)))) + + (pass-if "enum-set-member? is #f for universe but not set members" + (let* ((universe (make-enumeration '(a b c d))) + (set ((enum-set-constructor universe) '(a b c)))) + (not (enum-set-member? 'd set))))) + +(with-test-prefix "enum-set-subset?" + (pass-if "enum-set-subset? is #t when set1 subset of set2" + (let* ((universe (make-enumeration '(a b c d e))) + (set1 ((enum-set-constructor universe) '(a b c))) + (set2 ((enum-set-constructor universe) '(a b c d)))) + (enum-set-subset? set1 set2))) + + (pass-if "enum-set-subset? is #t when universe and set are subsets" + (let* ((universe1 (make-enumeration '(a b c d))) + (universe2 (make-enumeration '(a b c d e))) + (set1 ((enum-set-constructor universe1) '(a b c))) + (set2 ((enum-set-constructor universe2) '(a b c d)))) + (enum-set-subset? set1 set2))) + + (pass-if "enum-set-subset? is #f when set not subset" + (let* ((universe (make-enumeration '(a b c d e))) + (set1 ((enum-set-constructor universe) '(a b c d))) + (set2 ((enum-set-constructor universe) '(a b c)))) + (not (enum-set-subset? set1 set2)))) + + (pass-if "enum-set-subset? is #f when universe not subset" + (let* ((universe1 (make-enumeration '(a b c d e))) + (universe2 (make-enumeration '(a b c d))) + (set1 ((enum-set-constructor universe1) '(a b c))) + (set2 ((enum-set-constructor universe2) '(a b c d)))) + (not (enum-set-subset? set1 set2))))) + +(with-test-prefix "enum-set=?" + (pass-if "enum-set=? is #t when sets are equal" + (let* ((universe1 (make-enumeration '(a b c))) + (universe2 (make-enumeration '(a b c))) + (set1 ((enum-set-constructor universe1) '(a b c))) + (set2 ((enum-set-constructor universe2) '(a b c)))) + (enum-set=? set1 set2))) + + (pass-if "enum-set=? is #f when sets are not equal" + (let* ((universe (make-enumeration '(a b c d))) + (set1 ((enum-set-constructor universe) '(a b))) + (set2 ((enum-set-constructor universe) '(c d)))) + (not (enum-set=? set1 set2)))) + + (pass-if "enum-set=? is #f when universes are not equal" + (let* ((universe1 (make-enumeration '(a b c d))) + (universe2 (make-enumeration '(a b c d e))) + (set1 ((enum-set-constructor universe1) '(a b c d))) + (set2 ((enum-set-constructor universe2) '(a b c d)))) + (not (enum-set=? set1 set2))))) + +(with-test-prefix "enum-set-union" + (pass-if "&assertion raised on different universes" + (guard (condition ((assertion-violation? condition) #t)) + (let* ((universe1 (make-enumeration '(a b c))) + (universe2 (make-enumeration '(d e f))) + (set1 ((enum-set-constructor universe1) '(a b c))) + (set2 ((enum-set-constructor universe2) '(d e f)))) + (enum-set-union set1 set2) + #f))) + + (pass-if "enum-set-union creates union on overlapping sets" + (let* ((universe (make-enumeration '(a b c d e))) + (set1 ((enum-set-constructor universe) '(a b c))) + (set2 ((enum-set-constructor universe) '(c d e))) + (union (enum-set-union set1 set2))) + (equal? (enum-set->list union) '(a b c d e)))) + + (pass-if "enum-set-union creates union on disjoint sets" + (let* ((universe (make-enumeration '(a b c d e f))) + (set1 ((enum-set-constructor universe) '(a b c))) + (set2 ((enum-set-constructor universe) '(d e f))) + (union (enum-set-union set1 set2))) + (equal? (enum-set->list union) '(a b c d e f))))) + +(with-test-prefix "enum-set-intersection" + (pass-if "&assertion raised on different universes" + (guard (condition ((assertion-violation? condition) #t)) + (let* ((universe1 (make-enumeration '(a b c))) + (universe2 (make-enumeration '(d e f))) + (set1 ((enum-set-constructor universe1) '(a b c))) + (set2 ((enum-set-constructor universe2) '(d e f)))) + (enum-set-intersection set1 set2) + #f))) + + (pass-if "enum-set-intersection on overlapping sets" + (let* ((universe (make-enumeration '(a b c d e))) + (set1 ((enum-set-constructor universe) '(a b c))) + (set2 ((enum-set-constructor universe) '(c d e))) + (intersection (enum-set-intersection set1 set2))) + (equal? (enum-set->list intersection) '(c)))) + + (pass-if "enum-set-intersection on disjoint sets" + (let* ((universe (make-enumeration '(a b c d e f))) + (set1 ((enum-set-constructor universe) '(a b c))) + (set2 ((enum-set-constructor universe) '(d e f))) + (intersection (enum-set-intersection set1 set2))) + (null? (enum-set->list intersection))))) + +(with-test-prefix "enum-set-difference" + (pass-if "&assertion raised on different universes" + (guard (condition ((assertion-violation? condition) #t)) + (let* ((universe1 (make-enumeration '(a b c))) + (universe2 (make-enumeration '(d e f))) + (set1 ((enum-set-constructor universe1) '(a b c))) + (set2 ((enum-set-constructor universe2) '(d e f)))) + (enum-set-difference set1 set2) + #f))) + + (pass-if "enum-set-difference with subset" + (let* ((universe (make-enumeration '(a b c))) + (set1 ((enum-set-constructor universe) '(a b c))) + (set2 ((enum-set-constructor universe) '(a))) + (difference (enum-set-difference set1 set2))) + (equal? (enum-set->list difference) '(b c)))) + + (pass-if "enum-set-difference with superset is empty" + (let* ((universe (make-enumeration '(a b c d))) + (set1 ((enum-set-constructor universe) '(a b c))) + (set2 ((enum-set-constructor universe) '(a b c d))) + (difference (enum-set-difference set1 set2))) + (null? (enum-set->list difference))))) + +(with-test-prefix "enum-set-complement" + (pass-if "complement of empty set is universe" + (let* ((universe (make-enumeration '(a b c))) + (set ((enum-set-constructor universe) '())) + (complement (enum-set-complement set))) + (equal? (enum-set->list complement) (enum-set->list universe)))) + + (pass-if "simple complement" + (let* ((universe (make-enumeration '(a b c d))) + (set ((enum-set-constructor universe) '(a c))) + (complement (enum-set-complement set))) + (equal? (enum-set->list complement) '(b d))))) + +(with-test-prefix "enum-set-projection" + (pass-if "projection onto subset universe" + (let* ((universe1 (make-enumeration '(a b c d))) + (universe2 (make-enumeration '(a b c))) + (set1 ((enum-set-constructor universe1) '(a d))) + (set2 ((enum-set-constructor universe2) '(b c))) + (projection (enum-set-projection set1 set2))) + (equal? (enum-set->list projection) '(a)))) + + (pass-if "projection onto superset universe" + (let* ((universe1 (make-enumeration '(a b c))) + (universe2 (make-enumeration '(a b c d))) + (set1 ((enum-set-constructor universe1) '(a c))) + (set2 ((enum-set-constructor universe2) '(b d))) + (projection (enum-set-projection set1 set2))) + (equal? (enum-set->list projection) '(a c)))) + + (pass-if "projection onto disjoint universe" + (let* ((universe1 (make-enumeration '(a b c))) + (universe2 (make-enumeration '(d e f))) + (set1 ((enum-set-constructor universe1) '(a c))) + (set2 ((enum-set-constructor universe2) '(d f))) + (projection (enum-set-projection set1 set2))) + (equal? (enum-set->list projection) '())))) + +(with-test-prefix "define-enumeration" + (pass-if "define-enumeration creates bindings" + (and (defined? 'foo-enumeration) (defined? 'make-foo-set))) + + (pass-if "type-name syntax raises &syntax on non-member" + (guard (condition ((syntax-violation? condition) #t)) + (begin (eval '(foo-enumeration a) (current-module)) #f))) + + (pass-if "type-name evaluates to quote on member" + (guard (condition ((syntax-violation? condition) #f)) + (eq? (eval '(foo-enumeration foo) (current-module)) 'foo))) + + (pass-if "constructor-syntax raises &syntax on non-members" + (guard (condition ((syntax-violation? condition) #t)) + (begin (eval '(make-foo-set foo bar not-baz) (current-module)) #f))) + + (pass-if "constructor-syntax evaluates to new set" + (guard (condition ((syntax-violation? condition) #f)) + (equal? (enum-set->list (eval '(make-foo-set foo bar) + (current-module))) + '(foo bar))))) |