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 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298
|
;;; enum.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;; NOTES:
;; This implementation assume the universe is small
;; and the algorithms used by this implementation may be
;; up to linear in the universe
;;
;; This code is a good candidate for partial-static-structure optimization
;; Right now the define-enumeration macro is doing optimizations
;; that could be automatically performed by PSS if PSS worked on enums
;;
;; The R6RS standard is unclear whether the function returned by enum-set-indexer
;; should throw an error if its argument is not a symbol. We have chosen to
;; not include that check, but if the standard is updated, this may need to be changed.
(let ()
;;;;;;;;
#| Low-level enum-set definition and operations
The structure is as follows:
-------------------------------------------------------------------------------
The following records are created once:
enum-base-rtd:
+-----------------+--------------------+--------------------------------+-----+
| rtd:#!base-rtd | parent:#!base-rtd | fields:(index->sym sym->index) | ... |
+-----------------+--------------------+--------------------------------+-----+
enum-parent-rtd:
+-----------------+--------------------+--------------------------------+-----+
| rtd:#!base-rtd | parent: #f | fields:(members) | ... |
+-----------------+--------------------+--------------------------------+-----+
-------------------------------------------------------------------------------
The following record is created per enum-type and it stored the mappings
between symbols and their corresponding bits in the bit mask:
this-enum-rtd:
+-------------------+------------------------+-----------+-----
| rtd:enum-base-rtd | parent:enum-parent-rtd | fields:() | ...
+-------------------+------------------------+-----------+-----
----+------------+------------+
...| index->sym | sym->index |
----+------------+------------+
-------------------------------------------------------------------------------
The following record is created per enum-set:
an-enum-set:
+-------------------+--------------------------------+
| rtd:this-enum-rtd | members: 17 (integer bit mask) |
+-------------------+--------------------------------+
|#
(define enum-base-rtd
(make-record-type ; not sealed, not opaque
#!base-rtd ; undocumented #!base-rtd
'#{enum b9s78zmm79qs7j22-a} ; make enum-base-rtd type nongenerative
'((immutable sym->index) ; static (per enumeration type) fields
(immutable index->sym))))
(define enum-parent-rtd ; not sealed, not opaque, nongenerative
(make-record-type
'#{enum-parent dwwi4y1kribh7mif58yoxe-0}
'((immutable members))))
(define get-sym->index (csv7:record-field-accessor enum-base-rtd 'sym->index))
(define get-index->sym (csv7:record-field-accessor enum-base-rtd 'index->sym))
(define get-members (csv7:record-field-accessor enum-parent-rtd 'members))
(define members-universe -1) ;; All bits set
;;;;;;;;
;; Make a new enum-set using the rtd and the new set of members
(define (make-enum-set enum-set-rtd members)
#;((record-constructor enum-set-rtd) members)
; breaking the abstraction to avoid significant efficiency hit
($record enum-set-rtd members))
;; Perform type check for enum-set and return its RTD
(define (enum-set-rtd who enum-set)
(or (and (record? enum-set)
(let ([rtd (record-rtd enum-set)])
(and (eq? (record-rtd rtd) enum-base-rtd)
rtd)))
($oops who "~s is not an enumeration" enum-set)))
(define (assert-symbol-list who symbol-list)
(unless (and (list? symbol-list)
(for-all symbol? symbol-list))
($oops who "~s is not a list of symbols" symbol-list)))
(define (assert-symbol who symbol)
(unless (symbol? symbol)
($oops who "~s is not a symbol" symbol)))
(define rtd&list->enum-set
(lambda (who rtd symbol-list)
(let ([sym->index (get-sym->index rtd)])
(let loop ([members 0]
[symbol-list symbol-list])
(if (null? symbol-list)
(make-enum-set rtd members)
(let ([index (symbol-hashtable-ref sym->index (car symbol-list) #f)])
(if (not index)
(if who
($oops who "universe does not include specified symbol ~s"
(car symbol-list))
(loop members (cdr symbol-list)))
(loop (logbit1 index members) (cdr symbol-list)))))))))
(define $enum-set->list
(lambda (who enum-set)
(let ([rtd (enum-set-rtd who enum-set)])
(let ([index->sym (get-index->sym rtd)]
[members (get-members enum-set)])
(let loop ([i (fx1- (vector-length index->sym))]
[lst '()])
(if (fx< i 0)
lst
(loop (fx1- i)
(if (logbit? i members)
(cons (vector-ref index->sym i) lst)
lst))))))))
(record-writer enum-parent-rtd (lambda (x p wr) (display "#<enum-set>" p)))
;;;;;;;;
;; Constructor
(let ()
;; Takes lst and assigns indexes to each element of lst
;; lst :: symbol-list
;; index :: fixnum
;; symbol->index :: hashtable from symbols to fixnum
;; rev-lst :: symbol-list (stored in reverse order)
;;
;; Result :: (values fixnum (vector of symbols))
(define (make-symbol->index lst index symbol->index rev-lst)
(cond
[(null? lst)
(let ([index->symbol (make-vector index)])
(let loop ([i (fx1- index)]
[rev-lst rev-lst])
(unless (null? rev-lst) ;; or (< i 0)
(vector-set! index->symbol i (car rev-lst))
(loop (fx1- i) (cdr rev-lst))))
(values index index->symbol))]
[(symbol-hashtable-contains? symbol->index (car lst))
(make-symbol->index (cdr lst) index symbol->index rev-lst)]
[else
(symbol-hashtable-set! symbol->index (car lst) index)
(make-symbol->index (cdr lst) (fx1+ index) symbol->index (cons (car lst) rev-lst))]))
(set! make-enumeration
(lambda (symbol-list)
(assert-symbol-list 'make-enumeration symbol-list)
(let ([sym->index (make-hashtable symbol-hash eq?)])
(let-values ([(index index->sym) (make-symbol->index symbol-list 0 sym->index '())])
(let ([this-enum-rtd
($make-record-type
enum-base-rtd enum-parent-rtd "enum-type"
'() ; no fields to add
#t ; sealed
#f ; not opaque
sym->index
index->sym)])
(make-enum-set this-enum-rtd members-universe)))))))
;;;;;;;;;
;; Misc functions
(set! $enum-set-members get-members)
(set! enum-set-universe
(lambda (enum-set)
(make-enum-set (enum-set-rtd 'enum-set-universe enum-set) -1)))
(set! enum-set-indexer
(lambda (enum-set)
(let ([sym->index (get-sym->index (enum-set-rtd 'enum-set-indexer enum-set))])
(lambda (x)
(assert-symbol 'enum-set-indexer x)
(symbol-hashtable-ref sym->index x #f)))))
(set! enum-set-constructor
(lambda (enum-set)
(let ([rtd (enum-set-rtd 'enum-set-constructor enum-set)])
(lambda (symbol-list)
(assert-symbol-list 'enum-set-constructor symbol-list)
(rtd&list->enum-set 'enum-set-constructor rtd symbol-list)))))
(set! enum-set->list
(lambda (enum-set)
($enum-set->list 'enum-set->list enum-set)))
;;;;;;;;;
;; Predicates
(set! enum-set?
(lambda (enum-set)
(and (record? enum-set)
(let ([rtd (record-rtd enum-set)])
(eq? (record-rtd rtd) enum-base-rtd)))))
(let ()
(define (enum-set-subset-aux? enum-set1 enum-set2 rtd1 rtd2)
(let ([index->sym1 (get-index->sym rtd1)]
[members1 (get-members enum-set1)]
[sym->index2 (get-sym->index rtd2)]
[members2 (get-members enum-set2)])
(let loop ([index1 0])
(or (fx= index1 (vector-length index->sym1))
(let ([index2 (symbol-hashtable-ref
sym->index2
(vector-ref index->sym1 index1) #f)])
(and index2
(or (not (logbit? index1 members1))
(logbit? index2 members2))
(loop (fx1+ index1))))))))
(set! enum-set-member?
(lambda (symbol enum-set)
(assert-symbol 'enum-set-member? symbol)
(let ([sym->index (get-sym->index
(enum-set-rtd 'enum-set-member? enum-set))])
(let ([index (symbol-hashtable-ref sym->index symbol #f)])
(and index
(logbit? index (get-members enum-set)))))))
(set! enum-set-subset?
(lambda (enum-set1 enum-set2)
(let ([rtd1 (enum-set-rtd 'enum-set-subset? enum-set1)]
[rtd2 (enum-set-rtd 'enum-set-subset? enum-set2)])
(if (eq? rtd1 rtd2)
(let ([members2 (get-members enum-set2)])
(= members2 (logor (get-members enum-set1) members2)))
(enum-set-subset-aux? enum-set1 enum-set2 rtd1 rtd2)))))
(set! enum-set=?
(lambda (enum-set1 enum-set2)
(let ([rtd1 (enum-set-rtd 'enum-set=? enum-set1)]
[rtd2 (enum-set-rtd 'enum-set=? enum-set2)])
(if (eq? rtd1 rtd2)
(= (get-members enum-set1) (get-members enum-set2))
(and (enum-set-subset-aux? enum-set1 enum-set2 rtd1 rtd2)
(enum-set-subset-aux? enum-set2 enum-set1 rtd2 rtd1))))))
)
;;;;;;;;
;; Set-like functions
(let ()
(define-syntax enum-bin-op
(syntax-rules ()
[(_ name (members1 members2) members-expr)
(set! name
(lambda (enum-set1 enum-set2)
(let ([rtd1 (enum-set-rtd 'name enum-set1)]
[rtd2 (enum-set-rtd 'name enum-set2)])
(unless (eq? rtd1 rtd2)
($oops 'name "~s and ~s have different enumeration types"
enum-set1 enum-set2))
(make-enum-set rtd1 (let ([members1 (get-members enum-set1)]
[members2 (get-members enum-set2)])
members-expr)))))]))
(enum-bin-op enum-set-union (members1 members2) (logor members1 members2))
(enum-bin-op enum-set-intersection (members1 members2) (logand members1 members2))
(enum-bin-op enum-set-difference (members1 members2) (logand members1 (lognot members2)))
)
;;;;;;;;
;; Other functions
(set! enum-set-complement
(lambda (enum-set)
(let ([rtd (enum-set-rtd 'enum-set-complement enum-set)])
(make-enum-set rtd (lognot (get-members enum-set))))))
(set! enum-set-projection
(lambda (enum-set1 enum-set2)
(rtd&list->enum-set #f
(enum-set-rtd 'enum-set-projection enum-set2)
($enum-set->list 'enum-set-projection enum-set1))))
)
|