Changeset 3200

Timestamp:

05/28/08 13:26:38 (8 months ago)

Author:

hans

Message:

pull alexandria from darcs repository

Files:

• trunk/thirdparty/alexandria/_darcs/inventory (modified) (1 diff)
• trunk/thirdparty/alexandria/_darcs/pristine/alexandria.asd (modified) (1 diff)
• trunk/thirdparty/alexandria/_darcs/pristine/arrays.lisp (modified) (1 diff)
• trunk/thirdparty/alexandria/_darcs/pristine/conditions.lisp (modified) (1 diff)
• trunk/thirdparty/alexandria/_darcs/pristine/control-flow.lisp (modified) (3 diffs)
• trunk/thirdparty/alexandria/_darcs/pristine/definitions.lisp (modified) (3 diffs)
• trunk/thirdparty/alexandria/_darcs/pristine/doc/alexandria.texinfo (modified) (4 diffs)
• trunk/thirdparty/alexandria/_darcs/pristine/hash-tables.lisp (modified) (2 diffs)
• trunk/thirdparty/alexandria/_darcs/pristine/lists.lisp (modified) (2 diffs)
• trunk/thirdparty/alexandria/_darcs/pristine/macros.lisp (modified) (2 diffs)
• trunk/thirdparty/alexandria/_darcs/pristine/numbers.lisp (modified) (2 diffs)
• trunk/thirdparty/alexandria/_darcs/pristine/package.lisp (modified) (6 diffs)
• trunk/thirdparty/alexandria/_darcs/pristine/sequences.lisp (modified) (8 diffs)
• trunk/thirdparty/alexandria/_darcs/pristine/symbols.lisp (modified) (1 diff)
• trunk/thirdparty/alexandria/_darcs/pristine/tests.lisp (modified) (17 diffs)
• trunk/thirdparty/alexandria/_darcs/pristine/types.lisp (modified) (2 diffs)
• trunk/thirdparty/alexandria/alexandria.asd (modified) (1 diff)
• trunk/thirdparty/alexandria/arrays.lisp (modified) (1 diff)
• trunk/thirdparty/alexandria/conditions.lisp (modified) (1 diff)
• trunk/thirdparty/alexandria/control-flow.lisp (modified) (3 diffs)
• trunk/thirdparty/alexandria/definitions.lisp (modified) (3 diffs)
• trunk/thirdparty/alexandria/doc/alexandria.texinfo (modified) (4 diffs)
• trunk/thirdparty/alexandria/hash-tables.lisp (modified) (2 diffs)
• trunk/thirdparty/alexandria/lists.lisp (modified) (2 diffs)
• trunk/thirdparty/alexandria/macros.lisp (modified) (2 diffs)
• trunk/thirdparty/alexandria/numbers.lisp (modified) (2 diffs)
• trunk/thirdparty/alexandria/package.lisp (modified) (6 diffs)
• trunk/thirdparty/alexandria/sequences.lisp (modified) (8 diffs)
• trunk/thirdparty/alexandria/symbols.lisp (modified) (1 diff)
• trunk/thirdparty/alexandria/tests.lisp (modified) (17 diffs)
• trunk/thirdparty/alexandria/types.lisp (modified) (2 diffs)

trunk/thirdparty/alexandria/_darcs/inventory

@@ -99 +99 @@
-] 
-[Small fix to REQUIRED-ARGUMENT's control string.
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

trunk/thirdparty/alexandria/_darcs/pristine/alexandria.asd

@@ -10 +10 @@
-   (:file "conditions" :depends-on ("package"))
-   (:file "hash-tables" :depends-on ("package"))
-
-
+ "symbols"
+definitions" "
-   (:file "symbols" :depends-on ("package"))
-
-
+ "types"
+ "symbols" "lists"
-   (:file "binding" :depends-on ("package"))
-   (:file "functions" :depends-on ("package" "symbols" "macros"))
-   (:file "lists" :depends-on ("package" "functions"))
-   (:file "sequences" :depends-on ("package" "lists"))
-
+
+

trunk/thirdparty/alexandria/_darcs/pristine/arrays.lisp

@@ -1 +1 @@
-(in-package :alexandria)
-
-(deftype array-index (&optional (length array-dimension-limit))
-  "Type designator for an index into array of LENGTH: an integer between
-0 (inclusive) and LENGTH (exclusive). LENGTH defaults to
-ARRAY-DIMENSION-LIMIT."
-  `(integer 0 (,length)))
-
-(deftype array-length (&optional (length array-dimension-limit))
-  "Type designator for a dimension of an array of LENGTH: an integer between
-0 (inclusive) and LENGTH (inclusive). LENGTH defaults to
-ARRAY-DIMENSION-LIMIT."
-  `(integer 0 ,length))
-
-(defun copy-array (array &key

trunk/thirdparty/alexandria/_darcs/pristine/conditions.lisp

@@ -13 +13 @@
-  (warn 'simple-style-warning :format-control message :format-arguments args))
-
+;; We don't specify a :report for simple-reader-error to let the underlying
+;; implementation report the line and column position for us. Unfortunately
+;; this way the message from simple-error is not displayed, but it's still
+;; inspectable from the debugger.
+(define-condition simple-reader-error (reader-error simple-error)
+  ())
+
+(defun simple-reader-error (stream message &rest args)
+  (error 'simple-reader-error
+         :stream stream
+         :format-control message
+         :format-arguments args))
+
+(define-condition simple-parse-error (simple-error parse-error)
+  ())
+
+(defun simple-parse-error (message &rest args)
+  (error 'simple-parse-error
+         :format-control message
+         :format-arguments args))
+
+(defmacro ignore-some-conditions ((&rest conditions) &body body)
+  "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS
+list determines which specific conditions are to be ignored."
+  `(handler-case
+       (progn ,@body)
+     ,@(loop for condition in conditions collect
+             `(,condition (c) (values nil c)))))
+
+(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses)
+  "Like CL:UNWIND-PROTECT, but you can specify the circumstances that
+the cleanup CLAUSES are run.
+
+ABORT-FLAG is the name of a variable that will be bound to T in
+CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL
+otherwise.
+
+Examples:
+
+  (unwind-protect-case ()
+       (protected-form)
+     (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\"))
+     (:abort  (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\"))
+     (:always (format t \"This is evaluated in either case.~%\")))
+
+  (unwind-protect-case (aborted-p)
+       (protected-form)
+     (:always (perform-cleanup-if aborted-p)))
+"
+  (check-type abort-flag (or null symbol))
+  (let ((gflag (gensym "FLAG+")))
+    `(let ((,gflag t))
+       (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil))
+         (let ,(and abort-flag `((,abort-flag ,gflag)))
+           ,@(loop for (cleanup-kind . forms) in clauses
+                   collect (ecase cleanup-kind
+                             (:normal `(when (not ,gflag) ,@forms))
+                             (:abort  `(when ,gflag ,@forms))
+                             (:always `(progn ,@forms)))))))))

trunk/thirdparty/alexandria/_darcs/pristine/control-flow.lisp

@@ -4 +4 @@
-  (with-gensyms (value)
-    (setf test (extract-function-name test))
+    (setf key (extract-function-name key))
-    (when (and (consp default)
-               (member (first default) '(error cerror)))
@@ -39 +40 @@
-  (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
-
-
+ &environment env
-  "Evaluates exactly one of POSSIBILITIES, chosen at random."
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
-
-(defmacro xor (&rest datums)
@@ -67 +73 @@
-                   datums)
-         (return-from ,xor (values ,true t))))))
+
+(defmacro nth-value-or (nth-value &body forms)
+  "Evaluates FORM arguments one at a time, until the NTH-VALUE returned by one
+of the forms is non-NIL. It then returns all the values returned by evaluating
+that form. If none of the forms return a non-nil nth value, this form returns
+NIL."
+  (once-only (nth-value)
+    (with-gensyms (values)
+      `(let ((,values (multiple-value-list ,(first forms))))
+         (if (nth ,nth-value ,values)
+             (values-list ,values)
+             ,(if (rest forms)
+                  `(nth-value-or ,nth-value ,@(rest forms))
+                  nil))))))

trunk/thirdparty/alexandria/_darcs/pristine/definitions.lisp

@@ -2 +2 @@
-
-(defun extract-function-name (spec)
-emulate
+mimic
-like #'eq and 'eq."
-  (if (and (consp spec)
@@ -9 +9 @@
-      spec))
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-Signals an error if NAME is already a bound non-constant variable.
@@ -19 +38 @@
-Signals an error if NAME is already a constant variable whose value is not
-equal under TEST to result of evaluating INITIAL-VALUE."
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
-     ,@(when documentation `(,documentation))))

trunk/thirdparty/alexandria/_darcs/pristine/doc/alexandria.texinfo

@@ -81 +81 @@
-* Type Designator Manipulation::  
-* Mathematical Utilities::      
+* Features::                    
-@end menu
-
@@ -126 +127 @@
-@include include/type-alexandria-circular-list.texinfo
-@include include/macro-alexandria-appendf.texinfo
+@include include/macro-alexandria-nconcf.texinfo
-@include include/fun-alexandria-circular-list.texinfo
-@include include/fun-alexandria-circular-list-p.texinfo
@@ -192 +194 @@
-@include include/fun-alexandria-of-type.texinfo
-@include include/fun-alexandria-type-equal.texinfo
+@include include/macro-alexandria-coercef.texinfo
-
-@node Mathematical Utilities
@@ -209 +212 @@
-@include include/fun-alexandria-standard-deviation.texinfo
-
+@c FIXME: get a better section name
+@node Features
+@comment  node-name,  next,  previous,  up
+@section Features
+
+@include include/fun-alexandria-featurep.texinfo
+
-@bye

trunk/thirdparty/alexandria/_darcs/pristine/hash-tables.lisp

@@ -1 +1 @@
-(in-package :alexandria)
-
-
-
-
-
-
-
+
+
+
-as the TABLE. The copy has the same properties as the original, unless
-
+
+
+
+
+
+
+
+
+
+
-  (let ((copy (make-hash-table :test test :size size
-                               :rehash-size rehash-size
-                               :rehash-threshold rehash-threshold)))
-    (maphash (lambda (k v)
-v
+(funcall key v)
-             table)
-    copy))
@@ -84 +90 @@
-    table))
-
+(defun ensure-gethash (key hash-table &optional default)
+  "Like GETHASH, but if KEY is not found in the HASH-TABLE saves the DEFAULT
+under key before returning it. Secondary return value is true if key was
+already in the table."
+  (multiple-value-bind (value ok) (gethash key hash-table)
+    (if ok
+        (values value ok)
+        (values (setf (gethash key hash-table) default) nil))))

trunk/thirdparty/alexandria/_darcs/pristine/lists.lisp

@@ -18 +18 @@
-      (push (cons (car tail) (cadr tail)) alist))))
-
+(defun malformed-plist (plist)
+  (error "Malformed plist: ~S" plist))
+
+(defmacro doplist ((key val plist &optional values) &body body)
+  "Iterates over elements of PLIST. BODY can be preceded by
+declarations, and is like a TAGBODY. RETURN may be used to terminate
+the iteration early. If RETURN is not used, returns VALUES."
+  (multiple-value-bind (forms declarations) (parse-body body)
+    (with-gensyms (tail loop results)
+      `(block nil
+         (flet ((,results ()
+                  (let (,key ,val)
+                    (declare (ignorable ,key ,val))
+                    (return ,values))))
+           (let* ((,tail ,plist)
+                  (,key (if ,tail
+                            (pop ,tail)
+                            (,results)))
+                 (,val (if ,tail
+                           (pop ,tail)
+                           (malformed-plist ',plist))))
+            (declare (ignorable ,key ,val))
+            ,@declarations
+            (tagbody
+               ,loop
+               ,@forms
+               (setf ,key (if ,tail
+                              (pop ,tail)
+                              (,results))
+                     ,val (if ,tail
+                              (pop ,tail)
+                              (malformed-plist ',plist)))
+               (go ,loop))))))))
+
-(define-modify-macro appendf (&rest lists) append
-  "Modify-macro for APPEND. Appends LISTS to the place designated by the first
+argument.")
+
+(define-modify-macro nconcf (&rest lists) nconc
+  "Modify-macro for NCONC. Concatenates LISTS to place designated by the first
-argument.")
-
@@ -152 +190 @@
-not destructively modified. Keys are compared using EQ."
-  (declare (optimize (speed 3)))
-
-
-
-
-
+
+
+
+
-        unless (member key keys :test #'eq)
-
-
-
+
-
-(defun delete-from-plist (plist &rest keys)
-  "Just like REMOVE-FROM-PLIST, but this version may destructively modify the
-provided plist."
- unoptimal
+: should not cons
-  (apply 'remove-from-plist plist keys))
-
-plist 
-plist 
+
+
-
-(declaim (inline sans))

trunk/thirdparty/alexandria/_darcs/pristine/macros.lisp

@@ -18 +18 @@
-    `(with-gensyms ,names ,@forms))
-
-
-
-
+
+
+
+
+
+
-
-Example:
-  (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
-  (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
-
+
+
+
+
+
+
+
+
+
-    ;; bind in user-macro
-n
-
+(car n)
+-and-forms
-       ;; bind in final expansion
-
+
+
+
-          ;; bind in user-macro
-
+
+
-             ,@forms)))))
-
@@ -51 +65 @@
-             (setf doc (pop body)))
-         (go :declarations))
-starts-with 'declare current
+and (listp current) (eql (first current) 'declare)
-         (push (pop body) decls)
-         (go :declarations)))

trunk/thirdparty/alexandria/_darcs/pristine/numbers.lisp

@@ -45 +45 @@
-  "Return a list of n numbers, starting from START (with numeric contagion
-from STEP applied), each consequtive number being the sum of the previous one
-0
+1
-
-Examples:
@@ -63 +63 @@
-  "Calls FUNCTION with N numbers, starting from START (with numeric contagion
-from STEP applied), each consequtive number being the sum of the previous one
-0
+1
-
-Examples:
-
-
-
-
+
+
+
+
-"
-  (declare (type (integer 0) n) (number start step))

trunk/thirdparty/alexandria/_darcs/pristine/package.lisp

@@ -13 +13 @@
-   #:cswitch
-   #:eswitch
+   #:nth-value-or
-   #:switch
-   #:whichever
@@ -19 +20 @@
-   #:alist-hash-table
-   #:copy-hash-table
+   #:ensure-gethash
-   #:hash-table-alist
-   #:hash-table-keys
@@ -38 +40 @@
-   #:alist-plist
-   #:appendf
+   #:nconcf
-   #:circular-list
-   #:circular-list-p
-   #:circular-tree-p
+   #:doplist
-   #:ensure-car
-   #:ensure-cons
@@ -90 +94 @@
-   #:map-combinations
-   #:map-derangements
-
+t
-   #:proper-sequence
-   #:random-elt
@@ -96 +100 @@
-   #:rotate
-   #:sequence-of-length-p
+   #:length=
-   #:shuffle
-   #:starts-with
@@ -114 +119 @@
-   #:of-type
-   #:type=
-
+
+
-   #:required-argument
+   #:ignore-some-conditions
-   #:simple-style-warning
+   #:simple-reader-error
+   #:simple-parse-error
+   #:unwind-protect-case
+   ;; Features
+   #:featurep
-   ))

trunk/thirdparty/alexandria/_darcs/pristine/sequences.lisp

@@ -1 +1 @@
-(in-package :alexandria)
+
+;; Make these inlinable by declaiming them INLINE here and some of them
+;; NOTINLINE at the end of the file. Exclude functions that have a compiler
+;; macro, because inlining seems to cancel compiler macros (at least on SBCL).
+(declaim (inline copy-sequence sequence-of-length-p))
-
-(defun rotate-tail-to-head (sequence n)
@@ -52 +57 @@
-(defun shuffle (sequence &key (start 0) end)
-  "Returns a random permutation of SEQUENCE bounded by START and END.
-
-an 
+ an
+
-  (declare (fixnum start) (type (or fixnum null) end))
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-  sequence)
-
@@ -70 +88 @@
-    (elt sequence i)))
-
+(declaim (inline remove/swapped-arguments))
+(defun remove/swapped-arguments (sequence item &rest keyword-arguments)
+  (apply #'remove item sequence keyword-arguments))
+
-(define-modify-macro removef (item &rest remove-keywords)
-
-
+
-  "Modify-macro for REMOVE. Sets place designated by the first argument to
-the result of calling REMOVE with ITEM, place, and the REMOVE-KEYWORDS.")
-
+(declaim (inline delete/swapped-arguments))
+(defun delete/swapped-arguments (sequence item &rest keyword-arguments)
+  (apply #'delete item sequence keyword-arguments))
+
-(define-modify-macro deletef (item &rest remove-keywords)
-
-
+
-  "Modify-macro for DELETE. Sets place designated by the first argument to
-the result of calling DELETE with ITEM, place, and the REMOVE-KEYWORDS.")
@@ -95 +119 @@
-    (sequence (zerop (length sequence)))))
-
+(defun length= (&rest sequences)
+  "Takes any number of sequences or integers in any order. Returns true iff
+the length of all the sequences and the integers are equal. Hint: there's a
+compiler macro that expands into more efficient code if the first argument
+is a literal integer."
+  (declare (dynamic-extent sequences)
+           (inline sequence-of-length-p)
+           (optimize speed))
+  (unless (cdr sequences)
+    (error "You must call LENGTH= with at least two arguments"))
+  ;; There's room for optimization here: multiple list arguments could be
+  ;; traversed in parallel.
+  (let* ((first (pop sequences))
+         (current (if (integerp first)
+                      first
+                      (length first))))
+    (declare (type array-index current))
+    (dolist (el sequences)
+      (if (integerp el)
+          (unless (= el current)
+            (return-from length= nil))
+          (unless (sequence-of-length-p el current)
+            (return-from length= nil)))))
+  t)
+
+(define-compiler-macro length= (&whole form length &rest sequences)
+  (cond
+    ((zerop (length sequences))
+     form)
+    (t
+     (let ((optimizedp (integerp length)))
+       (with-unique-names (tmp current)
+         (declare (ignorable current))
+         `(locally
+              (declare (inline sequence-of-length-p))
+            (let ((,tmp)
+                  ,@(unless optimizedp
+                     `((,current ,length))))
+              ,@(unless optimizedp
+                  `((unless (integerp ,current)
+                      (setf ,current (length ,current)))))
+              (and
+               ,@(loop
+                    :for sequence :in sequences
+                    :collect `(progn
+                                (setf ,tmp ,sequence)
+                                (if (integerp ,tmp)
+                                    (= ,tmp ,(if optimizedp
+                                                 length
+                                                 current))
+                                    (sequence-of-length-p ,tmp ,(if optimizedp
+                                                                    length
+                                                                    current)))))))))))))
+
-(defun sequence-of-length-p (sequence length)
-  "Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if
-SEQUENCE is not a sequence. Returns FALSE for circular lists."
+  (declare (type array-index length)
+           (inline length)
+           (optimize speed))
-  (etypecase sequence
-    (null
@@ -105 +186 @@
-       (unless (minusp n)
-         (let ((tail (nthcdr n sequence)))
-
+
+
+
+
-    (sequence
-     (= length (length sequence)))))
-
-(declaim (inline copy-sequence))
-(defun copy-sequence (type sequence)
-  "Returns a fresh sequence of TYPE, which has the same elements as
@@ -174 +257 @@
-                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
-
-sequence prefix
+prefix sequence
-  "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
-