Permalink
Browse files

added alexandria

  • Loading branch information...
vii committed May 13, 2009
1 parent f619572 commit 0b576e8f33efe9edb27c0b26af5be04e17718090
View
@@ -0,0 +1,13 @@
+# Boring file regexps:
+~$
+^_darcs
+^\{arch\}
+^.arch-ids
+\#
+\.dfsl$
+\.ppcf$
+\.fasl$
+\.x86f$
+\.fas$
+\.lib$
+^public_html
@@ -0,0 +1,9 @@
+
+ACTA EST FABULA PLAUDITE
+
+Nikodemus Siivola
+Attila Lendvai
+Marco Baringer
+Robert Strandh
+Luis Oliveira
+Tobias C. Rittweiler
View
@@ -0,0 +1,37 @@
+Alexandria software and associated documentation are in the public
+domain:
+
+ Authors dedicate this work to public domain, for the benefit of the
+ public at large and to the detriment of the authors' heirs and
+ successors. Authors intends this dedication to be an overt act of
+ relinquishment in perpetuity of all present and future rights under
+ copyright law, whether vested or contingent, in the work. Authors
+ understands that such relinquishment of all rights includes the
+ relinquishment of all rights to enforce (by lawsuit or otherwise)
+ those copyrights in the work.
+
+ Authors recognize that, once placed in the public domain, the work
+ may be freely reproduced, distributed, transmitted, used, modified,
+ built upon, or otherwise exploited by anyone for any purpose,
+ commercial or non-commercial, and in any way, including by methods
+ that have not yet been invented or conceived.
+
+In those legislations where public domain dedications are not
+recognized or possible, Alexandria is distributed under the following
+terms and conditions:
+
+ Permission is hereby granted, free of charge, to any person
+ obtaining a copy of this software and associated documentation files
+ (the "Software"), to deal in the Software without restriction,
+ including without limitation the rights to use, copy, modify, merge,
+ publish, distribute, sublicense, and/or sell copies of the Software,
+ and to permit persons to whom the Software is furnished to do so,
+ subject to the following conditions:
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
@@ -0,0 +1,13 @@
+(defsystem alexandria-tests
+ :depends-on (:alexandria #+sbcl :sb-rt #-sbcl :rt)
+ :components ((:file "tests")))
+
+(defmethod operation-done-p
+ ((o test-op) (c (eql (find-system :alexandria-tests))))
+ nil)
+
+(defmethod perform ((o test-op) (c (eql (find-system :alexandria-tests))))
+ (flet ((run-tests (&rest args)
+ (apply (intern (string '#:run-tests) '#:alexandria-tests) args)))
+ (run-tests :compiled nil)
+ (run-tests :compiled t)))
@@ -0,0 +1,30 @@
+(defsystem :alexandria
+ :version "0.0.0"
+ :licence "Public Domain / 0-clause MIT"
+ :components
+ ((:static-file "LICENCE")
+ (:static-file "tests.lisp")
+ (:file "package")
+ (:file "definitions" :depends-on ("package"))
+ (:file "binding" :depends-on ("package"))
+ (:file "strings" :depends-on ("package"))
+ (:file "conditions" :depends-on ("package"))
+ (:file "hash-tables" :depends-on ("package"))
+ (:file "io" :depends-on ("package" "macros" "lists"))
+ (:file "macros" :depends-on ("package" "strings" "symbols"))
+ (:file "control-flow" :depends-on ("package" "definitions" "macros"))
+ (:file "symbols" :depends-on ("package"))
+ (:file "functions" :depends-on ("package" "symbols" "macros"))
+ (:file "lists" :depends-on ("package" "functions"))
+ (:file "types" :depends-on ("package" "symbols" "lists"))
+ (:file "arrays" :depends-on ("package" "types"))
+ (:file "sequences" :depends-on ("package" "lists" "types"))
+ (:file "numbers" :depends-on ("package" "sequences"))
+ (:file "features" :depends-on ("package" "control-flow"))))
+
+(defmethod operation-done-p ((o test-op) (c (eql (find-system :alexandria))))
+ nil)
+
+(defmethod perform ((o test-op) (c (eql (find-system :alexandria))))
+ (operate 'load-op :alexandria-tests)
+ (operate 'test-op :alexandria-tests))
@@ -0,0 +1,19 @@
+(in-package :alexandria)
+
+(defun copy-array (array &key
+ (element-type (array-element-type array))
+ (fill-pointer (and (array-has-fill-pointer-p array)
+ (fill-pointer array)))
+ (adjustable (adjustable-array-p array)))
+ "Returns an undisplaced copy of ARRAY, with same fill-pointer
+and adjustability (if any) as the original, unless overridden by
+the keyword arguments."
+ (let ((dims (array-dimensions array)))
+ ;; Dictionary entry for ADJUST-ARRAY requires adjusting a
+ ;; displaced array to a non-displaced one to make a copy.
+ (adjust-array
+ (make-array dims
+ :element-type element-type :fill-pointer fill-pointer
+ :adjustable adjustable :displaced-to array)
+ dims)))
+
@@ -0,0 +1,93 @@
+(in-package :alexandria)
+
+(defmacro if-let (bindings &body (then-form &optional else-form))
+ "Creates new variable bindings, and conditionally executes either
+THEN-FORM or ELSE-FORM. ELSE-FORM defaults to NIL.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+ (variable-2 initial-form-2)
+ ...
+ (variable-n initial-form-n))
+
+All initial-forms are executed sequentially in the specified order. Then all
+the variables are bound to the corresponding values.
+
+If all variables were bound to true values, the THEN-FORM is executed with the
+bindings in effect, otherwise the ELSE-FORM is executed with the bindings in
+effect."
+ (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+ (list bindings)
+ bindings))
+ (variables (mapcar #'car binding-list)))
+ `(let ,binding-list
+ (if (and ,@variables)
+ ,then-form
+ ,else-form))))
+
+(defmacro when-let (bindings &body forms)
+ "Creates new variable bindings, and conditionally executes FORMS.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+ (variable-2 initial-form-2)
+ ...
+ (variable-n initial-form-n))
+
+All initial-forms are executed sequentially in the specified order. Then all
+the variables are bound to the corresponding values.
+
+If all variables were bound to true values, then FORMS are executed as an
+implicit PROGN."
+ (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+ (list bindings)
+ bindings))
+ (variables (mapcar #'car binding-list)))
+ `(let ,binding-list
+ (when (and ,@variables)
+ ,@forms))))
+
+(defmacro when-let* (bindings &body forms)
+ "Creates new variable bindings, and conditionally executes FORMS.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+ (variable-2 initial-form-2)
+ ...
+ (variable-n initial-form-n))
+
+Each initial-form is executed in turn, and the variable bound to the
+corresponding value. Initial-form expressions can refer to variables
+previously bound by the WHEN-LET*.
+
+Execution of WHEN-LET* stops immediately if any initial-form evaluates to NIL.
+If all initial-forms evaluate to true, then FORMS are executed as an implicit
+PROGN."
+ (let ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+ (list bindings)
+ bindings)))
+ (labels ((bind (bindings forms)
+ (if bindings
+ `((let (,(car bindings))
+ (when ,(caar bindings)
+ ,@(bind (cdr bindings) forms))))
+ forms)))
+ `(let (,(car binding-list))
+ (when ,(caar binding-list)
+ ,@(bind (cdr binding-list) forms))))))
+
@@ -0,0 +1,91 @@
+(in-package :alexandria)
+
+(defun required-argument (&optional name)
+ "Signals an error for a missing argument of NAME. Intended for
+use as an initialization form for structure and class-slots, and
+a default value for required keyword arguments."
+ (error "Required argument ~@[~S ~]missing." name))
+
+(define-condition simple-style-warning (style-warning simple-warning)
+ ())
+
+(defun simple-style-warning (message &rest args)
+ (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, unless there's special support for that in the
+;; implementation. But even then it's still inspectable from the
+;; debugger...
+(define-condition simple-reader-error
+ #-sbcl(reader-error simple-error)
+ #+sbcl(sb-int:simple-reader-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))
+
+(define-condition simple-program-error (simple-error program-error)
+ ())
+
+(defun simple-program-error (message &rest args)
+ (error 'simple-program-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.
+
+ clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)*
+
+Clauses can be given in any order, and more than one clause can be
+given for each circumstance. The clauses whose denoted circumstance
+occured, are executed in the order the clauses appear.
+
+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)))))))))
Oops, something went wrong.

0 comments on commit 0b576e8

Please sign in to comment.