/usr/share/scheme48-1.9/r6rs/enum.scm is in scheme48 1.9-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 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 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Mike Sperber
; The (rnrs enums (6)) library.
(define (make-enum-type members)
(let* ((table (make-constant-table
(map cons members (iota (length members)))
symbol-hash))
(find-index
(lambda (symbol)
(constant-table-lookup table symbol))))
(big:make-enum-set-type 'r6rs-enum
(lambda (symbol)
(and (find-index symbol) #t))
(list->vector members)
find-index)))
(define (iota n)
(let loop ((n n) (r '()))
(if (zero? n)
r
(loop (- n 1)
(cons (- n 1) r)))))
(define (make-enum-set type symbols)
(big:elements->enum-set type symbols))
(define (enum-type->enum-set et)
(big:enum-set-negation
(big:elements->enum-set et '())))
(define (make-enumeration symbols)
(enum-type->enum-set (make-enum-type symbols)))
(define (enum-set-universe es)
(enum-type->enum-set (big:enum-set-type es)))
(define (enum-set-indexer es)
(lambda (symbol)
(big:enum-set-type-element-index (big:enum-set-type es) symbol)))
(define (enum-set-constructor es)
(let ((et (big:enum-set-type es)))
(lambda (symbols)
(make-enum-set et symbols))))
(define enum-set->list big:enum-set->list)
(define (enum-set-member? symbol es)
(big:enum-set-member? es symbol))
(define (enum-set-subset? es1 es2)
(if (eq? (big:enum-set-type es1)
(big:enum-set-type es2))
(big:enum-set-subset? es1 es2)
;; slow case
(every? (lambda (member)
(enum-set-member? member es2))
(enum-set->list es1))))
(define (enum-set=? es1 es2)
(if (eq? (big:enum-set-type es1)
(big:enum-set-type es2))
(big:enum-set=? es1 es2)
;; slow case
(and (enum-set-subset? es1 es2)
(enum-set-subset? es2 es1))))
(define enum-set-union big:enum-set-union)
(define enum-set-intersection big:enum-set-intersection)
(define enum-set-difference big:enum-set-difference)
(define enum-set-complement big:enum-set-negation)
(define (enum-set-projection es1 es2)
(if (eq? (big:enum-set-type es1)
(big:enum-set-type es2))
es1
(let ((et2 (big:enum-set-type es2)))
(big:elements->enum-set et2
(filter (lambda (element)
(and (big:enum-set-type-member? et2 element)
(enum-set-member? element es2)))
(enum-set->list es1))))))
(define-syntax define-type-name-keyword
(lambda (form0 rename0 compare0)
(let ((%define-syntax (rename0 'define-syntax))
(%lambda (rename0 'lambda))
(%desyntaxify (rename0 'desyntaxify))
(%code-quote (rename0 'code-quote))
(%quote (rename0 'quote)))
`(,%define-syntax ,(cadr form0)
(,%lambda (form rename compare)
(let ((id (,%desyntaxify (cadr form))))
(let loop ((members ',(cddr form0)))
(cond
((null? members) form)
((eq? (car members) id) (list (,%code-quote ,%quote) id))
(else (loop (cdr members)))))))))))
(define-syntax define-enumeration
(syntax-rules ()
((define-enumeration ?type-name
(?member ...)
?constructor)
(begin
(define-type-name-keyword ?type-name ?member ...)
(define type (make-enum-type '(?member ...)))
(define (make elements)
(big:elements->enum-set type elements))
(big:define-enum-set-maker ?constructor make ?type-name)))))
|