Squashed 'third_party/lisp/alexandria/' content from commit fc2a2f5c

git-subtree-dir: third_party/lisp/alexandria
git-subtree-split: fc2a2f5c34147bb4e3e4a350b04220de0263710f
This commit is contained in:
Vincent Ambo 2020-01-17 18:04:20 +00:00
commit 95aeb2ebae
29 changed files with 6252 additions and 0 deletions

13
.boring Normal file
View file

@ -0,0 +1,13 @@
# Boring file regexps:
~$
^_darcs
^\{arch\}
^.arch-ids
\#
\.dfsl$
\.ppcf$
\.fasl$
\.x86f$
\.fas$
\.lib$
^public_html

4
.gitignore vendored Normal file
View file

@ -0,0 +1,4 @@
*.fasl
*~
\#*
*.patch

9
AUTHORS Normal file
View file

@ -0,0 +1,9 @@
ACTA EST FABULA PLAUDITE
Nikodemus Siivola
Attila Lendvai
Marco Baringer
Robert Strandh
Luis Oliveira
Tobias C. Rittweiler

37
LICENCE Normal file
View file

@ -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.

52
README Normal file
View file

@ -0,0 +1,52 @@
Alexandria is a collection of portable public domain utilities that
meet the following constraints:
* Utilities, not extensions: Alexandria will not contain conceptual
extensions to Common Lisp, instead limiting itself to tools and
utilities that fit well within the framework of standard ANSI
Common Lisp. Test-frameworks, system definitions, logging
facilities, serialization layers, etc. are all outside the scope of
Alexandria as a library, though well within the scope of Alexandria
as a project.
* Conservative: Alexandria limits itself to what project members
consider conservative utilities. Alexandria does not and will not
include anaphoric constructs, loop-like binding macros, etc.
* Portable: Alexandria limits itself to portable parts of Common
Lisp. Even apparently conservative and useful functions remain
outside the scope of Alexandria if they cannot be implemented
portably. Portability is here defined as portable within a
conforming implementation: implementation bugs are not considered
portability issues.
Homepage:
http://common-lisp.net/project/alexandria/
Mailing lists:
http://lists.common-lisp.net/mailman/listinfo/alexandria-devel
http://lists.common-lisp.net/mailman/listinfo/alexandria-cvs
Repository:
git://gitlab.common-lisp.net/alexandria/alexandria.git
Documentation:
http://common-lisp.net/project/alexandria/draft/alexandria.html
(To build docs locally: cd doc && make html pdf info)
Patches:
Patches are always welcome! Please send them to the mailing list as
attachments, generated by "git format-patch -1".
Patches should include a commit message that explains what's being
done and /why/, and when fixing a bug or adding a feature you should
also include a test-case.
Be advised though that right now new features are unlikely to be
accepted until 1.0 is officially out of the door.

11
alexandria-tests.asd Normal file
View file

@ -0,0 +1,11 @@
(defsystem "alexandria-tests"
:licence "Public Domain / 0-clause MIT"
:description "Tests for Alexandria, which is a collection of portable public domain utilities."
:author "Nikodemus Siivola <nikodemus@sb-studio.net>, and others."
:depends-on (:alexandria #+sbcl :sb-rt #-sbcl :rt)
:components ((:file "tests"))
:perform (test-op (o c)
(flet ((run-tests (&rest args)
(apply (intern (string '#:run-tests) '#:alexandria-tests) args)))
(run-tests :compiled nil)
(run-tests :compiled t))))

62
alexandria.asd Normal file
View file

@ -0,0 +1,62 @@
(defsystem "alexandria"
:version "1.0.0"
:licence "Public Domain / 0-clause MIT"
:description "Alexandria is a collection of portable public domain utilities."
:author "Nikodemus Siivola and others."
:long-description
"Alexandria is a project and a library.
As a project Alexandria's goal is to reduce duplication of effort and improve
portability of Common Lisp code according to its own idiosyncratic and rather
conservative aesthetic.
As a library Alexandria is one of the means by which the project strives for
its goals.
Alexandria is a collection of portable public domain utilities that meet
the following constraints:
* Utilities, not extensions: Alexandria will not contain conceptual
extensions to Common Lisp, instead limiting itself to tools and utilities
that fit well within the framework of standard ANSI Common Lisp.
Test-frameworks, system definitions, logging facilities, serialization
layers, etc. are all outside the scope of Alexandria as a library, though
well within the scope of Alexandria as a project.
* Conservative: Alexandria limits itself to what project members consider
conservative utilities. Alexandria does not and will not include anaphoric
constructs, loop-like binding macros, etc.
Also, its exported symbols are being imported by many other packages
already, so each new export carries the danger of causing conflicts.
* Portable: Alexandria limits itself to portable parts of Common Lisp. Even
apparently conservative and useful functions remain outside the scope of
Alexandria if they cannot be implemented portably. Portability is here
defined as portable within a conforming implementation: implementation bugs
are not considered portability issues.
* Team player: Alexandria will not (initially, at least) subsume or provide
functionality for which good-quality special-purpose packages exist, like
split-sequence. Instead, third party packages such as that may be
\"blessed\"."
: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 "io" :depends-on ("package" "macros" "lists" "types"))
(:file "macros" :depends-on ("package" "strings" "symbols"))
(:file "hash-tables" :depends-on ("package" "macros"))
(: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")))
:in-order-to ((test-op (test-op "alexandria-tests"))))

18
arrays.lisp Normal file
View file

@ -0,0 +1,18 @@
(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* ((dimensions (array-dimensions array))
(new-array (make-array dimensions
:element-type element-type
:adjustable adjustable
:fill-pointer fill-pointer)))
(dotimes (i (array-total-size array))
(setf (row-major-aref new-array i)
(row-major-aref array i)))
new-array))

90
binding.lisp Normal file
View file

@ -0,0 +1,90 @@
(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 body)
"Creates new variable bindings, and conditionally executes BODY.
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 BODY is executed as an implicit
PROGN."
(let ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
(list bindings)
bindings)))
(labels ((bind (bindings body)
(if bindings
`(let (,(car bindings))
(when ,(caar bindings)
,(bind (cdr bindings) body)))
`(progn ,@body))))
(bind binding-list body))))

91
conditions.lisp Normal file
View file

@ -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 (simple-warning style-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(simple-error reader-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)))))))))

106
control-flow.lisp Normal file
View file

@ -0,0 +1,106 @@
(in-package :alexandria)
(defun extract-function-name (spec)
"Useful for macros that want to mimic the functional interface for functions
like #'eq and 'eq."
(if (and (consp spec)
(member (first spec) '(quote function)))
(second spec)
spec))
(defun generate-switch-body (whole object clauses test key &optional default)
(with-gensyms (value)
(setf test (extract-function-name test))
(setf key (extract-function-name key))
(when (and (consp default)
(member (first default) '(error cerror)))
(setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S."
,value ',test)))
`(let ((,value (,key ,object)))
(cond ,@(mapcar (lambda (clause)
(if (member (first clause) '(t otherwise))
(progn
(when default
(error "Multiple default clauses or illegal use of a default clause in ~S."
whole))
(setf default `(progn ,@(rest clause)))
'(()))
(destructuring-bind (key-form &body forms) clause
`((,test ,value ,key-form)
,@forms))))
clauses)
(t ,default)))))
(defmacro switch (&whole whole (object &key (test 'eql) (key 'identity))
&body clauses)
"Evaluates first matching clause, returning its values, or evaluates and
returns the values of T or OTHERWISE if no keys match."
(generate-switch-body whole object clauses test key))
(defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity))
&body clauses)
"Like SWITCH, but signals an error if no key matches."
(generate-switch-body whole object clauses test key '(error)))
(defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity))
&body clauses)
"Like SWITCH, but signals a continuable error if no key matches."
(generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
(defmacro whichever (&rest possibilities &environment env)
"Evaluates exactly one of POSSIBILITIES, chosen at random."
(setf possibilities (mapcar (lambda (p) (macroexpand p env)) possibilities))
(if (every (lambda (p) (constantp p)) possibilities)
`(svref (load-time-value (vector ,@possibilities)) (random ,(length possibilities)))
(labels ((expand (possibilities position random-number)
(if (null (cdr possibilities))
(car possibilities)
(let* ((length (length possibilities))
(half (truncate length 2))
(second-half (nthcdr half possibilities))
(first-half (butlast possibilities (- length half))))
`(if (< ,random-number ,(+ position half))
,(expand first-half position random-number)
,(expand second-half (+ position half) random-number))))))
(with-gensyms (random-number)
(let ((length (length possibilities)))
`(let ((,random-number (random ,length)))
,(expand possibilities 0 random-number)))))))
(defmacro xor (&rest datums)
"Evaluates its arguments one at a time, from left to right. If more than one
argument evaluates to a true value no further DATUMS are evaluated, and NIL is
returned as both primary and secondary value. If exactly one argument
evaluates to true, its value is returned as the primary value after all the
arguments have been evaluated, and T is returned as the secondary value. If no
arguments evaluate to true NIL is retuned as primary, and T as secondary
value."
(with-gensyms (xor tmp true)
`(let (,tmp ,true)
(block ,xor
,@(mapcar (lambda (datum)
`(if (setf ,tmp ,datum)
(if ,true
(return-from ,xor (values nil nil))
(setf ,true ,tmp))))
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 true. It then returns all the values returned by evaluating
that form. If none of the forms return a true 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))))))
(defmacro multiple-value-prog2 (first-form second-form &body forms)
"Evaluates FIRST-FORM, then SECOND-FORM, and then FORMS. Yields as its value
all the value returned by SECOND-FORM."
`(progn ,first-form (multiple-value-prog1 ,second-form ,@forms)))

37
definitions.lisp Normal file
View file

@ -0,0 +1,37 @@
(in-package :alexandria)
(defun %reevaluate-constant (name value test)
(if (not (boundp name))
value
(let ((old (symbol-value name))
(new value))
(if (not (constantp name))
(prog1 new
(cerror "Try to redefine the variable as a constant."
"~@<~S is an already bound non-constant variable ~
whose value is ~S.~:@>" name old))
(if (funcall test old new)
old
(restart-case
(error "~@<~S is an already defined constant whose value ~
~S is not equal to the provided initial value ~S ~
under ~S.~:@>" name old new test)
(ignore ()
:report "Retain the current value."
old)
(continue ()
:report "Try to redefine the constant."
new)))))))
(defmacro define-constant (name initial-value &key (test ''eql) documentation)
"Ensures that the global variable named by NAME is a constant with a value
that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a
/function designator/ that defaults to EQL. If DOCUMENTATION is given, it
becomes the documentation string of the constant.
Signals an error if NAME is already a bound non-constant variable.
Signals an error if NAME is already a constant variable whose value is not
equal under TEST to result of evaluating INITIAL-VALUE."
`(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
,@(when documentation `(,documentation))))

3
doc/.gitignore vendored Normal file
View file

@ -0,0 +1,3 @@
alexandria
include

28
doc/Makefile Normal file
View file

@ -0,0 +1,28 @@
.PHONY: clean html pdf include clean-include clean-crap info doc
doc: pdf html info clean-crap
clean-include:
rm -rf include
clean-crap:
rm -f *.aux *.cp *.fn *.fns *.ky *.log *.pg *.toc *.tp *.tps *.vr
clean: clean-include
rm -f *.pdf *.html *.info
include:
sbcl --no-userinit --eval '(require :asdf)' \
--eval '(let ((asdf:*central-registry* (list "../"))) (require :alexandria))' \
--load docstrings.lisp \
--eval '(sb-texinfo:generate-includes "include/" (list :alexandria) :base-package :alexandria)' \
--eval '(quit)'
pdf: include
texi2pdf alexandria.texinfo
html: include
makeinfo --html --no-split alexandria.texinfo
info: include
makeinfo alexandria.texinfo

277
doc/alexandria.texinfo Normal file
View file

@ -0,0 +1,277 @@
\input texinfo @c -*-texinfo-*-
@c %**start of header
@setfilename alexandria.info
@settitle Alexandria Manual
@c %**end of header
@settitle Alexandria Manual -- draft version
@c for install-info
@dircategory Software development
@direntry
* alexandria: Common Lisp utilities.
@end direntry
@copying
Alexandria software and associated documentation are in the public
domain:
@quotation
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.
@end quotation
In those legislations where public domain dedications are not
recognized or possible, Alexandria is distributed under the following
terms and conditions:
@quotation
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.
@end quotation
@end copying
@titlepage
@title Alexandria Manual
@subtitle draft version
@c The following two commands start the copyright page.
@page
@vskip 0pt plus 1filll
@insertcopying
@end titlepage
@contents
@ifnottex
@include include/ifnottex.texinfo
@node Top
@comment node-name, next, previous, up
@top Alexandria
@insertcopying
@menu
* Hash Tables::
* Data and Control Flow::
* Conses::
* Sequences::
* IO::
* Macro Writing::
* Symbols::
* Arrays::
* Types::
* Numbers::
@end menu
@end ifnottex
@node Hash Tables
@comment node-name, next, previous, up
@chapter Hash Tables
@include include/macro-alexandria-ensure-gethash.texinfo
@include include/fun-alexandria-copy-hash-table.texinfo
@include include/fun-alexandria-maphash-keys.texinfo
@include include/fun-alexandria-maphash-values.texinfo
@include include/fun-alexandria-hash-table-keys.texinfo
@include include/fun-alexandria-hash-table-values.texinfo
@include include/fun-alexandria-hash-table-alist.texinfo
@include include/fun-alexandria-hash-table-plist.texinfo
@include include/fun-alexandria-alist-hash-table.texinfo
@include include/fun-alexandria-plist-hash-table.texinfo
@node Data and Control Flow
@comment node-name, next, previous, up
@chapter Data and Control Flow
@include include/macro-alexandria-define-constant.texinfo
@include include/macro-alexandria-destructuring-case.texinfo
@include include/macro-alexandria-ensure-functionf.texinfo
@include include/macro-alexandria-multiple-value-prog2.texinfo
@include include/macro-alexandria-named-lambda.texinfo
@include include/macro-alexandria-nth-value-or.texinfo
@include include/macro-alexandria-if-let.texinfo
@include include/macro-alexandria-when-let.texinfo
@include include/macro-alexandria-when-let-star.texinfo
@include include/macro-alexandria-switch.texinfo
@include include/macro-alexandria-cswitch.texinfo
@include include/macro-alexandria-eswitch.texinfo
@include include/macro-alexandria-whichever.texinfo
@include include/macro-alexandria-xor.texinfo
@include include/fun-alexandria-disjoin.texinfo
@include include/fun-alexandria-conjoin.texinfo
@include include/fun-alexandria-compose.texinfo
@include include/fun-alexandria-ensure-function.texinfo
@include include/fun-alexandria-multiple-value-compose.texinfo
@include include/fun-alexandria-curry.texinfo
@include include/fun-alexandria-rcurry.texinfo
@node Conses
@comment node-name, next, previous, up
@chapter Conses
@include include/type-alexandria-proper-list.texinfo
@include include/type-alexandria-circular-list.texinfo
@include include/macro-alexandria-appendf.texinfo
@include include/macro-alexandria-nconcf.texinfo
@include include/macro-alexandria-remove-from-plistf.texinfo
@include include/macro-alexandria-delete-from-plistf.texinfo
@include include/macro-alexandria-reversef.texinfo
@include include/macro-alexandria-nreversef.texinfo
@include include/macro-alexandria-unionf.texinfo
@include include/macro-alexandria-nunionf.texinfo
@include include/macro-alexandria-doplist.texinfo
@include include/fun-alexandria-circular-list-p.texinfo
@include include/fun-alexandria-circular-tree-p.texinfo
@include include/fun-alexandria-proper-list-p.texinfo
@include include/fun-alexandria-alist-plist.texinfo
@include include/fun-alexandria-plist-alist.texinfo
@include include/fun-alexandria-circular-list.texinfo
@include include/fun-alexandria-make-circular-list.texinfo
@include include/fun-alexandria-ensure-car.texinfo
@include include/fun-alexandria-ensure-cons.texinfo
@include include/fun-alexandria-ensure-list.texinfo
@include include/fun-alexandria-flatten.texinfo
@include include/fun-alexandria-lastcar.texinfo
@include include/fun-alexandria-setf-lastcar.texinfo
@include include/fun-alexandria-proper-list-length.texinfo
@include include/fun-alexandria-mappend.texinfo
@include include/fun-alexandria-map-product.texinfo
@include include/fun-alexandria-remove-from-plist.texinfo
@include include/fun-alexandria-delete-from-plist.texinfo
@include include/fun-alexandria-set-equal.texinfo
@include include/fun-alexandria-setp.texinfo
@node Sequences
@comment node-name, next, previous, up
@chapter Sequences
@include include/type-alexandria-proper-sequence.texinfo
@include include/macro-alexandria-deletef.texinfo
@include include/macro-alexandria-removef.texinfo
@include include/fun-alexandria-rotate.texinfo
@include include/fun-alexandria-shuffle.texinfo
@include include/fun-alexandria-random-elt.texinfo
@include include/fun-alexandria-emptyp.texinfo
@include include/fun-alexandria-sequence-of-length-p.texinfo
@include include/fun-alexandria-length-equals.texinfo
@include include/fun-alexandria-copy-sequence.texinfo
@include include/fun-alexandria-first-elt.texinfo
@include include/fun-alexandria-setf-first-elt.texinfo
@include include/fun-alexandria-last-elt.texinfo
@include include/fun-alexandria-setf-last-elt.texinfo
@include include/fun-alexandria-starts-with.texinfo
@include include/fun-alexandria-starts-with-subseq.texinfo
@include include/fun-alexandria-ends-with.texinfo
@include include/fun-alexandria-ends-with-subseq.texinfo
@include include/fun-alexandria-map-combinations.texinfo
@include include/fun-alexandria-map-derangements.texinfo
@include include/fun-alexandria-map-permutations.texinfo
@node IO
@comment node-name, next, previous, up
@chapter IO
@include include/fun-alexandria-read-stream-content-into-string.texinfo
@include include/fun-alexandria-read-file-into-string.texinfo
@include include/fun-alexandria-read-stream-content-into-byte-vector.texinfo
@include include/fun-alexandria-read-file-into-byte-vector.texinfo
@node Macro Writing
@comment node-name, next, previous, up
@chapter Macro Writing
@include include/macro-alexandria-once-only.texinfo
@include include/macro-alexandria-with-gensyms.texinfo
@include include/macro-alexandria-with-unique-names.texinfo
@include include/fun-alexandria-featurep.texinfo
@include include/fun-alexandria-parse-body.texinfo
@include include/fun-alexandria-parse-ordinary-lambda-list.texinfo
@node Symbols
@comment node-name, next, previous, up
@chapter Symbols
@include include/fun-alexandria-ensure-symbol.texinfo
@include include/fun-alexandria-format-symbol.texinfo
@include include/fun-alexandria-make-keyword.texinfo
@include include/fun-alexandria-make-gensym.texinfo
@include include/fun-alexandria-make-gensym-list.texinfo
@include include/fun-alexandria-symbolicate.texinfo
@node Arrays
@comment node-name, next, previous, up
@chapter Arrays
@include include/type-alexandria-array-index.texinfo
@include include/type-alexandria-array-length.texinfo
@include include/fun-alexandria-copy-array.texinfo
@node Types
@comment node-name, next, previous, up
@chapter Types
@include include/type-alexandria-string-designator.texinfo
@include include/macro-alexandria-coercef.texinfo
@include include/fun-alexandria-of-type.texinfo
@include include/fun-alexandria-type-equals.texinfo
@node Numbers
@comment node-name, next, previous, up
@chapter Numbers
@include include/macro-alexandria-maxf.texinfo
@include include/macro-alexandria-minf.texinfo
@include include/fun-alexandria-binomial-coefficient.texinfo
@include include/fun-alexandria-count-permutations.texinfo
@include include/fun-alexandria-clamp.texinfo
@include include/fun-alexandria-lerp.texinfo
@include include/fun-alexandria-factorial.texinfo
@include include/fun-alexandria-subfactorial.texinfo
@include include/fun-alexandria-gaussian-random.texinfo
@include include/fun-alexandria-iota.texinfo
@include include/fun-alexandria-map-iota.texinfo
@include include/fun-alexandria-mean.texinfo
@include include/fun-alexandria-median.texinfo
@include include/fun-alexandria-variance.texinfo
@include include/fun-alexandria-standard-deviation.texinfo
@bye

881
doc/docstrings.lisp Normal file
View file

@ -0,0 +1,881 @@
;;; -*- lisp -*-
;;;; A docstring extractor for the sbcl manual. Creates
;;;; @include-ready documentation from the docstrings of exported
;;;; symbols of specified packages.
;;;; This software is part of the SBCL software system. SBCL is in the
;;;; public domain and is provided with absolutely no warranty. See
;;;; the COPYING file for more information.
;;;;
;;;; Written by Rudi Schlatte <rudi@constantly.at>, mangled
;;;; by Nikodemus Siivola.
;;;; TODO
;;;; * Verbatim text
;;;; * Quotations
;;;; * Method documentation untested
;;;; * Method sorting, somehow
;;;; * Index for macros & constants?
;;;; * This is getting complicated enough that tests would be good
;;;; * Nesting (currently only nested itemizations work)
;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also
;;;; easily generated)
;;;; FIXME: The description below is no longer complete. This
;;;; should possibly be turned into a contrib with proper documentation.
;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely):
;;;;
;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in
;;;; the argument list of the defun / defmacro.
;;;;
;;;; Lines starting with * or - that are followed by intented lines
;;;; are marked up with @itemize.
;;;;
;;;; Lines containing only a SYMBOL that are followed by indented
;;;; lines are marked up as @table @code, with the SYMBOL as the item.
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'sb-introspect))
(defpackage :sb-texinfo
(:use :cl :sb-mop)
(:shadow #:documentation)
(:export #:generate-includes #:document-package)
(:documentation
"Tools to generate TexInfo documentation from docstrings."))
(in-package :sb-texinfo)
;;;; various specials and parameters
(defvar *texinfo-output*)
(defvar *texinfo-variables*)
(defvar *documentation-package*)
(defvar *base-package*)
(defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c))
(defparameter *documentation-types*
'(compiler-macro
function
method-combination
setf
;;structure ; also handled by `type'
type
variable)
"A list of symbols accepted as second argument of `documentation'")
(defparameter *character-replacements*
'((#\* . "star") (#\/ . "slash") (#\+ . "plus")
(#\< . "lt") (#\> . "gt")
(#\= . "equals"))
"Characters and their replacement names that `alphanumize' uses. If
the replacements contain any of the chars they're supposed to replace,
you deserve to lose.")
(defparameter *characters-to-drop* '(#\\ #\` #\')
"Characters that should be removed by `alphanumize'.")
(defparameter *texinfo-escaped-chars* "@{}"
"Characters that must be escaped with #\@ for Texinfo.")
(defparameter *itemize-start-characters* '(#\* #\-)
"Characters that might start an itemization in docstrings when
at the start of a line.")
(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890*:-+&#'"
"List of characters that make up symbols in a docstring.")
(defparameter *symbol-delimiters* " ,.!?;")
(defparameter *ordered-documentation-kinds*
'(package type structure condition class macro))
;;;; utilities
(defun flatten (list)
(cond ((null list)
nil)
((consp (car list))
(nconc (flatten (car list)) (flatten (cdr list))))
((null (cdr list))
(cons (car list) nil))
(t
(cons (car list) (flatten (cdr list))))))
(defun whitespacep (char)
(find char #(#\tab #\space #\page)))
(defun setf-name-p (name)
(or (symbolp name)
(and (listp name) (= 2 (length name)) (eq (car name) 'setf))))
(defgeneric specializer-name (specializer))
(defmethod specializer-name ((specializer eql-specializer))
(list 'eql (eql-specializer-object specializer)))
(defmethod specializer-name ((specializer class))
(class-name specializer))
(defun ensure-class-precedence-list (class)
(unless (class-finalized-p class)
(finalize-inheritance class))
(class-precedence-list class))
(defun specialized-lambda-list (method)
;; courtecy of AMOP p. 61
(let* ((specializers (method-specializers method))
(lambda-list (method-lambda-list method))
(n-required (length specializers)))
(append (mapcar (lambda (arg specializer)
(if (eq specializer (find-class 't))
arg
`(,arg ,(specializer-name specializer))))
(subseq lambda-list 0 n-required)
specializers)
(subseq lambda-list n-required))))
(defun string-lines (string)
"Lines in STRING as a vector."
(coerce (with-input-from-string (s string)
(loop for line = (read-line s nil nil)
while line collect line))
'vector))
(defun indentation (line)
"Position of first non-SPACE character in LINE."
(position-if-not (lambda (c) (char= c #\Space)) line))
(defun docstring (x doc-type)
(cl:documentation x doc-type))
(defun flatten-to-string (list)
(format nil "~{~A~^-~}" (flatten list)))
(defun alphanumize (original)
"Construct a string without characters like *`' that will f-star-ck
up filename handling. See `*character-replacements*' and
`*characters-to-drop*' for customization."
(let ((name (remove-if (lambda (x) (member x *characters-to-drop*))
(if (listp original)
(flatten-to-string original)
(string original))))
(chars-to-replace (mapcar #'car *character-replacements*)))
(flet ((replacement-delimiter (index)
(cond ((or (< index 0) (>= index (length name))) "")
((alphanumericp (char name index)) "-")
(t ""))))
(loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
name)
while index
do (setf name (concatenate 'string (subseq name 0 index)
(replacement-delimiter (1- index))
(cdr (assoc (aref name index)
*character-replacements*))
(replacement-delimiter (1+ index))
(subseq name (1+ index))))))
name))
;;;; generating various names
(defgeneric name (thing)
(:documentation "Name for a documented thing. Names are either
symbols or lists of symbols."))
(defmethod name ((symbol symbol))
symbol)
(defmethod name ((cons cons))
cons)
(defmethod name ((package package))
(short-package-name package))
(defmethod name ((method method))
(list
(generic-function-name (method-generic-function method))
(method-qualifiers method)
(specialized-lambda-list method)))
;;; Node names for DOCUMENTATION instances
(defgeneric name-using-kind/name (kind name doc))
(defmethod name-using-kind/name (kind (name string) doc)
(declare (ignore kind doc))
name)
(defmethod name-using-kind/name (kind (name symbol) doc)
(declare (ignore kind))
(format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
(defmethod name-using-kind/name (kind (name list) doc)
(declare (ignore kind))
(assert (setf-name-p name))
(format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
(defmethod name-using-kind/name ((kind (eql 'method)) name doc)
(format nil "~A~{ ~A~} ~A"
(name-using-kind/name nil (first name) doc)
(second name)
(third name)))
(defun node-name (doc)
"Returns TexInfo node name as a string for a DOCUMENTATION instance."
(let ((kind (get-kind doc)))
(format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc))))
(defun short-package-name (package)
(unless (eq package *base-package*)
(car (sort (copy-list (cons (package-name package) (package-nicknames package)))
#'< :key #'length))))
;;; Definition titles for DOCUMENTATION instances
(defgeneric title-using-kind/name (kind name doc))
(defmethod title-using-kind/name (kind (name string) doc)
(declare (ignore kind doc))
name)
(defmethod title-using-kind/name (kind (name symbol) doc)
(declare (ignore kind))
(format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
(defmethod title-using-kind/name (kind (name list) doc)
(declare (ignore kind))
(assert (setf-name-p name))
(format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
(defmethod title-using-kind/name ((kind (eql 'method)) name doc)
(format nil "~{~A ~}~A"
(second name)
(title-using-kind/name nil (first name) doc)))
(defun title-name (doc)
"Returns a string to be used as name of the definition."
(string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc)))
(defun include-pathname (doc)
(let* ((kind (get-kind doc))
(name (nstring-downcase
(if (eq 'package kind)
(format nil "package-~A" (alphanumize (get-name doc)))
(format nil "~A-~A-~A"
(case (get-kind doc)
((function generic-function) "fun")
(structure "struct")
(variable "var")
(otherwise (symbol-name (get-kind doc))))
(alphanumize (let ((*base-package* nil))
(short-package-name (get-package doc))))
(alphanumize (get-name doc)))))))
(make-pathname :name name :type "texinfo")))
;;;; documentation class and related methods
(defclass documentation ()
((name :initarg :name :reader get-name)
(kind :initarg :kind :reader get-kind)
(string :initarg :string :reader get-string)
(children :initarg :children :initform nil :reader get-children)
(package :initform *documentation-package* :reader get-package)))
(defmethod print-object ((documentation documentation) stream)
(print-unreadable-object (documentation stream :type t)
(princ (list (get-kind documentation) (get-name documentation)) stream)))
(defgeneric make-documentation (x doc-type string))
(defmethod make-documentation ((x package) doc-type string)
(declare (ignore doc-type))
(make-instance 'documentation
:name (name x)
:kind 'package
:string string))
(defmethod make-documentation (x (doc-type (eql 'function)) string)
(declare (ignore doc-type))
(let* ((fdef (and (fboundp x) (fdefinition x)))
(name x)
(kind (cond ((and (symbolp x) (special-operator-p x))
'special-operator)
((and (symbolp x) (macro-function x))
'macro)
((typep fdef 'generic-function)
(assert (or (symbolp name) (setf-name-p name)))
'generic-function)
(fdef
(assert (or (symbolp name) (setf-name-p name)))
'function)))
(children (when (eq kind 'generic-function)
(collect-gf-documentation fdef))))
(make-instance 'documentation
:name (name x)
:string string
:kind kind
:children children)))
(defmethod make-documentation ((x method) doc-type string)
(declare (ignore doc-type))
(make-instance 'documentation
:name (name x)
:kind 'method
:string string))
(defmethod make-documentation (x (doc-type (eql 'type)) string)
(make-instance 'documentation
:name (name x)
:string string
:kind (etypecase (find-class x nil)
(structure-class 'structure)
(standard-class 'class)
(sb-pcl::condition-class 'condition)
((or built-in-class null) 'type))))
(defmethod make-documentation (x (doc-type (eql 'variable)) string)
(make-instance 'documentation
:name (name x)
:string string
:kind (if (constantp x)
'constant
'variable)))
(defmethod make-documentation (x (doc-type (eql 'setf)) string)
(declare (ignore doc-type))
(make-instance 'documentation
:name (name x)
:kind 'setf-expander
:string string))
(defmethod make-documentation (x doc-type string)
(make-instance 'documentation
:name (name x)
:kind doc-type
:string string))
(defun maybe-documentation (x doc-type)
"Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if
there is no corresponding docstring."
(let ((docstring (docstring x doc-type)))
(when docstring
(make-documentation x doc-type docstring))))
(defun lambda-list (doc)
(case (get-kind doc)
((package constant variable type structure class condition nil)
nil)
(method
(third (get-name doc)))
(t
;; KLUDGE: Eugh.
;;
;; believe it or not, the above comment was written before CSR
;; came along and obfuscated this. (2005-07-04)
(when (symbolp (get-name doc))
(labels ((clean (x &key optional key)
(typecase x
(atom x)
((cons (member &optional))
(cons (car x) (clean (cdr x) :optional t)))
((cons (member &key))
(cons (car x) (clean (cdr x) :key t)))
((cons (member &whole &environment))
;; Skip these
(clean (cdr x) :optional optional :key key))
((cons cons)
(cons
(cond (key (if (consp (caar x))
(caaar x)
(caar x)))
(optional (caar x))
(t (clean (car x))))
(clean (cdr x) :key key :optional optional)))
(cons
(cons
(cond ((or key optional) (car x))
(t (clean (car x))))
(clean (cdr x) :key key :optional optional))))))
(clean (sb-introspect:function-lambda-list (get-name doc))))))))
(defun get-string-name (x)
(let ((name (get-name x)))
(cond ((symbolp name)
(symbol-name name))
((and (consp name) (eq 'setf (car name)))
(symbol-name (second name)))
((stringp name)
name)
(t
(error "Don't know which symbol to use for name ~S" name)))))
(defun documentation< (x y)
(let ((p1 (position (get-kind x) *ordered-documentation-kinds*))
(p2 (position (get-kind y) *ordered-documentation-kinds*)))
(if (or (not (and p1 p2)) (= p1 p2))
(string< (get-string-name x) (get-string-name y))
(< p1 p2))))
;;;; turning text into texinfo
(defun escape-for-texinfo (string &optional downcasep)
"Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped
with #\@. Optionally downcase the result."
(let ((result (with-output-to-string (s)
(loop for char across string
when (find char *texinfo-escaped-chars*)
do (write-char #\@ s)
do (write-char char s)))))
(if downcasep (nstring-downcase result) result)))
(defun empty-p (line-number lines)
(and (< -1 line-number (length lines))
(not (indentation (svref lines line-number)))))
;;; line markups
(defvar *not-symbols* '("ANSI" "CLHS"))
(defun locate-symbols (line)
"Return a list of index pairs of symbol-like parts of LINE."
;; This would be a good application for a regex ...
(let (result)
(flet ((grab (start end)
(unless (member (subseq line start end) '("ANSI" "CLHS"))
(push (list start end) result))))
(do ((begin nil)
(maybe-begin t)
(i 0 (1+ i)))
((= i (length line))
;; symbol at end of line
(when (and begin (or (> i (1+ begin))
(not (member (char line begin) '(#\A #\I)))))
(grab begin i))
(nreverse result))
(cond
((and begin (find (char line i) *symbol-delimiters*))
;; symbol end; remember it if it's not "A" or "I"
(when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
(grab begin i))
(setf begin nil
maybe-begin t))
((and begin (not (find (char line i) *symbol-characters*)))
;; Not a symbol: abort
(setf begin nil))
((and maybe-begin (not begin) (find (char line i) *symbol-characters*))
;; potential symbol begin at this position
(setf begin i
maybe-begin nil))
((find (char line i) *symbol-delimiters*)
;; potential symbol begin after this position
(setf maybe-begin t))
(t
;; Not reading a symbol, not at potential start of symbol
(setf maybe-begin nil)))))))
(defun texinfo-line (line)
"Format symbols in LINE texinfo-style: either as code or as
variables if the symbol in question is contained in symbols
*TEXINFO-VARIABLES*."
(with-output-to-string (result)
(let ((last 0))
(dolist (symbol/index (locate-symbols line))
(write-string (subseq line last (first symbol/index)) result)
(let ((symbol-name (apply #'subseq line symbol/index)))
(format result (if (member symbol-name *texinfo-variables*
:test #'string=)
"@var{~A}"
"@code{~A}")
(string-downcase symbol-name)))
(setf last (second symbol/index)))
(write-string (subseq line last) result))))
;;; lisp sections
(defun lisp-section-p (line line-number lines)
"Returns T if the given LINE looks like start of lisp code --
ie. if it starts with whitespace followed by a paren or
semicolon, and the previous line is empty"
(let ((offset (indentation line)))
(and offset
(plusp offset)
(find (find-if-not #'whitespacep line) "(;")
(empty-p (1- line-number) lines))))
(defun collect-lisp-section (lines line-number)
(let ((lisp (loop for index = line-number then (1+ index)
for line = (and (< index (length lines)) (svref lines index))
while (indentation line)
collect line)))
(values (length lisp) `("@lisp" ,@lisp "@end lisp"))))
;;; itemized sections
(defun maybe-itemize-offset (line)
"Return NIL or the indentation offset if LINE looks like it starts
an item in an itemization."
(let* ((offset (indentation line))
(char (when offset (char line offset))))
(and offset
(member char *itemize-start-characters* :test #'char=)
(char= #\Space (find-if-not (lambda (c) (char= c char))
line :start offset))
offset)))
(defun collect-maybe-itemized-section (lines starting-line)
;; Return index of next line to be processed outside
(let ((this-offset (maybe-itemize-offset (svref lines starting-line)))
(result nil)
(lines-consumed 0))
(loop for line-number from starting-line below (length lines)
for line = (svref lines line-number)
for indentation = (indentation line)
for offset = (maybe-itemize-offset line)
do (cond
((not indentation)
;; empty line -- inserts paragraph.
(push "" result)
(incf lines-consumed))
((and offset (> indentation this-offset))
;; nested itemization -- handle recursively
;; FIXME: tables in itemizations go wrong
(multiple-value-bind (sub-lines-consumed sub-itemization)
(collect-maybe-itemized-section lines line-number)
(when sub-lines-consumed
(incf line-number (1- sub-lines-consumed)) ; +1 on next loop
(incf lines-consumed sub-lines-consumed)
(setf result (nconc (nreverse sub-itemization) result)))))
((and offset (= indentation this-offset))
;; start of new item
(push (format nil "@item ~A"
(texinfo-line (subseq line (1+ offset))))
result)
(incf lines-consumed))
((and (not offset) (> indentation this-offset))
;; continued item from previous line
(push (texinfo-line line) result)
(incf lines-consumed))
(t
;; end of itemization
(loop-finish))))
;; a single-line itemization isn't.
(if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
(values lines-consumed `("@itemize" ,@(reverse result) "@end itemize"))
nil)))
;;; table sections
(defun tabulation-body-p (offset line-number lines)
(when (< line-number (length lines))
(let ((offset2 (indentation (svref lines line-number))))
(and offset2 (< offset offset2)))))
(defun tabulation-p (offset line-number lines direction)
(let ((step (ecase direction
(:backwards (1- line-number))
(:forwards (1+ line-number)))))
(when (and (plusp line-number) (< line-number (length lines)))
(and (eql offset (indentation (svref lines line-number)))
(or (when (eq direction :backwards)
(empty-p step lines))
(tabulation-p offset step lines direction)
(tabulation-body-p offset step lines))))))
(defun maybe-table-offset (line-number lines)
"Return NIL or the indentation offset if LINE looks like it starts
an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an
empty line, another tabulation label, or a tabulation body, (3) and
followed another tabulation label or a tabulation body."
(let* ((line (svref lines line-number))
(offset (indentation line))
(prev (1- line-number))
(next (1+ line-number)))
(when (and offset (plusp offset))
(and (or (empty-p prev lines)
(tabulation-body-p offset prev lines)
(tabulation-p offset prev lines :backwards))
(or (tabulation-body-p offset next lines)
(tabulation-p offset next lines :forwards))
offset))))
;;; FIXME: This and itemization are very similar: could they share
;;; some code, mayhap?
(defun collect-maybe-table-section (lines starting-line)
;; Return index of next line to be processed outside
(let ((this-offset (maybe-table-offset starting-line lines))
(result nil)
(lines-consumed 0))
(loop for line-number from starting-line below (length lines)
for line = (svref lines line-number)
for indentation = (indentation line)
for offset = (maybe-table-offset line-number lines)
do (cond
((not indentation)
;; empty line -- inserts paragraph.
(push "" result)
(incf lines-consumed))
((and offset (= indentation this-offset))
;; start of new item, or continuation of previous item
(if (and result (search "@item" (car result) :test #'char=))
(push (format nil "@itemx ~A" (texinfo-line line))
result)
(progn
(push "" result)
(push (format nil "@item ~A" (texinfo-line line))
result)))
(incf lines-consumed))
((> indentation this-offset)
;; continued item from previous line
(push (texinfo-line line) result)
(incf lines-consumed))
(t
;; end of itemization
(loop-finish))))
;; a single-line table isn't.
(if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
(values lines-consumed
`("" "@table @emph" ,@(reverse result) "@end table" ""))
nil)))
;;; section markup
(defmacro with-maybe-section (index &rest forms)
`(multiple-value-bind (count collected) (progn ,@forms)
(when count
(dolist (line collected)
(write-line line *texinfo-output*))
(incf ,index (1- count)))))
(defun write-texinfo-string (string &optional lambda-list)
"Try to guess as much formatting for a raw docstring as possible."
(let ((*texinfo-variables* (flatten lambda-list))
(lines (string-lines (escape-for-texinfo string nil))))
(loop for line-number from 0 below (length lines)
for line = (svref lines line-number)
do (cond
((with-maybe-section line-number
(and (lisp-section-p line line-number lines)
(collect-lisp-section lines line-number))))
((with-maybe-section line-number
(and (maybe-itemize-offset line)
(collect-maybe-itemized-section lines line-number))))
((with-maybe-section line-number
(and (maybe-table-offset line-number lines)
(collect-maybe-table-section lines line-number))))
(t
(write-line (texinfo-line line) *texinfo-output*))))))
;;;; texinfo formatting tools
(defun hide-superclass-p (class-name super-name)
(let ((super-package (symbol-package super-name)))
(or
;; KLUDGE: We assume that we don't want to advertise internal
;; classes in CP-lists, unless the symbol we're documenting is
;; internal as well.
(and (member super-package #.'(mapcar #'find-package *undocumented-packages*))
(not (eq super-package (symbol-package class-name))))
;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or
;; SIMPLE-CONDITION in the CPLs of conditions that inherit them
;; simply as a matter of convenience. The assumption here is that
;; the inheritance is incidental unless the name of the condition
;; begins with SIMPLE-.
(and (member super-name '(simple-error simple-condition))
(let ((prefix "SIMPLE-"))
(mismatch prefix (string class-name) :end2 (length prefix)))
t ; don't return number from MISMATCH
))))
(defun hide-slot-p (symbol slot)
;; FIXME: There is no pricipal reason to avoid the slot docs fo
;; structures and conditions, but their DOCUMENTATION T doesn't
;; currently work with them the way we'd like.
(not (and (typep (find-class symbol nil) 'standard-class)
(docstring slot t))))
(defun texinfo-anchor (doc)
(format *texinfo-output* "@anchor{~A}~%" (node-name doc)))
;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please"
(defun texinfo-begin (doc &aux *print-pretty*)
(let ((kind (get-kind doc)))
(format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%"
(case kind
((package constant variable)
"defvr")
((structure class condition type)
"deftp")
(t
"deffn"))
(map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind))
(title-name doc)
;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo
;; interactions,so we escape the ampersand -- amusingly for TeX.
;; sbcl.texinfo defines macros that expand @&key and friends to &key.
(mapcar (lambda (name)
(if (member name lambda-list-keywords)
(format nil "@~A" name)
name))
(lambda-list doc)))))
(defun texinfo-index (doc)
(let ((title (title-name doc)))
(case (get-kind doc)
((structure type class condition)
(format *texinfo-output* "@tindex ~A~%" title))
((variable constant)
(format *texinfo-output* "@vindex ~A~%" title))
((compiler-macro function method-combination macro generic-function)
(format *texinfo-output* "@findex ~A~%" title)))))
(defun texinfo-inferred-body (doc)
(when (member (get-kind doc) '(class structure condition))
(let ((name (get-name doc)))
;; class precedence list
(format *texinfo-output* "Class precedence list: @code{~(~{@lw{~A}~^, ~}~)}~%~%"
(remove-if (lambda (class) (hide-superclass-p name class))
(mapcar #'class-name (ensure-class-precedence-list (find-class name)))))
;; slots
(let ((slots (remove-if (lambda (slot) (hide-slot-p name slot))
(class-direct-slots (find-class name)))))
(when slots
(format *texinfo-output* "Slots:~%@itemize~%")
(dolist (slot slots)
(format *texinfo-output*
"@item ~(@code{~A}~#[~:; --- ~]~
~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%"
(slot-definition-name slot)
(remove
nil
(mapcar
(lambda (name things)
(if things
(list name (length things) things)))
'("initarg" "reader" "writer")
(list
(slot-definition-initargs slot)
(slot-definition-readers slot)
(slot-definition-writers slot)))))
;; FIXME: Would be neater to handler as children
(write-texinfo-string (docstring slot t)))
(format *texinfo-output* "@end itemize~%~%"))))))
(defun texinfo-body (doc)
(write-texinfo-string (get-string doc)))
(defun texinfo-end (doc)
(write-line (case (get-kind doc)
((package variable constant) "@end defvr")
((structure type class condition) "@end deftp")
(t "@end deffn"))
*texinfo-output*))
(defun write-texinfo (doc)
"Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*."
(texinfo-anchor doc)
(texinfo-begin doc)
(texinfo-index doc)
(texinfo-inferred-body doc)
(texinfo-body doc)
(texinfo-end doc)
;; FIXME: Children should be sorted one way or another
(mapc #'write-texinfo (get-children doc)))
;;;; main logic
(defun collect-gf-documentation (gf)
"Collects method documentation for the generic function GF"
(loop for method in (generic-function-methods gf)
for doc = (maybe-documentation method t)
when doc
collect doc))
(defun collect-name-documentation (name)
(loop for type in *documentation-types*
for doc = (maybe-documentation name type)
when doc
collect doc))
(defun collect-symbol-documentation (symbol)
"Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of
the form DOC instances. See `*documentation-types*' for the possible
values of doc-type."
(nconc (collect-name-documentation symbol)
(collect-name-documentation (list 'setf symbol))))
(defun collect-documentation (package)
"Collects all documentation for all external symbols of the given
package, as well as for the package itself."
(let* ((*documentation-package* (find-package package))
(docs nil))
(check-type package package)
(do-external-symbols (symbol package)
(setf docs (nconc (collect-symbol-documentation symbol) docs)))
(let ((doc (maybe-documentation *documentation-package* t)))
(when doc
(push doc docs)))
docs))
(defmacro with-texinfo-file (pathname &body forms)
`(with-open-file (*texinfo-output* ,pathname
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
,@forms))
(defun write-ifnottex ()
;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to
;; define them for info as well.
(flet ((macro (name)
(let ((string (string-downcase name)))
(format *texinfo-output* "@macro ~A~%~A~%@end macro~%" string string))))
(macro '&allow-other-keys)
(macro '&optional)
(macro '&rest)
(macro '&key)
(macro '&body)))
(defun generate-includes (directory packages &key (base-package :cl-user))
"Create files in `directory' containing Texinfo markup of all
docstrings of each exported symbol in `packages'. `directory' is
created if necessary. If you supply a namestring that doesn't end in a
slash, you lose. The generated files are of the form
\"<doc-type>_<packagename>_<symbol-name>.texinfo\" and can be included
via @include statements. Texinfo syntax-significant characters are
escaped in symbol names, but if a docstring contains invalid Texinfo
markup, you lose."
(handler-bind ((warning #'muffle-warning))
(let ((directory (merge-pathnames (pathname directory)))
(*base-package* (find-package base-package)))
(ensure-directories-exist directory)
(dolist (package packages)
(dolist (doc (collect-documentation (find-package package)))
(with-texinfo-file (merge-pathnames (include-pathname doc) directory)
(write-texinfo doc))))
(with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory)
(write-ifnottex))
directory)))
(defun document-package (package &optional filename)
"Create a file containing all available documentation for the
exported symbols of `package' in Texinfo format. If `filename' is not
supplied, a file \"<packagename>.texinfo\" is generated.
The definitions can be referenced using Texinfo statements like
@ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo
syntax-significant characters are escaped in symbol names, but if a
docstring contains invalid Texinfo markup, you lose."
(handler-bind ((warning #'muffle-warning))
(let* ((package (find-package package))
(filename (or filename (make-pathname
:name (string-downcase (short-package-name package))
:type "texinfo")))
(docs (sort (collect-documentation package) #'documentation<)))
(with-texinfo-file filename
(dolist (doc docs)
(write-texinfo doc)))
filename)))

14
features.lisp Normal file
View file

@ -0,0 +1,14 @@
(in-package :alexandria)
(defun featurep (feature-expression)
"Returns T if the argument matches the state of the *FEATURES*
list and NIL if it does not. FEATURE-EXPRESSION can be any atom
or list acceptable to the reader macros #+ and #-."
(etypecase feature-expression
(symbol (not (null (member feature-expression *features*))))
(cons (check-type (first feature-expression) symbol)
(eswitch ((first feature-expression) :test 'string=)
(:and (every #'featurep (rest feature-expression)))
(:or (some #'featurep (rest feature-expression)))
(:not (assert (= 2 (length feature-expression)))
(not (featurep (second feature-expression))))))))

161
functions.lisp Normal file
View file

@ -0,0 +1,161 @@
(in-package :alexandria)
;;; To propagate return type and allow the compiler to eliminate the IF when
;;; it is known if the argument is function or not.
(declaim (inline ensure-function))
(declaim (ftype (function (t) (values function &optional))
ensure-function))
(defun ensure-function (function-designator)
"Returns the function designated by FUNCTION-DESIGNATOR:
if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
it must be a function name and its FDEFINITION is returned."
(if (functionp function-designator)
function-designator
(fdefinition function-designator)))
(define-modify-macro ensure-functionf/1 () ensure-function)
(defmacro ensure-functionf (&rest places)
"Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of
PLACES contains a function."
`(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places)))
(defun disjoin (predicate &rest more-predicates)
"Returns a function that applies each of PREDICATE and MORE-PREDICATE
functions in turn to its arguments, returning the primary value of the first
predicate that returns true, without calling the remaining predicates.
If none of the predicates returns true, NIL is returned."
(declare (optimize (speed 3) (safety 1) (debug 1)))
(let ((predicate (ensure-function predicate))
(more-predicates (mapcar #'ensure-function more-predicates)))
(lambda (&rest arguments)
(or (apply predicate arguments)
(some (lambda (p)
(declare (type function p))
(apply p arguments))
more-predicates)))))
(defun conjoin (predicate &rest more-predicates)
"Returns a function that applies each of PREDICATE and MORE-PREDICATE
functions in turn to its arguments, returning NIL if any of the predicates
returns false, without calling the remaining predicates. If none of the
predicates returns false, returns the primary value of the last predicate."
(if (null more-predicates)
predicate
(lambda (&rest arguments)
(and (apply predicate arguments)
;; Cannot simply use CL:EVERY because we want to return the
;; non-NIL value of the last predicate if all succeed.
(do ((tail (cdr more-predicates) (cdr tail))
(head (car more-predicates) (car tail)))
((not tail)
(apply head arguments))
(unless (apply head arguments)
(return nil)))))))
(defun compose (function &rest more-functions)
"Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its
arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS,
and then calling the next one with the primary value of the last."
(declare (optimize (speed 3) (safety 1) (debug 1)))
(reduce (lambda (f g)
(let ((f (ensure-function f))
(g (ensure-function g)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
(funcall f (apply g arguments)))))
more-functions
:initial-value function))
(define-compiler-macro compose (function &rest more-functions)
(labels ((compose-1 (funs)
(if (cdr funs)
`(funcall ,(car funs) ,(compose-1 (cdr funs)))
`(apply ,(car funs) arguments))))
(let* ((args (cons function more-functions))
(funs (make-gensym-list (length args) "COMPOSE")))
`(let ,(loop for f in funs for arg in args
collect `(,f (ensure-function ,arg)))
(declare (optimize (speed 3) (safety 1) (debug 1)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
,(compose-1 funs))))))
(defun multiple-value-compose (function &rest more-functions)
"Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies
its arguments to each in turn, starting from the rightmost of
MORE-FUNCTIONS, and then calling the next one with all the return values of
the last."
(declare (optimize (speed 3) (safety 1) (debug 1)))
(reduce (lambda (f g)
(let ((f (ensure-function f))
(g (ensure-function g)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
(multiple-value-call f (apply g arguments)))))
more-functions
:initial-value function))
(define-compiler-macro multiple-value-compose (function &rest more-functions)
(labels ((compose-1 (funs)
(if (cdr funs)
`(multiple-value-call ,(car funs) ,(compose-1 (cdr funs)))
`(apply ,(car funs) arguments))))
(let* ((args (cons function more-functions))
(funs (make-gensym-list (length args) "MV-COMPOSE")))
`(let ,(mapcar #'list funs args)
(declare (optimize (speed 3) (safety 1) (debug 1)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
,(compose-1 funs))))))
(declaim (inline curry rcurry))
(defun curry (function &rest arguments)
"Returns a function that applies ARGUMENTS and the arguments
it is called with to FUNCTION."
(declare (optimize (speed 3) (safety 1)))
(let ((fn (ensure-function function)))
(lambda (&rest more)
(declare (dynamic-extent more))
;; Using M-V-C we don't need to append the arguments.
(multiple-value-call fn (values-list arguments) (values-list more)))))
(define-compiler-macro curry (function &rest arguments)
(let ((curries (make-gensym-list (length arguments) "CURRY"))
(fun (gensym "FUN")))
`(let ((,fun (ensure-function ,function))
,@(mapcar #'list curries arguments))
(declare (optimize (speed 3) (safety 1)))
(lambda (&rest more)
(declare (dynamic-extent more))
(apply ,fun ,@curries more)))))
(defun rcurry (function &rest arguments)
"Returns a function that applies the arguments it is called
with and ARGUMENTS to FUNCTION."
(declare (optimize (speed 3) (safety 1)))
(let ((fn (ensure-function function)))
(lambda (&rest more)
(declare (dynamic-extent more))
(multiple-value-call fn (values-list more) (values-list arguments)))))
(define-compiler-macro rcurry (function &rest arguments)
(let ((rcurries (make-gensym-list (length arguments) "RCURRY"))
(fun (gensym "FUN")))
`(let ((,fun (ensure-function ,function))
,@(mapcar #'list rcurries arguments))
(declare (optimize (speed 3) (safety 1)))
(lambda (&rest more)
(declare (dynamic-extent more))
(multiple-value-call ,fun (values-list more) ,@rcurries)))))
(declaim (notinline curry rcurry))
(defmacro named-lambda (name lambda-list &body body)
"Expands into a lambda-expression within whose BODY NAME denotes the
corresponding function."
`(labels ((,name ,lambda-list ,@body))
#',name))

101
hash-tables.lisp Normal file
View file

@ -0,0 +1,101 @@
(in-package :alexandria)
(defmacro 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."
(once-only (key hash-table)
(with-unique-names (value presentp)
`(multiple-value-bind (,value ,presentp) (gethash ,key ,hash-table)
(if ,presentp
(values ,value ,presentp)
(values (setf (gethash ,key ,hash-table) ,default) nil))))))
(defun copy-hash-table (table &key key test size
rehash-size rehash-threshold)
"Returns a copy of hash table TABLE, with the same keys and values
as the TABLE. The copy has the same properties as the original, unless
overridden by the keyword arguments.
Before each of the original values is set into the new hash-table, KEY
is invoked on the value. As KEY defaults to CL:IDENTITY, a shallow
copy is returned by default."
(setf key (or key 'identity))
(setf test (or test (hash-table-test table)))
(setf size (or size (hash-table-size table)))
(setf rehash-size (or rehash-size (hash-table-rehash-size table)))
(setf rehash-threshold (or rehash-threshold (hash-table-rehash-threshold table)))
(let ((copy (make-hash-table :test test :size size
:rehash-size rehash-size
:rehash-threshold rehash-threshold)))
(maphash (lambda (k v)
(setf (gethash k copy) (funcall key v)))
table)
copy))
(declaim (inline maphash-keys))
(defun maphash-keys (function table)
"Like MAPHASH, but calls FUNCTION with each key in the hash table TABLE."
(maphash (lambda (k v)
(declare (ignore v))
(funcall function k))
table))
(declaim (inline maphash-values))
(defun maphash-values (function table)
"Like MAPHASH, but calls FUNCTION with each value in the hash table TABLE."
(maphash (lambda (k v)
(declare (ignore k))
(funcall function v))
table))
(defun hash-table-keys (table)
"Returns a list containing the keys of hash table TABLE."
(let ((keys nil))
(maphash-keys (lambda (k)
(push k keys))
table)
keys))
(defun hash-table-values (table)
"Returns a list containing the values of hash table TABLE."
(let ((values nil))
(maphash-values (lambda (v)
(push v values))
table)
values))
(defun hash-table-alist (table)
"Returns an association list containing the keys and values of hash table
TABLE."
(let ((alist nil))
(maphash (lambda (k v)
(push (cons k v) alist))
table)
alist))
(defun hash-table-plist (table)
"Returns a property list containing the keys and values of hash table
TABLE."
(let ((plist nil))
(maphash (lambda (k v)
(setf plist (list* k v plist)))
table)
plist))
(defun alist-hash-table (alist &rest hash-table-initargs)
"Returns a hash table containing the keys and values of the association list
ALIST. Hash table is initialized using the HASH-TABLE-INITARGS."
(let ((table (apply #'make-hash-table hash-table-initargs)))
(dolist (cons alist)
(ensure-gethash (car cons) table (cdr cons)))
table))
(defun plist-hash-table (plist &rest hash-table-initargs)
"Returns a hash table containing the keys and values of the property list
PLIST. Hash table is initialized using the HASH-TABLE-INITARGS."
(let ((table (apply #'make-hash-table hash-table-initargs)))
(do ((tail plist (cddr tail)))
((not tail))
(ensure-gethash (car tail) table (cadr tail)))
table))

172
io.lisp Normal file
View file

@ -0,0 +1,172 @@
;; Copyright (c) 2002-2006, Edward Marco Baringer
;; All rights reserved.
(in-package :alexandria)
(defmacro with-open-file* ((stream filespec &key direction element-type
if-exists if-does-not-exist external-format)
&body body)
"Just like WITH-OPEN-FILE, but NIL values in the keyword arguments mean to use
the default value specified for OPEN."
(once-only (direction element-type if-exists if-does-not-exist external-format)
`(with-open-stream
(,stream (apply #'open ,filespec
(append
(when ,direction
(list :direction ,direction))
(when ,element-type
(list :element-type ,element-type))
(when ,if-exists
(list :if-exists ,if-exists))
(when ,if-does-not-exist
(list :if-does-not-exist ,if-does-not-exist))
(when ,external-format
(list :external-format ,external-format)))))
,@body)))
(defmacro with-input-from-file ((stream-name file-name &rest args
&key (direction nil direction-p)
&allow-other-keys)
&body body)
"Evaluate BODY with STREAM-NAME to an input stream on the file
FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
which is only sent to WITH-OPEN-FILE when it's not NIL."
(declare (ignore direction))
(when direction-p
(error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))
`(with-open-file* (,stream-name ,file-name :direction :input ,@args)
,@body))
(defmacro with-output-to-file ((stream-name file-name &rest args
&key (direction nil direction-p)
&allow-other-keys)
&body body)
"Evaluate BODY with STREAM-NAME to an output stream on the file
FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
which is only sent to WITH-OPEN-FILE when it's not NIL."
(declare (ignore direction))
(when direction-p
(error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
`(with-open-file* (,stream-name ,file-name :direction :output ,@args)
,@body))
(defun read-stream-content-into-string (stream &key (buffer-size 4096))
"Return the \"content\" of STREAM as a fresh string."
(check-type buffer-size positive-integer)
(let ((*print-pretty* nil))
(with-output-to-string (datum)
(let ((buffer (make-array buffer-size :element-type 'character)))
(loop
:for bytes-read = (read-sequence buffer stream)
:do (write-sequence buffer datum :start 0 :end bytes-read)
:while (= bytes-read buffer-size))))))
(defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
"Return the contents of the file denoted by PATHNAME as a fresh string.
The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
unless it's NIL, which means the system default."
(with-input-from-file
(file-stream pathname :external-format external-format)
(read-stream-content-into-string file-stream :buffer-size buffer-size)))
(defun write-string-into-file (string pathname &key (if-exists :error)
if-does-not-exist
external-format)
"Write STRING to PATHNAME.
The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
unless it's NIL, which means the system default."
(with-output-to-file (file-stream pathname :if-exists if-exists
:if-does-not-exist if-does-not-exist
:external-format external-format)
(write-sequence string file-stream)))
(defun read-stream-content-into-byte-vector (stream &key ((%length length))
(initial-size 4096))
"Return \"content\" of STREAM as freshly allocated (unsigned-byte 8) vector."
(check-type length (or null non-negative-integer))
(check-type initial-size positive-integer)
(do ((buffer (make-array (or length initial-size)
:element-type '(unsigned-byte 8)))
(offset 0)
(offset-wanted 0))
((or (/= offset-wanted offset)
(and length (>= offset length)))
(if (= offset (length buffer))
buffer
(subseq buffer 0 offset)))
(unless (zerop offset)
(let ((new-buffer (make-array (* 2 (length buffer))
:element-type '(unsigned-byte 8))))
(replace new-buffer buffer)
(setf buffer new-buffer)))
(setf offset-wanted (length buffer)
offset (read-sequence buffer stream :start offset))))
(defun read-file-into-byte-vector (pathname)
"Read PATHNAME into a freshly allocated (unsigned-byte 8) vector."
(with-input-from-file (stream pathname :element-type '(unsigned-byte 8))
(read-stream-content-into-byte-vector stream '%length (file-length stream))))
(defun write-byte-vector-into-file (bytes pathname &key (if-exists :error)
if-does-not-exist)
"Write BYTES to PATHNAME."
(check-type bytes (vector (unsigned-byte 8)))
(with-output-to-file (stream pathname :if-exists if-exists
:if-does-not-exist if-does-not-exist
:element-type '(unsigned-byte 8))
(write-sequence bytes stream)))
(defun copy-file (from to &key (if-to-exists :supersede)
(element-type '(unsigned-byte 8)) finish-output)
(with-input-from-file (input from :element-type element-type)
(with-output-to-file (output to :element-type element-type
:if-exists if-to-exists)
(copy-stream input output
:element-type element-type
:finish-output finish-output))))
(defun copy-stream (input output &key (element-type (stream-element-type input))
(buffer-size 4096)
(buffer (make-array buffer-size :element-type element-type))
(start 0) end
finish-output)
"Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must
be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have
compatible element-types."
(check-type start non-negative-integer)
(check-type end (or null non-negative-integer))
(check-type buffer-size positive-integer)
(when (and end
(< end start))
(error "END is smaller than START in ~S" 'copy-stream))
(let ((output-position 0)
(input-position 0))
(unless (zerop start)
;; FIXME add platform specific optimization to skip seekable streams
(loop while (< input-position start)
do (let ((n (read-sequence buffer input
:end (min (length buffer)
(- start input-position)))))
(when (zerop n)
(error "~@<Could not read enough bytes from the input to fulfill ~
the :START ~S requirement in ~S.~:@>" 'copy-stream start))
(incf input-position n))))
(assert (= input-position start))
(loop while (or (null end) (< input-position end))
do (let ((n (read-sequence buffer input
:end (when end
(min (length buffer)
(- end input-position))))))
(when (zerop n)
(if end
(error "~@<Could not read enough bytes from the input to fulfill ~
the :END ~S requirement in ~S.~:@>" 'copy-stream end)
(return)))
(incf input-position n)
(write-sequence buffer output :end n)
(incf output-position n)))
(when finish-output
(finish-output output))
output-position))

367
lists.lisp Normal file
View file

@ -0,0 +1,367 @@
(in-package :alexandria)
(declaim (inline safe-endp))
(defun safe-endp (x)
(declare (optimize safety))
(endp x))
(defun alist-plist (alist)
"Returns a property list containing the same keys and values as the
association list ALIST in the same order."
(let (plist)
(dolist (pair alist)
(push (car pair) plist)
(push (cdr pair) plist))
(nreverse plist)))
(defun plist-alist (plist)
"Returns an association list containing the same keys and values as the
property list PLIST in the same order."
(let (alist)
(do ((tail plist (cddr tail)))
((safe-endp tail) (nreverse alist))
(push (cons (car tail) (cadr tail)) alist))))
(declaim (inline racons))
(defun racons (key value ralist)
(acons value key ralist))
(macrolet
((define-alist-get (name get-entry get-value-from-entry add doc)
`(progn
(declaim (inline ,name))
(defun ,name (alist key &key (test 'eql))
,doc
(let ((entry (,get-entry key alist :test test)))
(values (,get-value-from-entry entry) entry)))
(define-setf-expander ,name (place key &key (test ''eql)
&environment env)
(multiple-value-bind
(temporary-variables initforms newvals setter getter)
(get-setf-expansion place env)
(when (cdr newvals)
(error "~A cannot store multiple values in one place" ',name))
(with-unique-names (new-value key-val test-val alist entry)
(values
(append temporary-variables
(list alist
key-val
test-val
entry))
(append initforms
(list getter
key
test
`(,',get-entry ,key-val ,alist :test ,test-val)))
`(,new-value)
`(cond
(,entry
(setf (,',get-value-from-entry ,entry) ,new-value))
(t
(let ,newvals
(setf ,(first newvals) (,',add ,key ,new-value ,alist))
,setter
,new-value)))
`(,',get-value-from-entry ,entry))))))))
(define-alist-get assoc-value assoc cdr acons
"ASSOC-VALUE is an alist accessor very much like ASSOC, but it can
be used with SETF.")
(define-alist-get rassoc-value rassoc car racons
"RASSOC-VALUE is an alist accessor very much like RASSOC, but it can
be used with SETF."))
(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.")
(define-modify-macro unionf (list &rest args) union
"Modify-macro for UNION. Saves the union of LIST and the contents of the
place designated by the first argument to the designated place.")
(define-modify-macro nunionf (list &rest args) nunion
"Modify-macro for NUNION. Saves the union of LIST and the contents of the
place designated by the first argument to the designated place. May modify
either argument.")
(define-modify-macro reversef () reverse
"Modify-macro for REVERSE. Copies and reverses the list stored in the given
place and saves back the result into the place.")
(define-modify-macro nreversef () nreverse
"Modify-macro for NREVERSE. Reverses the list stored in the given place by
destructively modifying it and saves back the result into the place.")
(defun circular-list (&rest elements)
"Creates a circular list of ELEMENTS."
(let ((cycle (copy-list elements)))
(nconc cycle cycle)))
(defun circular-list-p (object)
"Returns true if OBJECT is a circular list, NIL otherwise."
(and (listp object)
(do ((fast object (cddr fast))
(slow (cons (car object) (cdr object)) (cdr slow)))
(nil)
(unless (and (consp fast) (listp (cdr fast)))
(return nil))
(when (eq fast slow)
(return t)))))
(defun circular-tree-p (object)
"Returns true if OBJECT is a circular tree, NIL otherwise."
(labels ((circularp (object seen)
(and (consp object)
(do ((fast (cons (car object) (cdr object)) (cddr fast))
(slow object (cdr slow)))
(nil)
(when (or (eq fast slow) (member slow seen))
(return-from circular-tree-p t))
(when (or (not (consp fast)) (not (consp (cdr slow))))
(return
(do ((tail object (cdr tail)))
((not (consp tail))
nil)
(let ((elt (car tail)))
(circularp elt (cons object seen))))))))))
(circularp object nil)))
(defun proper-list-p (object)
"Returns true if OBJECT is a proper list."
(cond ((not object)
t)
((consp object)
(do ((fast object (cddr fast))
(slow (cons (car object) (cdr object)) (cdr slow)))
(nil)
(unless (and (listp fast) (consp (cdr fast)))
(return (and (listp fast) (not (cdr fast)))))
(when (eq fast slow)
(return nil))))
(t
nil)))
(deftype proper-list ()
"Type designator for proper lists. Implemented as a SATISFIES type, hence
not recommended for performance intensive use. Main usefullness as a type
designator of the expected type in a TYPE-ERROR."
`(and list (satisfies proper-list-p)))
(defun circular-list-error (list)
(error 'type-error
:datum list
:expected-type '(and list (not circular-list))))
(macrolet ((def (name lambda-list doc step declare ret1 ret2)
(assert (member 'list lambda-list))
`(defun ,name ,lambda-list
,doc
(do ((last list fast)
(fast list (cddr fast))
(slow (cons (car list) (cdr list)) (cdr slow))
,@(when step (list step)))
(nil)
(declare (dynamic-extent slow) ,@(when declare (list declare))
(ignorable last))
(when (safe-endp fast)
(return ,ret1))
(when (safe-endp (cdr fast))
(return ,ret2))
(when (eq fast slow)
(circular-list-error list))))))
(def proper-list-length (list)
"Returns length of LIST, signalling an error if it is not a proper list."
(n 1 (+ n 2))
;; KLUDGE: Most implementations don't actually support lists with bignum
;; elements -- and this is WAY faster on most implementations then declaring
;; N to be an UNSIGNED-BYTE.
(fixnum n)
(1- n)
n)
(def lastcar (list)
"Returns the last element of LIST. Signals a type-error if LIST is not a
proper list."
nil
nil
(cadr last)
(car fast))
(def (setf lastcar) (object list)
"Sets the last element of LIST. Signals a type-error if LIST is not a proper
list."
nil
nil
(setf (cadr last) object)
(setf (car fast) object)))
(defun make-circular-list (length &key initial-element)
"Creates a circular list of LENGTH with the given INITIAL-ELEMENT."
(let ((cycle (make-list length :initial-element initial-element)))
(nconc cycle cycle)))
(deftype circular-list ()
"Type designator for circular lists. Implemented as a SATISFIES type, so not
recommended for performance intensive use. Main usefullness as the
expected-type designator of a TYPE-ERROR."
`(satisfies circular-list-p))
(defun ensure-car (thing)
"If THING is a CONS, its CAR is returned. Otherwise THING is returned."
(if (consp thing)
(car thing)
thing))
(defun ensure-cons (cons)
"If CONS is a cons, it is returned. Otherwise returns a fresh cons with CONS
in the car, and NIL in the cdr."
(if (consp cons)
cons
(cons cons nil)))
(defun ensure-list (list)
"If LIST is a list, it is returned. Otherwise returns the list designated by LIST."
(if (listp list)
list
(list list)))
(defun remove-from-plist (plist &rest keys)
"Returns a propery-list with same keys and values as PLIST, except that keys
in the list designated by KEYS and values corresponding to them are removed.
The returned property-list may share structure with the PLIST, but PLIST is
not destructively modified. Keys are compared using EQ."
(declare (optimize (speed 3)))
;; FIXME: possible optimization: (remove-from-plist '(:x 0 :a 1 :b 2) :a)
;; could return the tail without consing up a new list.
(loop for (key . rest) on plist by #'cddr
do (assert rest () "Expected a proper plist, got ~S" plist)
unless (member key keys :test #'eq)
collect key and collect (first rest)))
(defun delete-from-plist (plist &rest keys)
"Just like REMOVE-FROM-PLIST, but this version may destructively modify the
provided PLIST."
(declare (optimize speed))
(loop with head = plist
with tail = nil ; a nil tail means an empty result so far
for (key . rest) on plist by #'cddr
do (assert rest () "Expected a proper plist, got ~S" plist)
(if (member key keys :test #'eq)
;; skip over this pair
(let ((next (cdr rest)))
(if tail
(setf (cdr tail) next)
(setf head next)))
;; keep this pair
(setf tail rest))
finally (return head)))
(define-modify-macro remove-from-plistf (&rest keys) remove-from-plist
"Modify macro for REMOVE-FROM-PLIST.")
(define-modify-macro delete-from-plistf (&rest keys) delete-from-plist
"Modify macro for DELETE-FROM-PLIST.")
(declaim (inline sans))
(defun sans (plist &rest keys)
"Alias of REMOVE-FROM-PLIST for backward compatibility."
(apply #'remove-from-plist plist keys))
(defun mappend (function &rest lists)
"Applies FUNCTION to respective element(s) of each LIST, appending all the
all the result list to a single list. FUNCTION must return a list."
(loop for results in (apply #'mapcar function lists)
append results))
(defun setp (object &key (test #'eql) (key #'identity))
"Returns true if OBJECT is a list that denotes a set, NIL otherwise. A list
denotes a set if each element of the list is unique under KEY and TEST."
(and (listp object)
(let (seen)
(dolist (elt object t)
(let ((key (funcall key elt)))
(if (member key seen :test test)
(return nil)
(push key seen)))))))
(defun set-equal (list1 list2 &key (test #'eql) (key nil keyp))
"Returns true if every element of LIST1 matches some element of LIST2 and
every element of LIST2 matches some element of LIST1. Otherwise returns false."
(let ((keylist1 (if keyp (mapcar key list1) list1))
(keylist2 (if keyp (mapcar key list2) list2)))
(and (dolist (elt keylist1 t)
(or (member elt keylist2 :test test)
(return nil)))
(dolist (elt keylist2 t)
(or (member elt keylist1 :test test)
(return nil))))))
(defun map-product (function list &rest more-lists)
"Returns a list containing the results of calling FUNCTION with one argument
from LIST, and one from each of MORE-LISTS for each combination of arguments.
In other words, returns the product of LIST and MORE-LISTS using FUNCTION.
Example:
(map-product 'list '(1 2) '(3 4) '(5 6))
=> ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
(2 3 5) (2 3 6) (2 4 5) (2 4 6))
"
(labels ((%map-product (f lists)
(let ((more (cdr lists))
(one (car lists)))
(if (not more)
(mapcar f one)
(mappend (lambda (x)
(%map-product (curry f x) more))
one)))))
(%map-product (ensure-function function) (cons list more-lists))))
(defun flatten (tree)
"Traverses the tree in order, collecting non-null leaves into a list."
(let (list)
(labels ((traverse (subtree)
(when subtree
(if (consp subtree)
(progn
(traverse (car subtree))
(traverse (cdr subtree)))
(push subtree list)))))
(traverse tree))
(nreverse list)))

370
macros.lisp Normal file
View file

@ -0,0 +1,370 @@
(in-package :alexandria)
(defmacro with-gensyms (names &body forms)
"Binds a set of variables to gensyms and evaluates the implicit progn FORMS.
Each element within NAMES is either a symbol SYMBOL or a pair (SYMBOL
STRING-DESIGNATOR). Bare symbols are equivalent to the pair (SYMBOL SYMBOL).
Each pair (SYMBOL STRING-DESIGNATOR) specifies that the variable named by SYMBOL
should be bound to a symbol constructed using GENSYM with the string designated
by STRING-DESIGNATOR being its first argument."
`(let ,(mapcar (lambda (name)
(multiple-value-bind (symbol string)
(etypecase name
(symbol
(values name (symbol-name name)))
((cons symbol (cons string-designator null))
(values (first name) (string (second name)))))
`(,symbol (gensym ,string))))
names)
,@forms))
(defmacro with-unique-names (names &body forms)
"Alias for WITH-GENSYMS."
`(with-gensyms ,names ,@forms))
(defmacro once-only (specs &body forms)
"Constructs code whose primary goal is to help automate the handling of
multiple evaluation within macros. Multiple evaluation is handled by introducing
intermediate variables, in order to reuse the result of an expression.
The returned value is a list of the form
(let ((<gensym-1> <expr-1>)
...
(<gensym-n> <expr-n>))
<res>)
where GENSYM-1, ..., GENSYM-N are the intermediate variables introduced in order
to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the result of
evaluating the implicit progn FORMS within a special context determined by
SPECS. RES should make use of (reference) the intermediate variables.
Each element within SPECS is either a symbol SYMBOL or a pair (SYMBOL INITFORM).
Bare symbols are equivalent to the pair (SYMBOL SYMBOL).
Each pair (SYMBOL INITFORM) specifies a single intermediate variable:
- INITFORM is an expression evaluated to produce EXPR-i
- SYMBOL is the name of the variable that will be bound around FORMS to the
corresponding gensym GENSYM-i, in order for FORMS to generate RES that
references the intermediate variable
The evaluation of INITFORMs and binding of SYMBOLs resembles LET. INITFORMs of
all the pairs are evaluated before binding SYMBOLs and evaluating FORMS.
Example:
The following expression
(let ((x '(incf y)))
(once-only (x)
`(cons ,x ,x)))
;;; =>
;;; (let ((#1=#:X123 (incf y)))
;;; (cons #1# #1#))
could be used within a macro to avoid multiple evaluation like so
(defmacro cons1 (x)
(once-only (x)
`(cons ,x ,x)))
(let ((y 0))
(cons1 (incf y)))
;;; => (1 . 1)
Example:
The following expression demonstrates the usage of the INITFORM field
(let ((expr '(incf y)))
(once-only ((var `(1+ ,expr)))
`(list ',expr ,var ,var)))
;;; =>
;;; (let ((#1=#:VAR123 (1+ (incf y))))
;;; (list '(incf y) #1# #1))
which could be used like so
(defmacro print-succ-twice (expr)
(once-only ((var `(1+ ,expr)))
`(format t \"Expr: ~s, Once: ~s, Twice: ~s~%\" ',expr ,var ,var)))
(let ((y 10))
(print-succ-twice (incf y)))
;;; >>
;;; Expr: (INCF Y), Once: 12, Twice: 12"
(let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
(names-and-forms (mapcar (lambda (spec)
(etypecase spec
(list
(destructuring-bind (name form) spec
(cons name form)))
(symbol
(cons spec spec))))
specs)))
;; bind in user-macro
`(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
gensyms names-and-forms)
;; bind in final expansion
`(let (,,@(mapcar (lambda (g n)
``(,,g ,,(cdr n)))
gensyms names-and-forms))
;; bind in user-macro
,(let ,(mapcar (lambda (n g) (list (car n) g))
names-and-forms gensyms)
,@forms)))))
(defun parse-body (body &key documentation whole)
"Parses BODY into (values remaining-forms declarations doc-string).
Documentation strings are recognized only if DOCUMENTATION is true.
Syntax errors in body are signalled and WHOLE is used in the signal
arguments when given."
(let ((doc nil)
(decls nil)
(current nil))
(tagbody
:declarations
(setf current (car body))
(when (and documentation (stringp current) (cdr body))
(if doc
(error "Too many documentation strings in ~S." (or whole body))
(setf doc (pop body)))
(go :declarations))
(when (and (listp current) (eql (first current) 'declare))
(push (pop body) decls)
(go :declarations)))
(values body (nreverse decls) doc)))
(defun parse-ordinary-lambda-list (lambda-list &key (normalize t)
allow-specializers
(normalize-optional normalize)
(normalize-keyword normalize)
(normalize-auxilary normalize))
"Parses an ordinary lambda-list, returning as multiple values:
1. Required parameters.
2. Optional parameter specifications, normalized into form:
(name init suppliedp)
3. Name of the rest parameter, or NIL.
4. Keyword parameter specifications, normalized into form:
((keyword-name name) init suppliedp)
5. Boolean indicating &ALLOW-OTHER-KEYS presence.
6. &AUX parameter specifications, normalized into form
(name init).
7. Existence of &KEY in the lambda-list.
Signals a PROGRAM-ERROR is the lambda-list is malformed."
(let ((state :required)
(allow-other-keys nil)
(auxp nil)
(required nil)
(optional nil)
(rest nil)
(keys nil)
(keyp nil)
(aux nil))
(labels ((fail (elt)
(simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S"
elt lambda-list))
(check-variable (elt what &optional (allow-specializers allow-specializers))
(unless (and (or (symbolp elt)
(and allow-specializers
(consp elt) (= 2 (length elt)) (symbolp (first elt))))
(not (constantp elt)))
(simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S"
what elt lambda-list)))
(check-spec (spec what)
(destructuring-bind (init suppliedp) spec
(declare (ignore init))
(check-variable suppliedp what nil))))
(dolist (elt lambda-list)
(case elt
(&optional
(if (eq state :required)
(setf state elt)
(fail elt)))
(&rest
(if (member state '(:required &optional))
(setf state elt)
(fail elt)))
(&key
(if (member state '(:required &optional :after-rest))
(setf state elt)
(fail elt))
(setf keyp t))
(&allow-other-keys
(if (eq state '&key)
(setf allow-other-keys t
state elt)
(fail elt)))
(&aux
(cond ((eq state '&rest)
(fail elt))
(auxp
(simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S"
elt lambda-list))
(t
(setf auxp t
state elt))
))
(otherwise
(when (member elt '#.(set-difference lambda-list-keywords
'(&optional &rest &key &allow-other-keys &aux)))
(simple-program-error
"Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S"
elt lambda-list))
(case state
(:required
(check-variable elt "required parameter")
(push elt required))
(&optional
(cond ((consp elt)
(destructuring-bind (name &rest tail) elt
(check-variable name "optional parameter")
(cond ((cdr tail)
(check-spec tail "optional-supplied-p parameter"))
((and normalize-optional tail)
(setf elt (append elt '(nil))))
(normalize-optional
(setf elt (append elt '(nil nil)))))))
(t
(check-variable elt "optional parameter")
(when normalize-optional
(setf elt (cons elt '(nil nil))))))
(push (ensure-list elt) optional))
(&rest
(check-variable elt "rest parameter")
(setf rest elt
state :after-rest))
(&key
(cond ((consp elt)
(destructuring-bind (var-or-kv &rest tail) elt
(cond ((consp var-or-kv)
(destructuring-bind (keyword var) var-or-kv
(unless (symbolp keyword)
(simple-program-error "Invalid keyword name ~S in ordinary ~
lambda-list:~% ~S"
keyword lambda-list))
(check-variable var "keyword parameter")))
(t
(check-variable var-or-kv "keyword parameter")
(when normalize-keyword
(setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)))))
(cond ((cdr tail)
(check-spec tail "keyword-supplied-p parameter"))
((and normalize-keyword tail)
(setf tail (append tail '(nil))))
(normalize-keyword
(setf tail '(nil nil))))
(setf elt (cons var-or-kv tail))))
(t
(check-variable elt "keyword parameter")
(setf elt (if normalize-keyword
(list (list (make-keyword elt) elt) nil nil)
elt))))
(push elt keys))
(&aux
(if (consp elt)
(destructuring-bind (var &optional init) elt
(declare (ignore init))
(check-variable var "&aux parameter"))
(progn
(check-variable elt "&aux parameter")
(setf elt (list* elt (when normalize-auxilary
'(nil))))))
(push elt aux))
(t
(simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list)))))))
(values (nreverse required) (nreverse optional) rest (nreverse keys)
allow-other-keys (nreverse aux) keyp)))
;;;; DESTRUCTURING-*CASE
(defun expand-destructuring-case (key clauses case)
(once-only (key)
`(if (typep ,key 'cons)
(,case (car ,key)
,@(mapcar (lambda (clause)
(destructuring-bind ((keys . lambda-list) &body body) clause
`(,keys
(destructuring-bind ,lambda-list (cdr ,key)
,@body))))
clauses))
(error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key))))
(defmacro destructuring-case (keyform &body clauses)
"DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND.
KEYFORM must evaluate to a CONS.
Clauses are of the form:
((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*)
The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE,
is selected, and FORMs are then executed with CDR of KEY is destructured and
bound by the DESTRUCTURING-LAMBDA-LIST.
Example:
(defun dcase (x)
(destructuring-case x
((:foo a b)
(format nil \"foo: ~S, ~S\" a b))
((:bar &key a b)
(format nil \"bar: ~S, ~S\" a b))
(((:alt1 :alt2) a)
(format nil \"alt: ~S\" a))
((t &rest rest)
(format nil \"unknown: ~S\" rest))))
(dcase (list :foo 1 2)) ; => \"foo: 1, 2\"
(dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
(dcase (list :alt1 1)) ; => \"alt: 1\"
(dcase (list :alt2 2)) ; => \"alt: 2\"
(dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\"
(defun decase (x)
(destructuring-case x
((:foo a b)
(format nil \"foo: ~S, ~S\" a b))
((:bar &key a b)
(format nil \"bar: ~S, ~S\" a b))
(((:alt1 :alt2) a)
(format nil \"alt: ~S\" a))))
(decase (list :foo 1 2)) ; => \"foo: 1, 2\"
(decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
(decase (list :alt1 1)) ; => \"alt: 1\"
(decase (list :alt2 2)) ; => \"alt: 2\"
(decase (list :quux 1 2 3)) ; =| error
"
(expand-destructuring-case keyform clauses 'case))
(defmacro destructuring-ccase (keyform &body clauses)
(expand-destructuring-case keyform clauses 'ccase))
(defmacro destructuring-ecase (keyform &body clauses)
(expand-destructuring-case keyform clauses 'ecase))
(dolist (name '(destructuring-ccase destructuring-ecase))
(setf (documentation name 'function) (documentation 'destructuring-case 'function)))

295
numbers.lisp Normal file
View file

@ -0,0 +1,295 @@
(in-package :alexandria)
(declaim (inline clamp))
(defun clamp (number min max)
"Clamps the NUMBER into [min, max] range. Returns MIN if NUMBER is lesser then
MIN and MAX if NUMBER is greater then MAX, otherwise returns NUMBER."
(if (< number min)
min
(if (> number max)
max
number)))
(defun gaussian-random (&optional min max)
"Returns two gaussian random double floats as the primary and secondary value,
optionally constrained by MIN and MAX. Gaussian random numbers form a standard
normal distribution around 0.0d0.
Sufficiently positive MIN or negative MAX will cause the algorithm used to
take a very long time. If MIN is positive it should be close to zero, and
similarly if MAX is negative it should be close to zero."
(macrolet
((valid (x)
`(<= (or min ,x) ,x (or max ,x)) ))
(labels
((gauss ()
(loop
for x1 = (- (random 2.0d0) 1.0d0)
for x2 = (- (random 2.0d0) 1.0d0)
for w = (+ (expt x1 2) (expt x2 2))
when (< w 1.0d0)
do (let ((v (sqrt (/ (* -2.0d0 (log w)) w))))
(return (values (* x1 v) (* x2 v))))))
(guard (x)
(unless (valid x)
(tagbody
:retry
(multiple-value-bind (x1 x2) (gauss)
(when (valid x1)
(setf x x1)
(go :done))
(when (valid x2)
(setf x x2)
(go :done))
(go :retry))
:done))
x))
(multiple-value-bind
(g1 g2) (gauss)
(values (guard g1) (guard g2))))))
(declaim (inline iota))
(defun iota (n &key (start 0) (step 1))
"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
and STEP. START defaults to 0 and STEP to 1.
Examples:
(iota 4) => (0 1 2 3)
(iota 3 :start 1 :step 1.0) => (1.0 2.0 3.0)
(iota 3 :start -1 :step -1/2) => (-1 -3/2 -2)
"
(declare (type (integer 0) n) (number start step))
(loop ;; KLUDGE: get numeric contagion right for the first element too
for i = (+ (- (+ start step) step)) then (+ i step)
repeat n
collect i))
(declaim (inline map-iota))
(defun map-iota (function n &key (start 0) (step 1))
"Calls FUNCTION with N numbers, starting from START (with numeric contagion
from STEP applied), each consequtive number being the sum of the previous one
and STEP. START defaults to 0 and STEP to 1. Returns N.
Examples:
(map-iota #'print 3 :start 1 :step 1.0) => 3
;;; 1.0
;;; 2.0
;;; 3.0
"
(declare (type (integer 0) n) (number start step))
(loop ;; KLUDGE: get numeric contagion right for the first element too
for i = (+ start (- step step)) then (+ i step)
repeat n
do (funcall function i))
n)
(declaim (inline lerp))
(defun lerp (v a b)
"Returns the result of linear interpolation between A and B, using the
interpolation coefficient V."
;; The correct version is numerically stable, at the expense of an
;; extra multiply. See (lerp 0.1 4 25) with (+ a (* v (- b a))). The
;; unstable version can often be converted to a fast instruction on
;; a lot of machines, though this is machine/implementation
;; specific. As alexandria is more about correct code, than
;; efficiency, and we're only talking about a single extra multiply,
;; many would prefer the stable version
(+ (* (- 1.0 v) a) (* v b)))
(declaim (inline mean))
(defun mean (sample)
"Returns the mean of SAMPLE. SAMPLE must be a sequence of numbers."
(/ (reduce #'+ sample) (length sample)))
(defun median (sample)
"Returns median of SAMPLE. SAMPLE must be a sequence of real numbers."
;; Implements and uses the quick-select algorithm to find the median
;; https://en.wikipedia.org/wiki/Quickselect
(labels ((randint-in-range (start-int end-int)
"Returns a random integer in the specified range, inclusive"
(+ start-int (random (1+ (- end-int start-int)))))
(partition (vec start-i end-i)
"Implements the partition function, which performs a partial
sort of vec around the (randomly) chosen pivot.
Returns the index where the pivot element would be located
in a correctly-sorted array"
(if (= start-i end-i)
start-i
(let ((pivot-i (randint-in-range start-i end-i)))
(rotatef (aref vec start-i) (aref vec pivot-i))
(let ((swap-i end-i))
(loop for i from swap-i downto (1+ start-i) do
(when (>= (aref vec i) (aref vec start-i))
(rotatef (aref vec i) (aref vec swap-i))
(decf swap-i)))
(rotatef (aref vec swap-i) (aref vec start-i))
swap-i)))))
(let* ((vector (copy-sequence 'vector sample))
(len (length vector))
(mid-i (ash len -1))
(i 0)
(j (1- len)))
(loop for correct-pos = (partition vector i j)
while (/= correct-pos mid-i) do
(if (< correct-pos mid-i)
(setf i (1+ correct-pos))
(setf j (1- correct-pos))))
(if (oddp len)
(aref vector mid-i)
(* 1/2
(+ (aref vector mid-i)
(reduce #'max (make-array
mid-i
:displaced-to vector))))))))
(declaim (inline variance))
(defun variance (sample &key (biased t))
"Variance of SAMPLE. Returns the biased variance if BIASED is true (the default),
and the unbiased estimator of variance if BIASED is false. SAMPLE must be a
sequence of numbers."
(let ((mean (mean sample)))
(/ (reduce (lambda (a b)
(+ a (expt (- b mean) 2)))
sample
:initial-value 0)
(- (length sample) (if biased 0 1)))))
(declaim (inline standard-deviation))
(defun standard-deviation (sample &key (biased t))
"Standard deviation of SAMPLE. Returns the biased standard deviation if
BIASED is true (the default), and the square root of the unbiased estimator
for variance if BIASED is false (which is not the same as the unbiased
estimator for standard deviation). SAMPLE must be a sequence of numbers."
(sqrt (variance sample :biased biased)))
(define-modify-macro maxf (&rest numbers) max
"Modify-macro for MAX. Sets place designated by the first argument to the
maximum of its original value and NUMBERS.")
(define-modify-macro minf (&rest numbers) min
"Modify-macro for MIN. Sets place designated by the first argument to the
minimum of its original value and NUMBERS.")
;;;; Factorial
;;; KLUDGE: This is really dependant on the numbers in question: for
;;; small numbers this is larger, and vice versa. Ideally instead of a
;;; constant we would have RANGE-FAST-TO-MULTIPLY-DIRECTLY-P.
(defconstant +factorial-bisection-range-limit+ 8)
;;; KLUDGE: This is really platform dependant: ideally we would use
;;; (load-time-value (find-good-direct-multiplication-limit)) instead.
(defconstant +factorial-direct-multiplication-limit+ 13)
(defun %multiply-range (i j)
;; We use a a bit of cleverness here:
;;
;; 1. For large factorials we bisect in order to avoid expensive bignum
;; multiplications: 1 x 2 x 3 x ... runs into bignums pretty soon,
;; and once it does that all further multiplications will be with bignums.
;;
;; By instead doing the multiplication in a tree like
;; ((1 x 2) x (3 x 4)) x ((5 x 6) x (7 x 8))
;; we manage to get less bignums.
;;
;; 2. Division isn't exactly free either, however, so we don't bisect
;; all the way down, but multiply ranges of integers close to each
;; other directly.
;;
;; For even better results it should be possible to use prime
;; factorization magic, but Nikodemus ran out of steam.
;;
;; KLUDGE: We support factorials of bignums, but it seems quite
;; unlikely anyone would ever be able to use them on a modern lisp,
;; since the resulting numbers are unlikely to fit in memory... but
;; it would be extremely unelegant to define FACTORIAL only on
;; fixnums, _and_ on lisps with 16 bit fixnums this can actually be
;; needed.
(labels ((bisect (j k)
(declare (type (integer 1 #.most-positive-fixnum) j k))
(if (< (- k j) +factorial-bisection-range-limit+)
(multiply-range j k)
(let ((middle (+ j (truncate (- k j) 2))))
(* (bisect j middle)
(bisect (+ middle 1) k)))))
(bisect-big (j k)
(declare (type (integer 1) j k))
(if (= j k)
j
(let ((middle (+ j (truncate (- k j) 2))))
(* (if (<= middle most-positive-fixnum)
(bisect j middle)
(bisect-big j middle))
(bisect-big (+ middle 1) k)))))
(multiply-range (j k)
(declare (type (integer 1 #.most-positive-fixnum) j k))
(do ((f k (* f m))
(m (1- k) (1- m)))
((< m j) f)
(declare (type (integer 0 (#.most-positive-fixnum)) m)
(type unsigned-byte f)))))
(if (and (typep i 'fixnum) (typep j 'fixnum))
(bisect i j)
(bisect-big i j))))
(declaim (inline factorial))
(defun %factorial (n)
(if (< n 2)
1
(%multiply-range 1 n)))
(defun factorial (n)
"Factorial of non-negative integer N."
(check-type n (integer 0))
(%factorial n))
;;;; Combinatorics
(defun binomial-coefficient (n k)
"Binomial coefficient of N and K, also expressed as N choose K. This is the
number of K element combinations given N choises. N must be equal to or
greater then K."
(check-type n (integer 0))
(check-type k (integer 0))
(assert (>= n k))
(if (or (zerop k) (= n k))
1
(let ((n-k (- n k)))
;; Swaps K and N-K if K < N-K because the algorithm
;; below is faster for bigger K and smaller N-K
(when (< k n-k)
(rotatef k n-k))
(if (= 1 n-k)
n
;; General case, avoid computing the 1x...xK twice:
;;
;; N! 1x...xN (K+1)x...xN
;; -------- = ---------------- = ------------, N>1
;; K!(N-K)! 1x...xK x (N-K)! (N-K)!
(/ (%multiply-range (+ k 1) n)
(%factorial n-k))))))
(defun subfactorial (n)
"Subfactorial of the non-negative integer N."
(check-type n (integer 0))
(if (zerop n)
1
(do ((x 1 (1+ x))
(a 0 (* x (+ a b)))
(b 1 a))
((= n x) a))))
(defun count-permutations (n &optional (k n))
"Number of K element permutations for a sequence of N objects.
K defaults to N"
(check-type n (integer 0))
(check-type k (integer 0))
(assert (>= n k))
(%multiply-range (1+ (- n k)) n))

243
package.lisp Normal file
View file

@ -0,0 +1,243 @@
(defpackage :alexandria.1.0.0
(:nicknames :alexandria)
(:use :cl)
#+sb-package-locks
(:lock t)
(:export
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BLESSED
;;
;; Binding constructs
#:if-let
#:when-let
#:when-let*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; REVIEW IN PROGRESS
;;
;; Control flow
;;
;; -- no clear consensus yet --
#:cswitch
#:eswitch
#:switch
;; -- problem free? --
#:multiple-value-prog2
#:nth-value-or
#:whichever
#:xor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; REVIEW PENDING
;;
;; Definitions
#:define-constant
;; Hash tables
#:alist-hash-table
#:copy-hash-table
#:ensure-gethash
#:hash-table-alist
#:hash-table-keys
#:hash-table-plist
#:hash-table-values
#:maphash-keys
#:maphash-values
#:plist-hash-table
;; Functions
#:compose
#:conjoin
#:curry
#:disjoin
#:ensure-function
#:ensure-functionf
#:multiple-value-compose
#:named-lambda
#:rcurry
;; Lists
#:alist-plist
#:appendf
#:nconcf
#:reversef
#:nreversef
#:circular-list
#:circular-list-p
#:circular-tree-p
#:doplist
#:ensure-car
#:ensure-cons
#:ensure-list
#:flatten
#:lastcar
#:make-circular-list
#:map-product
#:mappend
#:nunionf
#:plist-alist
#:proper-list
#:proper-list-length
#:proper-list-p
#:remove-from-plist
#:remove-from-plistf
#:delete-from-plist
#:delete-from-plistf
#:set-equal
#:setp
#:unionf
;; Numbers
#:binomial-coefficient
#:clamp
#:count-permutations
#:factorial
#:gaussian-random
#:iota
#:lerp
#:map-iota
#:maxf
#:mean
#:median
#:minf
#:standard-deviation
#:subfactorial
#:variance
;; Arrays
#:array-index
#:array-length
#:copy-array
;; Sequences
#:copy-sequence
#:deletef
#:emptyp
#:ends-with
#:ends-with-subseq
#:extremum
#:first-elt
#:last-elt
#:length=
#:map-combinations
#:map-derangements
#:map-permutations
#:proper-sequence
#:random-elt
#:removef
#:rotate
#:sequence-of-length-p
#:shuffle
#:starts-with
#:starts-with-subseq
;; Macros
#:once-only
#:parse-body
#:parse-ordinary-lambda-list
#:with-gensyms
#:with-unique-names
;; Symbols
#:ensure-symbol
#:format-symbol
#:make-gensym
#:make-gensym-list
#:make-keyword
;; Strings
#:string-designator
;; Types
#:negative-double-float
#:negative-fixnum-p
#:negative-float
#:negative-float-p
#:negative-long-float
#:negative-long-float-p
#:negative-rational
#:negative-rational-p
#:negative-real
#:negative-single-float-p
#:non-negative-double-float
#:non-negative-double-float-p
#:non-negative-fixnum
#:non-negative-fixnum-p
#:non-negative-float
#:non-negative-float-p
#:non-negative-integer-p
#:non-negative-long-float
#:non-negative-rational
#:non-negative-real-p
#:non-negative-short-float-p
#:non-negative-single-float
#:non-negative-single-float-p
#:non-positive-double-float
#:non-positive-double-float-p
#:non-positive-fixnum
#:non-positive-fixnum-p
#:non-positive-float
#:non-positive-float-p
#:non-positive-integer
#:non-positive-rational
#:non-positive-real
#:non-positive-real-p
#:non-positive-short-float
#:non-positive-short-float-p
#:non-positive-single-float-p
#:positive-double-float
#:positive-double-float-p
#:positive-fixnum
#:positive-fixnum-p
#:positive-float
#:positive-float-p
#:positive-integer
#:positive-rational
#:positive-real
#:positive-real-p
#:positive-short-float
#:positive-short-float-p
#:positive-single-float
#:positive-single-float-p
#:coercef
#:negative-double-float-p
#:negative-fixnum
#:negative-integer
#:negative-integer-p
#:negative-real-p
#:negative-short-float
#:negative-short-float-p
#:negative-single-float
#:non-negative-integer
#:non-negative-long-float-p
#:non-negative-rational-p
#:non-negative-real
#:non-negative-short-float
#:non-positive-integer-p
#:non-positive-long-float
#:non-positive-long-float-p
#:non-positive-rational-p
#:non-positive-single-float
#:of-type
#:positive-integer-p
#:positive-long-float
#:positive-long-float-p
#:positive-rational-p
#:type=
;; Conditions
#:required-argument
#:ignore-some-conditions
#:simple-style-warning
#:simple-reader-error
#:simple-parse-error
#:simple-program-error
#:unwind-protect-case
;; Features
#:featurep
;; io
#:with-input-from-file
#:with-output-to-file
#:read-stream-content-into-string
#:read-file-into-string
#:write-string-into-file
#:read-stream-content-into-byte-vector
#:read-file-into-byte-vector
#:write-byte-vector-into-file
#:copy-stream
#:copy-file
;; new additions collected at the end (subject to removal or further changes)
#:symbolicate
#:assoc-value
#:rassoc-value
#:destructuring-case
#:destructuring-ccase
#:destructuring-ecase
))

555
sequences.lisp Normal file
View file

@ -0,0 +1,555 @@
(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 NOTINLINE is required to prevent compiler-macro expansion.
(declaim (inline copy-sequence sequence-of-length-p))
(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)
#-lispworks (inline length)
(optimize speed))
(etypecase sequence
(null
(zerop length))
(cons
(let ((n (1- length)))
(unless (minusp n)
(let ((tail (nthcdr n sequence)))
(and tail
(null (cdr tail)))))))
(vector
(= length (length sequence)))
(sequence
(= length (length sequence)))))
(defun rotate-tail-to-head (sequence n)
(declare (type (integer 1) n))
(if (listp sequence)
(let ((m (mod n (proper-list-length sequence))))
(if (null (cdr sequence))
sequence
(let* ((tail (last sequence (+ m 1)))
(last (cdr tail)))
(setf (cdr tail) nil)
(nconc last sequence))))
(let* ((len (length sequence))
(m (mod n len))
(tail (subseq sequence (- len m))))
(replace sequence sequence :start1 m :start2 0)
(replace sequence tail)
sequence)))
(defun rotate-head-to-tail (sequence n)
(declare (type (integer 1) n))
(if (listp sequence)
(let ((m (mod (1- n) (proper-list-length sequence))))
(if (null (cdr sequence))
sequence
(let* ((headtail (nthcdr m sequence))
(tail (cdr headtail)))
(setf (cdr headtail) nil)
(nconc tail sequence))))
(let* ((len (length sequence))
(m (mod n len))
(head (subseq sequence 0 m)))
(replace sequence sequence :start1 0 :start2 m)
(replace sequence head :start1 (- len m))
sequence)))
(defun rotate (sequence &optional (n 1))
"Returns a sequence of the same type as SEQUENCE, with the elements of
SEQUENCE rotated by N: N elements are moved from the end of the sequence to
the front if N is positive, and -N elements moved from the front to the end if
N is negative. SEQUENCE must be a proper sequence. N must be an integer,
defaulting to 1.
If absolute value of N is greater then the length of the sequence, the results
are identical to calling ROTATE with
(* (signum n) (mod n (length sequence))).
Note: the original sequence may be destructively altered, and result sequence may
share structure with it."
(if (plusp n)
(rotate-tail-to-head sequence n)
(if (minusp n)
(rotate-head-to-tail sequence (- n))
sequence)))
(defun shuffle (sequence &key (start 0) end)
"Returns a random permutation of SEQUENCE bounded by START and END.
Original sequence may be destructively modified, and (if it contains
CONS or lists themselv) share storage with the original one.
Signals an error if SEQUENCE is not a proper sequence."
(declare (type fixnum start)
(type (or fixnum null) end))
(etypecase sequence
(list
(let* ((end (or end (proper-list-length sequence)))
(n (- end start)))
(do ((tail (nthcdr start sequence) (cdr tail)))
((zerop n))
(rotatef (car tail) (car (nthcdr (random n) tail)))
(decf n))))
(vector
(let ((end (or end (length sequence))))
(loop for i from start below end
do (rotatef (aref sequence i)
(aref sequence (+ i (random (- end i))))))))
(sequence
(let ((end (or end (length sequence))))
(loop for i from (- end 1) downto start
do (rotatef (elt sequence i)
(elt sequence (+ i (random (- end i)))))))))
sequence)
(defun random-elt (sequence &key (start 0) end)
"Returns a random element from SEQUENCE bounded by START and END. Signals an
error if the SEQUENCE is not a proper non-empty sequence, or if END and START
are not proper bounding index designators for SEQUENCE."
(declare (sequence sequence) (fixnum start) (type (or fixnum null) end))
(let* ((size (if (listp sequence)
(proper-list-length sequence)
(length sequence)))
(end2 (or end size)))
(cond ((zerop size)
(error 'type-error
:datum sequence
:expected-type `(and sequence (not (satisfies emptyp)))))
((not (and (<= 0 start) (< start end2) (<= end2 size)))
(error 'simple-type-error
:datum (cons start end)
:expected-type `(cons (integer 0 (,end2))
(or null (integer (,start) ,size)))
:format-control "~@<~S and ~S are not valid bounding index designators for ~
a sequence of length ~S.~:@>"
:format-arguments (list start end size)))
(t
(let ((index (+ start (random (- end2 start)))))
(elt sequence index))))))
(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 keyword-arguments)
remove/swapped-arguments
"Modify-macro for REMOVE. Sets place designated by the first argument to
the result of calling REMOVE with ITEM, place, and the KEYWORD-ARGUMENTS.")
(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 keyword-arguments)
delete/swapped-arguments
"Modify-macro for DELETE. Sets place designated by the first argument to
the result of calling DELETE with ITEM, place, and the KEYWORD-ARGUMENTS.")
(deftype proper-sequence ()
"Type designator for proper sequences, that is proper lists and sequences
that are not lists."
`(or proper-list
(and (not list) sequence)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (and (find-package '#:sequence)
(find-symbol (string '#:emptyp) '#:sequence))
(pushnew 'sequence-emptyp *features*)))
#-alexandria::sequence-emptyp
(defun emptyp (sequence)
"Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
is not a sequence."
(etypecase sequence
(list (null sequence))
(sequence (zerop (length sequence)))))
#+alexandria::sequence-emptyp
(declaim (ftype (function (sequence) (values boolean &optional)) emptyp))
#+alexandria::sequence-emptyp
(setf (symbol-function 'emptyp) (symbol-function 'sequence:emptyp))
#+alexandria::sequence-emptyp
(define-compiler-macro emptyp (sequence)
`(sequence:emptyp ,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 copy-sequence (type sequence)
"Returns a fresh sequence of TYPE, which has the same elements as
SEQUENCE."
(if (typep sequence type)
(copy-seq sequence)
(coerce sequence type)))
(defun first-elt (sequence)
"Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is
not a sequence, or is an empty sequence."
;; Can't just directly use ELT, as it is not guaranteed to signal the
;; type-error.
(cond ((consp sequence)
(car sequence))
((and (typep sequence 'sequence) (not (emptyp sequence)))
(elt sequence 0))
(t
(error 'type-error
:datum sequence
:expected-type '(and sequence (not (satisfies emptyp)))))))
(defun (setf first-elt) (object sequence)
"Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE is
not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
;; Can't just directly use ELT, as it is not guaranteed to signal the
;; type-error.
(cond ((consp sequence)
(setf (car sequence) object))
((and (typep sequence 'sequence) (not (emptyp sequence)))
(setf (elt sequence 0) object))
(t
(error 'type-error
:datum sequence
:expected-type '(and sequence (not (satisfies emptyp)))))))
(defun last-elt (sequence)
"Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
not a proper sequence, or is an empty sequence."
;; Can't just directly use ELT, as it is not guaranteed to signal the
;; type-error.
(let ((len 0))
(cond ((consp sequence)
(lastcar sequence))
((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
(elt sequence (1- len)))
(t
(error 'type-error
:datum sequence
:expected-type '(and proper-sequence (not (satisfies emptyp))))))))
(defun (setf last-elt) (object sequence)
"Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper
sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
(let ((len 0))
(cond ((consp sequence)
(setf (lastcar sequence) object))
((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
(setf (elt sequence (1- len)) object))
(t
(error 'type-error
:datum sequence
:expected-type '(and proper-sequence (not (satisfies emptyp))))))))
(defun starts-with-subseq (prefix sequence &rest args
&key
(return-suffix nil return-suffix-supplied-p)
&allow-other-keys)
"Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
If RETURN-SUFFIX is T the function returns, as a second value, a
sub-sequence or displaced array pointing to the sequence after PREFIX."
(declare (dynamic-extent args))
(let ((sequence-length (length sequence))
(prefix-length (length prefix)))
(when (< sequence-length prefix-length)
(return-from starts-with-subseq (values nil nil)))
(flet ((make-suffix (start)
(when return-suffix
(cond
((not (arrayp sequence))
(if start
(subseq sequence start)
(subseq sequence 0 0)))
((not start)
(make-array 0
:element-type (array-element-type sequence)
:adjustable nil))
(t
(make-array (- sequence-length start)
:element-type (array-element-type sequence)
:displaced-to sequence
:displaced-index-offset start
:adjustable nil))))))
(let ((mismatch (apply #'mismatch prefix sequence
(if return-suffix-supplied-p
(remove-from-plist args :return-suffix)
args))))
(cond
((not mismatch)
(values t (make-suffix nil)))
((= mismatch prefix-length)
(values t (make-suffix mismatch)))
(t
(values nil nil)))))))
(defun ends-with-subseq (suffix sequence &key (test #'eql))
"Test whether SEQUENCE ends with SUFFIX. In other words: return true if
the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
(let ((sequence-length (length sequence))
(suffix-length (length suffix)))
(when (< sequence-length suffix-length)
;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX.
(return-from ends-with-subseq nil))
(loop for sequence-index from (- sequence-length suffix-length) below sequence-length
for suffix-index from 0 below suffix-length
when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index)))
do (return-from ends-with-subseq nil)
finally (return t))))
(defun starts-with (object sequence &key (test #'eql) (key #'identity))
"Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
(let ((first-elt (typecase sequence
(cons (car sequence))
(sequence
(if (emptyp sequence)
(return-from starts-with nil)
(elt sequence 0)))
(t
(return-from starts-with nil)))))
(funcall test (funcall key first-elt) object)))
(defun ends-with (object sequence &key (test #'eql) (key #'identity))
"Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
an error if SEQUENCE is an improper list."
(let ((last-elt (typecase sequence
(cons
(lastcar sequence)) ; signals for improper lists
(sequence
;; Can't use last-elt, as that signals an error
;; for empty sequences
(let ((len (length sequence)))
(if (plusp len)
(elt sequence (1- len))
(return-from ends-with nil))))
(t
(return-from ends-with nil)))))
(funcall test (funcall key last-elt) object)))
(defun map-combinations (function sequence &key (start 0) end length (copy t))
"Calls FUNCTION with each combination of LENGTH constructable from the
elements of the subsequence of SEQUENCE delimited by START and END. START
defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the
delimited subsequence. (So unless LENGTH is specified there is only a single
combination, which has the same elements as the delimited subsequence.) If
COPY is true (the default) each combination is freshly allocated. If COPY is
false all combinations are EQ to each other, in which case consequences are
unspecified if a combination is modified by FUNCTION."
(let* ((end (or end (length sequence)))
(size (- end start))
(length (or length size))
(combination (subseq sequence 0 length))
(function (ensure-function function)))
(if (= length size)
(funcall function combination)
(flet ((call ()
(funcall function (if copy
(copy-seq combination)
combination))))
(etypecase sequence
;; When dealing with lists we prefer walking back and
;; forth instead of using indexes.
(list
(labels ((combine-list (c-tail o-tail)
(if (not c-tail)
(call)
(do ((tail o-tail (cdr tail)))
((not tail))
(setf (car c-tail) (car tail))
(combine-list (cdr c-tail) (cdr tail))))))
(combine-list combination (nthcdr start sequence))))
(vector
(labels ((combine (count start)
(if (zerop count)
(call)
(loop for i from start below end
do (let ((j (- count 1)))
(setf (aref combination j) (aref sequence i))
(combine j (+ i 1)))))))
(combine length start)))
(sequence
(labels ((combine (count start)
(if (zerop count)
(call)
(loop for i from start below end
do (let ((j (- count 1)))
(setf (elt combination j) (elt sequence i))
(combine j (+ i 1)))))))
(combine length start)))))))
sequence)
(defun map-permutations (function sequence &key (start 0) end length (copy t))
"Calls function with each permutation of LENGTH constructable
from the subsequence of SEQUENCE delimited by START and END. START
defaults to 0, END to length of the sequence, and LENGTH to the
length of the delimited subsequence."
(let* ((end (or end (length sequence)))
(size (- end start))
(length (or length size)))
(labels ((permute (seq n)
(let ((n-1 (- n 1)))
(if (zerop n-1)
(funcall function (if copy
(copy-seq seq)
seq))
(loop for i from 0 upto n-1
do (permute seq n-1)
(if (evenp n-1)
(rotatef (elt seq 0) (elt seq n-1))
(rotatef (elt seq i) (elt seq n-1)))))))
(permute-sequence (seq)
(permute seq length)))
(if (= length size)
;; Things are simple if we need to just permute the
;; full START-END range.
(permute-sequence (subseq sequence start end))
;; Otherwise we need to generate all the combinations
;; of LENGTH in the START-END range, and then permute
;; a copy of the result: can't permute the combination
;; directly, as they share structure with each other.
(let ((permutation (subseq sequence 0 length)))
(flet ((permute-combination (combination)
(permute-sequence (replace permutation combination))))
(declare (dynamic-extent #'permute-combination))
(map-combinations #'permute-combination sequence
:start start
:end end
:length length
:copy nil)))))))
(defun map-derangements (function sequence &key (start 0) end (copy t))
"Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted
by the bounding index designators START and END. Derangement is a permutation
of the sequence where no element remains in place. SEQUENCE is not modified,
but individual derangements are EQ to each other. Consequences are unspecified
if calling FUNCTION modifies either the derangement or SEQUENCE."
(let* ((end (or end (length sequence)))
(size (- end start))
;; We don't really care about the elements here.
(derangement (subseq sequence 0 size))
;; Bitvector that has 1 for elements that have been deranged.
(mask (make-array size :element-type 'bit :initial-element 0)))
(declare (dynamic-extent mask))
;; ad hoc algorith
(labels ((derange (place n)
;; Perform one recursive step in deranging the
;; sequence: PLACE is index of the original sequence
;; to derange to another index, and N is the number of
;; indexes not yet deranged.
(if (zerop n)
(funcall function (if copy
(copy-seq derangement)
derangement))
;; Itarate over the indexes I of the subsequence to
;; derange: if I != PLACE and I has not yet been
;; deranged by an earlier call put the element from
;; PLACE to I, mark I as deranged, and recurse,
;; finally removing the mark.
(loop for i from 0 below size
do
(unless (or (= place (+ i start)) (not (zerop (bit mask i))))
(setf (elt derangement i) (elt sequence place)
(bit mask i) 1)
(derange (1+ place) (1- n))
(setf (bit mask i) 0))))))
(derange start size)
sequence)))
(declaim (notinline sequence-of-length-p))
(defun extremum (sequence predicate &key key (start 0) end)
"Returns the element of SEQUENCE that would appear first if the subsequence
bounded by START and END was sorted using PREDICATE and KEY.
EXTREMUM determines the relationship between two elements of SEQUENCE by using
the PREDICATE function. PREDICATE should return true if and only if the first
argument is strictly less than the second one (in some appropriate sense). Two
arguments X and Y are considered to be equal if (FUNCALL PREDICATE X Y)
and (FUNCALL PREDICATE Y X) are both false.
The arguments to the PREDICATE function are computed from elements of SEQUENCE
using the KEY function, if supplied. If KEY is not supplied or is NIL, the
sequence element itself is used.
If SEQUENCE is empty, NIL is returned."
(let* ((pred-fun (ensure-function predicate))
(key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity))
(ensure-function key)))
(real-end (or end (length sequence))))
(cond ((> real-end start)
(if key-fun
(flet ((reduce-keys (a b)
(if (funcall pred-fun
(funcall key-fun a)
(funcall key-fun b))
a
b)))
(declare (dynamic-extent #'reduce-keys))
(reduce #'reduce-keys sequence :start start :end real-end))
(flet ((reduce-elts (a b)
(if (funcall pred-fun a b)
a
b)))
(declare (dynamic-extent #'reduce-elts))
(reduce #'reduce-elts sequence :start start :end real-end))))
((= real-end start)
nil)
(t
(error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
(length sequence)
:start start
:end end)))))

6
strings.lisp Normal file
View file

@ -0,0 +1,6 @@
(in-package :alexandria)
(deftype string-designator ()
"A string designator type. A string designator is either a string, a symbol,
or a character."
`(or symbol string character))

65
symbols.lisp Normal file
View file

@ -0,0 +1,65 @@
(in-package :alexandria)
(declaim (inline ensure-symbol))
(defun ensure-symbol (name &optional (package *package*))
"Returns a symbol with name designated by NAME, accessible in package
designated by PACKAGE. If symbol is not already accessible in PACKAGE, it is
interned there. Returns a secondary value reflecting the status of the symbol
in the package, which matches the secondary return value of INTERN.
Example:
(ensure-symbol :cons :cl) => cl:cons, :external
"
(intern (string name) package))
(defun maybe-intern (name package)
(values
(if package
(intern name (if (eq t package) *package* package))
(make-symbol name))))
(declaim (inline format-symbol))
(defun format-symbol (package control &rest arguments)
"Constructs a string by applying ARGUMENTS to string designator CONTROL as
if by FORMAT within WITH-STANDARD-IO-SYNTAX, and then creates a symbol named
by that string.
If PACKAGE is NIL, returns an uninterned symbol, if package is T, returns a
symbol interned in the current package, and otherwise returns a symbol
interned in the package designated by PACKAGE."
(maybe-intern (with-standard-io-syntax
(apply #'format nil (string control) arguments))
package))
(defun make-keyword (name)
"Interns the string designated by NAME in the KEYWORD package."
(intern (string name) :keyword))
(defun make-gensym (name)
"If NAME is a non-negative integer, calls GENSYM using it. Otherwise NAME
must be a string designator, in which case calls GENSYM using the designated
string as the argument."
(gensym (if (typep name '(integer 0))
name
(string name))))
(defun make-gensym-list (length &optional (x "G"))
"Returns a list of LENGTH gensyms, each generated as if with a call to MAKE-GENSYM,
using the second (optional, defaulting to \"G\") argument."
(let ((g (if (typep x '(integer 0)) x (string x))))
(loop repeat length
collect (gensym g))))
(defun symbolicate (&rest things)
"Concatenate together the names of some strings and symbols,
producing a symbol in the current package."
(let* ((length (reduce #'+ things
:key (lambda (x) (length (string x)))))
(name (make-array length :element-type 'character)))
(let ((index 0))
(dolist (thing things (values (intern name)))
(let* ((x (string thing))
(len (length x)))
(replace name x :start1 index)
(incf index len))))))

2047
tests.lisp Normal file

File diff suppressed because it is too large Load diff

137
types.lisp Normal file
View file

@ -0,0 +1,137 @@
(in-package :alexandria)
(deftype array-index (&optional (length (1- array-dimension-limit)))
"Type designator for an index into array of LENGTH: an integer between
0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than
ARRAY-DIMENSION-LIMIT."
`(integer 0 (,length)))
(deftype array-length (&optional (length (1- array-dimension-limit)))
"Type designator for a dimension of an array of LENGTH: an integer between
0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than
ARRAY-DIMENSION-LIMIT."
`(integer 0 ,length))
;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/)
;; except the RATIO related definitions and ARRAY-INDEX.
(macrolet
((frob (type &optional (base-type type))
(let ((subtype-names (list))
(predicate-names (list)))
(flet ((make-subtype-name (format-control)
(let ((result (format-symbol :alexandria format-control
(symbol-name type))))
(push result subtype-names)
result))
(make-predicate-name (sybtype-name)
(let ((result (format-symbol :alexandria '#:~A-p
(symbol-name sybtype-name))))
(push result predicate-names)
result))
(make-docstring (range-beg range-end range-type)
(let ((inf (ecase range-type (:negative "-inf") (:positive "+inf"))))
(format nil "Type specifier denoting the ~(~A~) range from ~A to ~A."
type
(if (equal range-beg ''*) inf (ensure-car range-beg))
(if (equal range-end ''*) inf (ensure-car range-end))))))
(let* ((negative-name (make-subtype-name '#:negative-~a))
(non-positive-name (make-subtype-name '#:non-positive-~a))
(non-negative-name (make-subtype-name '#:non-negative-~a))
(positive-name (make-subtype-name '#:positive-~a))
(negative-p-name (make-predicate-name negative-name))
(non-positive-p-name (make-predicate-name non-positive-name))
(non-negative-p-name (make-predicate-name non-negative-name))
(positive-p-name (make-predicate-name positive-name))
(negative-extremum)
(positive-extremum)
(below-zero)
(above-zero)
(zero))
(setf (values negative-extremum below-zero
above-zero positive-extremum zero)
(ecase type
(fixnum (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0))
(integer (values ''* -1 1 ''* 0))
(rational (values ''* '(0) '(0) ''* 0))
(real (values ''* '(0) '(0) ''* 0))
(float (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0))
(short-float (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0))
(single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0))
(double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0))
(long-float (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0))))
`(progn
(deftype ,negative-name ()
,(make-docstring negative-extremum below-zero :negative)
`(,',base-type ,,negative-extremum ,',below-zero))
(deftype ,non-positive-name ()
,(make-docstring negative-extremum zero :negative)
`(,',base-type ,,negative-extremum ,',zero))
(deftype ,non-negative-name ()
,(make-docstring zero positive-extremum :positive)
`(,',base-type ,',zero ,,positive-extremum))
(deftype ,positive-name ()
,(make-docstring above-zero positive-extremum :positive)
`(,',base-type ,',above-zero ,,positive-extremum))
(declaim (inline ,@predicate-names))
(defun ,negative-p-name (n)
(and (typep n ',type)
(< n ,zero)))
(defun ,non-positive-p-name (n)
(and (typep n ',type)
(<= n ,zero)))
(defun ,non-negative-p-name (n)
(and (typep n ',type)
(<= ,zero n)))
(defun ,positive-p-name (n)
(and (typep n ',type)
(< ,zero n)))))))))
(frob fixnum integer)
(frob integer)
(frob rational)
(frob real)
(frob float)
(frob short-float)
(frob single-float)
(frob double-float)
(frob long-float))
(defun of-type (type)
"Returns a function of one argument, which returns true when its argument is
of TYPE."
(lambda (thing) (typep thing type)))
(define-compiler-macro of-type (&whole form type &environment env)
;; This can yeild a big benefit, but no point inlining the function
;; all over the place if TYPE is not constant.
(if (constantp type env)
(with-gensyms (thing)
`(lambda (,thing)
(typep ,thing ,type)))
form))
(declaim (inline type=))
(defun type= (type1 type2)
"Returns a primary value of T is TYPE1 and TYPE2 are the same type,
and a secondary value that is true is the type equality could be reliably
determined: primary value of NIL and secondary value of T indicates that the
types are not equivalent."
(multiple-value-bind (sub ok) (subtypep type1 type2)
(cond ((and ok sub)
(subtypep type2 type1))
(ok
(values nil ok))
(t
(multiple-value-bind (sub ok) (subtypep type2 type1)
(declare (ignore sub))
(values nil ok))))))
(define-modify-macro coercef (type-spec) coerce
"Modify-macro for COERCE.")