299 lines
12 KiB
Scheme
299 lines
12 KiB
Scheme
|
;;; 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))))
|
||
|
|
)
|