From pscott at common-lisp.net Mon May 9 21:26:29 2005 From: pscott at common-lisp.net (Peter Scott) Date: Mon, 9 May 2005 23:26:29 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: Module imported: cl-utilities Message-ID: <20050509212629.044E28870E@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv19680 Log Message: Initial commit Status: Vendor Tag: pscott Release Tags: start N cl-utilities/cl-utilities.asd N cl-utilities/expt-mod.lisp N cl-utilities/package.lisp N cl-utilities/test.lisp N cl-utilities/split-sequence.lisp N cl-utilities/extremum.lisp N cl-utilities/collecting.lisp N cl-utilities/with-unique-names.lisp N cl-utilities/rotate-byte.lisp N cl-utilities/copy-array.lisp N cl-utilities/read-delimited.lisp N cl-utilities/README N cl-utilities/once-only.lisp N cl-utilities/compose.lisp N cl-utilities/package.sh N cl-utilities/project/index.html N cl-utilities/project/style.css No conflicts created by this import Date: Mon May 9 23:26:29 2005 Author: pscott New module cl-utilities added From pscott at common-lisp.net Mon May 9 21:37:12 2005 From: pscott at common-lisp.net (Peter Scott) Date: Mon, 9 May 2005 23:37:12 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/project/index.html Message-ID: <20050509213712.3F7C08870E@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities/project In directory common-lisp.net:/tmp/cvs-serv20881 Modified Files: index.html Log Message: Added CVS tarball link and fixed HTML problems. Date: Mon May 9 23:37:11 2005 Author: pscott Index: cl-utilities/project/index.html diff -u cl-utilities/project/index.html:1.1.1.1 cl-utilities/project/index.html:1.2 --- cl-utilities/project/index.html:1.1.1.1 Mon May 9 23:26:29 2005 +++ cl-utilities/project/index.html Mon May 9 23:37:11 2005 @@ -58,6 +58,11 @@ and the signature is cl-utilities-latest.tar.gz.asc

+

You can also download the nightly + CVS tarball, but I don't expect you to see much difference + between that and the latest release.

+

CVS

You can Valid XHTML 1.0 Strict - From pscott at common-lisp.net Mon May 9 21:45:02 2005 From: pscott at common-lisp.net (Peter Scott) Date: Mon, 9 May 2005 23:45:02 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/test.lisp Message-ID: <20050509214502.3FCC18870E@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv21142 Modified Files: test.lisp Log Message: Removed bad test Date: Mon May 9 23:45:00 2005 Author: pscott Index: cl-utilities/test.lisp diff -u cl-utilities/test.lisp:1.1.1.1 cl-utilities/test.lisp:1.2 --- cl-utilities/test.lisp:1.1.1.1 Mon May 9 23:26:29 2005 +++ cl-utilities/test.lisp Mon May 9 23:45:00 2005 @@ -72,8 +72,7 @@ ;; 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.3 -4 5.4) (mod (expt 2.3 -4) 5.4)))) + (is (= (expt-mod 20 3 54) (mod (expt 20 3) 54)))) (test collecting (is (tree-equal (collecting (dotimes (x 10) (collect x))) From pscott at common-lisp.net Mon May 9 21:51:32 2005 From: pscott at common-lisp.net (Peter Scott) Date: Mon, 9 May 2005 23:51:32 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/expt-mod.lisp Message-ID: <20050509215132.D0B898870E@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv22187 Modified Files: expt-mod.lisp Log Message: Added support for non-integer arguments on Lisps other than SBCL. Date: Mon May 9 23:51:31 2005 Author: pscott Index: cl-utilities/expt-mod.lisp diff -u cl-utilities/expt-mod.lisp:1.1.1.1 cl-utilities/expt-mod.lisp:1.2 --- cl-utilities/expt-mod.lisp:1.1.1.1 Mon May 9 23:26:29 2005 +++ cl-utilities/expt-mod.lisp Mon May 9 23:51:31 2005 @@ -9,12 +9,14 @@ ;; compiler to optimize it. This may be the case on other Lisp ;; implementations as well. #+sbcl (mod (expt n exponent) modulus) - #-sbcl (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))) + #-sbcl (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 SBCL is going to expand compiler macros, we should directly ;; inline the simple expansion; this lets SBCL do all sorts of fancy From pscott at common-lisp.net Mon May 9 21:53:34 2005 From: pscott at common-lisp.net (Peter Scott) Date: Mon, 9 May 2005 23:53:34 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/test.lisp Message-ID: <20050509215334.C71B18870E@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv22260 Modified Files: test.lisp Log Message: Added two more tests for EXPT-MOD. Date: Mon May 9 23:53:33 2005 Author: pscott Index: cl-utilities/test.lisp diff -u cl-utilities/test.lisp:1.2 cl-utilities/test.lisp:1.3 --- cl-utilities/test.lisp:1.2 Mon May 9 23:45:00 2005 +++ cl-utilities/test.lisp Mon May 9 23:53:33 2005 @@ -72,7 +72,9 @@ ;; 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 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))) From pscott at common-lisp.net Tue May 10 19:45:41 2005 From: pscott at common-lisp.net (Peter Scott) Date: Tue, 10 May 2005 21:45:41 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/compose.lisp Message-ID: <20050510194541.1D27D88736@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv5183 Modified Files: compose.lisp Log Message: Fixed subtle bug in COMPOSE compiler macro. It was optimizing too much, causing lexical definitions to be used when, strictly speaking, funcall-time dynamic values should have been used. Date: Tue May 10 21:45:38 2005 Author: pscott Index: cl-utilities/compose.lisp diff -u cl-utilities/compose.lisp:1.1.1.1 cl-utilities/compose.lisp:1.2 --- cl-utilities/compose.lisp:1.1.1.1 Mon May 9 23:26:29 2005 +++ cl-utilities/compose.lisp Tue May 10 21:45:34 2005 @@ -34,19 +34,12 @@ ;; 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 ((quoted-symbolp (x) - (and (listp x) - (eql (first x) 'quote) - (symbolp (second x)))) - (sharp-quotedp (x) + (labels ((sharp-quoted-p (x) (and (listp x) (eql (first x) 'function) - (symbolp (second x)))) - (directly-callable-p (x) - (or (quoted-symbolp x) - (sharp-quotedp x)))) + (symbolp (second x))))) `(lambda (x) ,(reduce #'(lambda (fun arg) - (if (directly-callable-p fun) + (if (sharp-quoted-p fun) (list (second fun) arg) (list 'funcall fun arg))) functions From pscott at common-lisp.net Tue May 10 19:46:42 2005 From: pscott at common-lisp.net (Peter Scott) Date: Tue, 10 May 2005 21:46:42 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/test.lisp Message-ID: <20050510194642.6D9DE88736@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv5591 Modified Files: test.lisp Log Message: Added EVAL-WHEN to make things work better, de-stupidified the COMPOSE unit tests and added a new one. Date: Tue May 10 21:46:40 2005 Author: pscott Index: cl-utilities/test.lisp diff -u cl-utilities/test.lisp:1.3 cl-utilities/test.lisp:1.4 --- cl-utilities/test.lisp:1.3 Mon May 9 23:53:33 2005 +++ cl-utilities/test.lisp Tue May 10 21:46:38 2005 @@ -1,6 +1,7 @@ ;; This file requires the FiveAM unit testing framework. -(asdf:oos 'asdf:load-op :fiveam) -(asdf:oos 'asdf:load-op :cl-utilities) +(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) @@ -120,5 +121,11 @@ (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)))) \ No newline at end of file + (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 From pscott at common-lisp.net Thu May 12 21:17:23 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 12 May 2005 23:17:23 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/extremum.lisp Message-ID: <20050512211723.113FA88735@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv18708 Modified Files: extremum.lisp Log Message: Improved efficiency some. Added EXTREMUM-FASTKEY which uses a different, and sometimes faster, algorithm. Date: Thu May 12 23:17:23 2005 Author: pscott Index: cl-utilities/extremum.lisp diff -u cl-utilities/extremum.lisp:1.1.1.1 cl-utilities/extremum.lisp:1.2 --- cl-utilities/extremum.lisp:1.1.1.1 Mon May 9 23:26:29 2005 +++ cl-utilities/extremum.lisp Thu May 12 23:17:23 2005 @@ -13,6 +13,15 @@ a b))) +(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)) + ;; 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. @@ -23,7 +32,7 @@ http://www.cliki.net/EXTREMUM for the full specification. Additionally, START and END specify the beginning and ending indices of the part of the sequence we should look at." - (if (= 0 (length sequence)) + (if (zero-length-p sequence) (restart-case (error 'no-extremum) (continue () :report "Return NIL instead" @@ -37,9 +46,44 @@ "Returns the element of SEQUENCE that would appear first if the sequence were ordered according to SORT using PREDICATE and KEY. See http://www.cliki.net/EXTREMUM for the full specification." - (if (= 0 (length sequence)) + (if (zero-length-p sequence) + (restart-case (error 'no-extremum) + (continue () + :report "Return NIL instead" + nil)) + (reduce (comparator predicate key) sequence))) + +;; 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))) + (if (zero-length-p sequence) (restart-case (error 'no-extremum) (continue () :report "Return NIL instead" nil)) - (reduce (comparator predicate key) sequence))) \ No newline at end of file + (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 #.most-positive-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))) \ No newline at end of file From pscott at common-lisp.net Thu May 12 21:17:51 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 12 May 2005 23:17:51 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/package.lisp Message-ID: <20050512211751.5D6BD88735@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv18728 Modified Files: package.lisp Log Message: Added EXTREMUM-FASTKEY symbol to exports list. Date: Thu May 12 23:17:50 2005 Author: pscott Index: cl-utilities/package.lisp diff -u cl-utilities/package.lisp:1.1.1.1 cl-utilities/package.lisp:1.2 --- cl-utilities/package.lisp:1.1.1.1 Mon May 9 23:26:29 2005 +++ cl-utilities/package.lisp Thu May 12 23:17:50 2005 @@ -9,6 +9,7 @@ #:extremum #:no-extremum + #:extremum-fastkey #:read-delimited #:read-delimited-bounds-error From pscott at common-lisp.net Fri May 13 19:17:40 2005 From: pscott at common-lisp.net (Peter Scott) Date: Fri, 13 May 2005 21:17:40 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/compose.lisp Message-ID: <20050513191740.43F028873C@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv32649 Modified Files: compose.lisp Log Message: Fixed some problems with the benchmarking code and some comments. Date: Fri May 13 21:17:39 2005 Author: pscott Index: cl-utilities/compose.lisp diff -u cl-utilities/compose.lisp:1.2 cl-utilities/compose.lisp:1.3 --- cl-utilities/compose.lisp:1.2 Tue May 10 21:45:34 2005 +++ cl-utilities/compose.lisp Fri May 13 21:17:38 2005 @@ -23,16 +23,16 @@ , at body)))) ;; Make sure the compiler macro gets run (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))) - (time (repeat (3000000) (funcall (compose #'1+ #'2* '1+) 6))) - (time (repeat (3000000) (funcall (lambda (x) (1+ (2* (1+ x)))) 6))) - (time (repeat (3000000) + (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)))) + (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)))) +;; 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) @@ -40,7 +40,7 @@ (symbolp (second x))))) `(lambda (x) ,(reduce #'(lambda (fun arg) (if (sharp-quoted-p fun) - (list (second fun) arg) + (list (second fun) arg) (list 'funcall fun arg))) functions :initial-value 'x From pscott at common-lisp.net Fri May 13 19:45:10 2005 From: pscott at common-lisp.net (Peter Scott) Date: Fri, 13 May 2005 21:45:10 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/extremum.lisp Message-ID: <20050513194510.9AD098873C@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv1422 Modified Files: extremum.lisp Log Message: Added a couple of compiler macros which optimize the case where KEY is #'identity. Date: Fri May 13 21:45:10 2005 Author: pscott Index: cl-utilities/extremum.lisp diff -u cl-utilities/extremum.lisp:1.2 cl-utilities/extremum.lisp:1.3 --- cl-utilities/extremum.lisp:1.2 Thu May 12 23:17:23 2005 +++ cl-utilities/extremum.lisp Fri May 13 21:45:09 2005 @@ -7,12 +7,21 @@ (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) + (if (funcall ,test a b) a b)) + whole)) + (defun zero-length-p (sequence) "Is the length of SEQUENCE equal to zero?" (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))) @@ -39,6 +48,21 @@ nil)) (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) + `(if (zero-length-p ,sequence) + (restart-case (error 'no-extremum) + (continue () + :report "Return NIL instead" + nil)) + (locally (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))) + (reduce (comparator ,predicate) ,sequence + :start ,start :end ,end)))) + whole)) ;; And, for backup, here's a strictly spec-compliant version. #+nil From pscott at common-lisp.net Fri May 13 19:45:58 2005 From: pscott at common-lisp.net (Peter Scott) Date: Fri, 13 May 2005 21:45:58 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/test.lisp Message-ID: <20050513194558.23BBA8873C@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv2061 Modified Files: test.lisp Log Message: Added more tests for EXREMUM. Date: Fri May 13 21:45:58 2005 Author: pscott Index: cl-utilities/test.lisp diff -u cl-utilities/test.lisp:1.4 cl-utilities/test.lisp:1.5 --- cl-utilities/test.lisp:1.4 Tue May 10 21:46:38 2005 +++ cl-utilities/test.lisp Fri May 13 21:45:57 2005 @@ -41,7 +41,11 @@ (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 (= (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))) (defun delimited-test (&key (delimiter #\|) (start 0) end (string "foogo|ogreogrjejgierjijri|bar|baz")) From pscott at common-lisp.net Fri May 13 21:18:23 2005 From: pscott at common-lisp.net (Peter Scott) Date: Fri, 13 May 2005 23:18:23 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/with-unique-names.lisp Message-ID: <20050513211823.D68BB8873C@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv7403 Modified Files: with-unique-names.lisp Log Message: Replaced (string prefix) with (format nil "~A" prefix), which is more general. I can't see why anybody would want to take advantage of this, but I can't see any reason *not* to let them either. Date: Fri May 13 23:18:23 2005 Author: pscott Index: cl-utilities/with-unique-names.lisp diff -u cl-utilities/with-unique-names.lisp:1.1.1.1 cl-utilities/with-unique-names.lisp:1.2 --- cl-utilities/with-unique-names.lisp:1.1.1.1 Mon May 9 23:26:29 2005 +++ cl-utilities/with-unique-names.lisp Fri May 13 23:18:23 2005 @@ -10,7 +10,7 @@ (if (consp binding) binding (list binding binding)) - `(,var (gensym ,(string prefix))))) + `(,var (gensym ,(format nil "~A" prefix))))) bindings) , at body)) From pscott at common-lisp.net Mon May 16 19:12:01 2005 From: pscott at common-lisp.net (Peter Scott) Date: Mon, 16 May 2005 21:12:01 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/with-unique-names.lisp Message-ID: <20050516191201.7AC7C8871A@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv1864 Modified Files: with-unique-names.lisp Log Message: Improved documentation and type checking. Cleaned up code a little. Date: Mon May 16 21:12:00 2005 Author: pscott Index: cl-utilities/with-unique-names.lisp diff -u cl-utilities/with-unique-names.lisp:1.2 cl-utilities/with-unique-names.lisp:1.3 --- cl-utilities/with-unique-names.lisp:1.2 Fri May 13 23:18:23 2005 +++ cl-utilities/with-unique-names.lisp Mon May 16 21:12:00 2005 @@ -10,7 +10,11 @@ (if (consp binding) binding (list binding binding)) - `(,var (gensym ,(format nil "~A" prefix))))) + (if (symbolp var) + `(,var (gensym ,(format nil "~A" prefix))) + (error 'type-error + :datum var + :expected-type 'symbol)))) bindings) , at body)) @@ -28,7 +32,11 @@ (defmacro with-gensyms ((&rest bindings) &body body) "Synonym for WITH-UNIQUE-NAMES, but BINDINGS should only consist of -atoms; lists are not supported." +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)) From pscott at common-lisp.net Mon May 16 22:06:47 2005 From: pscott at common-lisp.net (Peter Scott) Date: Tue, 17 May 2005 00:06:47 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/extremum.lisp Message-ID: <20050516220647.0A86B8871A@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv13214 Modified Files: extremum.lisp Log Message: Probably fixed problem with START and END and error checking. Date: Tue May 17 00:06:47 2005 Author: pscott Index: cl-utilities/extremum.lisp diff -u cl-utilities/extremum.lisp:1.3 cl-utilities/extremum.lisp:1.4 --- cl-utilities/extremum.lisp:1.3 Fri May 13 21:45:09 2005 +++ cl-utilities/extremum.lisp Tue May 17 00:06:47 2005 @@ -41,7 +41,8 @@ http://www.cliki.net/EXTREMUM for the full specification. Additionally, START and END specify the beginning and ending indices of the part of the sequence we should look at." - (if (zero-length-p sequence) + (if (or (zero-length-p sequence) + (>= start (or end (length sequence)))) (restart-case (error 'no-extremum) (continue () :report "Return NIL instead" @@ -54,7 +55,8 @@ &key (key #'identity) (start 0) end) (if (eql key #'identity) (once-only (sequence predicate start end) - `(if (zero-length-p ,sequence) + `(if (or (zero-length-p ,sequence) + (>= ,start (or ,end (length ,sequence)))) (restart-case (error 'no-extremum) (continue () :report "Return NIL instead" @@ -89,7 +91,8 @@ 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))) - (if (zero-length-p sequence) + (if (or (zero-length-p sequence) + (>= start (or end (length sequence)))) (restart-case (error 'no-extremum) (continue () :report "Return NIL instead" From pscott at common-lisp.net Tue May 17 19:17:34 2005 From: pscott at common-lisp.net (Peter Scott) Date: Tue, 17 May 2005 21:17:34 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/extremum.lisp Message-ID: <20050517191734.103A388726@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv24989 Modified Files: extremum.lisp Log Message: Fixed various problems and factored out some very ugly repeated checking code into a macro. The code is now much cleaner and less error-prone. Date: Tue May 17 21:17:34 2005 Author: pscott Index: cl-utilities/extremum.lisp diff -u cl-utilities/extremum.lisp:1.4 cl-utilities/extremum.lisp:1.5 --- cl-utilities/extremum.lisp:1.4 Tue May 17 00:06:47 2005 +++ cl-utilities/extremum.lisp Tue May 17 21:17:34 2005 @@ -31,6 +31,19 @@ (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)) + , 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. @@ -41,26 +54,16 @@ http://www.cliki.net/EXTREMUM for the full specification. Additionally, START and END specify the beginning and ending indices of the part of the sequence we should look at." - (if (or (zero-length-p sequence) - (>= start (or end (length sequence)))) - (restart-case (error 'no-extremum) - (continue () - :report "Return NIL instead" - nil)) - (reduce (comparator predicate key) sequence - :start start :end end))) + (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) - `(if (or (zero-length-p ,sequence) - (>= ,start (or ,end (length ,sequence)))) - (restart-case (error 'no-extremum) - (continue () - :report "Return NIL instead" - nil)) + `(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)))) @@ -72,12 +75,8 @@ "Returns the element of SEQUENCE that would appear first if the sequence were ordered according to SORT using PREDICATE and KEY. See http://www.cliki.net/EXTREMUM for the full specification." - (if (zero-length-p sequence) - (restart-case (error 'no-extremum) - (continue () - :report "Return NIL instead" - nil)) - (reduce (comparator predicate key) sequence))) + (with-check-length (sequence 0 nil) + (reduce (comparator predicate key) sequence))) ;; This is an "optimized" version which calls KEY less. REDUCE is ;; already so optimized that this will actually be slower unless KEY @@ -91,26 +90,21 @@ 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))) - (if (or (zero-length-p sequence) - (>= start (or end (length sequence)))) - (restart-case (error 'no-extremum) - (continue () - :report "Return NIL instead" - nil)) - (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 #.most-positive-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))) \ No newline at end of file + (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 #.most-positive-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))) \ No newline at end of file From pscott at common-lisp.net Tue May 17 19:30:10 2005 From: pscott at common-lisp.net (Peter Scott) Date: Tue, 17 May 2005 21:30:10 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/package.sh Message-ID: <20050517193010.1F92A88726@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv25204 Modified Files: package.sh Log Message: Fixed symlink bug Date: Tue May 17 21:30:09 2005 Author: pscott Index: cl-utilities/package.sh diff -u cl-utilities/package.sh:1.1.1.1 cl-utilities/package.sh:1.2 --- cl-utilities/package.sh:1.1.1.1 Mon May 9 23:26:29 2005 +++ cl-utilities/package.sh Tue May 17 21:30:09 2005 @@ -1,15 +1,17 @@ #!/bin/sh -mkdir cl-utilities-1.0 -cp cl-utilities.asd package.sh collecting.lisp expt-mod.lisp package.lisp split-sequence.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.0/ +mkdir cl-utilities-1.0.2 +cp cl-utilities.asd package.sh collecting.lisp expt-mod.lisp package.lisp split-sequence.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.0.2/ -tar -czvf cl-utilities-1.0.tar.gz cl-utilities-1.0/ -ln -s /root/lisp/cl-utilities/cl-utilities-1.0.tar.gz /root/lisp/cl-utilities/cl-utilities-latest.tar.gz -/usr/bin/xterm -e gpg -b -a /root/lisp/cl-utilities/cl-utilities-1.0.tar.gz -ln -s /root/lisp/cl-utilities/cl-utilities-1.0.tar.gz.asc /root/lisp/cl-utilities/cl-utilities-latest.tar.gz.asc -rm -Rf cl-utilities-1.0/ +rm -f cl-utilities-latest.tar.gz cl-utilities-latest.tar.gz.asc -scp cl-utilities-1.0.tar.gz pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.0.tar.gz -scp cl-utilities-1.0.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.0.tar.gz.asc +tar -czvf cl-utilities-1.0.2.tar.gz cl-utilities-1.0.2/ +ln -s /root/lisp/cl-utilities/cl-utilities-1.0.2.tar.gz /root/lisp/cl-utilities/cl-utilities-latest.tar.gz +/usr/bin/xterm -e gpg -b -a /root/lisp/cl-utilities/cl-utilities-1.0.2.tar.gz +ln -s /root/lisp/cl-utilities/cl-utilities-1.0.2.tar.gz.asc /root/lisp/cl-utilities/cl-utilities-latest.tar.gz.asc +rm -Rf cl-utilities-1.0.2/ + +scp cl-utilities-1.0.2.tar.gz pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.0.2.tar.gz +scp cl-utilities-1.0.2.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.0.2.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 From pscott at common-lisp.net Thu May 26 19:09:06 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 26 May 2005 21:09:06 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/once-only.lisp Message-ID: <20050526190906.22FA588756@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv3083 Modified Files: once-only.lisp Log Message: Factored out error checking Date: Thu May 26 21:09:05 2005 Author: pscott Index: cl-utilities/once-only.lisp diff -u cl-utilities/once-only.lisp:1.1.1.1 cl-utilities/once-only.lisp:1.2 --- cl-utilities/once-only.lisp:1.1.1.1 Mon May 9 23:26:29 2005 +++ cl-utilities/once-only.lisp Thu May 26 21:09:05 2005 @@ -7,11 +7,18 @@ (in-package :cl-utilities) -(defmacro once-only ((&rest names) &body body) - ;; Check that all of the NAMES are symbols. If not, raise an error. +(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))) + (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 From pscott at common-lisp.net Thu May 26 19:11:52 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 26 May 2005 21:11:52 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/compose.lisp Message-ID: <20050526191152.B249088743@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv3117 Modified Files: compose.lisp Log Message: Added some commentary on single and multiple values. Date: Thu May 26 21:11:52 2005 Author: pscott Index: cl-utilities/compose.lisp diff -u cl-utilities/compose.lisp:1.3 cl-utilities/compose.lisp:1.4 --- cl-utilities/compose.lisp:1.3 Fri May 13 21:17:38 2005 +++ cl-utilities/compose.lisp Thu May 26 21:11:51 2005 @@ -1,3 +1,7 @@ +;; 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 From pscott at common-lisp.net Thu May 26 19:20:29 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 26 May 2005 21:20:29 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/extremum.lisp Message-ID: <20050526192029.7757388743@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv3996 Modified Files: extremum.lisp Log Message: Updated and improved documentation Date: Thu May 26 21:20:28 2005 Author: pscott Index: cl-utilities/extremum.lisp diff -u cl-utilities/extremum.lisp:1.5 cl-utilities/extremum.lisp:1.6 --- cl-utilities/extremum.lisp:1.5 Tue May 17 21:17:34 2005 +++ cl-utilities/extremum.lisp Thu May 26 21:20:28 2005 @@ -22,6 +22,11 @@ (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))) @@ -51,9 +56,7 @@ &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. See -http://www.cliki.net/EXTREMUM for the full -specification. Additionally, START and END specify the beginning and -ending indices of the part of the sequence we should look at." +http://www.cliki.net/EXTREMUM for the full specification." (with-check-length (sequence start end) (reduce (comparator predicate key) sequence :start start :end end))) @@ -68,15 +71,6 @@ (reduce (comparator ,predicate) ,sequence :start ,start :end ,end)))) whole)) - -;; And, for backup, here's a strictly spec-compliant version. -#+nil -(defun extremum (sequence predicate &key (key #'identity)) - "Returns the element of SEQUENCE that would appear first if the -sequence were ordered according to SORT using PREDICATE and KEY. See -http://www.cliki.net/EXTREMUM for the full specification." - (with-check-length (sequence 0 nil) - (reduce (comparator predicate key) sequence))) ;; This is an "optimized" version which calls KEY less. REDUCE is ;; already so optimized that this will actually be slower unless KEY From pscott at common-lisp.net Thu May 26 19:46:47 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 26 May 2005 21:46:47 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/read-delimited.lisp Message-ID: <20050526194647.AE57E88743@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv5758 Modified Files: read-delimited.lisp Log Message: Major refactoring. It now does exactly the same thing as it used to, but now it does it in such a way that I'm not afraid of its source code. Date: Thu May 26 21:46:46 2005 Author: pscott Index: cl-utilities/read-delimited.lisp diff -u cl-utilities/read-delimited.lisp:1.1.1.1 cl-utilities/read-delimited.lisp:1.2 --- cl-utilities/read-delimited.lisp:1.1.1.1 Mon May 9 23:26:29 2005 +++ cl-utilities/read-delimited.lisp Thu May 26 21:46:46 2005 @@ -1,5 +1,25 @@ (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) @@ -11,41 +31,48 @@ (:documentation "There's a problem with the indices START and END for SEQUENCE. See CLHS SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR issue.")) -(defun read-delimited (sequence stream &key (start 0) end - (delimiter #\Newline) (test #'eql) key) - ;; Check to make sure END is in bounds - (when (and end (> end (length sequence))) +;; 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 "Use default instead" - (setf end nil)))) - ;; Check to make sure START is in bounds + :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 instead" + :report "Use default for START instead" (setf start 0)))) - (let ((key (or key #'identity)) - (end (or end (length sequence)))) - ;; START and END should be positive integers by now - (check-type start unsigned-byte) - (check-type end unsigned-byte) - ;; Check to make sure that START < END - (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)))) - ;; Actually do the looping - (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))))) \ No newline at end of file + 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 From pscott at common-lisp.net Thu May 26 19:47:53 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 26 May 2005 21:47:53 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/once-only.lisp Message-ID: <20050526194753.E5DD788743@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv5783 Modified Files: once-only.lisp Log Message: Switched to %foo naming convention for auxilliary functions. Date: Thu May 26 21:47:53 2005 Author: pscott Index: cl-utilities/once-only.lisp diff -u cl-utilities/once-only.lisp:1.2 cl-utilities/once-only.lisp:1.3 --- cl-utilities/once-only.lisp:1.2 Thu May 26 21:09:05 2005 +++ cl-utilities/once-only.lisp Thu May 26 21:47:53 2005 @@ -7,7 +7,7 @@ (in-package :cl-utilities) -(defun check-once-only-names (names) +(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 @@ -18,7 +18,7 @@ (defmacro once-only (names &body body) ;; Check the NAMES list for validity. - (check-once-only-names names) + (%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 From pscott at common-lisp.net Thu May 26 20:00:00 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 26 May 2005 22:00:00 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/with-unique-names.lisp Message-ID: <20050526200000.D895388743@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv5859 Modified Files: with-unique-names.lisp Log Message: Refactored and improved type checking. Date: Thu May 26 22:00:00 2005 Author: pscott Index: cl-utilities/with-unique-names.lisp diff -u cl-utilities/with-unique-names.lisp:1.3 cl-utilities/with-unique-names.lisp:1.4 --- cl-utilities/with-unique-names.lisp:1.3 Mon May 16 21:12:00 2005 +++ cl-utilities/with-unique-names.lisp Thu May 26 22:00:00 2005 @@ -6,17 +6,21 @@ "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) - (destructuring-bind (var prefix) - (if (consp binding) - binding - (list binding binding)) - (if (symbolp var) - `(,var (gensym ,(format nil "~A" prefix))) - (error 'type-error - :datum var - :expected-type 'symbol)))) + (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)) From pscott at common-lisp.net Thu May 26 20:10:56 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 26 May 2005 22:10:56 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/cl-utilities.asd Message-ID: <20050526201056.E5CC088743@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv6732 Modified Files: cl-utilities.asd Log Message: Added dependency for COMPOSE used in macroexpander code in WITH-COLLECTORS Date: Thu May 26 22:10:56 2005 Author: pscott Index: cl-utilities/cl-utilities.asd diff -u cl-utilities/cl-utilities.asd:1.1.1.1 cl-utilities/cl-utilities.asd:1.2 --- cl-utilities/cl-utilities.asd:1.1.1.1 Mon May 9 23:26:29 2005 +++ cl-utilities/cl-utilities.asd Thu May 26 22:10:56 2005 @@ -8,11 +8,15 @@ (defsystem cl-utilities :author "Maintained by Peter Scott" :components ((:file "package") - (:file "extremum" :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")) + (: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")) From pscott at common-lisp.net Thu May 26 20:16:48 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 26 May 2005 22:16:48 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/collecting.lisp Message-ID: <20050526201648.0DF3788743@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv7621 Modified Files: collecting.lisp Log Message: Refactored, moved things around, improved error handling, and generally improved things. Date: Thu May 26 22:16:47 2005 Author: pscott Index: cl-utilities/collecting.lisp diff -u cl-utilities/collecting.lisp:1.1.1.1 cl-utilities/collecting.lisp:1.2 --- cl-utilities/collecting.lisp:1.1.1.1 Mon May 9 23:26:29 2005 +++ cl-utilities/collecting.lisp Thu May 26 22:16:47 2005 @@ -1,5 +1,3 @@ -(in-package :cl-utilities) - ;; Opinions differ on how a collection macro should work. There are ;; two main points for discussion: multiple collection variables and ;; implementation method. @@ -14,11 +12,11 @@ ;; 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 +;; 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" @@ -40,27 +38,13 @@ , at body) ,collector))) -#+nil -(collecting - (dotimes (x 10) - (collect x))) - -;(collecting (mapc #'collect '(1 2 3 4 5))) - (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." - ;; 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 "WITH-COLLECTORS expected a symbol but got ~S" bad-collector))) - (let ((gensyms-alist (mapcar #'cons collectors - (mapcar #'gensym - (mapcar #'(lambda (x) - (format nil "~A-TAIL-" x)) - collectors))))) + (%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)) @@ -75,10 +59,26 @@ , at body) (values , at collectors)))) -#+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 +(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 From pscott at common-lisp.net Thu May 26 20:24:25 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 26 May 2005 22:24:25 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/copy-array.lisp Message-ID: <20050526202425.7DAFB88743@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv7681 Modified Files: copy-array.lisp Log Message: Factored out part of COPY-ARRAY into its own function. Date: Thu May 26 22:24:24 2005 Author: pscott Index: cl-utilities/copy-array.lisp diff -u cl-utilities/copy-array.lisp:1.1.1.1 cl-utilities/copy-array.lisp:1.2 --- cl-utilities/copy-array.lisp:1.1.1.1 Mon May 9 23:26:29 2005 +++ cl-utilities/copy-array.lisp Thu May 26 22:24:24 2005 @@ -7,19 +7,23 @@ 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 - (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))))))) + (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)) \ No newline at end of file + 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 From pscott at common-lisp.net Thu May 26 20:29:24 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 26 May 2005 22:29:24 +0200 (CEST) Subject: [cl-utilities-cvs] CVS update: cl-utilities/package.sh Message-ID: <20050526202924.CB06088743@common-lisp.net> Update of /project/cl-utilities/cvsroot/cl-utilities In directory common-lisp.net:/tmp/cvs-serv7761 Modified Files: package.sh Log Message: Updated version number Date: Thu May 26 22:29:24 2005 Author: pscott Index: cl-utilities/package.sh diff -u cl-utilities/package.sh:1.2 cl-utilities/package.sh:1.3 --- cl-utilities/package.sh:1.2 Tue May 17 21:30:09 2005 +++ cl-utilities/package.sh Thu May 26 22:29:24 2005 @@ -1,17 +1,17 @@ #!/bin/sh -mkdir cl-utilities-1.0.2 -cp cl-utilities.asd package.sh collecting.lisp expt-mod.lisp package.lisp split-sequence.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.0.2/ +mkdir cl-utilities-1.1 +cp cl-utilities.asd package.sh collecting.lisp expt-mod.lisp package.lisp split-sequence.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.1/ rm -f cl-utilities-latest.tar.gz cl-utilities-latest.tar.gz.asc -tar -czvf cl-utilities-1.0.2.tar.gz cl-utilities-1.0.2/ -ln -s /root/lisp/cl-utilities/cl-utilities-1.0.2.tar.gz /root/lisp/cl-utilities/cl-utilities-latest.tar.gz -/usr/bin/xterm -e gpg -b -a /root/lisp/cl-utilities/cl-utilities-1.0.2.tar.gz -ln -s /root/lisp/cl-utilities/cl-utilities-1.0.2.tar.gz.asc /root/lisp/cl-utilities/cl-utilities-latest.tar.gz.asc -rm -Rf cl-utilities-1.0.2/ +tar -czvf cl-utilities-1.1.tar.gz cl-utilities-1.1/ +ln -s /root/lisp/cl-utilities/cl-utilities-1.1.tar.gz /root/lisp/cl-utilities/cl-utilities-latest.tar.gz +/usr/bin/xterm -e gpg -b -a /root/lisp/cl-utilities/cl-utilities-1.1.tar.gz +ln -s /root/lisp/cl-utilities/cl-utilities-1.1.tar.gz.asc /root/lisp/cl-utilities/cl-utilities-latest.tar.gz.asc +rm -Rf cl-utilities-1.1/ -scp cl-utilities-1.0.2.tar.gz pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.0.2.tar.gz -scp cl-utilities-1.0.2.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.0.2.tar.gz.asc +scp cl-utilities-1.1.tar.gz pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.1.tar.gz +scp cl-utilities-1.1.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.1.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