From sburson at common-lisp.net Mon Nov 3 05:08:58 2008 From: sburson at common-lisp.net (Scott L. Burson) Date: Mon, 03 Nov 2008 05:08:58 +0000 Subject: [fset-cvs] r20 - trunk/Code Message-ID: Author: sburson Date: Mon Nov 3 05:08:58 2008 New Revision: 20 Log: Some final tweaks for the 1.2 release. Modified: trunk/Code/fset.lisp trunk/Code/interval.lisp trunk/Code/port.lisp trunk/Code/relations.lisp trunk/Code/tuples.lisp trunk/Code/wb-trees.lisp Modified: trunk/Code/fset.lisp ============================================================================== --- trunk/Code/fset.lisp (original) +++ trunk/Code/fset.lisp Mon Nov 3 05:08:58 2008 @@ -1847,7 +1847,6 @@ (map-default m))) (defmethod domain ((m wb-map)) - ;; &&& Cache this? It's pretty fast anyway. (make-wb-set (WB-Map-Tree-Domain (wb-map-contents m)))) (defmethod compare ((map1 wb-map) (map2 wb-map)) Modified: trunk/Code/interval.lisp ============================================================================== --- trunk/Code/interval.lisp (original) +++ trunk/Code/interval.lisp Mon Nov 3 05:08:58 2008 @@ -390,11 +390,12 @@ ;;; for this). Adam Megacz calls it a "topological bag", but that doesn't seem ;;; right to me (it's certainly not a bag in the sense in which I use the word). +#|| Someday (defstruct (interval-set-relation (:constructor make-interval-set-relation (contents)) (:predicate interval-set-relation?) (:print-function print-interval-set-relation) (:copier nil)) contents) - +||# Modified: trunk/Code/port.lisp ============================================================================== --- trunk/Code/port.lisp (original) +++ trunk/Code/port.lisp Mon Nov 3 05:08:58 2008 @@ -28,39 +28,42 @@ (defmacro write-memory-barrier () 'nil)) -#+(and allegro os-threads) +#+(and allegro os-threads) ; &&& untested (progn - (defun make-lock (&optional (name "A lock")) - (mp:make-process-lock :name name)) + (defun make-lock (&optional name) + (apply #'mp:make-process-lock (and name `(:name ,name)))) (defmacro with-lock ((lock &key (wait? t)) &body body) - ;; See the OpenMCL code below for a suggestion of how to implement non-waiting - ;; mode (Allegro doesn't have it built in). - (error "&&& Write me")) - (defvar *Allegro-Read-Memory-Barrier-Lock* - (mp:make-process-lock :name "Read Memory Barrier Lock")) - (defmacro read-memory-barrier () - ;; Allegro doesn't seem to have any better way to do this. - (mp:with-process-lock (*Allegro-Read-Memory-Barrier-Lock*) - nil)) - (defvar *Allegro-Write-Memory-Barrier-Lock* - (mp:make-process-lock :name "Write Memory Barrier Lock")) + `(mp:with-process-lock (,lock :timeout (if ,wait? nil 0)) + . ,body)) + ;; For those implementations that support SMP but don't give us direct ways + ;; to generate memory barriers, we assume that grabbing a lock suffices. + (deflex *Memory-Barrier-Lock* + (mp:make-process-lock :name "Memory Barrier Lock")) + (defmacro read-memory-barrier () + '(mp:with-process-lock (*Memory-Barrier-Lock*) + nil)) (defmacro write-memory-barrier () - ;; Allegro doesn't seem to have any better way to do this. - (mp:with-process-lock (*Allegro-Write-Memory-Barrier-Lock*) - nil))) + '(mp:with-process-lock (*Memory-Barrier-Lock*) + nil))) + #+lispworks (progn (defun make-lock (&optional name) - (declare (ignore name)) - nil) + (apply #'mp:make-lock (and name `(:name ,name)))) (defmacro with-lock ((lock &key (wait? t)) &body body) - (declare (ignore lock wait?)) - `(mp:without-interrupts . ,body)) + `(mp:with-lock (,lock :timeout (if ,wait? nil 0)) + . ,body)) + ;; For those implementations that support SMP but don't give us direct ways + ;; to generate memory barriers, we assume that grabbing a lock suffices. + (deflex *Memory-Barrier-Lock* + (mp:make-lock :name "Memory Barrier Lock")) (defmacro read-memory-barrier () - 'nil) + '(mp:with-lock (*Memory-Barrier-Lock*) + nil)) (defmacro write-memory-barrier () - 'nil)) + '(mp:with-lock (*Memory-Barrier-Lock*) + nil))) #+cmu @@ -76,33 +79,38 @@ (defmacro write-memory-barrier () 'nil)) -#+sbcl + +#+(and sbcl (not sb-thread)) (progn (defun make-lock (&optional name) - (sb-thread:make-mutex :name name)) + nil) (defmacro with-lock ((lock &key (wait? t)) &body body) - `(sb-thread:with-mutex (,lock :wait-p ,wait?) + (declare (ignore lock wait?)) + `(progn . ,body)) - #-sb-thread (progn (defmacro read-memory-barrier () - nil) + 'nil) (defmacro write-memory-barrier () - nil)) - #+sb-thread - (progn - (defvar *SBCL-Read-Memory-Barrier-Lock* - (sb-thread:make-mutex :name "Read Memory Barrier Lock")) - (defmacro read-memory-barrier () - ;; SBCL doesn't seem to have any better way to do this (yet). - (mp:with-process-lock (*SBCL-Read-Memory-Barrier-Lock*) - nil)) - (defvar *SBCL-Write-Memory-Barrier-Lock* - (sb-thread:make-mutex :name "Write Memory Barrier Lock")) - (defmacro write-memory-barrier () - ;; SBCL doesn't seem to have any better way to do this (yet). - (mp:with-process-lock (*SBCL-Write-Memory-Barrier-Lock*) - nil)))) + 'nil))) + +#+(and sbcl sb-thread) +(progn + (defun make-lock (&optional name) + (apply #'sb-thread:make-mutex (and name `(:name ,name)))) + (defmacro with-lock ((lock &key (wait? t)) &body body) + `(sb-thread:with-mutex (,lock :wait-p ,wait?) + . ,body)) + ;; For those implementations that support SMP but don't give us direct ways + ;; to generate memory barriers, we assume that grabbing a lock suffices. + (deflex *Memory-Barrier-Lock* + (sb-thread:make-mutex :name "Memory Barrier Lock")) + (defmacro read-memory-barrier () + '(mp:with-process-lock (*Memory-Barrier-Lock*) + nil)) + (defmacro write-memory-barrier () + '(mp:with-process-lock (*Memory-Barrier-Lock*) + nil))) #+scl @@ -111,12 +119,13 @@ (thread:make-lock name :type ':recursive :auto-free t)) (defmacro with-lock ((lock &key (wait? t)) &body body) `(thread:with-lock-held (,lock "Lock Wait" :wait ,wait?) - . ,body)) + . ,body)) (defmacro read-memory-barrier () '(kernel:read-memory-barrier)) (defmacro write-memory-barrier () '(kernel:write-memory-barrier))) + #+openmcl (progn (defun make-lock (&optional name) @@ -139,18 +148,17 @@ . ,body)) (when ,try-succeeded?-var (ccl:release-lock ,lock-var))))))) - (defvar *OpenMCL-Read-Memory-Barrier-Lock* - (ccl:make-lock "Read Memory Barrier Lock")) + ;; For those implementations that support SMP but don't give us direct ways + ;; to generate memory barriers, we assume that grabbing a lock suffices. + (deflex *Memory-Barrier-Lock* + (ccl:make-lock "Memory Barrier Lock")) (defmacro read-memory-barrier () - ;; OpenMCL doesn't seem to have any better way to do this. - (ccl:with-lock-grabbed (*OpenMCL-Read-Memory-Barrier-Lock*) - nil)) - (defvar *OpenMCL-Write-Memory-Barrier-Lock* - (ccl:make-lock "Write Memory Barrier Lock")) + `(ccl:with-lock-grabbed (*Memory-Barrier-Lock*) + nil)) (defmacro write-memory-barrier () - ;; OpenMCL doesn't seem to have any better way to do this. - (ccl:with-lock-grabbed (*OpenMCL-Write-Memory-Barrier-Lock*) - nil))) + `(ccl:with-lock-grabbed (*Memory-Barrier-Lock*) + nil))) + #+(and genera new-scheduler) (progn @@ -165,7 +173,7 @@ (defmacro read-memory-barrier () 'nil)) -;;; Some implementations have no threading at all (yet). + #+clisp (progn (defun make-lock (&optional name) @@ -180,6 +188,54 @@ 'nil)) +#+(and ecl (not threads)) +(progn + (defun make-lock (&optional name) + (declare (ignore name)) + nil) + (defmacro with-lock ((lock &key (wait? t)) &body body) + (declare (ignore lock wait?)) + `(progn . ,body)) + (defmacro read-memory-barrier () + 'nil) + (defmacro write-memory-barrier () + 'nil)) + +#+(and ecl threads) +(progn + (defun make-lock (&optional name) + (apply #'mp:make-lock (and name `(:name ,name)))) + (defmacro with-lock ((lock &key (wait? t)) &body body) + (let ((lock-var (gensym "LOCK-")) + (wait?-var (gensym "WAIT?-")) + (try-succeeded?-var (gensym "TRY-SUCCEEDED?-"))) + `(let ((,lock-var ,lock) + . ,(and (not (eq wait? 't)) + `((,wait?-var ,wait?) + (,try-succeeded?-var nil)))) + ,(if (eq wait? 't) + `(mp:with-lock (,lock-var) + . ,body) + `(unwind-protect + (and (or ,wait?-var (and (mp:get-lock ,lock-var nil) + (setq ,try-succeeded?-var t))) + (mp:with-lock (,lock-var) + . ,body)) + (when ,try-succeeded?-var + (mp:giveup-lock ,lock-var))))))) + (deflex *ECL-Read-Memory-Barrier-Lock* + (mp:make-lock :name "Read Memory Barrier Lock")) + (defmacro read-memory-barrier () + '(mp:with-lock (*ECL-Read-Memory-Barrier-Lock*) + nil)) + (deflex *ECL-Write-Memory-Barrier-Lock* + (mp:make-lock :name "Write Memory Barrier Lock")) + (defmacro write-memory-barrier () + '(mp:with-lock (*ECL-Write-Memory-Barrier-Lock*) + nil))) + + + ;;; ---------------- ;;; Constants used by the tuple implementation. We choose the widths of @@ -187,9 +243,11 @@ (defconstant Tuple-Key-Number-Size (ecase (integer-length most-positive-fixnum) + (61 40) ; ECL, 64-bit (60 40) ; SBCL, OpenMCL, Scieneer CL, 64-bit + (48 32) ; CLISP, 64-bit (31 18) ; Symbolics L-machine, I-machine - (29 17) ; Allegro, CMUCL, SBCL, LispWorks (most), 32-bit + (29 17) ; Allegro, CMUCL, SBCL, LispWorks (most), ECL, 32-bit (24 15) ; CLISP, 32-bit (23 14)) ; LispWorks 4 on Linux "This limits the number of tuple-keys that can exist in a session.") @@ -199,7 +257,9 @@ (defconstant Tuple-Value-Index-Size (ecase (integer-length most-positive-fixnum) + (61 21) (60 20) + (48 16) (31 13) (29 12) (24 9) Modified: trunk/Code/relations.lisp ============================================================================== --- trunk/Code/relations.lisp (original) +++ trunk/Code/relations.lisp Mon Nov 3 05:08:58 2008 @@ -448,18 +448,18 @@ nil)))))) -(defgeneric closure (2-relation set) +(defgeneric transitive-closure (2-relation set) (:documentation "The transitive closure of the set over the relation. The relation may also be supplied as a function returning a set.")) -(defmethod closure ((fn function) (s set)) - (set-closure fn s)) +(defmethod transitive-closure ((fn function) (s set)) + (set-transitive-closure fn s)) -(defmethod closure ((r 2-relation) (s set)) - (set-closure r s)) +(defmethod transitive-closure ((r 2-relation) (s set)) + (set-transitive-closure r s)) -(defun set-closure (r s) +(defun set-transitive-closure (r s) ;; This could probably use a little moer work. (let ((workset (set-difference (reduce #'union (image r (convert 'seq s)) :initial-value (set)) Modified: trunk/Code/tuples.lisp ============================================================================== --- trunk/Code/tuples.lisp (original) +++ trunk/Code/tuples.lisp Mon Nov 3 05:08:58 2008 @@ -124,11 +124,11 @@ ; (called with one argument, the tuple), or nil number) ; used for lookup and sorting -(defvar *Tuple-Key-Name-Map* (empty-map)) +(deflex +Tuple-Key-Name-Map+ (empty-map)) -(defvar *Tuple-Key-Seq* (empty-seq)) +(deflex +Tuple-Key-Seq+ (empty-seq)) -(defvar *Tuple-Key-Lock* (make-lock "Tuple Key Lock")) +(deflex +Tuple-Key-Lock+ (make-lock "Tuple Key Lock")) (defun get-tuple-key (name &optional default-fn) "Finds or creates a tuple key named `name'. If the key did not already exist, @@ -136,23 +136,24 @@ the tuple has no explicit pair with this key; it is called with one argument, the tuple." (assert (or (null default-fn) (typep default-fn 'function))) - (with-lock (*Tuple-Key-Lock*) - (let ((key (lookup *Tuple-Key-Name-Map* name)) - (key-idx (size *Tuple-Key-Seq*))) + (with-lock (+Tuple-Key-Lock+) + (let ((key (lookup +Tuple-Key-Name-Map+ name)) + (key-idx (size +Tuple-Key-Seq+))) (or key (if (<= key-idx Tuple-Key-Number-Mask) (let ((key (make-tuple-key name default-fn key-idx))) - (setf (lookup *Tuple-Key-Name-Map* name) key) - (push-last *Tuple-Key-Seq* key) + (setf (lookup +Tuple-Key-Name-Map+ name) key) + (push-last +Tuple-Key-Seq+ key) key) (error "Tuple key space exhausted")))))) (defmacro def-tuple-key (name &optional default-fn) - "Defines a tuple key named `name'. If `default-fn' is supplied, it is used -to compute a value for lookups where the tuple has no explicit pair with this -key; it is called with one argument, the tuple." + "Defines a tuple key named `name' as a global lexical variable (see `deflex'). +If `default-fn' is supplied, it is used to compute a value for lookups where +the tuple has no explicit pair with this key; it is called with one argument, +the tuple." (assert (symbolp name)) - `(defvar ,name (get-tuple-key ',name ,default-fn))) + `(deflex ,name (get-tuple-key ',name ,default-fn))) (defun print-tuple-key (key stream level) (declare (ignore level)) @@ -193,17 +194,17 @@ ;; Serial number (used for `Reorder-Map-Map'). Serial-Number) -(defvar Tuple-Desc-Next-Serial-Number 0) +(deflex +Tuple-Desc-Next-Serial-Number+ 0) -(defvar Tuple-Desc-Next-Serial-Number-Lock (make-lock)) +(deflex +Tuple-Desc-Next-Serial-Number-Lock+ (make-lock)) (defun Make-Tuple-Desc (key-set pairs) (Make-Tuple-Desc-Internal key-set pairs (make-lock) - (prog1 Tuple-Desc-Next-Serial-Number - (with-lock (Tuple-Desc-Next-Serial-Number-Lock) - (incf Tuple-Desc-Next-Serial-Number))))) + (prog1 +Tuple-Desc-Next-Serial-Number+ + (with-lock (+Tuple-Desc-Next-Serial-Number-Lock+) + (incf +Tuple-Desc-Next-Serial-Number+))))) -(defvar *Tuple-Descriptor-Map* (empty-map)) +(deflex +Tuple-Descriptor-Map+ (empty-map)) (defmethod compare ((x Tuple-Desc) (y Tuple-Desc)) (let ((xser (Tuple-Desc-Serial-Number x)) @@ -233,13 +234,13 @@ (defun empty-dyn-tuple () "Returns an empty dyn-tuple." - (let ((desc (lookup *Tuple-Descriptor-Map* (empty-map)))) + (let ((desc (lookup +Tuple-Descriptor-Map+ (empty-map)))) (unless desc (setq desc (Make-Tuple-Desc (empty-set) (vector))) - (setf (lookup *Tuple-Descriptor-Map* (empty-map)) desc)) + (setf (lookup +Tuple-Descriptor-Map+ (empty-map)) desc)) (make-dyn-tuple desc (vector)))) -(defvar *Tuple-Random-Value* 0 +(deflex +Tuple-Random-Value+ 0 "State for an extremely fast, low-quality generator of small numbers of pseudorandom bits. Yep, this is about as quick-and-dirty as it gets -- we just increment this value by some small prime like 5 each time. We @@ -248,8 +249,8 @@ (declaim (inline Tuple-Random-Value)) (defun Tuple-Random-Value () (the fixnum - (setf *Tuple-Random-Value* - (logand (+ (the fixnum *Tuple-Random-Value*) 5) + (setf +Tuple-Random-Value+ + (logand (+ (the fixnum +Tuple-Random-Value+) 5) most-positive-fixnum)))) (defconstant Tuple-Reorder-Frequency 31 @@ -349,7 +350,7 @@ (let ((nks (with (Tuple-Desc-Key-Set old-desc) key)) ((nd (progn (read-memory-barrier) - (lookup *Tuple-Descriptor-Map* nks))))) + (lookup +Tuple-Descriptor-Map+ nks))))) (when nd (setf (lookup (Tuple-Desc-Next-Desc-Map old-desc) key) nd)) (values nd nks))))) @@ -358,7 +359,7 @@ (old-pairs (Tuple-Desc-Pairs old-desc))) (unless new-desc ;; Lock out reorderings while we do this. One might think we also need a - ;; lock to protect `*Tuple-Descriptor-Map*', but actually it doesn't hurt + ;; lock to protect `+Tuple-Descriptor-Map+', but actually it doesn't hurt ;; anything if we lose an occasional entry -- some tuples will use a ;; descriptor not in the map, but nothing goes wrong as a consequence. (with-lock ((Tuple-Desc-Lock old-desc)) @@ -380,12 +381,12 @@ (dotimes (i (- nkeys window-size 1)) (add-pair (+ i window-size 1) (svref old-pairs (+ i window-size))))))))) - ;(setf (lookup *Tuple-Descriptor-Map* new-key-set) new-desc) + ;(setf (lookup +Tuple-Descriptor-Map+ new-key-set) new-desc) ;; Technically, we need a memory barrier to make sure the new map value ;; is fully constructed before being made available to other threads. - (setq *Tuple-Descriptor-Map* + (setq +Tuple-Descriptor-Map+ (prog1 - (with *Tuple-Descriptor-Map* new-key-set new-desc) + (with +Tuple-Descriptor-Map+ new-key-set new-desc) (write-memory-barrier))) (setf (lookup (Tuple-Desc-Next-Desc-Map old-desc) key) new-desc)) (let ((reorder-map (Tuple-Get-Reorder-Map old-desc new-desc)) @@ -478,7 +479,7 @@ (declare (fixnum ,idx-var)) (let ((,pr-var (the fixnum (svref ,pairs-var ,idx-var))) ((,val-idx-var (ash ,pr-var (- Tuple-Key-Number-Size))))) - (let ((,key-var (lookup *Tuple-Key-Seq* + (let ((,key-var (lookup +Tuple-Key-Seq+ (logand ,pr-var Tuple-Key-Number-Mask))) (,value-var (svref (svref ,contents-var (ash ,val-idx-var Modified: trunk/Code/wb-trees.lisp ============================================================================== --- trunk/Code/wb-trees.lisp (original) +++ trunk/Code/wb-trees.lisp Mon Nov 3 05:08:58 2008 @@ -1610,7 +1610,8 @@ ;;; Utilities used by all tree types in this file (defun Make-WB-Tree-Iterator (tree size frame-size nodes-have-values?) - (declare (type fixnum frame-size)) + (declare (optimize (speed 3) (safety 0)) + (type fixnum frame-size)) (let ((depth (the fixnum (WB-Tree-Max-Depth size nodes-have-values?))) ((stack (make-array (the fixnum (1+ (the fixnum (* frame-size depth)))))))) (setf (svref stack 0) 1) @@ -1632,11 +1633,11 @@ (defconstant WB-Tree-Precomputed-Max-Depths 1000) -(defvar *WB-Tree-Max-Depths-Without-Values* +(deflex +WB-Tree-Max-Depths-Without-Values+ (gmap :vector (lambda (i) (WB-Tree-True-Max-Depth i nil)) (:index 0 WB-Tree-Precomputed-Max-Depths))) -(defvar *WB-Tree-Max-Depths-With-Values* +(deflex +WB-Tree-Max-Depths-With-Values+ (gmap :vector (lambda (i) (WB-Tree-True-Max-Depth i t)) (:index 0 WB-Tree-Precomputed-Max-Depths))) @@ -1649,8 +1650,8 @@ (type fixnum size)) (if (< size WB-Tree-Precomputed-Max-Depths) (svref (if nodes-have-values? - *WB-Tree-Max-Depths-With-Values* - *WB-Tree-Max-Depths-Without-Values*) + +WB-Tree-Max-Depths-With-Values+ + +WB-Tree-Max-Depths-Without-Values+) size) (values (ceiling (* (1- (integer-length size)) ;; constant: From sburson at common-lisp.net Mon Nov 3 05:10:55 2008 From: sburson at common-lisp.net (Scott L. Burson) Date: Mon, 03 Nov 2008 05:10:55 +0000 Subject: [fset-cvs] r21 - trunk Message-ID: Author: sburson Date: Mon Nov 3 05:10:55 2008 New Revision: 21 Log: Update `fset.asd' for new files. Modified: trunk/fset.asd Modified: trunk/fset.asd ============================================================================== --- trunk/fset.asd (original) +++ trunk/fset.asd Mon Nov 3 05:10:55 2008 @@ -24,4 +24,8 @@ (:file "fset") (:file "tuples") (:file "reader") - (:file "testing"))))) + (:file "testing") + (:file "interval") + (:file "relations") + (:file "complement-sets") + (:file "bounded-sets"))))) From sburson at common-lisp.net Mon Nov 3 05:11:51 2008 From: sburson at common-lisp.net (Scott L. Burson) Date: Mon, 03 Nov 2008 05:11:51 +0000 Subject: [fset-cvs] r22 - tags/fset_1.2.0 Message-ID: Author: sburson Date: Mon Nov 3 05:11:51 2008 New Revision: 22 Log: Tagging 1.2.0. Added: tags/fset_1.2.0/ - copied from r21, /trunk/ From sburson at common-lisp.net Tue Nov 4 05:36:22 2008 From: sburson at common-lisp.net (Scott L. Burson) Date: Tue, 04 Nov 2008 05:36:22 +0000 Subject: [fset-cvs] r23 - trunk/Code Message-ID: Author: sburson Date: Tue Nov 4 05:36:20 2008 New Revision: 23 Log: Oops -- error in port interface for threaded SBCL. Modified: trunk/Code/port.lisp Modified: trunk/Code/port.lisp ============================================================================== --- trunk/Code/port.lisp (original) +++ trunk/Code/port.lisp Tue Nov 4 05:36:20 2008 @@ -83,6 +83,7 @@ #+(and sbcl (not sb-thread)) (progn (defun make-lock (&optional name) + (declare (ignore name)) nil) (defmacro with-lock ((lock &key (wait? t)) &body body) (declare (ignore lock wait?)) @@ -106,10 +107,10 @@ (deflex *Memory-Barrier-Lock* (sb-thread:make-mutex :name "Memory Barrier Lock")) (defmacro read-memory-barrier () - '(mp:with-process-lock (*Memory-Barrier-Lock*) + '(sb-thread:with-mutex (*Memory-Barrier-Lock*) nil)) (defmacro write-memory-barrier () - '(mp:with-process-lock (*Memory-Barrier-Lock*) + '(sb-thread:with-mutex (*Memory-Barrier-Lock*) nil))) From sburson at common-lisp.net Tue Nov 4 05:37:14 2008 From: sburson at common-lisp.net (Scott L. Burson) Date: Tue, 04 Nov 2008 05:37:14 +0000 Subject: [fset-cvs] r24 - tags/fset_1.2.1 Message-ID: Author: sburson Date: Tue Nov 4 05:37:13 2008 New Revision: 24 Log: Tagging 1.2.1. Added: tags/fset_1.2.1/ - copied from r23, /trunk/ From sburson at common-lisp.net Mon Nov 10 05:44:30 2008 From: sburson at common-lisp.net (Scott L. Burson) Date: Mon, 10 Nov 2008 05:44:30 +0000 Subject: [fset-cvs] r25 - trunk/Code Message-ID: Author: sburson Date: Mon Nov 10 05:44:30 2008 New Revision: 25 Log: Some minor fixes: () `domain-contains' and `range-contains' were not exported. () Some `deflex' variables in `testing.lisp' needed +earmuffs+ on Scieneer. () A case error showed up in case-sensitive Lisps. Modified: trunk/Code/defs.lisp trunk/Code/testing.lisp trunk/Code/tuples.lisp Modified: trunk/Code/defs.lisp ============================================================================== --- trunk/Code/defs.lisp (original) +++ trunk/Code/defs.lisp Mon Nov 10 05:44:30 2008 @@ -37,7 +37,8 @@ ;; are unlikely to be useful in user code. #:equal? #:compare #:compare-slots #:identity-ordering-mixin #:define-cross-type-compare-methods - #:empty? nonempty? #:size #:set-size #:arb #:contains? #:multiplicity + #:empty? nonempty? #:size #:set-size #:arb + #:contains? #:domain-contains? #:range-contains? #:member? #:multiplicity #:empty-set #:empty-bag #:empty-map #:empty-seq #:empty-tuple #:empty-wb-set #:empty-wb-bag #:empty-wb-map #:empty-wb-seq #:empty-dyn-tuple Modified: trunk/Code/testing.lisp ============================================================================== --- trunk/Code/testing.lisp (original) +++ trunk/Code/testing.lisp Mon Nov 10 05:44:30 2008 @@ -15,16 +15,16 @@ (:constructor Make-My-Integer (Value))) Value) -(def-tuple-key K0) -(def-tuple-key K1) -(def-tuple-key K2) -(def-tuple-key K3) -(def-tuple-key K4) -(def-tuple-key K5) -(def-tuple-key K6) -(def-tuple-key K7) -(def-tuple-key K8) -(def-tuple-key K9) +(def-tuple-key +K0+) +(def-tuple-key +K1+) +(def-tuple-key +K2+) +(def-tuple-key +K3+) +(def-tuple-key +K4+) +(def-tuple-key +K5+) +(def-tuple-key +K6+) +(def-tuple-key +K7+) +(def-tuple-key +K8+) +(def-tuple-key +K9+) (defun run-test-suite (n-iterations &optional random-seed) @@ -122,12 +122,12 @@ (test (unequal? (seq 'a 3 'c) (seq 'a 3.0 'c))) (test (less-than? (seq 'a 3 'c) (seq 'a 3.0 'd))) (test (less-than? (seq) (tuple))) - (test (equal (convert 'list (eval '(tuple (k0 1) ($ (tuple (k1 2) (k2 3))) - (k0 2) ($ (tuple (k4 7) (k2 8)))))) - `((,k0 . 2) (,k1 . 2) (,k2 . 8) (,k4 . 7)))) - (test (less-than? (tuple (k0 1)) (tuple (k0 2)))) - (test (unequal? (tuple (k0 1.0) (k1 'c)) (tuple (k0 1) (k1 'c)))) - (test (less-than? (tuple (k0 1.0) (k1 'c)) (tuple (k0 1) (k1 'd)))) + (test (equal (convert 'list (eval '(tuple (+K0+ 1) ($ (tuple (+K1+ 2) (+K2+ 3))) + (+K0+ 2) ($ (tuple (+K4+ 7) (+K2+ 8)))))) + `((,+K0+ . 2) (,+K1+ . 2) (,+K2+ . 8) (,+K4+ . 7)))) + (test (less-than? (tuple (+K0+ 1)) (tuple (+K0+ 2)))) + (test (unequal? (tuple (+K0+ 1.0) (+K1+ 'c)) (tuple (+K0+ 1) (+K1+ 'c)))) + (test (less-than? (tuple (+K0+ 1.0) (+K1+ 'c)) (tuple (+K0+ 1) (+K1+ 'd)))) (test (empty? (set))) (test (empty? (map))) (test (empty? (bag))) @@ -301,16 +301,16 @@ (error "Set arb/contains? failed (fs1) on iteration ~D" i)) (unless (member (compare (least fs0) (reduce (lambda (mi1 mi2) - (if (< (my-integer-value mi1) - (my-integer-value mi2)) + (if (< (My-Integer-Value mi1) + (My-Integer-Value mi2)) mi1 mi2)) s0)) '(:equal :unequal)) (error "Set least failed on iteration ~D" i)) (unless (member (compare (greatest fs0) (reduce (lambda (mi1 mi2) - (if (> (my-integer-value mi1) - (my-integer-value mi2)) + (if (> (My-Integer-Value mi1) + (My-Integer-Value mi2)) mi1 mi2)) s0)) '(:equal :unequal)) @@ -429,16 +429,16 @@ (error "Map arb/contains? failed (fm1) on iteration ~D" i)) (unless (member (compare (least fm0) (reduce (lambda (mi1 mi2) - (if (< (my-integer-value mi1) - (my-integer-value mi2)) + (if (< (My-Integer-Value mi1) + (My-Integer-Value mi2)) mi1 mi2)) (mapcar #'car m0))) '(:equal :unequal)) (error "Map least failed on iteration ~D" i)) (unless (member (compare (greatest fm0) (reduce (lambda (mi1 mi2) - (if (> (my-integer-value mi1) - (my-integer-value mi2)) + (if (> (My-Integer-Value mi1) + (My-Integer-Value mi2)) mi1 mi2)) (mapcar #'car m0))) '(:equal :unequal)) @@ -586,16 +586,16 @@ (error "Bag arb/contains? failed (fb1) on iteration ~D" i)) (unless (member (compare (least fb0) (reduce (lambda (mi1 mi2) - (if (< (my-integer-value mi1) - (my-integer-value mi2)) + (if (< (My-Integer-Value mi1) + (My-Integer-Value mi2)) mi1 mi2)) (mapcar #'car b0))) '(:equal :unequal)) (error "Bag least failed on iteration ~D" i)) (unless (member (compare (greatest fb0) (reduce (lambda (mi1 mi2) - (if (> (my-integer-value mi1) - (my-integer-value mi2)) + (if (> (My-Integer-Value mi1) + (My-Integer-Value mi2)) mi1 mi2)) (mapcar #'car b0))) '(:equal :unequal)) @@ -785,7 +785,7 @@ (error "Find failed on iteration ~D" i))))) -(deflex Tuple-Keys (vector K0 K1 K2 K3 K4 K5 K6 K7 K8 K9)) +(deflex Tuple-Keys (vector +K0+ +K1+ +K2+ +K3+ +K4+ +K5+ +K6+ +K7+ +K8+ +K9+)) (defun Test-Tuple-Operations (i) (let ((tup (tuple)) Modified: trunk/Code/tuples.lisp ============================================================================== --- trunk/Code/tuples.lisp (original) +++ trunk/Code/tuples.lisp Mon Nov 10 05:44:30 2008 @@ -510,8 +510,8 @@ (format stream ">")) (defmethod compare ((tup1 tuple) (tup2 tuple)) - (let ((key-set-1 (tuple-desc-key-set (dyn-tuple-descriptor tup1))) - (key-set-2 (tuple-desc-key-set (dyn-tuple-descriptor tup2))) + (let ((key-set-1 (Tuple-Desc-Key-Set (dyn-tuple-descriptor tup1))) + (key-set-2 (Tuple-Desc-Key-Set (dyn-tuple-descriptor tup2))) ((res (compare key-set-1 key-set-2))) (default ':equal)) (if (not (eq res ':equal)) From sburson at common-lisp.net Mon Nov 10 05:44:59 2008 From: sburson at common-lisp.net (Scott L. Burson) Date: Mon, 10 Nov 2008 05:44:59 +0000 Subject: [fset-cvs] r26 - tags/fset_1.2.2 Message-ID: Author: sburson Date: Mon Nov 10 05:44:59 2008 New Revision: 26 Log: Tagging 1.2.2. Added: tags/fset_1.2.2/ - copied from r25, /trunk/