reimplemented enums to use bitmaps instead of lists.

scheme/ikarus.compiler.ss

@@ -2337,7 +2337,7 @@
      (printf "    ~s\n" x)]))
 
 (define optimizer-output (make-parameter #f))
-(define perform-tag-analysis (make-parameter #f))
+(define perform-tag-analysis (make-parameter #t))
 
 (define (compile-core-expr->code p)
   (let* ([p (recordize p)]

scheme/ikarus.enumerations.ss

@@ -28,197 +28,177 @@
       enum-set-projection
       make-file-options))
 
-  (define-record-type enum
+  (define-record-type enum-type
-    (fields g univ values)
+    (fields id mask symbol->index-hashtable index->symbol-vector)
-    (opaque #f) (sealed #t)
+    (sealed #t)
+    (opaque #t)
     (nongenerative))
-  
-  (define (remove-dups ls)
-    (cond
-      [(null? ls) '()]
-      [else (cons (car ls) (remq (car ls) (cdr ls)))]))
 
+  (define-record-type enum-set
+    (fields type bits)
+    (sealed #t)
+    (nongenerative))
 
   (define (make-enumeration ls) 
     (unless (and (list? ls) (for-all symbol? ls))
       (die 'make-enumeration "not a list of symbols" ls))
-    (let ([u (remove-dups ls)])
+    (let ([h (make-eq-hashtable)] [v (list->vector ls)])
-      (make-enum (gensym) u u)))
+      (let f ([i 0] [n (vector-length v)])
+        (cond
+          [(= i n) 
+           (let ([mask (sub1 (sll 1 n))])
+             (let ([t (make-enum-type (gensym) mask h v)])
+               (make-enum-set t mask)))]
+          [else 
+           (hashtable-set! h (vector-ref v i) i)
+           (f (+ i 1) n)]))))
   
   (define (enum-set-universe x)
-    (unless (enum? x) 
+    (unless (enum-set? x) 
-      (die 'enum-set-universe "not an enumeration" x))
+      (die 'enum-set-universe "not an enum set" x))
-    (let ([u (enum-univ x)])
+    (make-enum-set (enum-set-type x) -1))
-      (make-enum (enum-g x) u u)))
   
   (define (enum-set-indexer x)
-    (unless (enum? x) 
+    (unless (enum-set? x) 
-      (die 'enum-set-indexer "not an enumeration" x))
+      (die 'enum-set-indexer "not an enum set" x))
-    (lambda (s)
+    (let ([h (enum-type-symbol->index-hashtable (enum-set-type x))])
-      (unless (symbol? s) 
+      (lambda (s)
-        (die 'enum-set-indexer "not a symbol" s))
+        (unless (symbol? s) 
-      (let f ([s s] [i 0] [ls (enum-univ x)])
+          (die 'enum-set-indexer "not a symbol" s))
-        (cond
+        (hashtable-ref h s #f))))
-          [(pair? ls) 
-           (if (eq? s (car ls)) 
-               i
-               (f s (+ i 1) (cdr ls)))]
-          [else #f]))))
   
   (define (enum-set-constructor x)
-    (unless (enum? x)
+    (unless (enum-set? x)
-      (die 'enum-set-constructor "not an enumeration" x))
+      (die 'enum-set-constructor "not an enum set" x))
-    (lambda (ls)
+    (let ([t (enum-set-type x)])
-      (unless (and (list? ls) (for-all symbol? ls))
+      (let ([h (enum-type-symbol->index-hashtable t)])
-        (die 'enum-set-constructor "not a list of symbols" ls))
+        (lambda (ls)
-      (for-each
+          (unless (list? ls) (die 'enum-set-constructor "not a list" ls))
-        (lambda (s)
+          (let f ([ls ls] [n 0])
-          (unless (memq s (enum-univ x))
+            (cond
-            (die 'enum-set-constructor "not in the universe" s x)))
+              [(null? ls) (make-enum-set t n)]
-        ls)
+              [else
-      (let ([idx (enum-set-indexer x)])
+               (f (cdr ls) 
-        (make-enum (enum-g x) (enum-univ x)
+                  (bitwise-ior n
-          (map car
+                    (sll 1
-            (list-sort (lambda (a b) (< (cdr a) (cdr b)))
+                      (or (hashtable-ref h (car ls) #f)
-              (map (lambda (x) (cons x (idx x)))
+                          (die 'enum-set-constructor 
-                   ls)))))))
+                               "not in universe" 
-    
+                               (car ls) t)))))]))))))
+   
   (define (enum-set->list x)
-    (unless (enum? x) 
+    (unless (enum-set? x) 
-      (die 'enum-set->list "not an enumeration" x))
+      (die 'enum-set->list "not an enum set" x))
-    (let ([idx (enum-set-indexer x)]
+    (let ([v (enum-type-index->symbol-vector (enum-set-type x))])
-          [ls (enum-values x)])
+      (let ([n (vector-length v)])
-      (map car
+        (let f ([bits (enum-set-bits x)] [i 0])
-        (list-sort (lambda (a b) (< (cdr a) (cdr b)))
+          (if (eqv? bits 0)
-          (map (lambda (x) (cons x (idx x)))
+              '()
-               ls)))))
+              (if (even? bits)
-  
+                  (f (sra bits 1) (+ i 1))
+                  (cons (vector-ref v i)
+                    (f (sra bits 1) (+ i 1)))))))))
+
+
+  (define (enum-set-andmap proc x)
+    (let ([v (enum-type-index->symbol-vector (enum-set-type x))])
+      (let ([n (vector-length v)])
+        (let f ([bits (enum-set-bits x)] [i 0])
+          (if (= bits 0)
+              #t
+              (if (even? bits)
+                  (f (sra bits 1) (+ i 1))
+                  (and (proc (vector-ref v i))
+                       (f (sra bits 1) (+ i 1)))))))))
+
   (define (enum-set-member? s x) 
-    (if (enum? x)
+    (unless (enum-set? x) 
-        (if (memq s (enum-values x))
+      (die 'enum-set-member? "not an enum set" x))
-            #t
+    (let ([h (enum-type-symbol->index-hashtable (enum-set-type x))])
-            (if (symbol? s) 
+      (let ([idx (hashtable-ref h s #f)])
-                #f 
+        (cond
-                (die 'enum-set-member? "not a symbol" s)))
+          [idx (bitwise-bit-set? (enum-set-bits x) idx)]
-        (die 'enum-set-member? "not an enumeration" x)))
+          [(symbol? s) #f]
+          [else (die 'enum-set-member? "not a symbol" s)]))))
   
   (define (enum-set-subset? x1 x2) 
-    (define (subset? s1 s2) 
+    (unless (enum-set? x1) 
-      (or (null? s1) 
+      (die 'enum-set-subset? "not an enum set" x1))
-          (and (memq (car s1) s2)
+    (unless (enum-set? x2) 
-               (subset? (cdr s1) s2))))
+      (die 'enum-set-subset? "not an enum set" x2))
-    (if (enum? x1) 
+    (let ([t1 (enum-set-type x1)] [t2 (enum-set-type x2)])
-        (if (enum? x2) 
+      (if (or (eq? t1 t2) (eq? (enum-type-id t1) (enum-type-id t2)))
-            (and (subset? (enum-values x1) (enum-values x2))
+          (let ([b1 (enum-set-bits x1)] [b2 (enum-set-bits x2)])
-                 (or (eq? (enum-g x1) (enum-g x2))
+            (= (bitwise-and b1 b2) b1))
-                     (subset? (enum-univ x1) (enum-univ x2))))
+          (and (enum-set-andmap (lambda (s) (enum-set-member? s x2)) x1)
-            (die 'enum-set-subset? "not an enumeration" x2))
+               (let ([u2 (enum-set-universe x2)])
-        (die 'enum-set-subset? "not an enumeration" x1)))
+                 (enum-set-andmap (lambda (s) (enum-set-member? s u2))
+                   (enum-set-universe x1)))))))
   
+
   (define (enum-set=? x1 x2) 
-    (define (subset? s1 s2) 
+    (unless (enum-set? x1) 
-      (or (null? s1) 
+      (die 'enum-set=? "not an enum set" x1))
-          (and (memq (car s1) s2)
+    (unless (enum-set? x2) 
-               (subset? (cdr s1) s2))))
+      (die 'enum-set=? "not an enum set" x2))
-    (if (enum? x1) 
+    (let ([t1 (enum-set-type x1)] [t2 (enum-set-type x2)])
-        (if (enum? x2) 
+      (if (or (eq? t1 t2) (eq? (enum-type-id t1) (enum-type-id t2)))
-            (and (subset? (enum-values x1) (enum-values x2))
+          (= (enum-set-bits x1) (enum-set-bits x2))
-                 (subset? (enum-values x2) (enum-values x1))
+          (and (enum-set-andmap (lambda (s) (enum-set-member? s x2)) x1)
-                 (or (eq? (enum-g x1) (enum-g x2))
+               (enum-set-andmap (lambda (s) (enum-set-member? s x1)) x2)
-                     (and (subset? (enum-univ x1) (enum-univ x2))
+               (let ([u1 (enum-set-universe x1)] [u2 (enum-set-universe x2)])
-                          (subset? (enum-univ x2) (enum-univ x1)))))
+                 (and 
-            (die 'enum-set=? "not an enumeration" x2))
+                   (enum-set-andmap (lambda (s) (enum-set-member? s u2)) u1)
-        (die 'enum-set=? "not an enumeration" x1)))
+                   (enum-set-andmap (lambda (s) (enum-set-member? s u1)) u2)))))))
   
   (define (enum-set-op x1 x2 who combine)
-    (if (enum? x1) 
+    (unless (enum-set? x1) 
-        (if (enum? x2) 
+      (die who "not an enum set" x1))
-            (let ([g (enum-g x1)] [u (enum-univ x1)])
+    (unless (enum-set? x2) 
-              (if (eq? g (enum-g x2))
+      (die who "not an enum set" x2))
-                  (make-enum g u (combine u (enum-values x1) (enum-values x2)))
+    (let ([t1 (enum-set-type x1)] [t2 (enum-set-type x2)])
-                  (die who 
+      (if (or (eq? t1 t2) (eq? (enum-type-id t1) (enum-type-id t2)))
-                    "enum sets have different enumeration types" x1 x2)))
+          (make-enum-set t1 (combine (enum-set-bits x1) (enum-set-bits x2)))
-            (die who "not an enumeration" x2))
+          (die who "enum sets have different enumeration types" x1 x2))))
-        (die who "not an enumeration" x1)))
   
   (define (enum-set-union x1 x2)
-    (define (union u s1 s2) 
+    (enum-set-op x1 x2 'enum-set-union bitwise-ior))
-      (if (pair? s1) 
-          (if (pair? s2) 
-              (let ([x (car u)])
-                (if (eq? x (car s1))
-                    (cons x 
-                      (union (cdr u) (cdr s1) 
-                        (if (eq? x (car s2)) (cdr s2) s2)))
-                    (if (eq? x (car s2)) 
-                        (cons x (union (cdr u) s1 (cdr s2)))
-                        (union (cdr u) s1 s2))))
-              s1)
-          s2))
-    (enum-set-op x1 x2 'enum-set-union union))
   
   (define (enum-set-intersection x1 x2)
-    (define (intersection u s1 s2) 
+    (enum-set-op x1 x2 'enum-set-intersection bitwise-and))
-      (if (pair? s1) 
-          (if (pair? s2) 
-              (let ([x (car u)])
-                (if (eq? x (car s1))
-                    (if (eq? x (car s2)) 
-                        (cons x (intersection (cdr u) (cdr s1) (cdr s2)))
-                        (intersection (cdr u) (cdr s1) s2))
-                    (intersection (cdr u) s1
-                      (if (eq? x (car s2)) (cdr s2) s2))))
-              '())
-          '()))
-    (enum-set-op x1 x2 'enum-set-intersection intersection))
   
   (define (enum-set-difference x1 x2)
-    (define (difference u s1 s2) 
+    (enum-set-op x1 x2 'enum-set-difference 
-      (if (pair? s1) 
+      (lambda (n1 n2) (bitwise-and n1 (bitwise-not n2)))))
-          (if (pair? s2)
-              (let ([x (car u)])
-                (if (eq? x (car s1))
-                    (if (eq? x (car s2)) 
-                        (difference (cdr u) (cdr s1) (cdr s2))
-                        (cons x (difference (cdr u) (cdr s1) s2)))
-                    (difference (cdr u) s1
-                      (if (eq? x (car s2)) (cdr s2) s2))))
-              s1)
-          '()))
-    (enum-set-op x1 x2 'enum-set-difference difference))
   
   (define (enum-set-complement x)
-    (define (complement u s) 
+    (define who 'enum-set-complement)
-      (if (pair? s) 
+    (unless (enum-set? x) 
-          (let ([x (car u)])
+      (die who "not an enum set" x))
-            (if (eq? x (car s)) 
+    (let ([t (enum-set-type x)])
-                (complement (cdr u) (cdr s))
+      (make-enum-set t
-                (cons x (complement (cdr u) s))))
+        (bitwise-and 
-          u))
+          (enum-type-mask t)
-    (if (enum? x) 
+          (bitwise-not (enum-set-bits x))))))
-        (let ([g (enum-g x)] [u (enum-univ x)])
-           (make-enum g u (complement u (enum-values x))))
-        (die 'enum-set-complement "not an enumeration" x)))
   
   (define (enum-set-projection x1 x2)
-    (define (combine u s) 
+    (define who 'enum-set-projection)
-      (if (pair? u)
+    (unless (enum-set? x1) (die who "not an enum set" x1))
-          (let ([x (car u)])
+    (unless (enum-set? x2) (die who "not an enum set" x2))
-            (if (memq x s) 
+    (let ([t1 (enum-set-type x1)] [t2 (enum-set-type x2)])
-                (cons x (combine (cdr u) s))
+      (let ([h (enum-type-symbol->index-hashtable t2)]
-                (combine (cdr u) s)))
+            [v (enum-type-index->symbol-vector t1)])
-          '()))
+        (let f ([in-bits (enum-set-bits x1)] [i 0] [out-bits 0])
-    (if (enum? x1)
+          (if (= in-bits 0)
-        (if (enum? x2) 
+              (make-enum-set t2 out-bits)
-            (let ([g (enum-g x2)])
+              (if (even? in-bits)
-              (if (eq? g (enum-g x1))
+                  (f (sra in-bits 1) (+ i 1) out-bits)
-                  x1
+                  (let ([idx (hashtable-ref h (vector-ref v i) #f)])
-                  (let ([u (enum-univ x2)] [s (enum-values x1)])
+                    (if idx
-                    (if (null? s) 
+                        (f (sra in-bits 1) (+ i 1) 
-                        (make-enum g u '())
+                           (bitwise-ior out-bits (sll 1 idx)))
-                        (make-enum g u (combine u s))))))
+                        (f (sra in-bits 1) (+ i 1)
-            (die 'enum-set-projection "not an enumeration" x2))
+                           out-bits)))))))))
-        (die 'enum-set-projection "not an enumeration" x1)))
 
   (define make-file-options
     (enum-set-constructor
@@ -227,74 +207,3 @@
 
 )
 
-#!eof
-
-(define (trace-equal? x y) (equal? x y))
-
-(assert 
-  (trace-equal? 
-    (let* ([e (make-enumeration '(red green blue))]
-           [i (enum-set-indexer e)])
-      (list (i 'red) (i 'green) (i 'blue) (i 'yellow)))
-    '(0 1 2 #f)))
-
-(assert 
-  (trace-equal? 
-    (let* ([e (make-enumeration '(red green blue))]
-           [c (enum-set-constructor e)])
-      (enum-set->list (c '(blue red))))
-    '(red blue)))
-
-(assert 
-  (trace-equal? 
-    (let* ([e (make-enumeration '(red green blue))]
-           [c (enum-set-constructor e)])
-      (list 
-        (enum-set-member? 'blue (c '(red blue)))
-        (enum-set-member? 'green (c '(red blue)))
-        (enum-set-subset? (c '(red blue)) e)
-        (enum-set-subset? (c '(red blue)) (c '(blue red)))
-        (enum-set-subset? (c '(red blue)) (c '(red)))
-        (enum-set=? (c '(red blue)) (c '(blue red)))))
-    '(#t #f #t #t #f #t)))
-
-(assert 
-  (trace-equal? 
-    (let* ([e (make-enumeration '(red green blue))]
-           [c (enum-set-constructor e)])
-      (list 
-        (enum-set->list (enum-set-union (c '(blue)) (c '(red))))
-        (enum-set->list (enum-set-intersection (c '(red green)) (c '(red blue))))
-        (enum-set->list (enum-set-difference (c '(red green)) (c '(red blue))))
-        (enum-set->list (enum-set-complement (c '(red))))))
-    '((red blue) (red) (green) (green blue))))
-
-(assert 
-  (trace-equal? 
-    (let* ([e1 (make-enumeration '(red green blue black))]
-           [e2 (make-enumeration '(red black white))])
-      (enum-set->list (enum-set-projection e1 e2)))
-    '(red black)))
-
-
-#!eof
-(define-condition-type &c &condition
-  make-c c?
-  (x c-x))
-
-(pretty-print (make-c 'hello))
-(assert (c? (make-c 'hello)))
-(assert (condition? (make-c 'hello)))
-
-(pretty-print (record-type-descriptor &no-nans))
-
-(assert (no-nans-violation? (make-no-nans-violation)))
-
-(pretty-print 
-  (condition
-    (condition
-      ((record-constructor (record-constructor-descriptor &message))
-       "Hello")
-      (condition)
-      (condition (make-message-condition "hi"))
-      (make-message-condition "there"))))

scheme/last-revision

@@ -1 +1 @@
-1566
+1567

scheme/run-tests.ss

@@ -17,6 +17,7 @@
 
 
 (import (ikarus)
+        (tests enums)
         (tests bitwise-op)
         (tests reader)
         (tests lists)
@@ -82,4 +83,5 @@
 (test-sorting)
 (test-fasl)
 (test-numerics)
+(test-enums)
 (printf "Happy Happy Joy Joy\n")

scheme/tests/enums.ss

@@ -0,0 +1,68 @@
+;;; Ikarus Scheme -- A compiler for R6RS Scheme.
+;;; Copyright (C) 2006,2007  Abdulaziz Ghuloum
+;;; 
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License version 3 as
+;;; published by the Free Software Foundation.
+;;; 
+;;; This program 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
+;;; General Public License for more details.
+;;; 
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+
+(library (tests enums)
+  (export test-enums)
+  (import (ikarus))
+    
+  (define (test-enums)
+    (define (trace-equal? x y) (equal? x y))
+    (assert 
+      (trace-equal? 
+        (let* ([e (make-enumeration '(red green blue))]
+               [i (enum-set-indexer e)])
+          (list (i 'red) (i 'green) (i 'blue) (i 'yellow)))
+        '(0 1 2 #f)))
+    (assert 
+      (trace-equal? 
+        (let* ([e (make-enumeration '(red green blue))]
+               [c (enum-set-constructor e)])
+          (enum-set->list (c '())))
+        '()))
+    (assert 
+      (trace-equal? 
+        (let* ([e (make-enumeration '(red green blue))]
+               [c (enum-set-constructor e)])
+          (enum-set->list (c '(blue red))))
+        '(red blue)))
+    (assert 
+      (trace-equal? 
+        (let* ([e (make-enumeration '(red green blue))]
+               [c (enum-set-constructor e)])
+          (list 
+            (enum-set-member? 'blue (c '(red blue)))
+            (enum-set-member? 'green (c '(red blue)))
+            (enum-set-subset? (c '(red blue)) e)
+            (enum-set-subset? (c '(red blue)) (c '(blue red)))
+            (enum-set-subset? (c '(red blue)) (c '(red)))
+            (enum-set=? (c '(red blue)) (c '(blue red)))))
+        '(#t #f #t #t #f #t)))
+    (assert 
+      (trace-equal? 
+        (let* ([e (make-enumeration '(red green blue))]
+               [c (enum-set-constructor e)])
+          (list 
+            (enum-set->list (enum-set-union (c '(blue)) (c '(red))))
+            (enum-set->list (enum-set-intersection (c '(red green)) (c '(red blue))))
+            (enum-set->list (enum-set-difference (c '(red green)) (c '(red blue))))
+            (enum-set->list (enum-set-complement (c '(red))))))
+        '((red blue) (red) (green) (green blue))))
+    (assert 
+      (trace-equal? 
+        (let* ([e1 (make-enumeration '(red green blue black))]
+               [e2 (make-enumeration '(red black white))])
+          (enum-set->list (enum-set-projection e1 e2)))
+        '(red black)))))