[snow-cvs] r6 - in trunk: dist lib/cl-utilities-1.2.4 lib/cl-utilities-1.2.4/doc src/java/snow src/java/snow/binding src/lisp/snow
Alessio Stalla
astalla at common-lisp.net
Mon Oct 19 21:28:32 UTC 2009
Author: astalla
Date: Mon Oct 19 17:28:31 2009
New Revision: 6
Log:
Added dependency on cl-utilities for split-sequence and with-unique-names
Started EL data binding
Added:
trunk/lib/cl-utilities-1.2.4/
trunk/lib/cl-utilities-1.2.4/README
trunk/lib/cl-utilities-1.2.4/cl-utilities.asd
trunk/lib/cl-utilities-1.2.4/collecting.lisp
trunk/lib/cl-utilities-1.2.4/compose.lisp
trunk/lib/cl-utilities-1.2.4/copy-array.lisp
trunk/lib/cl-utilities-1.2.4/doc/
trunk/lib/cl-utilities-1.2.4/doc/collecting.html
trunk/lib/cl-utilities-1.2.4/doc/compose.html
trunk/lib/cl-utilities-1.2.4/doc/copy-array.html
trunk/lib/cl-utilities-1.2.4/doc/expt-mod.html
trunk/lib/cl-utilities-1.2.4/doc/extremum.html
trunk/lib/cl-utilities-1.2.4/doc/index.html
trunk/lib/cl-utilities-1.2.4/doc/once-only.html
trunk/lib/cl-utilities-1.2.4/doc/read-delimited.html
trunk/lib/cl-utilities-1.2.4/doc/rotate-byte.html
trunk/lib/cl-utilities-1.2.4/doc/split-sequence.html
trunk/lib/cl-utilities-1.2.4/doc/style.css
trunk/lib/cl-utilities-1.2.4/doc/with-unique-names.html
trunk/lib/cl-utilities-1.2.4/expt-mod.lisp
trunk/lib/cl-utilities-1.2.4/extremum.lisp
trunk/lib/cl-utilities-1.2.4/once-only.lisp
trunk/lib/cl-utilities-1.2.4/package.lisp
trunk/lib/cl-utilities-1.2.4/package.sh (contents, props changed)
trunk/lib/cl-utilities-1.2.4/read-delimited.lisp
trunk/lib/cl-utilities-1.2.4/rotate-byte.lisp
trunk/lib/cl-utilities-1.2.4/split-sequence.lisp
trunk/lib/cl-utilities-1.2.4/test.lisp
trunk/lib/cl-utilities-1.2.4/with-unique-names.lisp
trunk/src/lisp/snow/data-binding.lisp
Removed:
trunk/dist/
Modified:
trunk/src/java/snow/Snow.java
trunk/src/java/snow/binding/BeanPropertyPathBinding.java
trunk/src/lisp/snow/compile-system.lisp
trunk/src/lisp/snow/packages.lisp
trunk/src/lisp/snow/sexy-java.lisp
trunk/src/lisp/snow/snow.asd
trunk/src/lisp/snow/utils.lisp
Added: trunk/lib/cl-utilities-1.2.4/README
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/README Mon Oct 19 17:28:31 2009
@@ -0,0 +1,59 @@
+CL-UTILITIES Collection
+=======================
+
+On Cliki.net <http://www.cliki.net/Common%20Lisp%20Utilities>, there
+is a collection of Common Lisp Utilities, things that everybody writes
+since they're not part of the official standard. There are some very
+useful things there; the only problems are that they aren't
+implemented as well as you'd like (some aren't implemented at all) and
+they aren't conveniently packaged and maintained. It takes quite a bit
+of work to carefully implement utilities for common use, commented
+and documented, with error checking placed everywhere some dumb user
+might make a mistake.
+
+The CLRFI process <http://clrfi.alu.org/> is a lot better thought out,
+and will probably produce better standards than informal discussion on
+a Wiki, but it has one problem: at the time of this writing, it's not
+doing anything yet. Until the CLRFI process gets going, I think that a
+high-quality collection of the informal standards on Cliki is a
+valuable thing to have. It's here, and it's called cl-utilities.
+
+The home page is <http://common-lisp.net/project/cl-utilities/>.
+
+Documentation
+-------------
+
+Right now, documentation is at
+<http://www.cliki.net/Common%20Lisp%20Utilities>. There are a few
+differences, though:
+
+* The READ-DELIMITED function takes :start and :end keyword args.
+* A WITH-GENSYMS function is provided for compatibility.
+* COPY-ARRAY is not called SHALLOW-COPY-ARRAY.
+* The ONCE-ONLY macro is included.
+
+Installation
+------------
+
+To install cl-utilities, you'll need to do one of two things:
+
+* Download cl-utilities into a place where asdf can find it, then
+ load it via asdf. You will also need to get the split-sequence
+ package, which cl-utilities depends on.
+
+-or-
+
+* Use asdf-install: (asdf-install:install :cl-utilities)
+
+Feedback
+--------
+
+The current maintainer is Peter Scott. If you have questions, bugs,
+comments, or contributions, please send them to the cl-utilities-devel
+mailing list, <cl-utilities-devel at common-lisp.net>.
+
+License
+-------
+
+The code in cl-utilities is in the public domain. Do whatever you want
+with it.
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/cl-utilities.asd
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/cl-utilities.asd Mon Oct 19 17:28:31 2009
@@ -0,0 +1,33 @@
+;; -*- Lisp -*-
+
+(defpackage #:cl-utilities-system
+ (:use #:common-lisp #:asdf))
+
+(in-package #:cl-utilities-system)
+
+(defsystem cl-utilities
+ :author "Maintained by Peter Scott"
+ :components ((:file "package")
+ (:file "split-sequence" :depends-on ("package"))
+ (:file "extremum" :depends-on ("package"
+ "with-unique-names"
+ "once-only"))
+ (:file "read-delimited" :depends-on ("package"))
+ (:file "expt-mod" :depends-on ("package"))
+ (:file "with-unique-names" :depends-on ("package"))
+ (:file "collecting" :depends-on ("package"
+ "with-unique-names"
+ "compose"))
+ (:file "once-only" :depends-on ("package"))
+ (:file "rotate-byte" :depends-on ("package"))
+ (:file "copy-array" :depends-on ("package"))
+ (:file "compose" :depends-on ("package"))))
+
+;; Sometimes we can accelerate byte rotation on SBCL by using the
+;; SB-ROTATE-BYTE extension. This loads it.
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (handler-case (progn
+ (require :sb-rotate-byte)
+ (pushnew :sbcl-uses-sb-rotate-byte *features*))
+ (error () (delete :sbcl-uses-sb-rotate-byte *features*))))
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/collecting.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/collecting.lisp Mon Oct 19 17:28:31 2009
@@ -0,0 +1,84 @@
+;; Opinions differ on how a collection macro should work. There are
+;; two major points for discussion: multiple collection variables and
+;; implementation method.
+;;
+;; There are two main ways of implementing collection: sticking
+;; successive elements onto the end of the list with tail-collection,
+;; and using the PUSH/NREVERSE idiom. Tail-collection is usually
+;; faster, except on CLISP, where PUSH/NREVERSE is a little faster.
+;;
+;; The COLLECTING macro only allows collection into one list, and you
+;; can't nest them to get the same effect as multiple collection since
+;; it always uses the COLLECT function. If you want to collect into
+;; multiple lists, use the WITH-COLLECT macro.
+
+(in-package :cl-utilities)
+
+;; This should only be called inside of COLLECTING macros, but we
+;; define it here to provide an informative error message and to make
+;; it easier for SLIME (et al.) to get documentation for the COLLECT
+;; function when it's used in the COLLECTING macro.
+(defun collect (thing)
+ "Collect THING in the context established by the COLLECTING macro"
+ (error "Can't collect ~S outside the context of the COLLECTING macro"
+ thing))
+
+(defmacro collecting (&body body)
+ "Collect things into a list forwards. Within the body of this macro,
+the COLLECT function will collect its argument into the list returned
+by COLLECTING."
+ (with-unique-names (collector tail)
+ `(let (,collector ,tail)
+ (labels ((collect (thing)
+ (if ,collector
+ (setf (cdr ,tail)
+ (setf ,tail (list thing)))
+ (setf ,collector
+ (setf ,tail (list thing))))))
+ , at body)
+ ,collector)))
+
+(defmacro with-collectors ((&rest collectors) &body body)
+ "Collect some things into lists forwards. The names in COLLECTORS
+are defined as local functions which each collect into a separate
+list. Returns as many values as there are collectors, in the order
+they were given."
+ (%with-collectors-check-collectors collectors)
+ (let ((gensyms-alist (%with-collectors-gensyms-alist collectors)))
+ `(let ,(loop for collector in collectors
+ for tail = (cdr (assoc collector gensyms-alist))
+ nconc (list collector tail))
+ (labels ,(loop for collector in collectors
+ for tail = (cdr (assoc collector gensyms-alist))
+ collect `(,collector (thing)
+ (if ,collector
+ (setf (cdr ,tail)
+ (setf ,tail (list thing)))
+ (setf ,collector
+ (setf ,tail (list thing))))))
+ , at body)
+ (values , at collectors))))
+
+(defun %with-collectors-check-collectors (collectors)
+ "Check that all of the COLLECTORS are symbols. If not, raise an error."
+ (let ((bad-collector (find-if-not #'symbolp collectors)))
+ (when bad-collector
+ (error 'type-error
+ :datum bad-collector
+ :expected-type 'symbol))))
+
+(defun %with-collectors-gensyms-alist (collectors)
+ "Return an alist mapping the symbols in COLLECTORS to gensyms"
+ (mapcar #'cons collectors
+ (mapcar (compose #'gensym
+ #'(lambda (x)
+ (format nil "~A-TAIL-" x)))
+ collectors)))
+
+;; Some test code which would be too hard to move to the test suite.
+#+nil (with-collectors (one-through-nine abc)
+ (mapcar #'abc '(a b c))
+ (dotimes (x 10)
+ (one-through-nine x)
+ (print one-through-nine))
+ (terpri) (terpri))
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/compose.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/compose.lisp Mon Oct 19 17:28:31 2009
@@ -0,0 +1,51 @@
+;; This version of COMPOSE can only handle functions which take one
+;; value and return one value. There are other ways of writing
+;; COMPOSE, but this is the most commonly used.
+
+(in-package :cl-utilities)
+
+;; This is really slow and conses a lot. Fortunately we can speed it
+;; up immensely with a compiler macro.
+(defun compose (&rest functions)
+ "Compose FUNCTIONS right-associatively, returning a function"
+ #'(lambda (x)
+ (reduce #'funcall functions
+ :initial-value x
+ :from-end t)))
+
+;; Here's some benchmarking code that compares various methods of
+;; doing the same thing. If the first method, using COMPOSE, is
+;; notably slower than the rest, the compiler macro probably isn't
+;; being run.
+#+nil
+(labels ((2* (x) (* 2 x)))
+ (macrolet ((repeat ((x) &body body)
+ (with-unique-names (counter)
+ `(dotimes (,counter ,x)
+ (declare (type (integer 0 ,x) ,counter)
+ (ignorable ,counter))
+ , at body))))
+ ;; Make sure the compiler macro gets run
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (time (repeat (30000000) (funcall (compose #'1+ #'2* #'1+) 6)))
+ (time (repeat (30000000) (funcall (lambda (x) (1+ (2* (1+ x)))) 6)))
+ (time (repeat (30000000)
+ (funcall (lambda (x)
+ (funcall #'1+ (funcall #'2* (funcall #'1+ x))))
+ 6)))))
+
+;; Converts calls to COMPOSE to lambda forms with everything written
+;; out and some things written as direct function calls.
+;; Example: (compose #'1+ #'2* #'1+) => (LAMBDA (X) (1+ (2* (1+ X))))
+(define-compiler-macro compose (&rest functions)
+ (labels ((sharp-quoted-p (x)
+ (and (listp x)
+ (eql (first x) 'function)
+ (symbolp (second x)))))
+ `(lambda (x) ,(reduce #'(lambda (fun arg)
+ (if (sharp-quoted-p fun)
+ (list (second fun) arg)
+ (list 'funcall fun arg)))
+ functions
+ :initial-value 'x
+ :from-end t))))
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/copy-array.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/copy-array.lisp Mon Oct 19 17:28:31 2009
@@ -0,0 +1,29 @@
+(in-package :cl-utilities)
+
+(defun copy-array (array &key (undisplace nil))
+ "Shallow copies the contents of any array into another array with
+equivalent properties. If array is displaced, then this function will
+normally create another displaced array with similar properties,
+unless UNDISPLACE is non-NIL, in which case the contents of the array
+will be copied into a completely new, not displaced, array."
+ (declare (type array array))
+ (let ((copy (%make-array-with-same-properties array undisplace)))
+ (unless (array-displacement copy)
+ (dotimes (n (array-total-size copy))
+ (setf (row-major-aref copy n) (row-major-aref array n))))
+ copy))
+
+(defun %make-array-with-same-properties (array undisplace)
+ "Make an array with the same properties (size, adjustability, etc.)
+as another array, optionally undisplacing the array."
+ (apply #'make-array
+ (list* (array-dimensions array)
+ :element-type (array-element-type array)
+ :adjustable (adjustable-array-p array)
+ :fill-pointer (when (array-has-fill-pointer-p array)
+ (fill-pointer array))
+ (multiple-value-bind (displacement offset)
+ (array-displacement array)
+ (when (and displacement (not undisplace))
+ (list :displaced-to displacement
+ :displaced-index-offset offset))))))
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/doc/collecting.html
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/doc/collecting.html Mon Oct 19 17:28:31 2009
@@ -0,0 +1,78 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Macro COLLECTING, WITH-COLLECTORS</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Macro</i> <b>COLLECTING</b></a></a> <p>
+<p><b>Syntax:</b><p>
+
+<p>
+
+<p><b>collecting</b> <i>form*</i> => <i>result</i><p>
+
+<p><b>with-collectors</b> <i>(collector*) form*</i> => <i>result</i>*<p>
+<p>
+<p><b>Arguments and Values:</b><p>
+<p>
+<i>forms</i>---an <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/glo_i.html#implicit_progn">implicit
+progn</a>.
+
+<p><i>collector</i>---a symbol which will have a collection function bound to it.
+
+<p><i>result</i>---a collected list.
+
+<p>
+<p><b>Description:</b><p>
+<p>
+<b>collecting</b> collects things into a list. Within the
+body of this macro, the <b>collect</b> function will collect its
+argument into <i>result</i>.
+
+<p><b>with-collectors</b> collects some things into lists. The
+<i>collector</i> names are defined as local functions which each
+collect into a separate list. Returns as many values as there are
+collectors, in the order they were given.
+
+<p><b>Exceptional situations:</b><p>
+<p>
+
+<p>If the <i>collector</i> names are not all symbols, a
+<b>type-error</b> will be signalled.
+
+<p><b>Examples:</b>
+
+<pre>
+(collecting (dotimes (x 10) (collect x))) => (0 1 2 3 4 5 6 7 8 9)
+
+(multiple-value-bind (a b)
+ (with-collectors (x y)
+ (x 1)
+ (y 2)
+ (x 3))
+ (append a b)) => (1 2 3)
+</pre>
+
+<p><p><b>Implementation notes:</b></p>
+
+<p>Opinions differ on how a collection macro should work. There are
+two major points for discussion: multiple collection variables and
+implementation method.</b>
+
+<p>There are two main ways of implementing collection: sticking
+successive elements onto the end of the list with tail-collection, or
+using the PUSH/NREVERSE idiom. Tail-collection is usually faster,
+except on CLISP, where PUSH/NREVERSE is a little faster because it's
+implemented in C which is always faster than Lisp bytecode.</p>
+
+<p>The <b>collecting</b> macro only allows collection into one list,
+and you can't nest them to get the same effect as multiple collection
+since it always uses the <b>collect</b> function. If you want to
+collect into multiple lists, use the <b>with-collect</b> macro.</p>
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+ </body></html>
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/doc/compose.html
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/doc/compose.html Mon Oct 19 17:28:31 2009
@@ -0,0 +1,59 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Function COMPOSE</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Function</i> <b>COMPOSE</b></p>
+
+<p><p><b>Syntax:</b></p>
+
+<p><p><b>compose</b> <i>function* <tt>=></tt> composite-function</i></p>
+
+<p><p><b>Arguments and Values:</b></p>
+
+<p><p><i>function</i>---a <i><a href="http://www.lispworks.com/documentation/HyperSpec/Body/glo_f.html#function_designator">function designator</a></i>.</p>
+
+<p><i>composite-function</i>---a <i>function</i>.
+
+<p><p><b>Description:</b></p>
+
+<p>Composes its arguments into a single composite function. All its
+arguments are assumed to designate functions which take one argument
+and return one argument.
+
+<p><tt>(funcall (compose f g) 42)</tt> is equivalent to <tt>(f (g
+42))</tt>. Composition is right-associative.
+
+<p><b>Examples:</b>
+
+<pre>
+;; Just to illustrate order of operations
+(defun 2* (x) (* 2 x))
+
+
+(funcall (compose #'1+ #'1+) 1) => 3
+(funcall (compose '1+ '2*) 5) => 11
+(funcall (compose #'1+ '2* '1+) 6) => 15
+</pre>
+
+<p><b>Notes:</b>
+<p>If you're dealing with multiple arguments and return values, the
+same concept can be used. Here is some code that could be useful:
+
+<pre>
+(defun mv-compose2 (f1 f2)
+ (lambda (&rest args)
+ (multiple-value-call f1 (apply f2 args))))
+
+(defun mv-compose (&rest functions)
+ (if functions
+ (reduce #'mv-compose2 functions)
+ #'values))
+</pre>
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: trunk/lib/cl-utilities-1.2.4/doc/copy-array.html
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/doc/copy-array.html Mon Oct 19 17:28:31 2009
@@ -0,0 +1,48 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Function COPY-ARRAY</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Function</i> <b>COPY-ARRAY</b></a></a> <p>
+<p><b>Syntax:</b><p>
+
+<p>
+
+<p><b>copy-array</b> <i>array <tt>&key</tt> undisplace</i> => <i>new-array</i>
+<p>
+<p><b>Arguments and Values:</b><p>
+<p>
+<i>array</i>---an <i>array</i>. <p>
+
+<i>undisplace</i>---a <i>generalized boolean</i>. The default is <i>false</i>.<p>
+
+<i>new-array</i>---an <i>array</i></a>. <p>
+
+<p>
+<p><b>Description:</b><p>
+
+<p>Shallow copies the contents of <i>array</i> into another array with
+equivalent properties. If <i>array</i> is displaced, then this
+function will normally create another displaced array with similar
+properties, unless <i>undisplace</i> is <i>true</i>, in which case the
+contents of <i>array</i> will be copied into a completely new, not
+displaced, array.</p>
+
+<p><p><b>Examples:</b></p>
+<pre>
+(copy-array #(1 2 3)) => #(1 2 3)
+
+(let ((array #(1 2 3)))
+ (eq (copy-array array) array)) => NIL
+</pre>
+
+<p><p><b>Side Effects:</b> None.</p>
+
+<p><p><b>Affected By:</b> None.</p>
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: trunk/lib/cl-utilities-1.2.4/doc/expt-mod.html
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/doc/expt-mod.html Mon Oct 19 17:28:31 2009
@@ -0,0 +1,60 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Function EXPT-MOD</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Function</i> <b>EXPT-MOD</b></a></a> <p>
+<p><b>Syntax:</b><p>
+
+<p><b>expt-mod</b> <i>n exponent divisor</i> => <i>result</i>
+<p>
+<p><b>Arguments and Values:</b><p>
+<p>
+<i>n</i>---a <i>number</i></a>. <p>
+
+<i>exponent</i>---a <i>number</i></a>. <p>
+
+<i>divisor</i>---a <i>number</i></a>. <p>
+
+<i>result</i>---a <i>number</i></a>. <p>
+
+<p>
+<p><b>Description:</b><p>
+<p>
+<b>expt-mod</b> returns <i>n</i> raised to the <i>exponent</i> power,
+modulo <i>divisor</i>. <tt>(expt-mod n exponent divisor)</tt> is
+equivalent to <tt>(mod (expt n exponent) divisor)</tt>.
+
+<p>
+<p><b>Exceptional situations:</b><p>
+<p>
+
+<p>The exceptional situations are the same as those for <tt>(mod (expt
+n exponent) divisor)</tt>.
+
+<p><p><b>Notes:</b></p>
+
+<p>One might wonder why we shouldn't simply write <tt>(mod (expt n
+exponent) divisor)</tt>. This function exists because the naïve
+way of evaluating <tt>(mod (expt n exponent) divisor)</tt> produces a
+gigantic intermediate result, which kills performance in applications
+which use this operation heavily. The operation can be done much more
+efficiently. Usually the compiler does this optimization
+automatically, producing very fast code. However, we can't
+<i>depend</i> on this behavior if we want to produce code that is
+guaranteed not to perform abysmally on some Lisp implementations.
+
+<p>Therefore cl-utilities provides a standard interface to this
+composite operation which uses mediocre code by default. Specific
+implementations can usually do much better, but some do much
+worse. We can get the best of both by simply using the same interface
+and doing read-time conditionalization within cl-utilities to get
+better performance on compilers like SBCL and Allegro CL which
+optimize this operation.
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: trunk/lib/cl-utilities-1.2.4/doc/extremum.html
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/doc/extremum.html Mon Oct 19 17:28:31 2009
@@ -0,0 +1,155 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Function EXTREMUM, EXTREMA, N-MOST-EXTREME</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Function</i> <b>EXTREMUM, EXTREMA, N-MOST-EXTREME</b></a></a> <p>
+<p><b>Syntax:</b><p>
+
+<p>
+
+<p><b>extremum</b> <i>sequence predicate <tt>&key</tt> key (start 0) end</i> => <i>morally-smallest-element</i><p>
+<p><b>extrema</b> <i>sequence predicate <tt>&key</tt> key (start 0) end</i> => <i>morally-smallest-elements</i><p>
+<p><b>n-most-extreme</b> <i>n sequence predicate <tt>&key</tt> key (start 0) end</i> => <i>n-smallest-elements</i><p>
+<p>
+<p><b>Arguments and Values:</b><p>
+<p>
+<i>sequence</i>---a <i>proper sequence</i></a>. <p>
+
+<i>predicate</i>---a <i>designator</i> for a <i>function</i> of two
+arguments that returns a <i>generalized boolean</i>. <p>
+
+<i>key</i>---a <i>designator</i> for a <i>function</i> of one
+argument, or <b>nil</b>. <p>
+
+<i>start, end</i>---bounding index designators of <i>sequence</i>. The
+defaults for start and end are 0 and <b>nil</b>, respectively.<p>
+
+<i>morally-smallest-element</i>---the element of <i>sequence</i> that
+would appear first if the sequence were ordered according to <a
+class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/fun_sortcm_stable-sort.html"><b>sort</b></a>
+using <i>predicate</i> and <i>key</i>
+
+<p><i>morally-smallest-elements</i>---the identical elements of
+<i>sequence</i> that would appear first if the sequence were ordered
+according to <a class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/fun_sortcm_stable-sort.html"><b>sort</b></a>
+using <i>predicate</i> and <i>key</i>. If <i>predicate</i> states that
+neither of two objects is before the other, they are considered
+identical.
+
+<i>n</i>---a positive integer<p>
+
+<i>n-smallest-elements</i>---the <i>n</i> elements of <i>sequence</i> that
+would appear first if the sequence were ordered according to <a
+class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/fun_sortcm_stable-sort.html"><b>sort</b></a>
+using <i>predicate</i> and <i>key</i>
+
+<p>
+<p><b>Description:</b><p>
+<p>
+<b>extremum</b> returns the element of <i>sequence</i> that would
+appear first if the subsequence of <i>sequence</i> specified by
+<i>start</i> and <i>end</i> were ordered according to <a
+class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/fun_sortcm_stable-sort.html"><b>sort</b></a>
+using <i>predicate</i> and <i>key</i>.
+
+
+<p><p><b>extremum</b> determines the relationship between two elements
+by giving keys extracted from the elements to the
+<i>predicate</i>. The first argument to the <i>predicate</i> function
+is the part of one element of <i>sequence</i> extracted by the
+<i>key</i> function (if supplied); the second argument is the part of
+another element of <i>sequence</i> extracted by the <i>key</i>
+function (if supplied). <i>Predicate</i> should return <i>true</i> if
+and only if the first argument is strictly less than the second (in
+some appropriate sense). If the first argument is greater than or
+equal to the second (in the appropriate sense), then the
+<i>predicate</i> should return <i>false</i>. <p>
+
+<p>The argument to the <i>key</i> function is the <i>sequence</i>
+element. The return value of the <i>key</i> function becomes an
+argument to <i>predicate</i>. If <i>key</i> is not supplied or
+<b>nil</b>, the <i>sequence</i> element itself is used. There is no
+guarantee on the number of times the <i>key</i> will be called. <p>
+
+<p>If the <i>key</i> and <i>predicate</i> always return, then the
+operation will always terminate. This is guaranteed even if the
+<i>predicate</i> does not really consistently represent a total order
+(in which case the answer may be wrong). If the <i>key</i>
+consistently returns meaningful keys, and the <i>predicate</i> does
+reflect some total ordering criterion on those keys, then the answer
+will be right <p>
+
+<p>The <i>predicate</i> is assumed to consider two elements <tt>x</tt>
+and <tt>y</tt> to be equal if <tt>(funcall </tt><i>predicate</i><tt>
+</tt><i>x</i><tt> </tt><i>y</i><tt>)</tt> and <tt>(funcall
+</tt><i>predicate</i><tt> </tt><i>y</i><tt> </tt><i>x</i><tt>)</tt>
+are both <i>false</i>.
+
+
+<p>The return value of <tt>(extremum predicate sequence :key key)</tt>
+can be defined as <tt>(elt (<a class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/fun_sortcm_stable-sort.html"><b>sort</b></a>
+predicate (subseq sequence start end) :key key) 0)</tt> except when
+<i>sequence</i> is empty (see Exceptional Situations), but may use
+faster (less asymptotically complex) algorithms to find this answer.
+
+<p><b>extrema</b> is similar to <b>extremum</b>, but it returns a list
+of values. There can be more than one extremum, as determined by
+<i>predicate</i>, and with <b>extremum</b> the choice of which
+extremum to return is arbitrary. <b>extrema</b> returns all the
+possible values which <i>predicate</i> determines to be equal.
+
+<p><b>n-most-extreme</b> returns a list of <i>n</i> values without
+testing for equality. It orders <i>sequence</i> in the same way as
+<b>extremum</b> and <b>extrema</b>, then returns the first <i>n</i>
+elements of the sorted sequence.
+
+<p>
+<p><b>Exceptional situations:</b><p>
+<p>
+
+<p>If <i>sequence</i> is empty, then the error <i>no-extremum</i> is
+signalled. Invoking the <b>continue</b> restart will cause
+<b>extremum</b> to return <b>nil</b>.
+
+
+<p>Should be prepared to signal an error of type <b>type-error</b> if
+<i>sequence</i> is not a proper sequence.
+
+<p>If there are fewer than <i>n</i> values in the part of
+<i>sequence</i> that <b>n-most-extreme</b> may operate on, it returns
+all the values it can in sorted order and signals the warning
+<b>n-most-extreme-not-enough-elements</b>. This warning stores the
+given values for <i>n</i> and the relevant subsequence, and they may
+be accessed with <b>n-most-extreme-not-enough-elements-n</b> and
+<b>n-most-extreme-not-enough-elements-subsequence</b>, respectively.
+
+<p><p><b>Implementation notes:</b></p>
+
+<p>There are two implementations of this function included in
+cl-utilities, which should only concern you if you want to squeeze out
+more efficiency, since the versions perform differently on different
+inputs.
+
+<p>The function <b>extremum-fastkey</b> is used exactly like
+<b>extremum</b>, but it calls <i>key</i> fewer times. If <i>key</i> is
+fast, <b>extremum-fastkey</b> is slower than regular <b>extremum</b>,
+but if <i>key</i> is hard to compute you can get significant gains in
+speed. The <b>extremum-fastkey</b> function is more complicated than
+<b>extremum</b>, and therefore may be more likely to contain
+bugs. That said, it doesn't seem buggy.</p>
+
+<p>Don't worry about the performance of passing <tt>#'identity</tt> as
+<i>key</i>. This is optimized by a compiler macro.</p>
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: trunk/lib/cl-utilities-1.2.4/doc/index.html
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/doc/index.html Mon Oct 19 17:28:31 2009
@@ -0,0 +1,58 @@
+<html>
+<head>
+ <title>cl-utilities manual</title>
+ <link rel="stylesheet" href="style.css" type="text/css" />
+</head>
+<body>
+
+<h1>cl-utilities manual</h1>
+
+<p>Everybody writes some utilities because they're not part of the
+standard but they're so broadly useful. This results in a lot of wheel
+reinvention, and most reinventions are not as good as they should
+be. The cl-utilities project is an actively maintained collection of
+some of these utilities, with high-quality public-domain
+implementations and decent documentation.
+
+<h2>Table of contents:</h2>
+
+<ul style="list-style-type: none;">
+
+<li><a href="split-sequence.html">SPLIT-SEQUENCE, SPLIT-SEQUENCE-IF,
+SPLIT-SEQUENCE-IF-NOT</a>. Used for splitting sequences.</li>
+
+<li><a href="extremum.html">EXTREMUM, EXTREMA,
+N-MOST-EXTREME</a>: Finding extreme values in sequences based on
+user-defined criteria.</li>
+
+<li><a href="read-delimited.html">READ-DELIMITED</a> reads from a
+sequence delimited somehow, in a somewhat inconvenient but hopefully
+efficient way.</li>
+
+<li><a href="expt-mod.html">EXPT-MOD</a>, an interface for calculating
+<tt>(mod (expt n e) m)</tt> efficiently across implementations.</li>
+
+<li><a href="with-unique-names.html">WITH-UNIQUE-NAMES, née
+WITH-GENSYMS</a>. A classic macro-writing macro for preventing
+variable capture.</li>
+
+<li><a href="collecting.html">COLLECTING, WITH-COLLECTORS</a>. Some
+macros for clearly and efficiently collecting items into lists.</li>
+
+<li><a href="once-only.html">ONCE-ONLY</a>, a classic macro-writing
+macro for preventing multiple evaluation.</li>
+
+<li><a href="rotate-byte.html">ROTATE-BYTE</a> rotates bits in a byte</li>
+
+<li><a href="copy-array.html">COPY-ARRAY</a> shallow copies arrays.</li>
+
+<li><a href="compose.html">COMPOSE</a>. Composes functions.</li>
+
+</ul>
+
+<p><hr>Public domain, maintained by <a
+href="mailto:sketerpot at gmail.com">Peter Scott</a>. For more information, see
+the <a href="http://common-lisp.net/project/cl-utilities/">home page</a>.
+
+</body>
+</html>
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/doc/once-only.html
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/doc/once-only.html Mon Oct 19 17:28:31 2009
@@ -0,0 +1,40 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/transitional.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Macro ONCE-ONLY</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Macro</i> <b>ONCE-ONLY</b></a></a> <p>
+<p><b>Syntax:</b><p>
+
+<p>
+
+<p><b>once-only</b> <i>(name*) form*</i>
+<p>
+<p><b>Arguments and Values:</b><p>
+<p>
+<i>name</i>---a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/glo_s.html#symbol"><i>symbol</i></a></a>. <p>
+
+<i>form</i>---a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/glo_f.html#form"><i>form</i></a></a>. <p>
+
+<p>
+<p><b>Description:</b><p>
+<p>Meant to be used in macro code, <b>once-only</b> guards against
+multiple evaluation of its arguments in macroexpansion code. Any
+concise description would be far too vague to grasp, but <a
+href="http://groups.google.com/group/comp.lang.lisp/browse_frm/thread/1783554653afad7f/f6357129c8c1c002?rnum=1&_done=%2Fgroup%2Fcomp.lang.lisp%2Fbrowse_frm%2Fthread%2F1783554653afad7f%2F940b6ebd2d1757f4%3F#doc_f6357129c8c1c002">this
+thread on comp.lang.lisp</a> does a decent job of explaining what
+<b>once-only</b> does.
+
+<p><p><b>Notes:</b></p>
+
+<p>The description here is frustratingly non-descriptive, and I
+apologize for that. If you understand <b>once-only</b> and can give a
+better explanation, I would be very grateful—not to mention
+completely awed.
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: trunk/lib/cl-utilities-1.2.4/doc/read-delimited.html
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/doc/read-delimited.html Mon Oct 19 17:28:31 2009
@@ -0,0 +1,88 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Function READ-DELIMITED</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Function</i> <b>READ-DELIMITED</b></p>
+
+<p><p><b>Syntax:</b></p>
+
+<p><p><b>read-delimited</b> <i>sequence stream <tt>&key </tt> start end delimiter test key</i> => <i>position, delimited-p</i></p>
+
+<p><p><b>Arguments and Values:</b></p>
+
+<p><p><i>sequence</i>---a <i>sequence</i>.</p>
+
+<p><i>stream</i>---an <i>input stream</i>.</p>
+<p><i>start, end</i>---<i>bounding index designators</i> of
+<i>sequence</i>. The defaults for <i>start</i> and <i>end</i> are 0
+and <b>nil</b>, respectively.
+
+<p><i>delimiter</i>---a <i>character</i>. It defaults to #\newline.</p>
+<p><i>test</i>---a <i>designator</i> for a <i>function</i> of two
+<i>arguments</i> that returns a <i>generalized boolean</i>.</p>
+
+<p><i>key</i>---a <i>designator</i> for a <i>function</i> of one
+argument, or <b>nil</b>.</p>
+<p><i>position</i>---an <i>integer</i> greater than or equal to zero,
+and less than or equal to the <i>length</i> of the sequence.</p>
+
+<p><i>delimited-p</i>---the result of the last invokation of <i>test</i></p>
+
+<p><p><b>Description:</b></p>
+
+<p><p>Destructively modifies <i>sequence</i> by replacing
+<i>elements</i> of <i>sequence</i> <i>bounded</i> by <i>start</i> and
+<i>end</i> with <i>elements</i> read from <i>stream</i>.</p>
+
+<p><p><i>Test</i> is called with the actual read character, converted
+by applying <i>key</i> to it, as the first and <i>delimiter</i> as the
+second argument.</p>
+
+<p><p>If a character is read for which (funcall <i>test</i> (funcall
+<i>key</i> <b>char</b>) <i>delimiter</i>) is non-nil,
+<b>read-delimited</b> terminates the copying even before reaching
+<i>end of file</i> or the <i>end</i> of the <i>bounding
+designator</i>.</p>
+
+<p><p><b>read-delimited</b> returns the index of the first
+<i>element</i> of <i>sequence</i> that was not updated as the first
+and the result of the last invokation of <i>test</i> as the second
+value.</p>
+
+<p><p><i>Sequence</i> is destructively modified by copying successive
+<i>elements</i> into it from <i>stream</i>. If the <i>end of file</i>
+for <i>stream</i> is reached before copying all <i>elements</i> of the
+subsequence, then the extra <i>elements</i> near the end of
+<i>sequence</i> are not updated.</p>
+
+<p><b>Exceptional situations:</b>
+
+<p>If <i>start</i> and/or <i>end</i> are out of bounds, or if
+<i>start</i> > <i>end</i>, then a
+<b>read-delimited-bounds-error</b> error is signalled. This error is
+passed the values of <i>start</i>, <i>end</i>, and <i>sequence</i>,
+which can be read with <b>read-delimited-bounds-error-start</b>,
+<b>read-delimited-bounds-error-end</b>, and
+<b>read-delimited-bounds-error-sequence</b>,
+respectively.
+
+<p><p><b>Implementation notes:</b></p>
+
+<p>This is one of the more complex utilities, and the amount of
+argument checking needed to do it properly is daunting. An amazing 76%
+of the code is spent on making sure that the bounds are valid and in
+order, and on what to do if they aren't. Once you remove all that, the
+actual function which does all the work is quite simple, and unlikely
+to contain bugs.</p>
+
+<p>The design of this function makes it a little annoying to use, but
+it is more efficient. If you need something more high-level, this
+could be built on top of <b>read-delimited</b> fairly easily.</p>
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: trunk/lib/cl-utilities-1.2.4/doc/rotate-byte.html
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/doc/rotate-byte.html Mon Oct 19 17:28:31 2009
@@ -0,0 +1,65 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Function ROTATE-BYTE</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Function</i> <b>ROTATE-BYTE</b></a></a> <p>
+<p><b>Syntax:</b><p>
+
+<p>
+
+<p><b>rotate-byte</b> <i>count bytespec integer</i> => <i>result</i>
+<p>
+<p><b>Arguments and Values:</b><p>
+<p>
+<i>count</i>---an <i>integer</i></a>. <p>
+
+<i>bytespec</i>---a <i>byte specifier</i></a>. <p>
+
+<i>integer</i>---an <i>integer</i></a>. <p>
+
+<i>result</i>---an <i>integer</i></a>. <p>
+
+<p>
+<p><b>Description:</b><p>
+
+<p>Rotates a field of bits within <i>integer</i>; specifically, returns an
+integer that contains the bits of <i>integer</i> rotated <i>count</i> times
+leftwards within the byte specified by <i>bytespec</i>, and elsewhere
+contains the bits of <i>integer</i>.</p>
+
+<p><p><b>Examples:</b></p>
+<pre>
+(rotate-byte 3 (byte 32 0) 3) => 24
+(rotate-byte 3 (byte 5 5) 3) => 3
+(rotate-byte 6 (byte 8 0) -3) => -129
+</pre>
+
+<p><p><b>Side Effects:</b> None.</p>
+
+<p><p><b>Affected By:</b> None.</p>
+
+<p><p><b>Exceptional Situations:</b> None.</p>
+
+<p><p><b>See Also:</b></p>
+
+<p><a class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/fun_bytecm_by_yte-position.html"><b>byte</b></a>,
+<a class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/fun_dpb.html"><b>dpb</b></a>, <a
+class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/acc_ldb.html"><b>ldb</b></a>
+
+<p><b>Implementation notes</b>
+
+<p>SBCL provides the sb-rotate-byte extension to do this
+efficiently. On SBCL, cl-utilities uses this extension
+automatically. On other implementations, portable Common Lisp code is
+used instead.
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: trunk/lib/cl-utilities-1.2.4/doc/split-sequence.html
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/doc/split-sequence.html Mon Oct 19 17:28:31 2009
@@ -0,0 +1,106 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Function SPLIT-SEQUENCE, SPLIT-SEQUENCE-IF, SPLIT-SEQUENCE-IF-NOT</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Function</i> <b>SPLIT-SEQUENCE, SPLIT-SEQUENCE-IF, SPLIT-SEQUENCE-IF-NOT</b></p>
+
+<p><p><b>Syntax:</b></p>
+
+<p><p><b>split-sequence</b> <i>delimiter sequence <tt>&key</tt> count remove-empty-subseqs from-end start end test test-not key</i> => <i>list, index</i></p>
+<p><p><b>split-sequence-if</b> <i>predicate sequence <tt>&key</tt> count remove-empty-subseqs from-end start end key</i> => <i>list, index</i></p>
+
+<p><p><b>split-sequence-if-not</b> <i>predicate sequence <tt>&key</tt> count remove-empty-subseqs from-end start end key</i> => <i>list, index</i></p>
+
+<p><p><b>Arguments and Values:</b></p>
+
+<p><p><i>delimiter</i>---an <i>object</i>.</p>
+
+<p><i>predicate</i>---a <i>designator</i> for a <i>function</i> of one <i>argument</i> that returns a <i>generalized boolean</i>.</p>
+<p><i>sequence</i>---a <i>proper sequence</i>.</p>
+
+<p><i>count</i>---an <i>integer</i> or <b>nil</b>. The default is <b>nil</b>.</p>
+<p><i>remove-empty-subseqs</i>---a <i>generalized boolean</i>. The default is <i>false</i>.</p>
+
+<p><i>from-end</i>---a <i>generalized boolean</i>. The default is <i>false</i>.</p>
+<p><i>start, end</i>---<i>bounding index designators</i> of <i>sequence</i>. The defaults for </i>start</i> and <i>end</i> are <tt>0</tt> and <b>nil</b>, respectively.</p>
+
+<p><i>test</i>---a <i>designator</i> for a <i>function</i> of two <i>arguments</i> that returns a <i>generalized boolean</i>.</p>
+<p><i>test-not</i>---a <i>designator</i> for a <i>function</i> of two <i>arguments</i> that returns a <i>generalized boolean</i>.</p>
+
+<p><i>key</i>---a <i>designator</i> for a <i>function</i> of one <i>argument</i>, or <b>nil</b>.</p>
+<p><i>list</i>---a <i>proper sequence</i>.</p>
+
+<p><i>index</i>---an <i>integer</i> greater than or equal to zero, and less than or equal to the <i>length</i> of the <i>sequence</i>.</p>
+
+<p><p><b>Description:</b></p>
+
+<p><p>Splits <i>sequence</i> into a list of subsequences delimited by objects <i>satisfying the test</i>.
+
+
+<p><i>List</i> is a list of sequences of the same kind as <i>sequence</i> that has elements consisting of subsequences of <i>sequence</i> that were delimited in the argument by elements <i>satisfying the test</i>. <i>Index</i> is an index into <i>sequence</i> indicating the unprocessed region, suitable as an argument to <a class="hyperspec" href =" http://www.lispworks.com/documentation/HyperSpec/Body/acc_subseq.html"><b>subseq</b></a> to continue processing in the same manner if desired.
+
+
+<p>The <i>count</i> argument, if supplied, limits the number of subsequences in the first return value; if more than <i>count</i> delimited subsequences exist in <i>sequence</i>, the <i>count</i> leftmost delimited subsequences will be in order in the first return value, and the second return value will be the index into <i>sequence</i> at which processing stopped.
+
+<p>If <i>from-end</i> is non-null, <i>sequence</i> is conceptually processed from right to left, accumulating the subsequences in reverse order; <i>from-end</i> only makes a difference in the case of a non-null <i>count</i> argument. In the presence of <i>from-end</i>, the <i>count</i> rightmost delimited subsequences will be in the order that they are in <i>sequence</i> in the first return value, and the second is the index indicating the end of the unprocessed region.
+
+
+<p>The <i>start</i> and <i>end</i> keyword arguments permit a certain subsequence of the <i>sequence</i> to be processed without the need for a copying stage; their use is conceptually equivalent to partitioning the subsequence delimited by <i>start</i> and <i>end</i>, only without the need for copying.
+
+<p>If <i>remove-empty-subseqs</i> is null (the default), then empty subsequences will be included in the result.
+
+
+<p>In all cases, the subsequences in the first return value will be in the order that they appeared in <i>sequence</i>.
+
+<p><p><b>Examples:</b></p>
+
+<p><pre>
+ (split-sequence:SPLIT-SEQUENCE #\Space "A stitch in time saves nine.")
+=> ("A" "stitch" "in" "time" "saves" "nine.")
+ 28
+ (split-sequence:SPLIT-SEQUENCE #\, "foo,bar ,baz, foobar , barbaz,")
+=> ("foo" "bar " "baz" " foobar " " barbaz" "")
+ 30
+</pre>
+
+<p><p><b>Implementation notes:</b></p>
+
+<p>This code was written various people, and the license is
+unknown. Since multiple people worked on it collaboratively and none
+of them seem interested in keeping their intellectual property rights
+to it, I'll assume that it is in the public domain (since the process
+that produced it seems like the very essence of public domain). If
+this is incorrect, please <a href="mailto:sketerpot at gmail.com">contact
+me</a> so we can get it straightened out.</p>
+
+<p>The implementation itself is mature and well tested, and it is
+widely used. The code should be fast enough for most people, but be
+warned: it was written with vectors in mind, with list manipulation as
+an afterthought. It does a lot of things that are quick on vectors but
+slow on lists, and this can result in many orders of magnitude
+slowdown in list benchmarks versus code written for lists. If this is
+a problem for you, it should be straightforward to write your own,
+such as the (more limited, not API compatible) example function given
+by Szymon in <a
+href="http://common-lisp.net/pipermail/cl-utilities-devel/2006-May/000011.html">this
+mailing list post</a>:</p>
+
+<p><pre>
+(defun split-list-if (test list &aux (start list) (end list))
+ (loop while (and end (setq start (member-if-not test end)))
+ collect (ldiff start (setq end (member-if test start)))))
+</pre></p>
+
+<p>If this is an issue for enough people, I could optimize the code
+and fix this problem. I'm reluctant to do that, however, since the
+code works and is tested. It's usually more important to be correct
+and non-buggy than to be fast, and I have been known to introduce
+bugs.</p>
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: trunk/lib/cl-utilities-1.2.4/doc/style.css
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/doc/style.css Mon Oct 19 17:28:31 2009
@@ -0,0 +1,16 @@
+pre {
+ margin-right: 0.5cm;
+ border: thin black solid;
+ background: #F3EEEE;
+ padding: 0.5em;
+}
+
+h1 {
+ font-family: sans-serif;
+ font-variant: small-caps;
+}
+
+h2 {
+ font-family: sans-serif;
+ font-size: medium;
+}
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/doc/with-unique-names.html
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/doc/with-unique-names.html Mon Oct 19 17:28:31 2009
@@ -0,0 +1,104 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Macro WITH-UNIQUE-NAMES</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><i>Macro</i> <b>WITH-UNIQUE-NAMES</b></p><p><b>Syntax:</b></p><p>
+
+<b>with-unique-names</b> <i>({<i>var</i> | (<i>var</i>
+ <i>prefix</i>)}<b>*</b>) <i>declaration</i><b>*</b>
+ <i>form</i><b>*</b></i> => <i><i>result</i><b>*</b></i>
+
+
+ </p><p><b>Arguments and Values:</b></p><p>
+ <p><i>var</i>---a <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol"><i>symbol</i></a>;
+ not <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_e.htm#evaluate"><i>evaluate</i></a>d.</p>
+ <p><i>prefix</i>---a <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#string_designator"><i>string designator</i></a>; not
+ <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_e.htm#evaluate"><i>evaluate</i></a>d. The default is <i>var</i>.</p>
+
+ <p><i>declaration</i>---a <a href ="
+ http://www.lispworks.com/documentation/HyperSpec/Body/sym_declare.html"><b>declare</b></a>
+ <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_e.htm#expression"><i>expression</i></a>;
+ not <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_e.htm#evaluate"><i>evaluate</i></a>d.</p>
+ <p><i>form</i>---a <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#form"><i>form</i></a>.</p>
+ <p><i>results</i>---the <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_v.htm#value"><i>value</i></a>s
+ <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_r.htm#return"><i>return</i></a>ed by the <i>form</i>s.</p>
+
+ </p><p><b>Description:</b></p><p> <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_e.htm#Execute"><i>Execute</i></a>s
+ a series of <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#form"><i>form</i></a>s
+ with each
+ <i>var</i> <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_b.htm#bound"><i>bound</i></a> to a <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#fresh"><i>fresh</i></a>,
+ <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_u.htm#uninterned"><i>uninterned</i></a> <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol"><i>symbol</i></a>. The
+ <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_u.htm#uninterned"><i>uninterned</i></a> <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol"><i>symbol</i></a> is created as if by
+ a <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#call"><i>call</i></a> to <a href =" http://www.lispworks.com/documentation/HyperSpec/Body/fun_gensym.html"><b>gensym</b></a> with the
+ <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#string"><i>string</i></a> denoted by <i>prefix</i>---or, if
+ <i>prefix</i> is not supplied, the <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#string"><i>string</i></a>
+
+ denoted by <i>var</i>---as <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#argument"><i>argument</i></a>.
+ <p></p> The <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_v.htm#variable"><i>variable</i></a>
+ <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_b.htm#binding"><i>binding</i></a>s
+ created are <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_l.htm#lexical"><i>lexical</i></a>
+ unless <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/dec_specia.htm#special"><b>special</b></a>
+
+ <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_d.htm#declaration"><i>declaration</i></a>s are specified.
+ <p></p>
+ The <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#form"><i>form</i></a>s are <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_e.htm#evaluate"><i>evaluate</i></a>d in order, and
+ the <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_v.htm#value"><i>value</i></a>s of all but the last are discarded (that
+ is, the body is an <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_i.htm#implicit_progn"><i>implicit progn</i></a>).
+ </p><p><b>Examples:</b></p><p>
+<pre>
+
+ (with-unique-names (sym1) sym1) => #:SYM13142
+ (with-unique-names ((sym1 "SYM1-")) sym1) => #:SYM1-3143
+ (find-symbol "SYM1-3143") => NIL, NIL
+ (with-unique-names ((sym #\Q)) sym) => #:Q3144
+ (with-unique-names ((sym1 :sym1-)) sym1) => #:SYM1-3145
+ (with-unique-names (sym1) (symbol-package sym1)) => NIL
+ (with-unique-names (sym8) (eq sym8 sym8)) => T
+ (with-unique-names (sym9) (set sym9 42) (symbol-value sym9)) => 42
+</pre>
+
+ </p><p><b>Side Effects:</b></p><p>
+ Might increment <a href =" http://www.lispworks.com/documentation/HyperSpec/Body/var_stgensym-counterst.html"><b>*gensym-counter*</b></a> once for each
+ <i>var</i>.
+ </p><p><b>Affected by:</b></p><p> <a href ="
+ http://www.lispworks.com/documentation/HyperSpec/Body/var_stgensym-counterst.html"><b>*gensym-counter*</b></a>
+
+ </p><p><b>Exceptional Situations:</b></p><p>
+ None.
+ </p><p><b>See Also:</b></p><p>
+<a href =" http://www.lispworks.com/documentation/HyperSpec/Body/fun_gensym.html"><b>gensym</b></a>, <a href =" http://www.lispworks.com/documentation/HyperSpec/Body/speope_letcm_letst.html"><b>let</b></a></b>
+ </p>
+ </p>
+
+<p><b>Notes:</b>
+<p>This is an extension of the classic macro <b>with-gensyms</b>. In
+fact, cl-utilities also exports <b>with-gensyms</b>, and it can be
+used as usual. The exported <b>with-gensyms</b> is actually just an
+alias for <b>with-unique-names</b> which gives a warning at
+compile-time if the extensions of <b>with-unique-names</b> are used.
+
+<p>You are encouraged to use <b>with-unique-names</b> instead of
+<b>with-gensyms</b> because it is a little more flexible and because
+it tells what is going on rather than how it works. This is a somewhat
+controversial point, so go ahead and use whichever you like if you
+have an opinion on it. But if you're a newbie who honestly doesn't
+care, please use <b>with-unique-names</b>.
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</BODY>
+</HTML>
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/expt-mod.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/expt-mod.lisp Mon Oct 19 17:28:31 2009
@@ -0,0 +1,38 @@
+(in-package :cl-utilities)
+
+;; This is portable Common Lisp, but implementation-specific code may
+;; improve performance considerably.
+(defun expt-mod (n exponent modulus)
+ "As (mod (expt n exponent) modulus), but more efficient."
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ ;; It's much faster on SBCL and ACL to use the simple method, and
+ ;; trust the compiler to optimize it. This may be the case on other
+ ;; Lisp implementations as well.
+ #+(or sbcl allegro) (mod (expt n exponent) modulus)
+ #-(or sbcl allegro)
+ (if (some (complement #'integerp) (list n exponent modulus))
+ (mod (expt n exponent) modulus)
+ (loop with result = 1
+ for i of-type fixnum from 0 below (integer-length exponent)
+ for sqr = n then (mod (* sqr sqr) modulus)
+ when (logbitp i exponent) do
+ (setf result (mod (* result sqr) modulus))
+ finally (return result))))
+
+;; If the compiler is going to expand compiler macros, we should
+;; directly inline the simple expansion; this lets the compiler do all
+;; sorts of fancy optimizations based on type information that
+;; wouldn't be used to optimize the normal EXPT-MOD function.
+#+(or sbcl allegro)
+(define-compiler-macro expt-mod (n exponent modulus)
+ `(mod (expt ,n ,exponent) ,modulus))
+
+
+;; Here's some benchmarking code that may be useful. I probably
+;; completely wasted my time declaring ITERATIONS to be a fixnum.
+#+nil
+(defun test (&optional (iterations 50000000))
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))
+ (fixnum iterations))
+ (time (loop repeat iterations do (mod (expt 12 34) 235)))
+ (time (loop repeat iterations do (expt-mod 12 34 235))))
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/extremum.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/extremum.lisp Mon Oct 19 17:28:31 2009
@@ -0,0 +1,167 @@
+(in-package :cl-utilities)
+
+(define-condition no-extremum (error) ()
+ (:report "Cannot find extremum of empty sequence")
+ (:documentation "Raised when EXTREMUM is called on an empty
+sequence, since there is no morally smallest element"))
+
+(defun comparator (test &optional (key #'identity))
+ "Comparison operator: auxilliary function used by EXTREMUM"
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (lambda (a b) (if (funcall test
+ (funcall key a)
+ (funcall key b))
+ a
+ b)))
+
+;; This optimizes the case where KEY is #'identity
+(define-compiler-macro comparator (&whole whole test
+ &optional (key #'identity))
+ (if (eql key #'identity)
+ `(lambda (a b)
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (if (funcall ,test a b) a b))
+ whole))
+
+;; The normal way of testing the if length of a proper sequence equals
+;; zero is to just use (zerop (length sequence)). And, while some
+;; implementations may optimize this, it's probably a good idea to
+;; just write an optimized version and use it. This method can speed
+;; up list length testing.
+(defun zero-length-p (sequence)
+ "Is the length of SEQUENCE equal to zero?"
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (or (null sequence)
+ (when (vectorp sequence)
+ (zerop (length sequence)))))
+
+(declaim (inline zero-length-p))
+
+;; Checks the length of the subsequence of SEQUENCE specified by START
+;; and END, and if it's 0 then a NO-EXTREMUM error is signalled. This
+;; should only be used in EXTREMUM functions.
+(defmacro with-check-length ((sequence start end) &body body)
+ (once-only (sequence start end)
+ `(if (or (zero-length-p ,sequence)
+ (>= ,start (or ,end (length ,sequence))))
+ (restart-case (error 'no-extremum)
+ (continue ()
+ :report "Return NIL instead"
+ nil))
+ (progn , at body))))
+
+;; This is an extended version which takes START and END keyword
+;; arguments. Any spec-compliant use of EXTREMUM will also work with
+;; this extended version.
+(defun extremum (sequence predicate
+ &key (key #'identity) (start 0) end)
+ "Returns the element of SEQUENCE that would appear first if the
+sequence were ordered according to SORT using PREDICATE and KEY using
+an unstable sorting algorithm. See http://www.cliki.net/EXTREMUM for
+the full specification."
+ (with-check-length (sequence start end)
+ (reduce (comparator predicate key) sequence
+ :start start :end end)))
+
+;; This optimizes the case where KEY is #'identity
+(define-compiler-macro extremum (&whole whole sequence predicate
+ &key (key #'identity) (start 0) end)
+ (if (eql key #'identity)
+ (once-only (sequence predicate start end)
+ `(with-check-length (,sequence ,start ,end)
+ (locally (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (reduce (comparator ,predicate) ,sequence
+ :start ,start :end ,end))))
+ whole))
+
+;; This is an "optimized" version which calls KEY less. REDUCE is
+;; already so optimized that this will actually be slower unless KEY
+;; is expensive. And on CLISP, of course, the regular version will be
+;; much faster since built-in functions are ridiculously faster than
+;; ones implemented in Lisp. Be warned, this isn't as carefully tested
+;; as regular EXTREMUM and there's more that could go wrong.
+(defun extremum-fastkey (sequence predicate
+ &key (key #'identity) (start 0) end)
+ "EXTREMUM implemented so that it calls KEY less. This is only faster
+if the KEY function is so slow that calling it less often would be a
+significant improvement; ordinarily it's slower."
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (with-check-length (sequence start end)
+ (let* ((smallest (elt sequence 0))
+ (smallest-key (funcall key smallest))
+ (current-index 0)
+ (real-end (or end (1- most-positive-fixnum))))
+ (declare (type (integer 0) current-index real-end start)
+ (fixnum current-index real-end start))
+ (map nil #'(lambda (x)
+ (when (<= start current-index real-end)
+ (let ((x-key (funcall key x)))
+ (when (funcall predicate
+ x-key
+ smallest-key)
+ (setf smallest x)
+ (setf smallest-key x-key))))
+ (incf current-index))
+ sequence)
+ smallest)))
+
+;; EXTREMA and N-MOST-EXTREME are based on code and ideas from Tobias
+;; C. Rittweiler. They deal with the cases in which you are not
+;; looking for a single extreme element, but for the extreme identical
+;; elements or the N most extreme elements.
+
+(defun extrema (sequence predicate &key (key #'identity) (start 0) end)
+ (with-check-length (sequence start end)
+ (let* ((sequence (subseq sequence start end))
+ (smallest-elements (list (elt sequence 0)))
+ (smallest-key (funcall key (elt smallest-elements 0))))
+ (map nil
+ #'(lambda (x)
+ (let ((x-key (funcall key x)))
+ (cond ((funcall predicate x-key smallest-key)
+ (setq smallest-elements (list x))
+ (setq smallest-key x-key))
+ ;; both elements are considered equal if the predicate
+ ;; returns false for (PRED A B) and (PRED B A)
+ ((not (funcall predicate smallest-key x-key))
+ (push x smallest-elements)))))
+ (subseq sequence 1))
+ ;; We use NREVERSE to make this stable (in the sorting algorithm
+ ;; sense of the word 'stable').
+ (nreverse smallest-elements))))
+
+
+
+(define-condition n-most-extreme-not-enough-elements (warning)
+ ((n :initarg :n :reader n-most-extreme-not-enough-elements-n
+ :documentation "The number of elements that need to be returned")
+ (subsequence :initarg :subsequence
+ :reader n-most-extreme-not-enough-elements-subsequence
+ :documentation "The subsequence from which elements
+must be taken. This is determined by the sequence and the :start and
+:end arguments to N-MOST-EXTREME."))
+ (:report (lambda (condition stream)
+ (with-slots (n subsequence) condition
+ (format stream "There are not enough elements in the sequence ~S~% to return the ~D most extreme elements"
+ subsequence n))))
+ (:documentation "There are not enough elements in the sequence given
+to N-MOST-EXTREME to return the N most extreme elements."))
+
+(defun n-most-extreme (n sequence predicate &key (key #'identity) (start 0) end)
+ "Returns a list of the N elements of SEQUENCE that would appear
+first if the sequence were ordered according to SORT using PREDICATE
+and KEY with a stable sorting algorithm. If there are less than N
+elements in the relevant part of the sequence, this will return all
+the elements it can and signal the warning
+N-MOST-EXTREME-NOT-ENOUGH-ELEMENTS"
+ (check-type n (integer 0))
+ (with-check-length (sequence start end)
+ ;; This is faster on vectors than on lists.
+ (let ((sequence (subseq sequence start end)))
+ (if (> n (length sequence))
+ (progn
+ (warn 'n-most-extreme-not-enough-elements
+ :n n :subsequence sequence)
+ (stable-sort (copy-seq sequence) predicate :key key))
+ (subseq (stable-sort (copy-seq sequence) predicate :key key)
+ 0 n)))))
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/once-only.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/once-only.lisp Mon Oct 19 17:28:31 2009
@@ -0,0 +1,31 @@
+;; The ONCE-ONLY macro is hard to explain, hard to understand, hard to
+;; write, hard to modify, and hard to live without once you figure out
+;; how to use it. It's used in macros to guard against multiple
+;; evaluation of arguments. My version is longer than most, but it
+;; does some error checking and it gives gensym'd variables more
+;; meaningful names than usual.
+
+(in-package :cl-utilities)
+
+(defun %check-once-only-names (names)
+ "Check that all of the NAMES are symbols. If not, raise an error."
+ ;; This only raises an error for the first non-symbol argument
+ ;; found. While this won't report multiple errors, it is probably
+ ;; more convenient to only report one.
+ (let ((bad-name (find-if-not #'symbolp names)))
+ (when bad-name
+ (error "ONCE-ONLY expected a symbol but got ~S" bad-name))))
+
+(defmacro once-only (names &body body)
+ ;; Check the NAMES list for validity.
+ (%check-once-only-names names)
+ ;; Do not touch this code unless you really know what you're doing.
+ (let ((gensyms (loop for name in names collect (gensym (string name)))))
+ `(let (,@(loop for g in gensyms
+ for name in names
+ collect `(,g (gensym ,(string name)))))
+ `(let (,,@(loop for g in gensyms for n in names
+ collect ``(,,g ,,n)))
+ ,(let (,@(loop for n in names for g in gensyms
+ collect `(,n ,g)))
+ , at body)))))
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/package.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/package.lisp Mon Oct 19 17:28:31 2009
@@ -0,0 +1,49 @@
+(defpackage :cl-utilities
+ (:use :common-lisp)
+ (:export #:split-sequence
+ #:split-sequence-if
+ #:split-sequence-if-not
+ #:partition
+ #:partition-if
+ #:partition-if-not
+
+ #:extremum
+ #:no-extremum
+ #:extremum-fastkey
+ #:extrema
+ #:n-most-extreme
+ #:n-most-extreme-not-enough-elements
+ #:n-most-extreme-not-enough-elements-n
+ #:n-most-extreme-not-enough-elements-subsequence
+
+ #:read-delimited
+ #:read-delimited-bounds-error
+ #:read-delimited-bounds-error-start
+ #:read-delimited-bounds-error-end
+ #:read-delimited-bounds-error-sequence
+
+ #:expt-mod
+
+ #:collecting
+ #:collect
+ #:with-collectors
+
+ #:with-unique-names
+ #:with-gensyms
+ #:list-binding-not-supported
+ #:list-binding-not-supported-binding
+
+ #:once-only
+
+ #:rotate-byte
+
+ #:copy-array
+
+ #:compose))
+
+#+split-sequence-deprecated
+(defpackage :split-sequence
+ (:documentation "This package mimics SPLIT-SEQUENCE for compatibility with
+packages that expect that system.")
+ (:use :cl-utilities)
+ (:export #:split-sequence #:split-sequence-if #:split-sequence-if-not))
Added: trunk/lib/cl-utilities-1.2.4/package.sh
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/package.sh Mon Oct 19 17:28:31 2009
@@ -0,0 +1,21 @@
+#!/bin/sh
+
+mkdir cl-utilities-1.2.4
+mkdir cl-utilities-1.2.4/doc
+cp cl-utilities.asd package.sh collecting.lisp split-sequence.lisp expt-mod.lisp package.lisp compose.lisp extremum.lisp read-delimited.lisp test.lisp copy-array.lisp once-only.lisp rotate-byte.lisp with-unique-names.lisp README cl-utilities-1.2.4/
+cp doc/collecting.html doc/expt-mod.html doc/read-delimited.html doc/with-unique-names.html doc/compose.html doc/extremum.html doc/rotate-byte.html doc/copy-array.html doc/index.html doc/split-sequence.html doc/once-only.html doc/style.css cl-utilities-1.2.4/doc/
+
+rm -f cl-utilities-latest.tar.gz cl-utilities-latest.tar.gz.asc
+
+tar -czvf cl-utilities-1.2.4.tar.gz cl-utilities-1.2.4/
+ln -s ~/hacking/lisp/cl-utilities/cl-utilities-1.2.4.tar.gz ~/hacking/lisp/cl-utilities/cl-utilities-latest.tar.gz
+gpg -b -a ~/hacking/lisp/cl-utilities/cl-utilities-1.2.4.tar.gz
+ln -s ~/hacking/lisp/cl-utilities/cl-utilities-1.2.4.tar.gz.asc ~/hacking/lisp/cl-utilities/cl-utilities-latest.tar.gz.asc
+rm -Rf cl-utilities-1.2.4/
+
+scp cl-utilities-1.2.4.tar.gz pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.2.4.tar.gz
+scp cl-utilities-1.2.4.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.2.4.tar.gz.asc
+scp cl-utilities-latest.tar.gz pscott at common-lisp.net:/project/cl-utilities/ftp/cl-utilities-1.2.4.tar.gz
+scp cl-utilities-latest.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/ftp/cl-utilities-1.2.4.tar.gz.asc
+scp cl-utilities-latest.tar.gz pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-latest.tar.gz
+scp cl-utilities-latest.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-latest.tar.gz.asc
Added: trunk/lib/cl-utilities-1.2.4/read-delimited.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/read-delimited.lisp Mon Oct 19 17:28:31 2009
@@ -0,0 +1,78 @@
+(in-package :cl-utilities)
+
+(defun read-delimited (sequence stream &key (start 0) end
+ (delimiter #\Newline) (test #'eql) (key #'identity))
+ ;; Check bounds on SEQUENCE
+ (multiple-value-setq (start end)
+ (%read-delimited-bounds-check sequence start end))
+ ;; Loop until we run out of input characters or places to put them,
+ ;; or until we encounter the delimiter.
+ (loop for index from start
+ for char = (read-char stream nil nil)
+ for test-result = (funcall test (funcall key char) delimiter)
+ while (and char
+ (< index end)
+ (not test-result))
+ do (setf (elt sequence index) char)
+ finally (return-from read-delimited
+ (values index test-result))))
+
+;; Conditions
+;;;;;;;;;;;;;
+
+(define-condition read-delimited-bounds-error (error)
+ ((start :initarg :start :reader read-delimited-bounds-error-start)
+ (end :initarg :end :reader read-delimited-bounds-error-end)
+ (sequence :initarg :sequence :reader read-delimited-bounds-error-sequence))
+ (:report (lambda (condition stream)
+ (with-slots (start end sequence) condition
+ (format stream "The bounding indices ~S and ~S are bad for a sequence of length ~S"
+ start end (length sequence)))))
+ (:documentation "There's a problem with the indices START and END
+for SEQUENCE. See CLHS SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR issue."))
+
+;; Error checking for bounds
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun %read-delimited-bounds-check (sequence start end)
+ "Check to make sure START and END are in bounds when calling
+READ-DELIMITED with SEQUENCE"
+ (check-type start (or integer null))
+ (check-type end (or integer null))
+ (let ((start (%read-delimited-bounds-check-start sequence start end))
+ (end (%read-delimited-bounds-check-end sequence start end)))
+ ;; Returns (values start end)
+ (%read-delimited-bounds-check-order sequence start end)))
+
+(defun %read-delimited-bounds-check-order (sequence start end)
+ "Check the order of START and END bounds, and return them in the
+correct order."
+ (when (< end start)
+ (restart-case (error 'read-delimited-bounds-error
+ :start start :end end :sequence sequence)
+ (continue ()
+ :report "Switch start and end"
+ (rotatef start end))))
+ (values start end))
+
+(defun %read-delimited-bounds-check-start (sequence start end)
+ "Check to make sure START is in bounds when calling READ-DELIMITED
+with SEQUENCE"
+ (when (and start (< start 0))
+ (restart-case (error 'read-delimited-bounds-error
+ :start start :end end :sequence sequence)
+ (continue ()
+ :report "Use default for START instead"
+ (setf start 0))))
+ start)
+
+(defun %read-delimited-bounds-check-end (sequence start end)
+ "Check to make sure END is in bounds when calling READ-DELIMITED
+with SEQUENCE"
+ (when (and end (> end (length sequence)))
+ (restart-case (error 'read-delimited-bounds-error
+ :start start :end end :sequence sequence)
+ (continue ()
+ :report "Use default for END instead"
+ (setf end nil))))
+ (or end (length sequence)))
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/rotate-byte.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/rotate-byte.lisp Mon Oct 19 17:28:31 2009
@@ -0,0 +1,29 @@
+(in-package :cl-utilities)
+
+(defun rotate-byte (count bytespec integer)
+ "Rotates a field of bits within INTEGER; specifically, returns an
+integer that contains the bits of INTEGER rotated COUNT times
+leftwards within the byte specified by BYTESPEC, and elsewhere
+contains the bits of INTEGER. See http://www.cliki.net/ROTATE-BYTE"
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ #-sbcl
+ (let ((size (byte-size bytespec)))
+ (when (= size 0)
+ (return-from rotate-byte integer))
+ (let ((count (mod count size)))
+ (labels ((rotate-byte-from-0 (count size integer)
+ (let ((bytespec (byte size 0)))
+ (if (> count 0)
+ (logior (ldb bytespec (ash integer count))
+ (ldb bytespec (ash integer (- count size))))
+ (logior (ldb bytespec (ash integer count))
+ (ldb bytespec (ash integer (+ count size))))))))
+ (dpb (rotate-byte-from-0 count size (ldb bytespec integer))
+ bytespec
+ integer))))
+ ;; On SBCL, we use the SB-ROTATE-BYTE extension.
+ #+sbcl-uses-sb-rotate-byte (sb-rotate-byte:rotate-byte count bytespec integer))
+
+;; If we're using the SB-ROTATE-BYTE extension, we should inline our
+;; call and let SBCL handle optimization from there.
+#+sbcl-uses-sb-rotate-byte (declaim (inline rotate-byte))
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/split-sequence.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/split-sequence.lisp Mon Oct 19 17:28:31 2009
@@ -0,0 +1,244 @@
+;;;; SPLIT-SEQUENCE
+;;;
+;;; This code was based on Arthur Lemmens' in
+;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>;
+;;;
+;;; changes include:
+;;;
+;;; * altering the behaviour of the :from-end keyword argument to
+;;; return the subsequences in original order, for consistency with
+;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only
+;;; affects the answer if :count is less than the number of
+;;; subsequences, by analogy with the above-referenced functions).
+;;;
+;;; * changing the :maximum keyword argument to :count, by analogy
+;;; with CL:REMOVE, CL:SUBSTITUTE, and so on.
+;;;
+;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather
+;;; than SPLIT.
+;;;
+;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT.
+;;;
+;;; * The second return value is now an index rather than a copy of a
+;;; portion of the sequence; this index is the `right' one to feed to
+;;; CL:SUBSEQ for continued processing.
+
+;;; There's a certain amount of code duplication here, which is kept
+;;; to illustrate the relationship between the SPLIT-SEQUENCE
+;;; functions and the CL:POSITION functions.
+
+;;; Examples:
+;;;
+;;; * (split-sequence #\; "a;;b;c")
+;;; -> ("a" "" "b" "c"), 6
+;;;
+;;; * (split-sequence #\; "a;;b;c" :from-end t)
+;;; -> ("a" "" "b" "c"), 0
+;;;
+;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1)
+;;; -> ("c"), 4
+;;;
+;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t)
+;;; -> ("a" "b" "c"), 6
+;;;
+;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra")
+;;; -> ("" "" "r" "c" "d" "" "r" ""), 11
+;;;
+;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra")
+;;; -> ("ab" "a" "a" "ab" "a"), 11
+;;;
+;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9)
+;;; -> ("oo" "bar" "b"), 9
+
+;; cl-utilities note: the license of this file is unclear, and I don't
+;; even know whom to contact to clarify it. If anybody objects to my
+;; assumption that it is public domain, please contact me so I can do
+;; something about it. Previously I required the split-sequence
+ ; package as a dependency, but that was so unwieldy that it was *the*
+;; sore spot sticking out in the design of cl-utilities. -Peter Scott
+
+(in-package :cl-utilities)
+
+(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by delimiter.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE. In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+ (let ((len (length seq))
+ (other-keys (nconc (when test-supplied
+ (list :test test))
+ (when test-not-supplied
+ (list :test-not test-not))
+ (when key-supplied
+ (list :key key)))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position delimiter seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position delimiter seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by items satisfying
+predicate.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE-IF. In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+ (let ((len (length seq))
+ (other-keys (when key-supplied
+ (list :key key))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position-if predicate seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position-if predicate seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by items satisfying
+(CL:COMPLEMENT predicate).
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular,
+the behaviour of :from-end is possibly different from other versions
+of this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped." ; Emacs syntax highlighting is broken, and this helps: "
+ (let ((len (length seq))
+ (other-keys (when key-supplied
+ (list :key key))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position-if-not predicate seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position-if-not predicate seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+;;; clean deprecation
+
+(defun partition (&rest args)
+ (apply #'split-sequence args))
+
+(defun partition-if (&rest args)
+ (apply #'split-sequence-if args))
+
+(defun partition-if-not (&rest args)
+ (apply #'split-sequence-if-not args))
+
+(define-compiler-macro partition (&whole form &rest args)
+ (declare (ignore args))
+ (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.")
+ form)
+
+(define-compiler-macro partition-if (&whole form &rest args)
+ (declare (ignore args))
+ (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.")
+ form)
+
+(define-compiler-macro partition-if-not (&whole form &rest args)
+ (declare (ignore args))
+ (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead")
+ form)
+
+(pushnew :split-sequence *features*)
Added: trunk/lib/cl-utilities-1.2.4/test.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/test.lisp Mon Oct 19 17:28:31 2009
@@ -0,0 +1,178 @@
+;; This file requires the FiveAM unit testing framework.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (asdf:oos 'asdf:load-op :fiveam)
+ (asdf:oos 'asdf:load-op :cl-utilities))
+
+;; To run all the tests:
+;; (5am:run! 'cl-utilities-tests::cl-utilities-suite)
+
+(defpackage :cl-utilities-tests
+ (:use :common-lisp :cl-utilities :5am))
+
+(in-package :cl-utilities-tests)
+
+(def-suite cl-utilities-suite :description "Test suite for cl-utilities")
+(in-suite cl-utilities-suite)
+
+;; These tests were taken directly from the comments at the top of
+;; split-sequence.lisp
+(test split-sequence
+ (is (tree-equal (values (split-sequence #\; "a;;b;c"))
+ '("a" "" "b" "c") :test #'equal))
+ (is (tree-equal (values (split-sequence #\; "a;;b;c" :from-end t))
+ '("a" "" "b" "c") :test #'equal))
+ (is (tree-equal (values (split-sequence #\; "a;;b;c" :from-end t :count 1))
+ '("c") :test #'equal))
+ (is (tree-equal (values (split-sequence #\; "a;;b;c" :remove-empty-subseqs t))
+ '("a" "b" "c") :test #'equal))
+ (is (tree-equal (values (split-sequence-if (lambda (x)
+ (member x '(#\a #\b)))
+ "abracadabra"))
+ '("" "" "r" "c" "d" "" "r" "") :test #'equal))
+ (is (tree-equal (values (split-sequence-if-not (lambda (x)
+ (member x '(#\a #\b)))
+ "abracadabra"))
+ '("ab" "a" "a" "ab" "a") :test #'equal))
+ (is (tree-equal (values (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9))
+ '("oo" "bar" "b") :test #'equal)))
+
+(test extremum
+ (is (= (extremum '(1 23 3 4 5 0) #'< :start 1 :end 4) 3))
+ (signals no-extremum (extremum '() #'<))
+ (is-false (handler-bind ((no-extremum #'continue))
+ (extremum '() #'<)))
+ (is (= (extremum '(2/3 2 3 4) #'> :key (lambda (x) (/ 1 x))) 2/3))
+ (is (= (locally (declare (optimize (speed 3) (safety 0)))
+ (extremum #(1 23 3 4 5 0) #'>))
+ 23))
+ (is (= (extremum-fastkey '(2/3 2 3 4) #'> :key (lambda (x) (/ 1 x))) 2/3)))
+
+(test extrema
+ (is (tree-equal (extrema '(3 2 1 1 2 1) #'<)
+ '(1 1 1)))
+ (is (tree-equal (extrema #(3 2 1 1 2 1) #'<)
+ '(1 1 1)))
+ (is (tree-equal (extrema #(3 2 1 1 2 1) #'< :end 4)
+ '(1 1)))
+ (is (tree-equal (extrema '(3 2 1 1 2 1) #'< :end 4)
+ '(1 1)))
+ (is (tree-equal (extrema #(3 2 1 1 2 1) #'< :start 3 :end 4)
+ '(1)))
+ (is (tree-equal (extrema '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr)
+ '((B . 1) (D . 1)))))
+
+(defmacro quietly (&body body)
+ "Perform BODY quietly, muffling any warnings that may arise"
+ `(handler-bind ((warning #'muffle-warning))
+ , at body))
+
+(test n-most-extreme
+ (is (tree-equal (n-most-extreme 1 '(3 1 2 1) #'>)
+ '(3)))
+ (is (tree-equal (n-most-extreme 2 '(3 1 2 1) #'>)
+ '(3 2)))
+ (is (tree-equal (n-most-extreme 2 '(3 1 2 1) #'<)
+ '(1 1)))
+ (is (tree-equal (n-most-extreme 1 '((A . 3) (B . 1) (C . 2) (D . 1)) #'> :key #'cdr)
+ '((A . 3))))
+ (is (tree-equal (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr)
+ '((B . 1) (D . 1))))
+ (is (tree-equal (quietly (n-most-extreme 20 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr))
+ '((B . 1) (D . 1) (C . 2) (A . 3))))
+ (is (tree-equal (quietly (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr :start 1 :end 2))
+ '((B . 1))))
+ (signals n-most-extreme-not-enough-elements (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr :start 1 :end 2)))
+
+(defun delimited-test (&key (delimiter #\|) (start 0) end
+ (string "foogo|ogreogrjejgierjijri|bar|baz"))
+ (with-input-from-string (str string)
+ (let ((buffer (copy-seq " ")))
+ (multiple-value-bind (position delimited-p)
+ (read-delimited buffer str
+ :delimiter delimiter :start start :end end)
+ (declare (ignore delimited-p))
+ (subseq buffer 0 position)))))
+
+(test read-delimited
+ (is (string= (delimited-test) "foogo"))
+ (is (string= (delimited-test :delimiter #\t) "foogo|ogreog"))
+ (is (string= (delimited-test :delimiter #\t :start 3) " foogo|ogr"))
+ (is (string= (delimited-test :start 3) " foogo"))
+ (is (string= (delimited-test :end 3) "foo"))
+ (is (string= (delimited-test :start 1 :end 3) " fo"))
+ (is (string= (delimited-test :string "Hello") "Hello"))
+ (is (string= (delimited-test :string "Hello" :start 3) " Hello"))
+ (is (string= (handler-bind ((read-delimited-bounds-error #'continue))
+ (delimited-test :start 3 :end 1))
+ " fo"))
+ (signals type-error (delimited-test :start 3/2))
+ (signals read-delimited-bounds-error (delimited-test :start -3))
+ (signals read-delimited-bounds-error (delimited-test :end 30))
+ (signals read-delimited-bounds-error (delimited-test :start 3 :end 1)))
+
+;; Random testing would probably work better here.
+(test expt-mod
+ (is (= (expt-mod 2 34 54) (mod (expt 2 34) 54)))
+ (is (= (expt-mod 20 3 54) (mod (expt 20 3) 54)))
+ (is (= (expt-mod 2.5 3.8 34.9) (mod (expt 2.5 3.8) 34.9)))
+ (is (= (expt-mod 2/5 3/8 34/9) (mod (expt 2/5 3/8) 34/9))))
+
+(test collecting
+ (is (tree-equal (collecting (dotimes (x 10) (collect x)))
+ '(0 1 2 3 4 5 6 7 8 9)))
+ (is (tree-equal (collecting
+ (labels ((collect-it (x) (collect x)))
+ (mapcar #'collect-it (reverse '(c b a)))))
+ '(a b c)))
+ (is (tree-equal (multiple-value-bind (a b)
+ (with-collectors (x y)
+ (x 1)
+ (y 2)
+ (x 3))
+ (append a b))
+ '(1 3 2))))
+
+(test with-unique-names
+ (is (equalp (subseq (with-unique-names (foo)
+ (string foo))
+ 0 3)
+ "foo"))
+ (is (equalp (subseq (with-unique-names ((foo "bar"))
+ (string foo))
+ 0 3)
+ "bar"))
+ (is (equalp (subseq (with-unique-names ((foo baz))
+ (string foo))
+ 0 3)
+ "baz"))
+ (is (equalp (subseq (with-unique-names ((foo #\y))
+ (string foo))
+ 0 1)
+ "y"))
+ (is (equalp (subseq (with-gensyms (foo)
+ (string foo))
+ 0 3)
+ "foo")))
+
+;; Taken from spec
+(test rotate-byte
+ (is (= (rotate-byte 3 (byte 32 0) 3) 24))
+ (is (= (rotate-byte 3 (byte 5 5) 3) 3))
+ (is (= (rotate-byte 6 (byte 8 0) -3) -129)))
+
+(test copy-array
+ (let ((test-array (make-array '(10 10) :initial-element 5)))
+ (is (not (eq (copy-array test-array) test-array)))
+ (is (equalp (copy-array test-array) test-array))))
+
+(test compose
+ (labels ((2* (x) (* 2 x)))
+ (is (= (funcall (compose #'1+ #'1+) 1) 3))
+ (is (= (funcall (compose '1+ #'2*) 5) 11))
+ (is (= (funcall (compose #'1+ #'2* '1+) 6) 15))
+ ;; This should signal an undefined function error, since we're
+ ;; using '2* rather than #'2*, which means that COMPOSE will use
+ ;; the dynamic binding at the time it is called rather than the
+ ;; lexical binding here.
+ (signals undefined-function
+ (= (funcall (compose #'1+ '2* '1+) 6) 15))))
\ No newline at end of file
Added: trunk/lib/cl-utilities-1.2.4/with-unique-names.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cl-utilities-1.2.4/with-unique-names.lisp Mon Oct 19 17:28:31 2009
@@ -0,0 +1,46 @@
+(in-package :cl-utilities)
+
+;; Defined at http://www.cliki.net/WITH-UNIQUE-NAMES
+
+(defmacro with-unique-names ((&rest bindings) &body body)
+ "Executes a series of forms with each var bound to a fresh,
+uninterned symbol. See http://www.cliki.net/WITH-UNIQUE-NAMES"
+ `(let ,(mapcar #'(lambda (binding)
+ (multiple-value-bind (var prefix)
+ (%with-unique-names-binding-parts binding)
+ (check-type var symbol)
+ `(,var (gensym ,(format nil "~A"
+ (or prefix var))))))
+ bindings)
+ , at body))
+
+(defun %with-unique-names-binding-parts (binding)
+ "Return (values var prefix) from a WITH-UNIQUE-NAMES binding
+form. If PREFIX is not given in the binding, NIL is returned to
+indicate that the default should be used."
+ (if (consp binding)
+ (values (first binding) (second binding))
+ (values binding nil)))
+
+(define-condition list-binding-not-supported (warning)
+ ((binding :initarg :binding :reader list-binding-not-supported-binding))
+ (:report (lambda (condition stream)
+ (format stream "List binding ~S not supported by WITH-GENSYMS.
+It will work, but you should use WITH-UNIQUE-NAMES instead."
+ (list-binding-not-supported-binding condition))))
+ (:documentation "List bindings aren't supported by WITH-GENSYMS, and
+if you want to use them you should use WITH-UNIQUE-NAMES instead. That
+said, they will work; they'll just signal this warning to complain
+about it."))
+
+
+(defmacro with-gensyms ((&rest bindings) &body body)
+ "Synonym for WITH-UNIQUE-NAMES, but BINDINGS should only consist of
+atoms; lists are not supported. If you try to give list bindings, a
+LIST-BINDING-NOT-SUPPORTED warning will be signalled, but it will work
+the same way as WITH-UNIQUE-NAMES. Don't do it, though."
+ ;; Signal a warning for each list binding, if there are any
+ (dolist (binding (remove-if-not #'listp bindings))
+ (warn 'list-binding-not-supported :binding binding))
+ ;; Otherwise, this is a synonym for WITH-UNIQUE-NAMES
+ `(with-unique-names ,bindings , at body))
\ No newline at end of file
Modified: trunk/src/java/snow/Snow.java
==============================================================================
--- trunk/src/java/snow/Snow.java (original)
+++ trunk/src/java/snow/Snow.java Mon Oct 19 17:28:31 2009
@@ -51,168 +51,182 @@
public abstract class Snow {
- private static boolean init = false;
- private static ScriptEngine lispEngine;
- private static final String fileSeparator = System.getProperty("file.separator");
-
- private static final String fixDirPath(String path) {
- if(!path.endsWith(fileSeparator)) {
- path += fileSeparator;
- }
- return path;
+ private static boolean init = false;
+ private static ScriptEngine lispEngine;
+ private static final String fileSeparator = System.getProperty("file.separator");
+
+ private static final String fixDirPath(String path) {
+ if(!path.endsWith(fileSeparator)) {
+ path += fileSeparator;
}
-
- public static synchronized ScriptEngine init() throws ScriptException {
- if(!init) {
- lispEngine = new ScriptEngineManager(Snow.class.getClassLoader()).getEngineByExtension("lisp");
- URL url = Snow.class.getResource("/snow/snow.asd");
- if(url == null) {
- throw new RuntimeException("snow.asd not found in classpath: have you installed Snow correctly?");
- }
- String baseDir;
- String libDir;
- if(!"file".equals(url.getProtocol())) {
- if("jar".equals(url.getProtocol())) {
- ZipInputStream extractor = null;
- try {
- String tmpDir = System.getProperty("java.io.tmpdir");
- if(tmpDir != null && fileSeparator != null) {
- tmpDir = fixDirPath(tmpDir);
- String jarUrlStr = url.getPath();
- int bangPos = jarUrlStr.indexOf('!');
- if(bangPos >= 0) {
- jarUrlStr = jarUrlStr.substring(0, bangPos);
- }
- URL jarUrl = new URL(jarUrlStr);
- extractor = new ZipInputStream(jarUrl.openStream());
- int targetDirIndex = 0;
- File targetDir;
- do {
- targetDir = new File(tmpDir + "snow" + (targetDirIndex++));
- } while(targetDir.exists());
- targetDir.mkdir();
- targetDir.deleteOnExit();
- baseDir = targetDir.getAbsolutePath();
- baseDir = fixDirPath(baseDir);
- libDir = baseDir;
- for(ZipEntry entry = extractor.getNextEntry(); entry != null; entry = extractor.getNextEntry()) {
- File extracted = new File(baseDir + entry.getName());
- extracted.deleteOnExit();
- if(entry.isDirectory()) {
- extracted.mkdirs();
- } else {
- extracted.getParentFile().mkdirs();
- byte[] buf = new byte[(int)entry.getSize()]; //probably inefficient
- int read = 0;
- while(true) {
- int justRead = extractor.read(buf, read, buf.length - read);
- if(justRead >= 0 && read < buf.length) {
- read += justRead;
- } else {
- break;
- }
- }
- FileOutputStream fos = new FileOutputStream(extracted);
- fos.write(buf);
- fos.flush();
- fos.close();
- }
- extracted.setLastModified(entry.getTime());
- System.out.println("Extracted " + extracted.getAbsolutePath());
- }
- } else {
- throw new RuntimeException("Cannot extract jar " + url + " - no temp dir or file separator defined");
- }
- } catch(Exception e) {
- throw new RuntimeException("Cannot extract jar " + url, e);
- } finally {
- if(extractor != null) {
- try {
- extractor.close();
- } catch (IOException e) {
- System.err.println("Couldn't close jar extractor: " + e.getMessage());
- e.printStackTrace();
- }
- }
- }
+ return path;
+ }
+
+ /**
+ * This method is public only because it needs to be called from Lisp.
+ * Do not call it.
+ */
+ public static synchronized void initAux() throws ScriptException {
+ if(!init) {
+ lispEngine = new ScriptEngineManager(Snow.class.getClassLoader()).getEngineByExtension("lisp");
+ URL url = Snow.class.getResource("/snow/snow.asd");
+ if(url == null) {
+ throw new RuntimeException("snow.asd not found in classpath: have you installed Snow correctly?");
+ }
+ String baseDir;
+ String libDir;
+ if(!"file".equals(url.getProtocol())) {
+ if("jar".equals(url.getProtocol())) {
+ ZipInputStream extractor = null;
+ try {
+ String tmpDir = System.getProperty("java.io.tmpdir");
+ if(tmpDir != null && fileSeparator != null) {
+ tmpDir = fixDirPath(tmpDir);
+ String jarUrlStr = url.getPath();
+ int bangPos = jarUrlStr.indexOf('!');
+ if(bangPos >= 0) {
+ jarUrlStr = jarUrlStr.substring(0, bangPos);
+ }
+ URL jarUrl = new URL(jarUrlStr);
+ extractor = new ZipInputStream(jarUrl.openStream());
+ int targetDirIndex = 0;
+ File targetDir;
+ do {
+ targetDir = new File(tmpDir + "snow" + (targetDirIndex++));
+ } while(targetDir.exists());
+ targetDir.mkdir();
+ targetDir.deleteOnExit();
+ baseDir = targetDir.getAbsolutePath();
+ baseDir = fixDirPath(baseDir);
+ libDir = baseDir;
+ for(ZipEntry entry = extractor.getNextEntry(); entry != null; entry = extractor.getNextEntry()) {
+ File extracted = new File(baseDir + entry.getName());
+ extracted.deleteOnExit();
+ if(entry.isDirectory()) {
+ extracted.mkdirs();
} else {
- throw new RuntimeException("Unsupported URL for snow.asd: " + url +
- " make sure it is a regular file or is in a jar.");
+ extracted.getParentFile().mkdirs();
+ byte[] buf = new byte[(int)entry.getSize()]; //probably inefficient
+ int read = 0;
+ while(true) {
+ int justRead = extractor.read(buf, read, buf.length - read);
+ if(justRead >= 0 && read < buf.length) {
+ read += justRead;
+ } else {
+ break;
+ }
+ }
+ FileOutputStream fos = new FileOutputStream(extracted);
+ fos.write(buf);
+ fos.flush();
+ fos.close();
}
+ extracted.setLastModified(entry.getTime());
+ System.out.println("Extracted " + extracted.getAbsolutePath());
+ }
} else {
- URI uri;
- try {
- uri = url.toURI();
- } catch (URISyntaxException e) {
- throw new RuntimeException(e);
- }
- File f = new File(uri);
- baseDir = fixDirPath(f.getParentFile().getParent());
- libDir = fixDirPath(new File(baseDir).getParent()) + "lib" + fileSeparator;
+ throw new RuntimeException("Cannot extract jar " + url + " - no temp dir or file separator defined");
+ }
+ } catch(Exception e) {
+ throw new RuntimeException("Cannot extract jar " + url, e);
+ } finally {
+ if(extractor != null) {
+ try {
+ extractor.close();
+ } catch (IOException e) {
+ System.err.println("Couldn't close jar extractor: " + e.getMessage());
+ e.printStackTrace();
+ }
}
- lispEngine.eval("(pushnew #P\"" + baseDir + "snow/\" asdf:*central-registry* :test #'equal)");
- lispEngine.eval("(pushnew #P\"" + baseDir + "snow/swing/\" asdf:*central-registry* :test #'equal)");
- lispEngine.eval("(pushnew #P\"" + libDir + "cells/\" asdf:*central-registry* :test #'equal)");
- lispEngine.eval("(pushnew #P\"" + libDir + "cells/utils-kt/\" asdf:*central-registry* :test #'equal)");
- lispEngine.eval("(pushnew :snow-cells *features*)");
- lispEngine.eval("(asdf:oos 'asdf:load-op :snow)");
- //lispEngine.eval("(snow:install-graphical-debugger) (ohmygod)");
- //lispEngine.eval("(snow::inspect-object (snow::new \"javax.swing.JButton\"))");
- init = true;
- return lispEngine;
+ }
} else {
- throw new RuntimeException("Already initialized");
+ throw new RuntimeException("Unsupported URL for snow.asd: " + url +
+ " make sure it is a regular file or is in a jar.");
}
- }
-
- public static synchronized ScriptEngine initIfNecessary() throws ScriptException {
- if(!init) {
- init();
- }
- return lispEngine;
- }
-
- public static Object evalResource(Class<?> aClass, String resourcePath) throws ScriptException {
- return evalResource(aClass, resourcePath, true);
- }
-
- public static Object evalResource(Class<?> aClass, String resourcePath, boolean compileItFirst) throws ScriptException {
- Reader r = new InputStreamReader(aClass.getResourceAsStream(resourcePath));
- return evalResource(r, compileItFirst);
- }
-
- public static Object evalResource(Reader reader) throws ScriptException {
- return evalResource(reader, true);
- }
-
- public static Object evalResource(Reader reader, boolean compileItFirst) throws ScriptException {
- initIfNecessary();
- if(compileItFirst) {
- return getCompilable().compile(reader).eval();
- } else {
- return lispEngine.eval(reader);
+ } else {
+ URI uri;
+ try {
+ uri = url.toURI();
+ } catch (URISyntaxException e) {
+ throw new RuntimeException(e);
}
+ File f = new File(uri);
+ baseDir = fixDirPath(f.getParentFile().getParent());
+ libDir = fixDirPath(new File(baseDir).getParent()) + "lib" + fileSeparator;
+ }
+ lispEngine.eval("(pushnew #P\"" + baseDir + "snow/\" asdf:*central-registry* :test #'equal)");
+ lispEngine.eval("(pushnew #P\"" + baseDir + "snow/swing/\" asdf:*central-registry* :test #'equal)");
+ lispEngine.eval("(pushnew #P\"" + libDir + "cl-utilities-1.2.4/\" asdf:*central-registry* :test #'equal)");
+ lispEngine.eval("(pushnew #P\"" + libDir + "cells/\" asdf:*central-registry* :test #'equal)");
+ lispEngine.eval("(pushnew #P\"" + libDir + "cells/utils-kt/\" asdf:*central-registry* :test #'equal)");
}
-
- public static ScriptEngine getScriptEngine() {
- return lispEngine;
+ }
+
+ public static synchronized ScriptEngine init() throws ScriptException {
+ if(!init) {
+ initAux();
+ lispEngine.eval("(pushnew :snow-cells *features*)");
+ lispEngine.eval("(asdf:oos 'asdf:load-op :snow)");
+
+
+ //lispEngine.eval("(snow:install-graphical-debugger) (ohmygod)");
+ //lispEngine.eval("(snow::inspect-object (snow::new \"javax.swing.JButton\"))");
+ init = true;
+ return lispEngine;
+ } else {
+ throw new RuntimeException("Already initialized");
}
-
- public static Compilable getCompilable() {
- return (Compilable) lispEngine;
+ }
+
+ public static synchronized ScriptEngine initIfNecessary() throws ScriptException {
+ if(!init) {
+ init();
}
+ return lispEngine;
+ }
- public static Invocable getInvocable() {
- return (Invocable) lispEngine;
+ public static Object evalResource(Class<?> aClass, String resourcePath) throws ScriptException {
+ return evalResource(aClass, resourcePath, true);
+ }
+
+ public static Object evalResource(Class<?> aClass, String resourcePath, boolean compileItFirst) throws ScriptException {
+ Reader r = new InputStreamReader(aClass.getResourceAsStream(resourcePath));
+ return evalResource(r, compileItFirst);
+ }
+
+ public static Object evalResource(Reader reader) throws ScriptException {
+ return evalResource(reader, true);
+ }
+
+ public static Object evalResource(Reader reader, boolean compileItFirst) throws ScriptException {
+ initIfNecessary();
+ if(compileItFirst) {
+ return getCompilable().compile(reader).eval();
+ } else {
+ return lispEngine.eval(reader);
}
-
+ }
+
+ public static ScriptEngine getScriptEngine() {
+ return lispEngine;
+ }
+
+ public static Compilable getCompilable() {
+ return (Compilable) lispEngine;
+ }
+
+ public static Invocable getInvocable() {
+ return (Invocable) lispEngine;
+ }
+
public static void main(String[] args) {
try {
Snow.init();
if(args.length == 0) { //Launch GUI REPL
evalResource(Snow.class, "/snow/start.lisp", true);
} else { //Launch regular ABCL
- org.armedbear.lisp.Main.main(args);
+ lispEngine.eval("(TOP-LEVEL::TOP-LEVEL)");
+ //org.armedbear.lisp.Main.main(args);
}
} catch (Exception e) {
e.printStackTrace();
Modified: trunk/src/java/snow/binding/BeanPropertyPathBinding.java
==============================================================================
--- trunk/src/java/snow/binding/BeanPropertyPathBinding.java (original)
+++ trunk/src/java/snow/binding/BeanPropertyPathBinding.java Mon Oct 19 17:28:31 2009
@@ -60,6 +60,10 @@
this(o, propertyPath.split("\\."));
}
+ public BeanPropertyPathBinding(Object o, String[] propertyPath) {
+ this(o, propertyPath, null);
+ }
+
protected BeanPropertyPathBinding(Object o, String[] propertyPath,
BeanPropertyPathBinding prevListener) {
this.prevListener = prevListener;
@@ -85,10 +89,6 @@
}
}
- public BeanPropertyPathBinding(Object o, String[] propertyPath) {
- this(o, propertyPath, null);
- }
-
public void remove() {
try {
Method removePropertyChangeListener = object.getClass().getMethod("removePropertyChangeListener", addRemovePropertyChangeListenerSignature);
Modified: trunk/src/lisp/snow/compile-system.lisp
==============================================================================
--- trunk/src/lisp/snow/compile-system.lisp (original)
+++ trunk/src/lisp/snow/compile-system.lisp Mon Oct 19 17:28:31 2009
@@ -3,15 +3,16 @@
(unwind-protect
(unless
(progn
- (pushnew #P"snow/" asdf:*central-registry* :test #'equal)
- (pushnew #P"snow/swing/" asdf:*central-registry* :test #'equal)
- (pushnew #P"cells/" asdf:*central-registry* :test #'equal)
+ #|(pushnew #P"snow/" asdf:*central-registry* :test #'equal)
+ (pushnew #P"snow/swing/" asdf:*central-registry* :test #'equal)
+ (pushnew #P"cl-utilities-1.2.4/" asdf:*central-registry* :test #'equal)
+ (pushnew #P"cells/" asdf:*central-registry* :test #'equal)
(pushnew #P"cells/utils-kt/" asdf:*central-registry* :test #'equal)
- (pushnew :snow-cells *features*)
-
- (format t "asdf:*central-registry*: ~A" asdf:*central-registry*)
-
- (asdf:oos 'asdf:compile-op :snow)
- t)
- (format t "failed"))
+ (pushnew :snow-cells *features*)|#
+ (jstatic "initAux" "snow.Snow")
+ (format t "asdf:*central-registry*: ~A" asdf:*central-registry*)
+
+ (asdf:oos 'asdf:compile-op :snow)
+ t)
+ (format t "failed"))
(quit))
\ No newline at end of file
Added: trunk/src/lisp/snow/data-binding.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/data-binding.lisp Mon Oct 19 17:28:31 2009
@@ -0,0 +1,157 @@
+;;; binding-jgoodies.lisp
+;;;
+;;; Copyright (C) 2008-2009 Alessio Stalla
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; 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, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+;;;
+;;; As a special exception, the copyright holders of this library give you
+;;; permission to link this library with independent modules to produce an
+;;; executable, regardless of the license terms of these independent
+;;; modules, and to copy and distribute the resulting executable under
+;;; terms of your choice, provided that you also meet, for each linked
+;;; independent module, the terms and conditions of the license of that
+;;; module. An independent module is a module which is not derived from
+;;; or based on this library. If you modify this library, you may extend
+;;; this exception to your version of the library, but you are not
+;;; obligated to do so. If you do not wish to do so, delete this
+;;; exception statement from your version.
+
+(in-package :snow)
+
+(defclass data-binding ()
+ ((converter :initarg :converter :initform nil :accessor binding-converter)))
+
+(defgeneric make-model (data-binding))
+
+(defmethod make-model :around ((binding data-binding))
+ "Wraps the model with a converter if one was specified for the binding"
+ (let ((model (call-next-method)))
+ (with-slots (converter) binding
+ (cond
+ ((functionp converter)
+ (new "snow.binding.Converter" model converter converter))
+ ((consp converter)
+ (new "snow.binding.Converter" model (car converter) (cdr converter)))
+ ((null converter) model)
+ (t (error "~A is not a valid converter" converter))))))
+
+(defgeneric bind-widget (widget data-binding)
+ (:documentation "Establishes a 'data binding' between a GUI component and a data binding target. Every time the data held by the component or by the target changes, the other one will be updated accordingly."))
+
+;;Concrete Binding implementations
+
+;;Simple Binding
+(defclass simple-data-binding (data-binding)
+ ((variable :initarg :variable :reader binding-variable :initform (error "variable is required"))))
+
+(defun make-var (&optional obj)
+ (new "com.jgoodies.binding.value.ValueHolder" obj (jbool nil)))
+
+(defun var (var)
+ (invoke "getValue" var))
+
+(defun (setf var) (value var)
+ (invoke "setValue" var value)
+ value)
+
+(defun make-simple-data-binding (variable)
+ (make-instance 'simple-data-binding :variable variable))
+
+(defmethod make-model ((binding simple-data-binding))
+ (binding-variable binding))
+
+;;Bean Binding
+
+;;JGoodies Binding presentation model
+(defvar *presentation-model* nil)
+
+(defun trigger-commit (&optional (presentation-model *presentation-model*))
+ (jcall (jmethod "com.jgoodies.binding.PresentationModel"
+ "triggerCommit")
+ presentation-model))
+
+(defmacro form ((bean) &body body)
+ `(let ((*presentation-model*
+ (new "com.jgoodies.binding.PresentationModel" ,bean)))
+ , at body))
+
+(defclass bean-data-binding (data-binding)
+ ((object :initarg :object :reader binding-object
+ :initform (or *presentation-model* (error "object is required")))
+ (property :initarg :property :reader binding-property
+ :initform (error "property is required"))
+ (observed-p :initarg :observed-p :reader binding-observed-p :initform t)
+ (buffered-p :initarg :buffered-p :reader binding-buffered-p :initform nil)))
+
+(defun make-bean-data-binding (object property &rest args)
+ (apply #'make-instance 'bean-data-binding :object object :property property
+ args))
+
+(defmethod make-model ((binding bean-data-binding))
+ (let ((presentation-model-class
+ (jclass "com.jgoodies.binding.PresentationModel")))
+ (if (jinstance-of-p (binding-object binding) presentation-model-class)
+ (if (binding-buffered-p binding)
+ (jcall (jmethod presentation-model-class
+ "getBufferedModel" "java.lang.String")
+ (binding-object binding)
+ (dashed->camelcased (binding-property binding)))
+ (jcall (jmethod presentation-model-class
+ "getModel" "java.lang.String")
+ (binding-object binding)
+ (dashed->camelcased (binding-property binding))))
+ (jnew (jconstructor "com.jgoodies.binding.beans.PropertyAdapter"
+ "java.lang.Object" "java.lang.String"
+ "boolean")
+ (binding-object binding)
+ (dashed->camelcased (binding-property binding))
+ (jbool (binding-observed-p binding))))))
+
+;;EL data binding
+(defvar *bean-factory*
+ #'(lambda (bean-name)
+ (declare (ignore bean-name))
+ (error "No bean factory defined - please bind *bean-factory*"))
+ "A callback called by the EL engine with a single argument, the name of a bean to fetch from the application.")
+
+;;For EL data bindings we reuse simple-data-binding, since its 'variable' can
+;;really be any JGoodies ValueModel
+(defun make-el-data-binding (el-expr)
+ (let* ((splitted-expr (split-sequence #\. el-expr))
+ (obj (funcall *bean-factory* (car splitted-expr)))
+ (path (cdr splitted-expr)))
+ (make-instance 'simple-data-binding
+ :variable (make-bean-property-path-binding obj path))))
+
+(defun make-bean-property-path-binding (object path)
+ (new "snow.binding.BeanPropertyPathBinding"
+ object (apply #'jvector "java.lang.String" path)))
+
+;;Default binding types
+(defun default-data-binding-types ()
+ (let ((ht (make-hash-table)))
+ (setf (gethash :simple ht) 'simple-data-binding)
+ (setf (gethash :bean ht) 'bean-data-binding)
+ ht))
+
+(defparameter *binding-types* (default-data-binding-types))
+
+(defun get-data-binding-class (binding-type)
+ (if (keywordp binding-type)
+ (gethash binding-type *binding-types*)
+ binding-type))
+
+(defun make-data-binding (type &rest options)
+ (apply #'make-instance (get-data-binding-class type) options))
Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp (original)
+++ trunk/src/lisp/snow/packages.lisp Mon Oct 19 17:28:31 2009
@@ -30,7 +30,7 @@
(defpackage :snow
- (:use :common-lisp :java #+snow-cells :cells)
+ (:use :common-lisp :java :cl-utilities #+snow-cells :cells)
(:shadow #+snow-cells #:dbg)
(:export
;;Widgets
Modified: trunk/src/lisp/snow/sexy-java.lisp
==============================================================================
--- trunk/src/lisp/snow/sexy-java.lisp (original)
+++ trunk/src/lisp/snow/sexy-java.lisp Mon Oct 19 17:28:31 2009
@@ -190,7 +190,10 @@
(t form)))
form))
-(defun ensure-list (obj)
- (if (listp obj)
- obj
- (list obj)))
\ No newline at end of file
+(defun jvector (element-type &rest args)
+ (let ((arr (jnew-array (jclass element-type) (length args))))
+ (loop
+ :for x :in args
+ :for i := 0 :then (incf i)
+ :do (setf (jarray-ref arr i) x))
+ arr))
\ No newline at end of file
Modified: trunk/src/lisp/snow/snow.asd
==============================================================================
--- trunk/src/lisp/snow/snow.asd (original)
+++ trunk/src/lisp/snow/snow.asd Mon Oct 19 17:28:31 2009
@@ -31,8 +31,8 @@
;;Core stuff + cells if needed
(asdf:defsystem :snow
:serial t
- :version "0.1"
- :depends-on (#+snow-cells :cells)
+ :version "0.2"
+ :depends-on (:cl-utilities #+snow-cells :cells)
:components ((:file "packages")
(:file "sexy-java")
(:file "utils")
Modified: trunk/src/lisp/snow/utils.lisp
==============================================================================
--- trunk/src/lisp/snow/utils.lisp (original)
+++ trunk/src/lisp/snow/utils.lisp Mon Oct 19 17:28:31 2009
@@ -32,13 +32,13 @@
(in-package :snow)
;;Some utilities...
-(defmacro with-unique-names ((&rest bindings) &body body)
+#|(defmacro with-unique-names ((&rest bindings) &body body)
`(let ,(mapcar #'(lambda (binding)
(destructuring-bind (var prefix)
(if (consp binding) binding (list binding binding))
`(,var (gensym ,(string prefix)))))
bindings)
- , at body))
+ , at body))|#
#|(defmacro with-captured-specials ((&rest specials) &body body)
(with-unique-names (tmp)
More information about the snow-cvs
mailing list