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:
commit
95aeb2ebae
29 changed files with 6252 additions and 0 deletions
13
.boring
Normal file
13
.boring
Normal 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
4
.gitignore
vendored
Normal file
|
@ -0,0 +1,4 @@
|
||||||
|
*.fasl
|
||||||
|
*~
|
||||||
|
\#*
|
||||||
|
*.patch
|
9
AUTHORS
Normal file
9
AUTHORS
Normal 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
37
LICENCE
Normal 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
52
README
Normal 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
11
alexandria-tests.asd
Normal 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
62
alexandria.asd
Normal 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
18
arrays.lisp
Normal 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
90
binding.lisp
Normal 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
91
conditions.lisp
Normal 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
106
control-flow.lisp
Normal 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
37
definitions.lisp
Normal 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
3
doc/.gitignore
vendored
Normal file
|
@ -0,0 +1,3 @@
|
||||||
|
alexandria
|
||||||
|
include
|
||||||
|
|
28
doc/Makefile
Normal file
28
doc/Makefile
Normal 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
277
doc/alexandria.texinfo
Normal 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
881
doc/docstrings.lisp
Normal 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
14
features.lisp
Normal 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
161
functions.lisp
Normal 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
101
hash-tables.lisp
Normal 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
172
io.lisp
Normal 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
367
lists.lisp
Normal 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
370
macros.lisp
Normal 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
295
numbers.lisp
Normal 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
243
package.lisp
Normal 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
555
sequences.lisp
Normal 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
6
strings.lisp
Normal 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
65
symbols.lisp
Normal 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
2047
tests.lisp
Normal file
File diff suppressed because it is too large
Load diff
137
types.lisp
Normal file
137
types.lisp
Normal 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.")
|
Loading…
Reference in a new issue