diff options
| author | Vincent Ambo <mail@tazj.in> | 2021-12-15T20·10+0300 |
|---|---|---|
| committer | clbot <clbot@tvl.fyi> | 2021-12-15T21·02+0000 |
| commit | 28ac55e94a4c71c1594d7ec51846315aed03e815 (patch) | |
| tree | 3cedf2ff4a608605163b848c727690a39821ee10 /third_party/lisp | |
| parent | 50b43cfb66a46fb5579e71d0e55174bb77fa2858 (diff) | |
chore(3p/lisp): Unvendor alexandria and use nixpkgs sources r/3254
Change-Id: Idee3cb18ac42bd820d87aac0c68206436c1f4691 Reviewed-on: https://cl.tvl.fyi/c/depot/+/4338 Autosubmit: tazjin <mail@tazj.in> Tested-by: BuildkiteCI Reviewed-by: grfn <grfn@gws.fyi>
Diffstat (limited to 'third_party/lisp')
31 files changed, 28 insertions, 6280 deletions
diff --git a/third_party/lisp/alexandria.nix b/third_party/lisp/alexandria.nix new file mode 100644 index 0000000000..b522e2d142 --- /dev/null +++ b/third_party/lisp/alexandria.nix @@ -0,0 +1,28 @@ +# Alexandria is one of the foundational Common Lisp libraries that +# pretty much everything depends on. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.alexandria; +in depot.nix.buildLisp.library { + name = "alexandria"; + + srcs = map (f: src + ("/alexandria-1/" + f)) [ + "package.lisp" + "definitions.lisp" + "binding.lisp" + "strings.lisp" + "conditions.lisp" + "symbols.lisp" + "macros.lisp" + "functions.lisp" + "io.lisp" + "hash-tables.lisp" + "control-flow.lisp" + "lists.lisp" + "types.lisp" + "arrays.lisp" + "sequences.lisp" + "numbers.lisp" + "features.lisp" + ]; +} diff --git a/third_party/lisp/alexandria/.boring b/third_party/lisp/alexandria/.boring deleted file mode 100644 index dfa9e6dd7b..0000000000 --- a/third_party/lisp/alexandria/.boring +++ /dev/null @@ -1,13 +0,0 @@ -# Boring file regexps: -~$ -^_darcs -^\{arch\} -^.arch-ids -\# -\.dfsl$ -\.ppcf$ -\.fasl$ -\.x86f$ -\.fas$ -\.lib$ -^public_html diff --git a/third_party/lisp/alexandria/.gitignore b/third_party/lisp/alexandria/.gitignore deleted file mode 100644 index e832e94718..0000000000 --- a/third_party/lisp/alexandria/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -*.fasl -*~ -\#* -*.patch diff --git a/third_party/lisp/alexandria/AUTHORS b/third_party/lisp/alexandria/AUTHORS deleted file mode 100644 index b550ea5032..0000000000 --- a/third_party/lisp/alexandria/AUTHORS +++ /dev/null @@ -1,9 +0,0 @@ - -ACTA EST FABULA PLAUDITE - -Nikodemus Siivola -Attila Lendvai -Marco Baringer -Robert Strandh -Luis Oliveira -Tobias C. Rittweiler \ No newline at end of file diff --git a/third_party/lisp/alexandria/LICENCE b/third_party/lisp/alexandria/LICENCE deleted file mode 100644 index b5140fbb24..0000000000 --- a/third_party/lisp/alexandria/LICENCE +++ /dev/null @@ -1,37 +0,0 @@ -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. diff --git a/third_party/lisp/alexandria/README b/third_party/lisp/alexandria/README deleted file mode 100644 index a5dae9ed1a..0000000000 --- a/third_party/lisp/alexandria/README +++ /dev/null @@ -1,52 +0,0 @@ -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. diff --git a/third_party/lisp/alexandria/alexandria-tests.asd b/third_party/lisp/alexandria/alexandria-tests.asd deleted file mode 100644 index 445c18cf7f..0000000000 --- a/third_party/lisp/alexandria/alexandria-tests.asd +++ /dev/null @@ -1,11 +0,0 @@ -(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)))) diff --git a/third_party/lisp/alexandria/alexandria.asd b/third_party/lisp/alexandria/alexandria.asd deleted file mode 100644 index db10e4f537..0000000000 --- a/third_party/lisp/alexandria/alexandria.asd +++ /dev/null @@ -1,62 +0,0 @@ -(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")))) diff --git a/third_party/lisp/alexandria/arrays.lisp b/third_party/lisp/alexandria/arrays.lisp deleted file mode 100644 index 76c18791ad..0000000000 --- a/third_party/lisp/alexandria/arrays.lisp +++ /dev/null @@ -1,18 +0,0 @@ -(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)) diff --git a/third_party/lisp/alexandria/binding.lisp b/third_party/lisp/alexandria/binding.lisp deleted file mode 100644 index 37a3d52fb9..0000000000 --- a/third_party/lisp/alexandria/binding.lisp +++ /dev/null @@ -1,90 +0,0 @@ -(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)))) diff --git a/third_party/lisp/alexandria/conditions.lisp b/third_party/lisp/alexandria/conditions.lisp deleted file mode 100644 index ac471cca7e..0000000000 --- a/third_party/lisp/alexandria/conditions.lisp +++ /dev/null @@ -1,91 +0,0 @@ -(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))))))))) \ No newline at end of file diff --git a/third_party/lisp/alexandria/control-flow.lisp b/third_party/lisp/alexandria/control-flow.lisp deleted file mode 100644 index dd00df3e16..0000000000 --- a/third_party/lisp/alexandria/control-flow.lisp +++ /dev/null @@ -1,106 +0,0 @@ -(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))) diff --git a/third_party/lisp/alexandria/default.nix b/third_party/lisp/alexandria/default.nix deleted file mode 100644 index 2358c898b3..0000000000 --- a/third_party/lisp/alexandria/default.nix +++ /dev/null @@ -1,28 +0,0 @@ -# Alexandria is one of the foundational Common Lisp libraries that -# pretty much everything depends on: -# -# Imported from https://common-lisp.net/project/alexandria/ -{ depot, ... }: - -depot.nix.buildLisp.library { - name = "alexandria"; - srcs = [ - ./package.lisp - ./definitions.lisp - ./binding.lisp - ./strings.lisp - ./conditions.lisp - ./symbols.lisp - ./macros.lisp - ./functions.lisp - ./io.lisp - ./hash-tables.lisp - ./control-flow.lisp - ./lists.lisp - ./types.lisp - ./arrays.lisp - ./sequences.lisp - ./numbers.lisp - ./features.lisp - ]; -} diff --git a/third_party/lisp/alexandria/definitions.lisp b/third_party/lisp/alexandria/definitions.lisp deleted file mode 100644 index 863e1f6962..0000000000 --- a/third_party/lisp/alexandria/definitions.lisp +++ /dev/null @@ -1,37 +0,0 @@ -(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)))) diff --git a/third_party/lisp/alexandria/doc/.gitignore b/third_party/lisp/alexandria/doc/.gitignore deleted file mode 100644 index f22577b3ac..0000000000 --- a/third_party/lisp/alexandria/doc/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -alexandria -include - diff --git a/third_party/lisp/alexandria/doc/Makefile b/third_party/lisp/alexandria/doc/Makefile deleted file mode 100644 index 85eb818220..0000000000 --- a/third_party/lisp/alexandria/doc/Makefile +++ /dev/null @@ -1,28 +0,0 @@ -.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 diff --git a/third_party/lisp/alexandria/doc/alexandria.texinfo b/third_party/lisp/alexandria/doc/alexandria.texinfo deleted file mode 100644 index 89b03ac349..0000000000 --- a/third_party/lisp/alexandria/doc/alexandria.texinfo +++ /dev/null @@ -1,277 +0,0 @@ -\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 diff --git a/third_party/lisp/alexandria/doc/docstrings.lisp b/third_party/lisp/alexandria/doc/docstrings.lisp deleted file mode 100644 index 51dda07d09..0000000000 --- a/third_party/lisp/alexandria/doc/docstrings.lisp +++ /dev/null @@ -1,881 +0,0 @@ -;;; -*- 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))) diff --git a/third_party/lisp/alexandria/features.lisp b/third_party/lisp/alexandria/features.lisp deleted file mode 100644 index 67348dbba4..0000000000 --- a/third_party/lisp/alexandria/features.lisp +++ /dev/null @@ -1,14 +0,0 @@ -(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)))))))) diff --git a/third_party/lisp/alexandria/functions.lisp b/third_party/lisp/alexandria/functions.lisp deleted file mode 100644 index dd83e38b4e..0000000000 --- a/third_party/lisp/alexandria/functions.lisp +++ /dev/null @@ -1,161 +0,0 @@ -(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)) diff --git a/third_party/lisp/alexandria/hash-tables.lisp b/third_party/lisp/alexandria/hash-tables.lisp deleted file mode 100644 index a9f7902204..0000000000 --- a/third_party/lisp/alexandria/hash-tables.lisp +++ /dev/null @@ -1,101 +0,0 @@ -(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)) diff --git a/third_party/lisp/alexandria/io.lisp b/third_party/lisp/alexandria/io.lisp deleted file mode 100644 index 28bf5e6d82..0000000000 --- a/third_party/lisp/alexandria/io.lisp +++ /dev/null @@ -1,172 +0,0 @@ -;; 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)) diff --git a/third_party/lisp/alexandria/lists.lisp b/third_party/lisp/alexandria/lists.lisp deleted file mode 100644 index 51286071eb..0000000000 --- a/third_party/lisp/alexandria/lists.lisp +++ /dev/null @@ -1,367 +0,0 @@ -(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))) diff --git a/third_party/lisp/alexandria/macros.lisp b/third_party/lisp/alexandria/macros.lisp deleted file mode 100644 index 4364ad63b8..0000000000 --- a/third_party/lisp/alexandria/macros.lisp +++ /dev/null @@ -1,370 +0,0 @@ -(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))) - - - diff --git a/third_party/lisp/alexandria/numbers.lisp b/third_party/lisp/alexandria/numbers.lisp deleted file mode 100644 index 1c06f71d50..0000000000 --- a/third_party/lisp/alexandria/numbers.lisp +++ /dev/null @@ -1,295 +0,0 @@ -(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)) diff --git a/third_party/lisp/alexandria/package.lisp b/third_party/lisp/alexandria/package.lisp deleted file mode 100644 index f9d2014cd7..0000000000 --- a/third_party/lisp/alexandria/package.lisp +++ /dev/null @@ -1,243 +0,0 @@ -(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 - )) diff --git a/third_party/lisp/alexandria/sequences.lisp b/third_party/lisp/alexandria/sequences.lisp deleted file mode 100644 index 21464f5376..0000000000 --- a/third_party/lisp/alexandria/sequences.lisp +++ /dev/null @@ -1,555 +0,0 @@ -(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))))) diff --git a/third_party/lisp/alexandria/strings.lisp b/third_party/lisp/alexandria/strings.lisp deleted file mode 100644 index e9fd91c961..0000000000 --- a/third_party/lisp/alexandria/strings.lisp +++ /dev/null @@ -1,6 +0,0 @@ -(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)) diff --git a/third_party/lisp/alexandria/symbols.lisp b/third_party/lisp/alexandria/symbols.lisp deleted file mode 100644 index 5733d3e1cc..0000000000 --- a/third_party/lisp/alexandria/symbols.lisp +++ /dev/null @@ -1,65 +0,0 @@ -(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)))))) diff --git a/third_party/lisp/alexandria/tests.lisp b/third_party/lisp/alexandria/tests.lisp deleted file mode 100644 index b70ef0475e..0000000000 --- a/third_party/lisp/alexandria/tests.lisp +++ /dev/null @@ -1,2047 +0,0 @@ -(in-package :cl-user) - -(defpackage :alexandria-tests - (:use :cl :alexandria #+sbcl :sb-rt #-sbcl :rtest) - (:import-from #+sbcl :sb-rt #-sbcl :rtest - #:*compile-tests* #:*expected-failures*)) - -(in-package :alexandria-tests) - -(defun run-tests (&key ((:compiled *compile-tests*))) - (do-tests)) - -(defun hash-table-test-name (name) - ;; Workaround for Clisp calling EQL in a hash-table FASTHASH-EQL. - (hash-table-test (make-hash-table :test name))) - -;;;; Arrays - -(deftest copy-array.1 - (let* ((orig (vector 1 2 3)) - (copy (copy-array orig))) - (values (eq orig copy) (equalp orig copy))) - nil t) - -(deftest copy-array.2 - (let ((orig (make-array 1024 :fill-pointer 0))) - (vector-push-extend 1 orig) - (vector-push-extend 2 orig) - (vector-push-extend 3 orig) - (let ((copy (copy-array orig))) - (values (eq orig copy) (equalp orig copy) - (array-has-fill-pointer-p copy) - (eql (fill-pointer orig) (fill-pointer copy))))) - nil t t t) - -(deftest copy-array.3 - (let* ((orig (vector 1 2 3)) - (copy (copy-array orig))) - (typep copy 'simple-array)) - t) - -(deftest copy-array.4 - (let ((orig (make-array 21 - :adjustable t - :fill-pointer 0))) - (dotimes (n 42) - (vector-push-extend n orig)) - (let ((copy (copy-array orig - :adjustable nil - :fill-pointer nil))) - (typep copy 'simple-array))) - t) - -(deftest array-index.1 - (typep 0 'array-index) - t) - -;;;; Conditions - -(deftest unwind-protect-case.1 - (let (result) - (unwind-protect-case () - (random 10) - (:normal (push :normal result)) - (:abort (push :abort result)) - (:always (push :always result))) - result) - (:always :normal)) - -(deftest unwind-protect-case.2 - (let (result) - (unwind-protect-case () - (random 10) - (:always (push :always result)) - (:normal (push :normal result)) - (:abort (push :abort result))) - result) - (:normal :always)) - -(deftest unwind-protect-case.3 - (let (result1 result2 result3) - (ignore-errors - (unwind-protect-case () - (error "FOOF!") - (:normal (push :normal result1)) - (:abort (push :abort result1)) - (:always (push :always result1)))) - (catch 'foof - (unwind-protect-case () - (throw 'foof 42) - (:normal (push :normal result2)) - (:abort (push :abort result2)) - (:always (push :always result2)))) - (block foof - (unwind-protect-case () - (return-from foof 42) - (:normal (push :normal result3)) - (:abort (push :abort result3)) - (:always (push :always result3)))) - (values result1 result2 result3)) - (:always :abort) - (:always :abort) - (:always :abort)) - -(deftest unwind-protect-case.4 - (let (result) - (unwind-protect-case (aborted-p) - (random 42) - (:always (setq result aborted-p))) - result) - nil) - -(deftest unwind-protect-case.5 - (let (result) - (block foof - (unwind-protect-case (aborted-p) - (return-from foof) - (:always (setq result aborted-p)))) - result) - t) - -;;;; Control flow - -(deftest switch.1 - (switch (13 :test =) - (12 :oops) - (13.0 :yay)) - :yay) - -(deftest switch.2 - (switch (13) - ((+ 12 2) :oops) - ((- 13 1) :oops2) - (t :yay)) - :yay) - -(deftest eswitch.1 - (let ((x 13)) - (eswitch (x :test =) - (12 :oops) - (13.0 :yay))) - :yay) - -(deftest eswitch.2 - (let ((x 13)) - (eswitch (x :key 1+) - (11 :oops) - (14 :yay))) - :yay) - -(deftest cswitch.1 - (cswitch (13 :test =) - (12 :oops) - (13.0 :yay)) - :yay) - -(deftest cswitch.2 - (cswitch (13 :key 1-) - (12 :yay) - (13.0 :oops)) - :yay) - -(deftest multiple-value-prog2.1 - (multiple-value-prog2 - (values 1 1 1) - (values 2 20 200) - (values 3 3 3)) - 2 20 200) - -(deftest nth-value-or.1 - (multiple-value-bind (a b c) - (nth-value-or 1 - (values 1 nil 1) - (values 2 2 2)) - (= a b c 2)) - t) - -(deftest whichever.1 - (let ((x (whichever 1 2 3))) - (and (member x '(1 2 3)) t)) - t) - -(deftest whichever.2 - (let* ((a 1) - (b 2) - (c 3) - (x (whichever a b c))) - (and (member x '(1 2 3)) t)) - t) - -(deftest xor.1 - (xor nil nil 1 nil) - 1 - t) - -(deftest xor.2 - (xor nil nil 1 2) - nil - nil) - -(deftest xor.3 - (xor nil nil nil) - nil - t) - -;;;; Definitions - -(deftest define-constant.1 - (let ((name (gensym))) - (eval `(define-constant ,name "FOO" :test 'equal)) - (eval `(define-constant ,name "FOO" :test 'equal)) - (values (equal "FOO" (symbol-value name)) - (constantp name))) - t - t) - -(deftest define-constant.2 - (let ((name (gensym))) - (eval `(define-constant ,name 13)) - (eval `(define-constant ,name 13)) - (values (eql 13 (symbol-value name)) - (constantp name))) - t - t) - -;;;; Errors - -;;; TYPEP is specified to return a generalized boolean and, for -;;; example, ECL exploits this by returning the superclasses of ERROR -;;; in this case. -(defun errorp (x) - (not (null (typep x 'error)))) - -(deftest required-argument.1 - (multiple-value-bind (res err) - (ignore-errors (required-argument)) - (errorp err)) - t) - -;;;; Hash tables - -(deftest ensure-gethash.1 - (let ((table (make-hash-table)) - (x (list 1))) - (multiple-value-bind (value already-there) - (ensure-gethash x table 42) - (and (= value 42) - (not already-there) - (= 42 (gethash x table)) - (multiple-value-bind (value2 already-there2) - (ensure-gethash x table 13) - (and (= value2 42) - already-there2 - (= 42 (gethash x table))))))) - t) - -(deftest ensure-gethash.2 - (let ((table (make-hash-table)) - (count 0)) - (multiple-value-call #'values - (ensure-gethash (progn (incf count) :foo) - (progn (incf count) table) - (progn (incf count) :bar)) - (gethash :foo table) - count)) - :bar nil :bar t 3) - -(deftest copy-hash-table.1 - (let ((orig (make-hash-table :test 'eq :size 123)) - (foo "foo")) - (setf (gethash orig orig) t - (gethash foo orig) t) - (let ((eq-copy (copy-hash-table orig)) - (eql-copy (copy-hash-table orig :test 'eql)) - (equal-copy (copy-hash-table orig :test 'equal)) - (equalp-copy (copy-hash-table orig :test 'equalp))) - (list (eql (hash-table-size eq-copy) (hash-table-size orig)) - (eql (hash-table-rehash-size eq-copy) - (hash-table-rehash-size orig)) - (hash-table-count eql-copy) - (gethash orig eq-copy) - (gethash (copy-seq foo) eql-copy) - (gethash foo eql-copy) - (gethash (copy-seq foo) equal-copy) - (gethash "FOO" equal-copy) - (gethash "FOO" equalp-copy)))) - (t t 2 t nil t t nil t)) - -(deftest copy-hash-table.2 - (let ((ht (make-hash-table)) - (list (list :list (vector :A :B :C)))) - (setf (gethash 'list ht) list) - (let* ((shallow-copy (copy-hash-table ht)) - (deep1-copy (copy-hash-table ht :key 'copy-list)) - (list (gethash 'list ht)) - (shallow-list (gethash 'list shallow-copy)) - (deep1-list (gethash 'list deep1-copy))) - (list (eq ht shallow-copy) - (eq ht deep1-copy) - (eq list shallow-list) - (eq list deep1-list) ; outer list was copied. - (eq (second list) (second shallow-list)) - (eq (second list) (second deep1-list)) ; inner vector wasn't copied. - ))) - (nil nil t nil t t)) - -(deftest maphash-keys.1 - (let ((keys nil) - (table (make-hash-table))) - (declare (notinline maphash-keys)) - (dotimes (i 10) - (setf (gethash i table) t)) - (maphash-keys (lambda (k) (push k keys)) table) - (set-equal keys '(0 1 2 3 4 5 6 7 8 9))) - t) - -(deftest maphash-values.1 - (let ((vals nil) - (table (make-hash-table))) - (declare (notinline maphash-values)) - (dotimes (i 10) - (setf (gethash i table) (- i))) - (maphash-values (lambda (v) (push v vals)) table) - (set-equal vals '(0 -1 -2 -3 -4 -5 -6 -7 -8 -9))) - t) - -(deftest hash-table-keys.1 - (let ((table (make-hash-table))) - (dotimes (i 10) - (setf (gethash i table) t)) - (set-equal (hash-table-keys table) '(0 1 2 3 4 5 6 7 8 9))) - t) - -(deftest hash-table-values.1 - (let ((table (make-hash-table))) - (dotimes (i 10) - (setf (gethash (gensym) table) i)) - (set-equal (hash-table-values table) '(0 1 2 3 4 5 6 7 8 9))) - t) - -(deftest hash-table-alist.1 - (let ((table (make-hash-table))) - (dotimes (i 10) - (setf (gethash i table) (- i))) - (let ((alist (hash-table-alist table))) - (list (length alist) - (assoc 0 alist) - (assoc 3 alist) - (assoc 9 alist) - (assoc nil alist)))) - (10 (0 . 0) (3 . -3) (9 . -9) nil)) - -(deftest hash-table-plist.1 - (let ((table (make-hash-table))) - (dotimes (i 10) - (setf (gethash i table) (- i))) - (let ((plist (hash-table-plist table))) - (list (length plist) - (getf plist 0) - (getf plist 2) - (getf plist 7) - (getf plist nil)))) - (20 0 -2 -7 nil)) - -(deftest alist-hash-table.1 - (let* ((alist '((0 a) (1 b) (2 c))) - (table (alist-hash-table alist))) - (list (hash-table-count table) - (gethash 0 table) - (gethash 1 table) - (gethash 2 table) - (eq (hash-table-test-name 'eql) - (hash-table-test table)))) - (3 (a) (b) (c) t)) - -(deftest alist-hash-table.duplicate-keys - (let* ((alist '((0 a) (1 b) (0 c) (1 d) (2 e))) - (table (alist-hash-table alist))) - (list (hash-table-count table) - (gethash 0 table) - (gethash 1 table) - (gethash 2 table))) - (3 (a) (b) (e))) - -(deftest plist-hash-table.1 - (let* ((plist '(:a 1 :b 2 :c 3)) - (table (plist-hash-table plist :test 'eq))) - (list (hash-table-count table) - (gethash :a table) - (gethash :b table) - (gethash :c table) - (gethash 2 table) - (gethash nil table) - (eq (hash-table-test-name 'eq) - (hash-table-test table)))) - (3 1 2 3 nil nil t)) - -(deftest plist-hash-table.duplicate-keys - (let* ((plist '(:a 1 :b 2 :a 3 :b 4 :c 5)) - (table (plist-hash-table plist))) - (list (hash-table-count table) - (gethash :a table) - (gethash :b table) - (gethash :c table))) - (3 1 2 5)) - -;;;; Functions - -(deftest disjoin.1 - (let ((disjunction (disjoin (lambda (x) - (and (consp x) :cons)) - (lambda (x) - (and (stringp x) :string))))) - (list (funcall disjunction 'zot) - (funcall disjunction '(foo bar)) - (funcall disjunction "test"))) - (nil :cons :string)) - -(deftest disjoin.2 - (let ((disjunction (disjoin #'zerop))) - (list (funcall disjunction 0) - (funcall disjunction 1))) - (t nil)) - -(deftest conjoin.1 - (let ((conjunction (conjoin #'consp - (lambda (x) - (stringp (car x))) - (lambda (x) - (char (car x) 0))))) - (list (funcall conjunction 'zot) - (funcall conjunction '(foo)) - (funcall conjunction '("foo")))) - (nil nil #\f)) - -(deftest conjoin.2 - (let ((conjunction (conjoin #'zerop))) - (list (funcall conjunction 0) - (funcall conjunction 1))) - (t nil)) - -(deftest compose.1 - (let ((composite (compose '1+ - (lambda (x) - (* x 2)) - #'read-from-string))) - (funcall composite "1")) - 3) - -(deftest compose.2 - (let ((composite - (locally (declare (notinline compose)) - (compose '1+ - (lambda (x) - (* x 2)) - #'read-from-string)))) - (funcall composite "2")) - 5) - -(deftest compose.3 - (let ((compose-form (funcall (compiler-macro-function 'compose) - '(compose '1+ - (lambda (x) - (* x 2)) - #'read-from-string) - nil))) - (let ((fun (funcall (compile nil `(lambda () ,compose-form))))) - (funcall fun "3"))) - 7) - -(deftest compose.4 - (let ((composite (compose #'zerop))) - (list (funcall composite 0) - (funcall composite 1))) - (t nil)) - -(deftest multiple-value-compose.1 - (let ((composite (multiple-value-compose - #'truncate - (lambda (x y) - (values y x)) - (lambda (x) - (with-input-from-string (s x) - (values (read s) (read s))))))) - (multiple-value-list (funcall composite "2 7"))) - (3 1)) - -(deftest multiple-value-compose.2 - (let ((composite (locally (declare (notinline multiple-value-compose)) - (multiple-value-compose - #'truncate - (lambda (x y) - (values y x)) - (lambda (x) - (with-input-from-string (s x) - (values (read s) (read s)))))))) - (multiple-value-list (funcall composite "2 11"))) - (5 1)) - -(deftest multiple-value-compose.3 - (let ((compose-form (funcall (compiler-macro-function 'multiple-value-compose) - '(multiple-value-compose - #'truncate - (lambda (x y) - (values y x)) - (lambda (x) - (with-input-from-string (s x) - (values (read s) (read s))))) - nil))) - (let ((fun (funcall (compile nil `(lambda () ,compose-form))))) - (multiple-value-list (funcall fun "2 9")))) - (4 1)) - -(deftest multiple-value-compose.4 - (let ((composite (multiple-value-compose #'truncate))) - (multiple-value-list (funcall composite 9 2))) - (4 1)) - -(deftest curry.1 - (let ((curried (curry '+ 3))) - (funcall curried 1 5)) - 9) - -(deftest curry.2 - (let ((curried (locally (declare (notinline curry)) - (curry '* 2 3)))) - (funcall curried 7)) - 42) - -(deftest curry.3 - (let ((curried-form (funcall (compiler-macro-function 'curry) - '(curry '/ 8) - nil))) - (let ((fun (funcall (compile nil `(lambda () ,curried-form))))) - (funcall fun 2))) - 4) - -(deftest curry.4 - (let* ((x 1) - (curried (curry (progn - (incf x) - (lambda (y z) (* x y z))) - 3))) - (list (funcall curried 7) - (funcall curried 7) - x)) - (42 42 2)) - -(deftest rcurry.1 - (let ((r (rcurry '/ 2))) - (funcall r 8)) - 4) - -(deftest rcurry.2 - (let* ((x 1) - (curried (rcurry (progn - (incf x) - (lambda (y z) (* x y z))) - 3))) - (list (funcall curried 7) - (funcall curried 7) - x)) - (42 42 2)) - -(deftest named-lambda.1 - (let ((fac (named-lambda fac (x) - (if (> x 1) - (* x (fac (- x 1))) - x)))) - (funcall fac 5)) - 120) - -(deftest named-lambda.2 - (let ((fac (named-lambda fac (&key x) - (if (> x 1) - (* x (fac :x (- x 1))) - x)))) - (funcall fac :x 5)) - 120) - -;;;; Lists - -(deftest alist-plist.1 - (alist-plist '((a . 1) (b . 2) (c . 3))) - (a 1 b 2 c 3)) - -(deftest plist-alist.1 - (plist-alist '(a 1 b 2 c 3)) - ((a . 1) (b . 2) (c . 3))) - -(deftest unionf.1 - (let* ((list (list 1 2 3)) - (orig list)) - (unionf list (list 1 2 4)) - (values (equal orig (list 1 2 3)) - (eql (length list) 4) - (set-difference list (list 1 2 3 4)) - (set-difference (list 1 2 3 4) list))) - t - t - nil - nil) - -(deftest nunionf.1 - (let ((list (list 1 2 3))) - (nunionf list (list 1 2 4)) - (values (eql (length list) 4) - (set-difference (list 1 2 3 4) list) - (set-difference list (list 1 2 3 4)))) - t - nil - nil) - -(deftest appendf.1 - (let* ((list (list 1 2 3)) - (orig list)) - (appendf list '(4 5 6) '(7 8)) - (list list (eq list orig))) - ((1 2 3 4 5 6 7 8) nil)) - -(deftest nconcf.1 - (let ((list1 (list 1 2 3)) - (list2 (list 4 5 6))) - (nconcf list1 list2 (list 7 8 9)) - list1) - (1 2 3 4 5 6 7 8 9)) - -(deftest circular-list.1 - (let ((circle (circular-list 1 2 3))) - (list (first circle) - (second circle) - (third circle) - (fourth circle) - (eq circle (nthcdr 3 circle)))) - (1 2 3 1 t)) - -(deftest circular-list-p.1 - (let* ((circle (circular-list 1 2 3 4)) - (tree (list circle circle)) - (dotted (cons circle t)) - (proper (list 1 2 3 circle)) - (tailcirc (list* 1 2 3 circle))) - (list (circular-list-p circle) - (circular-list-p tree) - (circular-list-p dotted) - (circular-list-p proper) - (circular-list-p tailcirc))) - (t nil nil nil t)) - -(deftest circular-list-p.2 - (circular-list-p 'foo) - nil) - -(deftest circular-tree-p.1 - (let* ((circle (circular-list 1 2 3 4)) - (tree1 (list circle circle)) - (tree2 (let* ((level2 (list 1 nil 2)) - (level1 (list level2))) - (setf (second level2) level1) - level1)) - (dotted (cons circle t)) - (proper (list 1 2 3 circle)) - (tailcirc (list* 1 2 3 circle)) - (quite-proper (list 1 2 3)) - (quite-dotted (list 1 (cons 2 3)))) - (list (circular-tree-p circle) - (circular-tree-p tree1) - (circular-tree-p tree2) - (circular-tree-p dotted) - (circular-tree-p proper) - (circular-tree-p tailcirc) - (circular-tree-p quite-proper) - (circular-tree-p quite-dotted))) - (t t t t t t nil nil)) - -(deftest circular-tree-p.2 - (alexandria:circular-tree-p '#1=(#1#)) - t) - -(deftest proper-list-p.1 - (let ((l1 (list 1)) - (l2 (list 1 2)) - (l3 (cons 1 2)) - (l4 (list (cons 1 2) 3)) - (l5 (circular-list 1 2))) - (list (proper-list-p l1) - (proper-list-p l2) - (proper-list-p l3) - (proper-list-p l4) - (proper-list-p l5))) - (t t nil t nil)) - -(deftest proper-list-p.2 - (proper-list-p '(1 2 . 3)) - nil) - -(deftest proper-list.type.1 - (let ((l1 (list 1)) - (l2 (list 1 2)) - (l3 (cons 1 2)) - (l4 (list (cons 1 2) 3)) - (l5 (circular-list 1 2))) - (list (typep l1 'proper-list) - (typep l2 'proper-list) - (typep l3 'proper-list) - (typep l4 'proper-list) - (typep l5 'proper-list))) - (t t nil t nil)) - -(deftest proper-list-length.1 - (values - (proper-list-length nil) - (proper-list-length (list 1)) - (proper-list-length (list 2 2)) - (proper-list-length (list 3 3 3)) - (proper-list-length (list 4 4 4 4)) - (proper-list-length (list 5 5 5 5 5)) - (proper-list-length (list 6 6 6 6 6 6)) - (proper-list-length (list 7 7 7 7 7 7 7)) - (proper-list-length (list 8 8 8 8 8 8 8 8)) - (proper-list-length (list 9 9 9 9 9 9 9 9 9))) - 0 1 2 3 4 5 6 7 8 9) - -(deftest proper-list-length.2 - (flet ((plength (x) - (handler-case - (proper-list-length x) - (type-error () - :ok)))) - (values - (plength (list* 1)) - (plength (list* 2 2)) - (plength (list* 3 3 3)) - (plength (list* 4 4 4 4)) - (plength (list* 5 5 5 5 5)) - (plength (list* 6 6 6 6 6 6)) - (plength (list* 7 7 7 7 7 7 7)) - (plength (list* 8 8 8 8 8 8 8 8)) - (plength (list* 9 9 9 9 9 9 9 9 9)))) - :ok :ok :ok - :ok :ok :ok - :ok :ok :ok) - -(deftest lastcar.1 - (let ((l1 (list 1)) - (l2 (list 1 2))) - (list (lastcar l1) - (lastcar l2))) - (1 2)) - -(deftest lastcar.error.2 - (handler-case - (progn - (lastcar (circular-list 1 2 3)) - nil) - (error () - t)) - t) - -(deftest setf-lastcar.1 - (let ((l (list 1 2 3 4))) - (values (lastcar l) - (progn - (setf (lastcar l) 42) - (lastcar l)))) - 4 - 42) - -(deftest setf-lastcar.2 - (let ((l (circular-list 1 2 3))) - (multiple-value-bind (res err) - (ignore-errors (setf (lastcar l) 4)) - (typep err 'type-error))) - t) - -(deftest make-circular-list.1 - (let ((l (make-circular-list 3 :initial-element :x))) - (setf (car l) :y) - (list (eq l (nthcdr 3 l)) - (first l) - (second l) - (third l) - (fourth l))) - (t :y :x :x :y)) - -(deftest circular-list.type.1 - (let* ((l1 (list 1 2 3)) - (l2 (circular-list 1 2 3)) - (l3 (list* 1 2 3 l2))) - (list (typep l1 'circular-list) - (typep l2 'circular-list) - (typep l3 'circular-list))) - (nil t t)) - -(deftest ensure-list.1 - (let ((x (list 1)) - (y 2)) - (list (ensure-list x) - (ensure-list y))) - ((1) (2))) - -(deftest ensure-cons.1 - (let ((x (cons 1 2)) - (y nil) - (z "foo")) - (values (ensure-cons x) - (ensure-cons y) - (ensure-cons z))) - (1 . 2) - (nil) - ("foo")) - -(deftest setp.1 - (setp '(1)) - t) - -(deftest setp.2 - (setp nil) - t) - -(deftest setp.3 - (setp "foo") - nil) - -(deftest setp.4 - (setp '(1 2 3 1)) - nil) - -(deftest setp.5 - (setp '(1 2 3)) - t) - -(deftest setp.6 - (setp '(a :a)) - t) - -(deftest setp.7 - (setp '(a :a) :key 'character) - nil) - -(deftest setp.8 - (setp '(a :a) :key 'character :test (constantly nil)) - t) - -(deftest set-equal.1 - (set-equal '(1 2 3) '(3 1 2)) - t) - -(deftest set-equal.2 - (set-equal '("Xa") '("Xb") - :test (lambda (a b) (eql (char a 0) (char b 0)))) - t) - -(deftest set-equal.3 - (set-equal '(1 2) '(4 2)) - nil) - -(deftest set-equal.4 - (set-equal '(a b c) '(:a :b :c) :key 'string :test 'equal) - t) - -(deftest set-equal.5 - (set-equal '(a d c) '(:a :b :c) :key 'string :test 'equal) - nil) - -(deftest set-equal.6 - (set-equal '(a b c) '(a b c d)) - nil) - -(deftest map-product.1 - (map-product 'cons '(2 3) '(1 4)) - ((2 . 1) (2 . 4) (3 . 1) (3 . 4))) - -(deftest map-product.2 - (map-product #'cons '(2 3) '(1 4)) - ((2 . 1) (2 . 4) (3 . 1) (3 . 4))) - -(deftest flatten.1 - (flatten '((1) 2 (((3 4))) ((((5)) 6)) 7)) - (1 2 3 4 5 6 7)) - -(deftest remove-from-plist.1 - (let ((orig '(a 1 b 2 c 3 d 4))) - (list (remove-from-plist orig 'a 'c) - (remove-from-plist orig 'b 'd) - (remove-from-plist orig 'b) - (remove-from-plist orig 'a) - (remove-from-plist orig 'd 42 "zot") - (remove-from-plist orig 'a 'b 'c 'd) - (remove-from-plist orig 'a 'b 'c 'd 'x) - (equal orig '(a 1 b 2 c 3 d 4)))) - ((b 2 d 4) - (a 1 c 3) - (a 1 c 3 d 4) - (b 2 c 3 d 4) - (a 1 b 2 c 3) - nil - nil - t)) - -(deftest delete-from-plist.1 - (let ((orig '(a 1 b 2 c 3 d 4 d 5))) - (list (delete-from-plist (copy-list orig) 'a 'c) - (delete-from-plist (copy-list orig) 'b 'd) - (delete-from-plist (copy-list orig) 'b) - (delete-from-plist (copy-list orig) 'a) - (delete-from-plist (copy-list orig) 'd 42 "zot") - (delete-from-plist (copy-list orig) 'a 'b 'c 'd) - (delete-from-plist (copy-list orig) 'a 'b 'c 'd 'x) - (equal orig (delete-from-plist orig)) - (eq orig (delete-from-plist orig)))) - ((b 2 d 4 d 5) - (a 1 c 3) - (a 1 c 3 d 4 d 5) - (b 2 c 3 d 4 d 5) - (a 1 b 2 c 3) - nil - nil - t - t)) - -(deftest mappend.1 - (mappend (compose 'list '*) '(1 2 3) '(1 2 3)) - (1 4 9)) - -(deftest assoc-value.1 - (let ((key1 '(complex key)) - (key2 'simple-key) - (alist '()) - (result '())) - (push 1 (assoc-value alist key1 :test #'equal)) - (push 2 (assoc-value alist key1 :test 'equal)) - (push 42 (assoc-value alist key2)) - (push 43 (assoc-value alist key2 :test 'eq)) - (push (assoc-value alist key1 :test #'equal) result) - (push (assoc-value alist key2) result) - - (push 'very (rassoc-value alist (list 2 1) :test #'equal)) - (push (cdr (assoc '(very complex key) alist :test #'equal)) result) - result) - ((2 1) (43 42) (2 1))) - -;;;; Numbers - -(deftest clamp.1 - (list (clamp 1.5 1 2) - (clamp 2.0 1 2) - (clamp 1.0 1 2) - (clamp 3 1 2) - (clamp 0 1 2)) - (1.5 2.0 1.0 2 1)) - -(deftest gaussian-random.1 - (let ((min -0.2) - (max +0.2)) - (multiple-value-bind (g1 g2) - (gaussian-random min max) - (values (<= min g1 max) - (<= min g2 max) - (/= g1 g2) ;uh - ))) - t - t - t) - -#+sbcl -(deftest gaussian-random.2 - (handler-case - (sb-ext:with-timeout 2 - (progn - (loop - :repeat 10000 - :do (gaussian-random 0 nil)) - 'done)) - (sb-ext:timeout () - 'timed-out)) - done) - -(deftest iota.1 - (iota 3) - (0 1 2)) - -(deftest iota.2 - (iota 3 :start 0.0d0) - (0.0d0 1.0d0 2.0d0)) - -(deftest iota.3 - (iota 3 :start 2 :step 3.0) - (2.0 5.0 8.0)) - -(deftest map-iota.1 - (let (all) - (declare (notinline map-iota)) - (values (map-iota (lambda (x) (push x all)) - 3 - :start 2 - :step 1.1d0) - all)) - 3 - (4.2d0 3.1d0 2.0d0)) - -(deftest lerp.1 - (lerp 0.5 1 2) - 1.5) - -(deftest lerp.2 - (lerp 0.1 1 2) - 1.1) - -(deftest lerp.3 - (lerp 0.1 4 25) - 6.1) - -(deftest mean.1 - (mean '(1 2 3)) - 2) - -(deftest mean.2 - (mean '(1 2 3 4)) - 5/2) - -(deftest mean.3 - (mean '(1 2 10)) - 13/3) - -(deftest median.1 - (median '(100 0 99 1 98 2 97)) - 97) - -(deftest median.2 - (median '(100 0 99 1 98 2 97 96)) - 193/2) - -(deftest variance.1 - (variance (list 1 2 3)) - 2/3) - -(deftest standard-deviation.1 - (< 0 (standard-deviation (list 1 2 3)) 1) - t) - -(deftest maxf.1 - (let ((x 1)) - (maxf x 2) - x) - 2) - -(deftest maxf.2 - (let ((x 1)) - (maxf x 0) - x) - 1) - -(deftest maxf.3 - (let ((x 1) - (c 0)) - (maxf x (incf c)) - (list x c)) - (1 1)) - -(deftest maxf.4 - (let ((xv (vector 0 0 0)) - (p 0)) - (maxf (svref xv (incf p)) (incf p)) - (list p xv)) - (2 #(0 2 0))) - -(deftest minf.1 - (let ((y 1)) - (minf y 0) - y) - 0) - -(deftest minf.2 - (let ((xv (vector 10 10 10)) - (p 0)) - (minf (svref xv (incf p)) (incf p)) - (list p xv)) - (2 #(10 2 10))) - -(deftest subfactorial.1 - (mapcar #'subfactorial (iota 22)) - (1 - 0 - 1 - 2 - 9 - 44 - 265 - 1854 - 14833 - 133496 - 1334961 - 14684570 - 176214841 - 2290792932 - 32071101049 - 481066515734 - 7697064251745 - 130850092279664 - 2355301661033953 - 44750731559645106 - 895014631192902121 - 18795307255050944540)) - -;;;; Arrays - -#+nil -(deftest array-index.type) - -#+nil -(deftest copy-array) - -;;;; Sequences - -(deftest rotate.1 - (list (rotate (list 1 2 3) 0) - (rotate (list 1 2 3) 1) - (rotate (list 1 2 3) 2) - (rotate (list 1 2 3) 3) - (rotate (list 1 2 3) 4)) - ((1 2 3) - (3 1 2) - (2 3 1) - (1 2 3) - (3 1 2))) - -(deftest rotate.2 - (list (rotate (vector 1 2 3 4) 0) - (rotate (vector 1 2 3 4)) - (rotate (vector 1 2 3 4) 2) - (rotate (vector 1 2 3 4) 3) - (rotate (vector 1 2 3 4) 4) - (rotate (vector 1 2 3 4) 5)) - (#(1 2 3 4) - #(4 1 2 3) - #(3 4 1 2) - #(2 3 4 1) - #(1 2 3 4) - #(4 1 2 3))) - -(deftest rotate.3 - (list (rotate (list 1 2 3) 0) - (rotate (list 1 2 3) -1) - (rotate (list 1 2 3) -2) - (rotate (list 1 2 3) -3) - (rotate (list 1 2 3) -4)) - ((1 2 3) - (2 3 1) - (3 1 2) - (1 2 3) - (2 3 1))) - -(deftest rotate.4 - (list (rotate (vector 1 2 3 4) 0) - (rotate (vector 1 2 3 4) -1) - (rotate (vector 1 2 3 4) -2) - (rotate (vector 1 2 3 4) -3) - (rotate (vector 1 2 3 4) -4) - (rotate (vector 1 2 3 4) -5)) - (#(1 2 3 4) - #(2 3 4 1) - #(3 4 1 2) - #(4 1 2 3) - #(1 2 3 4) - #(2 3 4 1))) - -(deftest rotate.5 - (values (rotate (list 1) 17) - (rotate (list 1) -5)) - (1) - (1)) - -(deftest shuffle.1 - (let ((s (shuffle (iota 100)))) - (list (equal s (iota 100)) - (every (lambda (x) - (member x s)) - (iota 100)) - (every (lambda (x) - (typep x '(integer 0 99))) - s))) - (nil t t)) - -(deftest shuffle.2 - (let ((s (shuffle (coerce (iota 100) 'vector)))) - (list (equal s (coerce (iota 100) 'vector)) - (every (lambda (x) - (find x s)) - (iota 100)) - (every (lambda (x) - (typep x '(integer 0 99))) - s))) - (nil t t)) - -(deftest shuffle.3 - (let* ((orig (coerce (iota 21) 'vector)) - (copy (copy-seq orig))) - (shuffle copy :start 10 :end 15) - (list (every #'eql (subseq copy 0 10) (subseq orig 0 10)) - (every #'eql (subseq copy 15) (subseq orig 15)))) - (t t)) - -(deftest random-elt.1 - (let ((s1 #(1 2 3 4)) - (s2 '(1 2 3 4))) - (list (dotimes (i 1000 nil) - (unless (member (random-elt s1) s2) - (return nil)) - (when (/= (random-elt s1) (random-elt s1)) - (return t))) - (dotimes (i 1000 nil) - (unless (member (random-elt s2) s2) - (return nil)) - (when (/= (random-elt s2) (random-elt s2)) - (return t))))) - (t t)) - -(deftest removef.1 - (let* ((x '(1 2 3)) - (x* x) - (y #(1 2 3)) - (y* y)) - (removef x 1) - (removef y 3) - (list x x* y y*)) - ((2 3) - (1 2 3) - #(1 2) - #(1 2 3))) - -(deftest deletef.1 - (let* ((x (list 1 2 3)) - (x* x) - (y (vector 1 2 3))) - (deletef x 2) - (deletef y 1) - (list x x* y)) - ((1 3) - (1 3) - #(2 3))) - -(deftest map-permutations.1 - (let ((seq (list 1 2 3)) - (seen nil) - (ok t)) - (map-permutations (lambda (s) - (unless (set-equal s seq) - (setf ok nil)) - (when (member s seen :test 'equal) - (setf ok nil)) - (push s seen)) - seq - :copy t) - (values ok (length seen))) - t - 6) - -(deftest proper-sequence.type.1 - (mapcar (lambda (x) - (typep x 'proper-sequence)) - (list (list 1 2 3) - (vector 1 2 3) - #2a((1 2) (3 4)) - (circular-list 1 2 3 4))) - (t t nil nil)) - -(deftest emptyp.1 - (mapcar #'emptyp - (list (list 1) - (circular-list 1) - nil - (vector) - (vector 1))) - (nil nil t t nil)) - -(deftest sequence-of-length-p.1 - (mapcar #'sequence-of-length-p - (list nil - #() - (list 1) - (vector 1) - (list 1 2) - (vector 1 2) - (list 1 2) - (vector 1 2) - (list 1 2) - (vector 1 2)) - (list 0 - 0 - 1 - 1 - 2 - 2 - 1 - 1 - 4 - 4)) - (t t t t t t nil nil nil nil)) - -(deftest length=.1 - (mapcar #'length= - (list nil - #() - (list 1) - (vector 1) - (list 1 2) - (vector 1 2) - (list 1 2) - (vector 1 2) - (list 1 2) - (vector 1 2)) - (list 0 - 0 - 1 - 1 - 2 - 2 - 1 - 1 - 4 - 4)) - (t t t t t t nil nil nil nil)) - -(deftest length=.2 - ;; test the compiler macro - (macrolet ((x (&rest args) - (funcall - (compile nil - `(lambda () - (length= ,@args)))))) - (list (x 2 '(1 2)) - (x '(1 2) '(3 4)) - (x '(1 2) 2) - (x '(1 2) 2 '(3 4)) - (x 1 2 3))) - (t t t t nil)) - -(deftest copy-sequence.1 - (let ((l (list 1 2 3)) - (v (vector #\a #\b #\c))) - (declare (notinline copy-sequence)) - (let ((l.list (copy-sequence 'list l)) - (l.vector (copy-sequence 'vector l)) - (l.spec-v (copy-sequence '(vector fixnum) l)) - (v.vector (copy-sequence 'vector v)) - (v.list (copy-sequence 'list v)) - (v.string (copy-sequence 'string v))) - (list (member l (list l.list l.vector l.spec-v)) - (member v (list v.vector v.list v.string)) - (equal l.list l) - (equalp l.vector #(1 2 3)) - (type= (upgraded-array-element-type 'fixnum) - (array-element-type l.spec-v)) - (equalp v.vector v) - (equal v.list '(#\a #\b #\c)) - (equal "abc" v.string)))) - (nil nil t t t t t t)) - -(deftest first-elt.1 - (mapcar #'first-elt - (list (list 1 2 3) - "abc" - (vector :a :b :c))) - (1 #\a :a)) - -(deftest first-elt.error.1 - (mapcar (lambda (x) - (handler-case - (first-elt x) - (type-error () - :type-error))) - (list nil - #() - 12 - :zot)) - (:type-error - :type-error - :type-error - :type-error)) - -(deftest setf-first-elt.1 - (let ((l (list 1 2 3)) - (s (copy-seq "foobar")) - (v (vector :a :b :c))) - (setf (first-elt l) -1 - (first-elt s) #\x - (first-elt v) 'zot) - (values l s v)) - (-1 2 3) - "xoobar" - #(zot :b :c)) - -(deftest setf-first-elt.error.1 - (let ((l 'foo)) - (multiple-value-bind (res err) - (ignore-errors (setf (first-elt l) 4)) - (typep err 'type-error))) - t) - -(deftest last-elt.1 - (mapcar #'last-elt - (list (list 1 2 3) - (vector :a :b :c) - "FOOBAR" - #*001 - #*010)) - (3 :c #\R 1 0)) - -(deftest last-elt.error.1 - (mapcar (lambda (x) - (handler-case - (last-elt x) - (type-error () - :type-error))) - (list nil - #() - 12 - :zot - (circular-list 1 2 3) - (list* 1 2 3 (circular-list 4 5)))) - (:type-error - :type-error - :type-error - :type-error - :type-error - :type-error)) - -(deftest setf-last-elt.1 - (let ((l (list 1 2 3)) - (s (copy-seq "foobar")) - (b (copy-seq #*010101001))) - (setf (last-elt l) '??? - (last-elt s) #\? - (last-elt b) 0) - (values l s b)) - (1 2 ???) - "fooba?" - #*010101000) - -(deftest setf-last-elt.error.1 - (handler-case - (setf (last-elt 'foo) 13) - (type-error () - :type-error)) - :type-error) - -(deftest starts-with.1 - (list (starts-with 1 '(1 2 3)) - (starts-with 1 #(1 2 3)) - (starts-with #\x "xyz") - (starts-with 2 '(1 2 3)) - (starts-with 3 #(1 2 3)) - (starts-with 1 1) - (starts-with nil nil)) - (t t t nil nil nil nil)) - -(deftest starts-with.2 - (values (starts-with 1 '(-1 2 3) :key '-) - (starts-with "foo" '("foo" "bar") :test 'equal) - (starts-with "f" '(#\f) :key 'string :test 'equal) - (starts-with -1 '(0 1 2) :key #'1+) - (starts-with "zot" '("ZOT") :test 'equal)) - t - t - t - nil - nil) - -(deftest ends-with.1 - (list (ends-with 3 '(1 2 3)) - (ends-with 3 #(1 2 3)) - (ends-with #\z "xyz") - (ends-with 2 '(1 2 3)) - (ends-with 1 #(1 2 3)) - (ends-with 1 1) - (ends-with nil nil)) - (t t t nil nil nil nil)) - -(deftest ends-with.2 - (values (ends-with 2 '(0 13 1) :key '1+) - (ends-with "foo" (vector "bar" "foo") :test 'equal) - (ends-with "X" (vector 1 2 #\X) :key 'string :test 'equal) - (ends-with "foo" "foo" :test 'equal)) - t - t - t - nil) - -(deftest ends-with.error.1 - (handler-case - (ends-with 3 (circular-list 3 3 3 1 3 3)) - (type-error () - :type-error)) - :type-error) - -(deftest sequences.passing-improper-lists - (macrolet ((signals-error-p (form) - `(handler-case - (progn ,form nil) - (type-error (e) - t))) - (cut (fn &rest args) - (with-gensyms (arg) - (print`(lambda (,arg) - (apply ,fn (list ,@(substitute arg '_ args)))))))) - (let ((circular-list (make-circular-list 5 :initial-element :foo)) - (dotted-list (list* 'a 'b 'c 'd))) - (loop for nth from 0 - for fn in (list - (cut #'lastcar _) - (cut #'rotate _ 3) - (cut #'rotate _ -3) - (cut #'shuffle _) - (cut #'random-elt _) - (cut #'last-elt _) - (cut #'ends-with :foo _)) - nconcing - (let ((on-circular-p (signals-error-p (funcall fn circular-list))) - (on-dotted-p (signals-error-p (funcall fn dotted-list)))) - (when (or (not on-circular-p) (not on-dotted-p)) - (append - (unless on-circular-p - (let ((*print-circle* t)) - (list - (format nil - "No appropriate error signalled when passing ~S to ~Ath entry." - circular-list nth)))) - (unless on-dotted-p - (list - (format nil - "No appropriate error signalled when passing ~S to ~Ath entry." - dotted-list nth))))))))) - nil) - -;;;; IO - -(deftest read-stream-content-into-string.1 - (values (with-input-from-string (stream "foo bar") - (read-stream-content-into-string stream)) - (with-input-from-string (stream "foo bar") - (read-stream-content-into-string stream :buffer-size 1)) - (with-input-from-string (stream "foo bar") - (read-stream-content-into-string stream :buffer-size 6)) - (with-input-from-string (stream "foo bar") - (read-stream-content-into-string stream :buffer-size 7))) - "foo bar" - "foo bar" - "foo bar" - "foo bar") - -(deftest read-stream-content-into-string.2 - (handler-case - (let ((stream (make-broadcast-stream))) - (read-stream-content-into-string stream :buffer-size 0)) - (type-error () - :type-error)) - :type-error) - -#+(or) -(defvar *octets* - (map '(simple-array (unsigned-byte 8) (7)) #'char-code "foo bar")) - -#+(or) -(deftest read-stream-content-into-byte-vector.1 - (values (with-input-from-byte-vector (stream *octets*) - (read-stream-content-into-byte-vector stream)) - (with-input-from-byte-vector (stream *octets*) - (read-stream-content-into-byte-vector stream :initial-size 1)) - (with-input-from-byte-vector (stream *octets*) - (read-stream-content-into-byte-vector stream 'alexandria::%length 6)) - (with-input-from-byte-vector (stream *octets*) - (read-stream-content-into-byte-vector stream 'alexandria::%length 3))) - *octets* - *octets* - *octets* - (subseq *octets* 0 3)) - -(deftest read-stream-content-into-byte-vector.2 - (handler-case - (let ((stream (make-broadcast-stream))) - (read-stream-content-into-byte-vector stream :initial-size 0)) - (type-error () - :type-error)) - :type-error) - -;;;; Macros - -(deftest with-unique-names.1 - (let ((*gensym-counter* 0)) - (let ((syms (with-unique-names (foo bar quux) - (list foo bar quux)))) - (list (find-if #'symbol-package syms) - (equal '("FOO0" "BAR1" "QUUX2") - (mapcar #'symbol-name syms))))) - (nil t)) - -(deftest with-unique-names.2 - (let ((*gensym-counter* 0)) - (let ((syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q)) - (list foo bar quux)))) - (list (find-if #'symbol-package syms) - (equal '("_foo_0" "-BAR-1" "q2") - (mapcar #'symbol-name syms))))) - (nil t)) - -(deftest with-unique-names.3 - (let ((*gensym-counter* 0)) - (multiple-value-bind (res err) - (ignore-errors - (eval - '(let ((syms - (with-unique-names ((foo "_foo_") (bar -bar-) (quux 42)) - (list foo bar quux)))) - (list (find-if #'symbol-package syms) - (equal '("_foo_0" "-BAR-1" "q2") - (mapcar #'symbol-name syms)))))) - (errorp err))) - t) - -(deftest once-only.1 - (macrolet ((cons1.good (x) - (once-only (x) - `(cons ,x ,x))) - (cons1.bad (x) - `(cons ,x ,x))) - (let ((y 0)) - (list (cons1.good (incf y)) - y - (cons1.bad (incf y)) - y))) - ((1 . 1) 1 (2 . 3) 3)) - -(deftest once-only.2 - (macrolet ((cons1 (x) - (once-only ((y x)) - `(cons ,y ,y)))) - (let ((z 0)) - (list (cons1 (incf z)) - z - (cons1 (incf z))))) - ((1 . 1) 1 (2 . 2))) - -(deftest parse-body.1 - (parse-body '("doc" "body") :documentation t) - ("body") - nil - "doc") - -(deftest parse-body.2 - (parse-body '("body") :documentation t) - ("body") - nil - nil) - -(deftest parse-body.3 - (parse-body '("doc" "body")) - ("doc" "body") - nil - nil) - -(deftest parse-body.4 - (parse-body '((declare (foo)) "doc" (declare (bar)) body) :documentation t) - (body) - ((declare (foo)) (declare (bar))) - "doc") - -(deftest parse-body.5 - (parse-body '((declare (foo)) "doc" (declare (bar)) body)) - ("doc" (declare (bar)) body) - ((declare (foo))) - nil) - -(deftest parse-body.6 - (multiple-value-bind (res err) - (ignore-errors - (parse-body '("foo" "bar" "quux") - :documentation t)) - (errorp err)) - t) - -;;;; Symbols - -(deftest ensure-symbol.1 - (ensure-symbol :cons :cl) - cons - :external) - -(deftest ensure-symbol.2 - (ensure-symbol "CONS" :alexandria) - cons - :inherited) - -(deftest ensure-symbol.3 - (ensure-symbol 'foo :keyword) - :foo - :external) - -(deftest ensure-symbol.4 - (ensure-symbol #\* :alexandria) - * - :inherited) - -(deftest format-symbol.1 - (let ((s (format-symbol nil '#:x-~d 13))) - (list (symbol-package s) - (string= (string '#:x-13) (symbol-name s)))) - (nil t)) - -(deftest format-symbol.2 - (format-symbol :keyword '#:sym-~a (string :bolic)) - :sym-bolic) - -(deftest format-symbol.3 - (let ((*package* (find-package :cl))) - (format-symbol t '#:find-~a (string 'package))) - find-package) - -(deftest make-keyword.1 - (list (make-keyword 'zot) - (make-keyword "FOO") - (make-keyword #\Q)) - (:zot :foo :q)) - -(deftest make-gensym-list.1 - (let ((*gensym-counter* 0)) - (let ((syms (make-gensym-list 3 "FOO"))) - (list (find-if 'symbol-package syms) - (equal '("FOO0" "FOO1" "FOO2") - (mapcar 'symbol-name syms))))) - (nil t)) - -(deftest make-gensym-list.2 - (let ((*gensym-counter* 0)) - (let ((syms (make-gensym-list 3))) - (list (find-if 'symbol-package syms) - (equal '("G0" "G1" "G2") - (mapcar 'symbol-name syms))))) - (nil t)) - -;;;; Type-system - -(deftest of-type.1 - (locally - (declare (notinline of-type)) - (let ((f (of-type 'string))) - (list (funcall f "foo") - (funcall f 'bar)))) - (t nil)) - -(deftest type=.1 - (type= 'string 'string) - t - t) - -(deftest type=.2 - (type= 'list '(or null cons)) - t - t) - -(deftest type=.3 - (type= 'null '(and symbol list)) - t - t) - -(deftest type=.4 - (type= 'string '(satisfies emptyp)) - nil - nil) - -(deftest type=.5 - (type= 'string 'list) - nil - t) - -(macrolet - ((test (type numbers) - `(deftest ,(format-symbol t '#:cdr5.~a (string type)) - (let ((numbers ,numbers)) - (values (mapcar (of-type ',(format-symbol t '#:negative-~a (string type))) numbers) - (mapcar (of-type ',(format-symbol t '#:non-positive-~a (string type))) numbers) - (mapcar (of-type ',(format-symbol t '#:non-negative-~a (string type))) numbers) - (mapcar (of-type ',(format-symbol t '#:positive-~a (string type))) numbers))) - (t t t nil nil nil nil) - (t t t t nil nil nil) - (nil nil nil t t t t) - (nil nil nil nil t t t)))) - (test fixnum (list most-negative-fixnum -42 -1 0 1 42 most-positive-fixnum)) - (test integer (list (1- most-negative-fixnum) -42 -1 0 1 42 (1+ most-positive-fixnum))) - (test rational (list (1- most-negative-fixnum) -42/13 -1 0 1 42/13 (1+ most-positive-fixnum))) - (test real (list most-negative-long-float -42/13 -1 0 1 42/13 most-positive-long-float)) - (test float (list most-negative-short-float -42.02 -1.0 0.0 1.0 42.02 most-positive-short-float)) - (test short-float (list most-negative-short-float -42.02s0 -1.0s0 0.0s0 1.0s0 42.02s0 most-positive-short-float)) - (test single-float (list most-negative-single-float -42.02f0 -1.0f0 0.0f0 1.0f0 42.02f0 most-positive-single-float)) - (test double-float (list most-negative-double-float -42.02d0 -1.0d0 0.0d0 1.0d0 42.02d0 most-positive-double-float)) - (test long-float (list most-negative-long-float -42.02l0 -1.0l0 0.0l0 1.0l0 42.02l0 most-positive-long-float))) - -;;;; Bindings - -(declaim (notinline opaque)) -(defun opaque (x) - x) - -(deftest if-let.1 - (if-let (x (opaque :ok)) - x - :bad) - :ok) - -(deftest if-let.2 - (if-let (x (opaque nil)) - :bad - (and (not x) :ok)) - :ok) - -(deftest if-let.3 - (let ((x 1)) - (if-let ((x 2) - (y x)) - (+ x y) - :oops)) - 3) - -(deftest if-let.4 - (if-let ((x 1) - (y nil)) - :oops - (and (not y) x)) - 1) - -(deftest if-let.5 - (if-let (x) - :oops - (not x)) - t) - -(deftest if-let.error.1 - (handler-case - (eval '(if-let x - :oops - :oops)) - (type-error () - :type-error)) - :type-error) - -(deftest when-let.1 - (when-let (x (opaque :ok)) - (setf x (cons x x)) - x) - (:ok . :ok)) - -(deftest when-let.2 - (when-let ((x 1) - (y nil) - (z 3)) - :oops) - nil) - -(deftest when-let.3 - (let ((x 1)) - (when-let ((x 2) - (y x)) - (+ x y))) - 3) - -(deftest when-let.error.1 - (handler-case - (eval '(when-let x :oops)) - (type-error () - :type-error)) - :type-error) - -(deftest when-let*.1 - (let ((x 1)) - (when-let* ((x 2) - (y x)) - (+ x y))) - 4) - -(deftest when-let*.2 - (let ((y 1)) - (when-let* (x y) - (1+ x))) - 2) - -(deftest when-let*.3 - (when-let* ((x t) - (y (consp x)) - (z (error "OOPS"))) - t) - nil) - -(deftest when-let*.error.1 - (handler-case - (eval '(when-let* x :oops)) - (type-error () - :type-error)) - :type-error) - -(deftest doplist.1 - (let (keys values) - (doplist (k v '(a 1 b 2 c 3) (values t (reverse keys) (reverse values) k v)) - (push k keys) - (push v values))) - t - (a b c) - (1 2 3) - nil - nil) - -(deftest count-permutations.1 - (values (count-permutations 31 7) - (count-permutations 1 1) - (count-permutations 2 1) - (count-permutations 2 2) - (count-permutations 3 2) - (count-permutations 3 1)) - 13253058000 - 1 - 2 - 2 - 6 - 3) - -(deftest binomial-coefficient.1 - (alexandria:binomial-coefficient 1239 139) - 28794902202288970200771694600561826718847179309929858835480006683522184441358211423695124921058123706380656375919763349913245306834194782172712255592710204598527867804110129489943080460154) - -;; Exercise bignum case (at least on x86). -(deftest binomial-coefficient.2 - (alexandria:binomial-coefficient 2000000000000 20) - 430998041177272843950422879590338454856322722740402365741730748431530623813012487773080486408378680853987520854296499536311275320016878730999689934464711239072435565454954447356845336730100919970769793030177499999999900000000000) - -(deftest copy-stream.1 - (let ((data "sdkfjhsakfh weior763495ewofhsdfk sdfadlkfjhsadf woif sdlkjfhslkdfh sdklfjh")) - (values (equal data - (with-input-from-string (in data) - (with-output-to-string (out) - (alexandria:copy-stream in out)))) - (equal (subseq data 10 20) - (with-input-from-string (in data) - (with-output-to-string (out) - (alexandria:copy-stream in out :start 10 :end 20)))) - (equal (subseq data 10) - (with-input-from-string (in data) - (with-output-to-string (out) - (alexandria:copy-stream in out :start 10)))) - (equal (subseq data 0 20) - (with-input-from-string (in data) - (with-output-to-string (out) - (alexandria:copy-stream in out :end 20)))))) - t - t - t - t) - -(deftest extremum.1 - (let ((n 0)) - (dotimes (i 10) - (let ((data (shuffle (coerce (iota 10000 :start i) 'vector))) - (ok t)) - (unless (eql i (extremum data #'<)) - (setf ok nil)) - (unless (eql i (extremum (coerce data 'list) #'<)) - (setf ok nil)) - (unless (eql (+ 9999 i) (extremum data #'>)) - (setf ok nil)) - (unless (eql (+ 9999 i) (extremum (coerce data 'list) #'>)) - (setf ok nil)) - (when ok - (incf n)))) - (when (eql 10 (extremum #(100 1 10 1000) #'> :start 1 :end 3)) - (incf n)) - (when (eql -1000 (extremum #(100 1 10 -1000) #'> :key 'abs)) - (incf n)) - (when (eq nil (extremum "" (lambda (a b) (error "wtf? ~S, ~S" a b)))) - (incf n)) - n) - 13) - -(deftest starts-with-subseq.string - (starts-with-subseq "f" "foo" :return-suffix t) - t - "oo") - -(deftest starts-with-subseq.vector - (starts-with-subseq #(1) #(1 2 3) :return-suffix t) - t - #(2 3)) - -(deftest starts-with-subseq.list - (starts-with-subseq '(1) '(1 2 3) :return-suffix t) - t - (2 3)) - -(deftest starts-with-subseq.start1 - (starts-with-subseq "foo" "oop" :start1 1) - t - nil) - -(deftest starts-with-subseq.start2 - (starts-with-subseq "foo" "xfoop" :start2 1) - t - nil) - -(deftest format-symbol.print-case-bound - (let ((upper (intern "FOO-BAR")) - (lower (intern "foo-bar")) - (*print-escape* nil)) - (values - (let ((*print-case* :downcase)) - (and (eq upper (format-symbol t "~A" upper)) - (eq lower (format-symbol t "~A" lower)))) - (let ((*print-case* :upcase)) - (and (eq upper (format-symbol t "~A" upper)) - (eq lower (format-symbol t "~A" lower)))) - (let ((*print-case* :capitalize)) - (and (eq upper (format-symbol t "~A" upper)) - (eq lower (format-symbol t "~A" lower)))))) - t - t - t) - -(deftest iota.fp-start-and-complex-integer-step - (equal '(#C(0.0 0.0) #C(0.0 2.0) #C(0.0 4.0)) - (iota 3 :start 0.0 :step #C(0 2))) - t) - -(deftest parse-ordinary-lambda-list.1 - (multiple-value-bind (req opt rest keys allowp aux keyp) - (parse-ordinary-lambda-list '(a b c - &optional o1 (o2 42) (o3 42 o3-supplied?) - &key (k1) ((:key k2)) (k3 42 k3-supplied?)) - :normalize t) - (and (equal '(a b c) req) - (equal '((o1 nil nil) - (o2 42 nil) - (o3 42 o3-supplied?)) - opt) - (equal '(((:k1 k1) nil nil) - ((:key k2) nil nil) - ((:k3 k3) 42 k3-supplied?)) - keys) - (not allowp) - (not aux) - (eq t keyp))) - t) diff --git a/third_party/lisp/alexandria/types.lisp b/third_party/lisp/alexandria/types.lisp deleted file mode 100644 index 1942d0ecdf..0000000000 --- a/third_party/lisp/alexandria/types.lisp +++ /dev/null @@ -1,137 +0,0 @@ -(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.") |