Squashed 'third_party/lisp/alexandria/' content from commit fc2a2f5c
git-subtree-dir: third_party/lisp/alexandria git-subtree-split: fc2a2f5c34147bb4e3e4a350b04220de0263710f
This commit is contained in:
Vincent Ambo
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