diff options
Diffstat (limited to 'third_party/lisp')
141 files changed, 13949 insertions, 0 deletions
diff --git a/third_party/lisp/alexandria/.boring b/third_party/lisp/alexandria/.boring new file mode 100644 index 0000000000..dfa9e6dd7b --- /dev/null +++ b/third_party/lisp/alexandria/.boring @@ -0,0 +1,13 @@ +# 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 new file mode 100644 index 0000000000..e832e94718 --- /dev/null +++ b/third_party/lisp/alexandria/.gitignore @@ -0,0 +1,4 @@ +*.fasl +*~ +\#* +*.patch diff --git a/third_party/lisp/alexandria/AUTHORS b/third_party/lisp/alexandria/AUTHORS new file mode 100644 index 0000000000..b550ea5032 --- /dev/null +++ b/third_party/lisp/alexandria/AUTHORS @@ -0,0 +1,9 @@ + +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 new file mode 100644 index 0000000000..b5140fbb24 --- /dev/null +++ b/third_party/lisp/alexandria/LICENCE @@ -0,0 +1,37 @@ +Alexandria software and associated documentation are in the public +domain: + + Authors dedicate this work to public domain, for the benefit of the + public at large and to the detriment of the authors' heirs and + successors. Authors intends this dedication to be an overt act of + relinquishment in perpetuity of all present and future rights under + copyright law, whether vested or contingent, in the work. Authors + understands that such relinquishment of all rights includes the + relinquishment of all rights to enforce (by lawsuit or otherwise) + those copyrights in the work. + + Authors recognize that, once placed in the public domain, the work + may be freely reproduced, distributed, transmitted, used, modified, + built upon, or otherwise exploited by anyone for any purpose, + commercial or non-commercial, and in any way, including by methods + that have not yet been invented or conceived. + +In those legislations where public domain dedications are not +recognized or possible, Alexandria is distributed under the following +terms and conditions: + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation files + (the "Software"), to deal in the Software without restriction, + including without limitation the rights to use, copy, modify, merge, + publish, distribute, sublicense, and/or sell copies of the Software, + and to permit persons to whom the Software is furnished to do so, + subject to the following conditions: + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY + CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, + TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE + SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/third_party/lisp/alexandria/README b/third_party/lisp/alexandria/README new file mode 100644 index 0000000000..a5dae9ed1a --- /dev/null +++ b/third_party/lisp/alexandria/README @@ -0,0 +1,52 @@ +Alexandria is a collection of portable public domain utilities that +meet the following constraints: + + * Utilities, not extensions: Alexandria will not contain conceptual + extensions to Common Lisp, instead limiting itself to tools and + utilities that fit well within the framework of standard ANSI + Common Lisp. Test-frameworks, system definitions, logging + facilities, serialization layers, etc. are all outside the scope of + Alexandria as a library, though well within the scope of Alexandria + as a project. + + * Conservative: Alexandria limits itself to what project members + consider conservative utilities. Alexandria does not and will not + include anaphoric constructs, loop-like binding macros, etc. + + * Portable: Alexandria limits itself to portable parts of Common + Lisp. Even apparently conservative and useful functions remain + outside the scope of Alexandria if they cannot be implemented + portably. Portability is here defined as portable within a + conforming implementation: implementation bugs are not considered + portability issues. + +Homepage: + + http://common-lisp.net/project/alexandria/ + +Mailing lists: + + http://lists.common-lisp.net/mailman/listinfo/alexandria-devel + http://lists.common-lisp.net/mailman/listinfo/alexandria-cvs + +Repository: + + git://gitlab.common-lisp.net/alexandria/alexandria.git + +Documentation: + + http://common-lisp.net/project/alexandria/draft/alexandria.html + + (To build docs locally: cd doc && make html pdf info) + +Patches: + + Patches are always welcome! Please send them to the mailing list as + attachments, generated by "git format-patch -1". + + Patches should include a commit message that explains what's being + done and /why/, and when fixing a bug or adding a feature you should + also include a test-case. + + Be advised though that right now new features are unlikely to be + accepted until 1.0 is officially out of the door. diff --git a/third_party/lisp/alexandria/alexandria-tests.asd b/third_party/lisp/alexandria/alexandria-tests.asd new file mode 100644 index 0000000000..445c18cf7f --- /dev/null +++ b/third_party/lisp/alexandria/alexandria-tests.asd @@ -0,0 +1,11 @@ +(defsystem "alexandria-tests" + :licence "Public Domain / 0-clause MIT" + :description "Tests for Alexandria, which is a collection of portable public domain utilities." + :author "Nikodemus Siivola <nikodemus@sb-studio.net>, and others." + :depends-on (:alexandria #+sbcl :sb-rt #-sbcl :rt) + :components ((:file "tests")) + :perform (test-op (o c) + (flet ((run-tests (&rest args) + (apply (intern (string '#:run-tests) '#:alexandria-tests) args))) + (run-tests :compiled nil) + (run-tests :compiled t)))) diff --git a/third_party/lisp/alexandria/alexandria.asd b/third_party/lisp/alexandria/alexandria.asd new file mode 100644 index 0000000000..db10e4f537 --- /dev/null +++ b/third_party/lisp/alexandria/alexandria.asd @@ -0,0 +1,62 @@ +(defsystem "alexandria" + :version "1.0.0" + :licence "Public Domain / 0-clause MIT" + :description "Alexandria is a collection of portable public domain utilities." + :author "Nikodemus Siivola and others." + :long-description + "Alexandria is a project and a library. + +As a project Alexandria's goal is to reduce duplication of effort and improve +portability of Common Lisp code according to its own idiosyncratic and rather +conservative aesthetic. + +As a library Alexandria is one of the means by which the project strives for +its goals. + +Alexandria is a collection of portable public domain utilities that meet +the following constraints: + + * Utilities, not extensions: Alexandria will not contain conceptual + extensions to Common Lisp, instead limiting itself to tools and utilities + that fit well within the framework of standard ANSI Common Lisp. + Test-frameworks, system definitions, logging facilities, serialization + layers, etc. are all outside the scope of Alexandria as a library, though + well within the scope of Alexandria as a project. + + * Conservative: Alexandria limits itself to what project members consider + conservative utilities. Alexandria does not and will not include anaphoric + constructs, loop-like binding macros, etc. + Also, its exported symbols are being imported by many other packages + already, so each new export carries the danger of causing conflicts. + + * Portable: Alexandria limits itself to portable parts of Common Lisp. Even + apparently conservative and useful functions remain outside the scope of + Alexandria if they cannot be implemented portably. Portability is here + defined as portable within a conforming implementation: implementation bugs + are not considered portability issues. + + * Team player: Alexandria will not (initially, at least) subsume or provide + functionality for which good-quality special-purpose packages exist, like + split-sequence. Instead, third party packages such as that may be + \"blessed\"." + :components + ((:static-file "LICENCE") + (:static-file "tests.lisp") + (:file "package") + (:file "definitions" :depends-on ("package")) + (:file "binding" :depends-on ("package")) + (:file "strings" :depends-on ("package")) + (:file "conditions" :depends-on ("package")) + (:file "io" :depends-on ("package" "macros" "lists" "types")) + (:file "macros" :depends-on ("package" "strings" "symbols")) + (:file "hash-tables" :depends-on ("package" "macros")) + (:file "control-flow" :depends-on ("package" "definitions" "macros")) + (:file "symbols" :depends-on ("package")) + (:file "functions" :depends-on ("package" "symbols" "macros")) + (:file "lists" :depends-on ("package" "functions")) + (:file "types" :depends-on ("package" "symbols" "lists")) + (:file "arrays" :depends-on ("package" "types")) + (:file "sequences" :depends-on ("package" "lists" "types")) + (:file "numbers" :depends-on ("package" "sequences")) + (:file "features" :depends-on ("package" "control-flow"))) + :in-order-to ((test-op (test-op "alexandria-tests")))) diff --git a/third_party/lisp/alexandria/arrays.lisp b/third_party/lisp/alexandria/arrays.lisp new file mode 100644 index 0000000000..76c18791ad --- /dev/null +++ b/third_party/lisp/alexandria/arrays.lisp @@ -0,0 +1,18 @@ +(in-package :alexandria) + +(defun copy-array (array &key (element-type (array-element-type array)) + (fill-pointer (and (array-has-fill-pointer-p array) + (fill-pointer array))) + (adjustable (adjustable-array-p array))) + "Returns an undisplaced copy of ARRAY, with same fill-pointer and +adjustability (if any) as the original, unless overridden by the keyword +arguments." + (let* ((dimensions (array-dimensions array)) + (new-array (make-array dimensions + :element-type element-type + :adjustable adjustable + :fill-pointer fill-pointer))) + (dotimes (i (array-total-size array)) + (setf (row-major-aref new-array i) + (row-major-aref array i))) + new-array)) diff --git a/third_party/lisp/alexandria/binding.lisp b/third_party/lisp/alexandria/binding.lisp new file mode 100644 index 0000000000..37a3d52fb9 --- /dev/null +++ b/third_party/lisp/alexandria/binding.lisp @@ -0,0 +1,90 @@ +(in-package :alexandria) + +(defmacro if-let (bindings &body (then-form &optional else-form)) + "Creates new variable bindings, and conditionally executes either +THEN-FORM or ELSE-FORM. ELSE-FORM defaults to NIL. + +BINDINGS must be either single binding of the form: + + (variable initial-form) + +or a list of bindings of the form: + + ((variable-1 initial-form-1) + (variable-2 initial-form-2) + ... + (variable-n initial-form-n)) + +All initial-forms are executed sequentially in the specified order. Then all +the variables are bound to the corresponding values. + +If all variables were bound to true values, the THEN-FORM is executed with the +bindings in effect, otherwise the ELSE-FORM is executed with the bindings in +effect." + (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) + (list bindings) + bindings)) + (variables (mapcar #'car binding-list))) + `(let ,binding-list + (if (and ,@variables) + ,then-form + ,else-form)))) + +(defmacro when-let (bindings &body forms) + "Creates new variable bindings, and conditionally executes FORMS. + +BINDINGS must be either single binding of the form: + + (variable initial-form) + +or a list of bindings of the form: + + ((variable-1 initial-form-1) + (variable-2 initial-form-2) + ... + (variable-n initial-form-n)) + +All initial-forms are executed sequentially in the specified order. Then all +the variables are bound to the corresponding values. + +If all variables were bound to true values, then FORMS are executed as an +implicit PROGN." + (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) + (list bindings) + bindings)) + (variables (mapcar #'car binding-list))) + `(let ,binding-list + (when (and ,@variables) + ,@forms)))) + +(defmacro when-let* (bindings &body body) + "Creates new variable bindings, and conditionally executes BODY. + +BINDINGS must be either single binding of the form: + + (variable initial-form) + +or a list of bindings of the form: + + ((variable-1 initial-form-1) + (variable-2 initial-form-2) + ... + (variable-n initial-form-n)) + +Each INITIAL-FORM is executed in turn, and the variable bound to the +corresponding value. INITIAL-FORM expressions can refer to variables +previously bound by the WHEN-LET*. + +Execution of WHEN-LET* stops immediately if any INITIAL-FORM evaluates to NIL. +If all INITIAL-FORMs evaluate to true, then BODY is executed as an implicit +PROGN." + (let ((binding-list (if (and (consp bindings) (symbolp (car bindings))) + (list bindings) + bindings))) + (labels ((bind (bindings body) + (if bindings + `(let (,(car bindings)) + (when ,(caar bindings) + ,(bind (cdr bindings) body))) + `(progn ,@body)))) + (bind binding-list body)))) diff --git a/third_party/lisp/alexandria/conditions.lisp b/third_party/lisp/alexandria/conditions.lisp new file mode 100644 index 0000000000..ac471cca7e --- /dev/null +++ b/third_party/lisp/alexandria/conditions.lisp @@ -0,0 +1,91 @@ +(in-package :alexandria) + +(defun required-argument (&optional name) + "Signals an error for a missing argument of NAME. Intended for +use as an initialization form for structure and class-slots, and +a default value for required keyword arguments." + (error "Required argument ~@[~S ~]missing." name)) + +(define-condition simple-style-warning (simple-warning style-warning) + ()) + +(defun simple-style-warning (message &rest args) + (warn 'simple-style-warning :format-control message :format-arguments args)) + +;; We don't specify a :report for simple-reader-error to let the +;; underlying implementation report the line and column position for +;; us. Unfortunately this way the message from simple-error is not +;; displayed, unless there's special support for that in the +;; implementation. But even then it's still inspectable from the +;; debugger... +(define-condition simple-reader-error + #-sbcl(simple-error reader-error) + #+sbcl(sb-int:simple-reader-error) + ()) + +(defun simple-reader-error (stream message &rest args) + (error 'simple-reader-error + :stream stream + :format-control message + :format-arguments args)) + +(define-condition simple-parse-error (simple-error parse-error) + ()) + +(defun simple-parse-error (message &rest args) + (error 'simple-parse-error + :format-control message + :format-arguments args)) + +(define-condition simple-program-error (simple-error program-error) + ()) + +(defun simple-program-error (message &rest args) + (error 'simple-program-error + :format-control message + :format-arguments args)) + +(defmacro ignore-some-conditions ((&rest conditions) &body body) + "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS +list determines which specific conditions are to be ignored." + `(handler-case + (progn ,@body) + ,@(loop for condition in conditions collect + `(,condition (c) (values nil c))))) + +(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses) + "Like CL:UNWIND-PROTECT, but you can specify the circumstances that +the cleanup CLAUSES are run. + + clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)* + +Clauses can be given in any order, and more than one clause can be +given for each circumstance. The clauses whose denoted circumstance +occured, are executed in the order the clauses appear. + +ABORT-FLAG is the name of a variable that will be bound to T in +CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL +otherwise. + +Examples: + + (unwind-protect-case () + (protected-form) + (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\")) + (:abort (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\")) + (:always (format t \"This is evaluated in either case.~%\"))) + + (unwind-protect-case (aborted-p) + (protected-form) + (:always (perform-cleanup-if aborted-p))) +" + (check-type abort-flag (or null symbol)) + (let ((gflag (gensym "FLAG+"))) + `(let ((,gflag t)) + (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil)) + (let ,(and abort-flag `((,abort-flag ,gflag))) + ,@(loop for (cleanup-kind . forms) in clauses + collect (ecase cleanup-kind + (:normal `(when (not ,gflag) ,@forms)) + (:abort `(when ,gflag ,@forms)) + (:always `(progn ,@forms))))))))) \ No newline at end of file diff --git a/third_party/lisp/alexandria/control-flow.lisp b/third_party/lisp/alexandria/control-flow.lisp new file mode 100644 index 0000000000..dd00df3e16 --- /dev/null +++ b/third_party/lisp/alexandria/control-flow.lisp @@ -0,0 +1,106 @@ +(in-package :alexandria) + +(defun extract-function-name (spec) + "Useful for macros that want to mimic the functional interface for functions +like #'eq and 'eq." + (if (and (consp spec) + (member (first spec) '(quote function))) + (second spec) + spec)) + +(defun generate-switch-body (whole object clauses test key &optional default) + (with-gensyms (value) + (setf test (extract-function-name test)) + (setf key (extract-function-name key)) + (when (and (consp default) + (member (first default) '(error cerror))) + (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S." + ,value ',test))) + `(let ((,value (,key ,object))) + (cond ,@(mapcar (lambda (clause) + (if (member (first clause) '(t otherwise)) + (progn + (when default + (error "Multiple default clauses or illegal use of a default clause in ~S." + whole)) + (setf default `(progn ,@(rest clause))) + '(())) + (destructuring-bind (key-form &body forms) clause + `((,test ,value ,key-form) + ,@forms)))) + clauses) + (t ,default))))) + +(defmacro switch (&whole whole (object &key (test 'eql) (key 'identity)) + &body clauses) + "Evaluates first matching clause, returning its values, or evaluates and +returns the values of T or OTHERWISE if no keys match." + (generate-switch-body whole object clauses test key)) + +(defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity)) + &body clauses) + "Like SWITCH, but signals an error if no key matches." + (generate-switch-body whole object clauses test key '(error))) + +(defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity)) + &body clauses) + "Like SWITCH, but signals a continuable error if no key matches." + (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH."))) + +(defmacro whichever (&rest possibilities &environment env) + "Evaluates exactly one of POSSIBILITIES, chosen at random." + (setf possibilities (mapcar (lambda (p) (macroexpand p env)) possibilities)) + (if (every (lambda (p) (constantp p)) possibilities) + `(svref (load-time-value (vector ,@possibilities)) (random ,(length possibilities))) + (labels ((expand (possibilities position random-number) + (if (null (cdr possibilities)) + (car possibilities) + (let* ((length (length possibilities)) + (half (truncate length 2)) + (second-half (nthcdr half possibilities)) + (first-half (butlast possibilities (- length half)))) + `(if (< ,random-number ,(+ position half)) + ,(expand first-half position random-number) + ,(expand second-half (+ position half) random-number)))))) + (with-gensyms (random-number) + (let ((length (length possibilities))) + `(let ((,random-number (random ,length))) + ,(expand possibilities 0 random-number))))))) + +(defmacro xor (&rest datums) + "Evaluates its arguments one at a time, from left to right. If more than one +argument evaluates to a true value no further DATUMS are evaluated, and NIL is +returned as both primary and secondary value. If exactly one argument +evaluates to true, its value is returned as the primary value after all the +arguments have been evaluated, and T is returned as the secondary value. If no +arguments evaluate to true NIL is retuned as primary, and T as secondary +value." + (with-gensyms (xor tmp true) + `(let (,tmp ,true) + (block ,xor + ,@(mapcar (lambda (datum) + `(if (setf ,tmp ,datum) + (if ,true + (return-from ,xor (values nil nil)) + (setf ,true ,tmp)))) + datums) + (return-from ,xor (values ,true t)))))) + +(defmacro nth-value-or (nth-value &body forms) + "Evaluates FORM arguments one at a time, until the NTH-VALUE returned by one +of the forms is true. It then returns all the values returned by evaluating +that form. If none of the forms return a true nth value, this form returns +NIL." + (once-only (nth-value) + (with-gensyms (values) + `(let ((,values (multiple-value-list ,(first forms)))) + (if (nth ,nth-value ,values) + (values-list ,values) + ,(if (rest forms) + `(nth-value-or ,nth-value ,@(rest forms)) + nil)))))) + +(defmacro multiple-value-prog2 (first-form second-form &body forms) + "Evaluates FIRST-FORM, then SECOND-FORM, and then FORMS. Yields as its value +all the value returned by SECOND-FORM." + `(progn ,first-form (multiple-value-prog1 ,second-form ,@forms))) diff --git a/third_party/lisp/alexandria/default.nix b/third_party/lisp/alexandria/default.nix new file mode 100644 index 0000000000..3c3fb83708 --- /dev/null +++ b/third_party/lisp/alexandria/default.nix @@ -0,0 +1,28 @@ +# Alexandria is one of the foundational Common Lisp libraries that +# pretty much everything depends on: +# +# Imported from https://common-lisp.net/project/alexandria/ +{ pkgs, ... }: + +pkgs.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 new file mode 100644 index 0000000000..863e1f6962 --- /dev/null +++ b/third_party/lisp/alexandria/definitions.lisp @@ -0,0 +1,37 @@ +(in-package :alexandria) + +(defun %reevaluate-constant (name value test) + (if (not (boundp name)) + value + (let ((old (symbol-value name)) + (new value)) + (if (not (constantp name)) + (prog1 new + (cerror "Try to redefine the variable as a constant." + "~@<~S is an already bound non-constant variable ~ + whose value is ~S.~:@>" name old)) + (if (funcall test old new) + old + (restart-case + (error "~@<~S is an already defined constant whose value ~ + ~S is not equal to the provided initial value ~S ~ + under ~S.~:@>" name old new test) + (ignore () + :report "Retain the current value." + old) + (continue () + :report "Try to redefine the constant." + new))))))) + +(defmacro define-constant (name initial-value &key (test ''eql) documentation) + "Ensures that the global variable named by NAME is a constant with a value +that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a +/function designator/ that defaults to EQL. If DOCUMENTATION is given, it +becomes the documentation string of the constant. + +Signals an error if NAME is already a bound non-constant variable. + +Signals an error if NAME is already a constant variable whose value is not +equal under TEST to result of evaluating INITIAL-VALUE." + `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test) + ,@(when documentation `(,documentation)))) diff --git a/third_party/lisp/alexandria/doc/.gitignore b/third_party/lisp/alexandria/doc/.gitignore new file mode 100644 index 0000000000..f22577b3ac --- /dev/null +++ b/third_party/lisp/alexandria/doc/.gitignore @@ -0,0 +1,3 @@ +alexandria +include + diff --git a/third_party/lisp/alexandria/doc/Makefile b/third_party/lisp/alexandria/doc/Makefile new file mode 100644 index 0000000000..85eb818220 --- /dev/null +++ b/third_party/lisp/alexandria/doc/Makefile @@ -0,0 +1,28 @@ +.PHONY: clean html pdf include clean-include clean-crap info doc + +doc: pdf html info clean-crap + +clean-include: + rm -rf include + +clean-crap: + rm -f *.aux *.cp *.fn *.fns *.ky *.log *.pg *.toc *.tp *.tps *.vr + +clean: clean-include + rm -f *.pdf *.html *.info + +include: + sbcl --no-userinit --eval '(require :asdf)' \ + --eval '(let ((asdf:*central-registry* (list "../"))) (require :alexandria))' \ + --load docstrings.lisp \ + --eval '(sb-texinfo:generate-includes "include/" (list :alexandria) :base-package :alexandria)' \ + --eval '(quit)' + +pdf: include + texi2pdf alexandria.texinfo + +html: include + makeinfo --html --no-split alexandria.texinfo + +info: include + makeinfo alexandria.texinfo diff --git a/third_party/lisp/alexandria/doc/alexandria.texinfo b/third_party/lisp/alexandria/doc/alexandria.texinfo new file mode 100644 index 0000000000..89b03ac349 --- /dev/null +++ b/third_party/lisp/alexandria/doc/alexandria.texinfo @@ -0,0 +1,277 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename alexandria.info +@settitle Alexandria Manual +@c %**end of header + +@settitle Alexandria Manual -- draft version + +@c for install-info +@dircategory Software development +@direntry +* alexandria: Common Lisp utilities. +@end direntry + +@copying +Alexandria software and associated documentation are in the public +domain: + +@quotation + Authors dedicate this work to public domain, for the benefit of the + public at large and to the detriment of the authors' heirs and + successors. Authors intends this dedication to be an overt act of + relinquishment in perpetuity of all present and future rights under + copyright law, whether vested or contingent, in the work. Authors + understands that such relinquishment of all rights includes the + relinquishment of all rights to enforce (by lawsuit or otherwise) + those copyrights in the work. + + Authors recognize that, once placed in the public domain, the work + may be freely reproduced, distributed, transmitted, used, modified, + built upon, or otherwise exploited by anyone for any purpose, + commercial or non-commercial, and in any way, including by methods + that have not yet been invented or conceived. +@end quotation + +In those legislations where public domain dedications are not +recognized or possible, Alexandria is distributed under the following +terms and conditions: + +@quotation + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation files + (the "Software"), to deal in the Software without restriction, + including without limitation the rights to use, copy, modify, merge, + publish, distribute, sublicense, and/or sell copies of the Software, + and to permit persons to whom the Software is furnished to do so, + subject to the following conditions: + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY + CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, + TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE + SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +@end quotation +@end copying + +@titlepage + +@title Alexandria Manual +@subtitle draft version + +@c The following two commands start the copyright page. +@page +@vskip 0pt plus 1filll +@insertcopying + +@end titlepage + +@contents + +@ifnottex + +@include include/ifnottex.texinfo + +@node Top +@comment node-name, next, previous, up +@top Alexandria + +@insertcopying + +@menu +* Hash Tables:: +* Data and Control Flow:: +* Conses:: +* Sequences:: +* IO:: +* Macro Writing:: +* Symbols:: +* Arrays:: +* Types:: +* Numbers:: +@end menu + +@end ifnottex + +@node Hash Tables +@comment node-name, next, previous, up +@chapter Hash Tables + +@include include/macro-alexandria-ensure-gethash.texinfo +@include include/fun-alexandria-copy-hash-table.texinfo +@include include/fun-alexandria-maphash-keys.texinfo +@include include/fun-alexandria-maphash-values.texinfo +@include include/fun-alexandria-hash-table-keys.texinfo +@include include/fun-alexandria-hash-table-values.texinfo +@include include/fun-alexandria-hash-table-alist.texinfo +@include include/fun-alexandria-hash-table-plist.texinfo +@include include/fun-alexandria-alist-hash-table.texinfo +@include include/fun-alexandria-plist-hash-table.texinfo + +@node Data and Control Flow +@comment node-name, next, previous, up +@chapter Data and Control Flow + +@include include/macro-alexandria-define-constant.texinfo +@include include/macro-alexandria-destructuring-case.texinfo +@include include/macro-alexandria-ensure-functionf.texinfo +@include include/macro-alexandria-multiple-value-prog2.texinfo +@include include/macro-alexandria-named-lambda.texinfo +@include include/macro-alexandria-nth-value-or.texinfo +@include include/macro-alexandria-if-let.texinfo +@include include/macro-alexandria-when-let.texinfo +@include include/macro-alexandria-when-let-star.texinfo +@include include/macro-alexandria-switch.texinfo +@include include/macro-alexandria-cswitch.texinfo +@include include/macro-alexandria-eswitch.texinfo +@include include/macro-alexandria-whichever.texinfo +@include include/macro-alexandria-xor.texinfo + +@include include/fun-alexandria-disjoin.texinfo +@include include/fun-alexandria-conjoin.texinfo +@include include/fun-alexandria-compose.texinfo +@include include/fun-alexandria-ensure-function.texinfo +@include include/fun-alexandria-multiple-value-compose.texinfo +@include include/fun-alexandria-curry.texinfo +@include include/fun-alexandria-rcurry.texinfo + +@node Conses +@comment node-name, next, previous, up +@chapter Conses + +@include include/type-alexandria-proper-list.texinfo +@include include/type-alexandria-circular-list.texinfo + +@include include/macro-alexandria-appendf.texinfo +@include include/macro-alexandria-nconcf.texinfo +@include include/macro-alexandria-remove-from-plistf.texinfo +@include include/macro-alexandria-delete-from-plistf.texinfo +@include include/macro-alexandria-reversef.texinfo +@include include/macro-alexandria-nreversef.texinfo +@include include/macro-alexandria-unionf.texinfo +@include include/macro-alexandria-nunionf.texinfo + +@include include/macro-alexandria-doplist.texinfo + +@include include/fun-alexandria-circular-list-p.texinfo +@include include/fun-alexandria-circular-tree-p.texinfo +@include include/fun-alexandria-proper-list-p.texinfo + +@include include/fun-alexandria-alist-plist.texinfo +@include include/fun-alexandria-plist-alist.texinfo +@include include/fun-alexandria-circular-list.texinfo +@include include/fun-alexandria-make-circular-list.texinfo +@include include/fun-alexandria-ensure-car.texinfo +@include include/fun-alexandria-ensure-cons.texinfo +@include include/fun-alexandria-ensure-list.texinfo +@include include/fun-alexandria-flatten.texinfo +@include include/fun-alexandria-lastcar.texinfo +@include include/fun-alexandria-setf-lastcar.texinfo +@include include/fun-alexandria-proper-list-length.texinfo +@include include/fun-alexandria-mappend.texinfo +@include include/fun-alexandria-map-product.texinfo +@include include/fun-alexandria-remove-from-plist.texinfo +@include include/fun-alexandria-delete-from-plist.texinfo +@include include/fun-alexandria-set-equal.texinfo +@include include/fun-alexandria-setp.texinfo + +@node Sequences +@comment node-name, next, previous, up +@chapter Sequences + +@include include/type-alexandria-proper-sequence.texinfo + +@include include/macro-alexandria-deletef.texinfo +@include include/macro-alexandria-removef.texinfo + +@include include/fun-alexandria-rotate.texinfo +@include include/fun-alexandria-shuffle.texinfo +@include include/fun-alexandria-random-elt.texinfo +@include include/fun-alexandria-emptyp.texinfo +@include include/fun-alexandria-sequence-of-length-p.texinfo +@include include/fun-alexandria-length-equals.texinfo +@include include/fun-alexandria-copy-sequence.texinfo +@include include/fun-alexandria-first-elt.texinfo +@include include/fun-alexandria-setf-first-elt.texinfo +@include include/fun-alexandria-last-elt.texinfo +@include include/fun-alexandria-setf-last-elt.texinfo +@include include/fun-alexandria-starts-with.texinfo +@include include/fun-alexandria-starts-with-subseq.texinfo +@include include/fun-alexandria-ends-with.texinfo +@include include/fun-alexandria-ends-with-subseq.texinfo +@include include/fun-alexandria-map-combinations.texinfo +@include include/fun-alexandria-map-derangements.texinfo +@include include/fun-alexandria-map-permutations.texinfo + +@node IO +@comment node-name, next, previous, up +@chapter IO + +@include include/fun-alexandria-read-stream-content-into-string.texinfo +@include include/fun-alexandria-read-file-into-string.texinfo +@include include/fun-alexandria-read-stream-content-into-byte-vector.texinfo +@include include/fun-alexandria-read-file-into-byte-vector.texinfo + +@node Macro Writing +@comment node-name, next, previous, up +@chapter Macro Writing + +@include include/macro-alexandria-once-only.texinfo +@include include/macro-alexandria-with-gensyms.texinfo +@include include/macro-alexandria-with-unique-names.texinfo +@include include/fun-alexandria-featurep.texinfo +@include include/fun-alexandria-parse-body.texinfo +@include include/fun-alexandria-parse-ordinary-lambda-list.texinfo + +@node Symbols +@comment node-name, next, previous, up +@chapter Symbols + +@include include/fun-alexandria-ensure-symbol.texinfo +@include include/fun-alexandria-format-symbol.texinfo +@include include/fun-alexandria-make-keyword.texinfo +@include include/fun-alexandria-make-gensym.texinfo +@include include/fun-alexandria-make-gensym-list.texinfo +@include include/fun-alexandria-symbolicate.texinfo + +@node Arrays +@comment node-name, next, previous, up +@chapter Arrays + +@include include/type-alexandria-array-index.texinfo +@include include/type-alexandria-array-length.texinfo +@include include/fun-alexandria-copy-array.texinfo + +@node Types +@comment node-name, next, previous, up +@chapter Types + +@include include/type-alexandria-string-designator.texinfo +@include include/macro-alexandria-coercef.texinfo +@include include/fun-alexandria-of-type.texinfo +@include include/fun-alexandria-type-equals.texinfo + +@node Numbers +@comment node-name, next, previous, up +@chapter Numbers + +@include include/macro-alexandria-maxf.texinfo +@include include/macro-alexandria-minf.texinfo + +@include include/fun-alexandria-binomial-coefficient.texinfo +@include include/fun-alexandria-count-permutations.texinfo +@include include/fun-alexandria-clamp.texinfo +@include include/fun-alexandria-lerp.texinfo +@include include/fun-alexandria-factorial.texinfo +@include include/fun-alexandria-subfactorial.texinfo +@include include/fun-alexandria-gaussian-random.texinfo +@include include/fun-alexandria-iota.texinfo +@include include/fun-alexandria-map-iota.texinfo +@include include/fun-alexandria-mean.texinfo +@include include/fun-alexandria-median.texinfo +@include include/fun-alexandria-variance.texinfo +@include include/fun-alexandria-standard-deviation.texinfo + +@bye diff --git a/third_party/lisp/alexandria/doc/docstrings.lisp b/third_party/lisp/alexandria/doc/docstrings.lisp new file mode 100644 index 0000000000..51dda07d09 --- /dev/null +++ b/third_party/lisp/alexandria/doc/docstrings.lisp @@ -0,0 +1,881 @@ +;;; -*- lisp -*- + +;;;; A docstring extractor for the sbcl manual. Creates +;;;; @include-ready documentation from the docstrings of exported +;;;; symbols of specified packages. + +;;;; This software is part of the SBCL software system. SBCL is in the +;;;; public domain and is provided with absolutely no warranty. See +;;;; the COPYING file for more information. +;;;; +;;;; Written by Rudi Schlatte <rudi@constantly.at>, mangled +;;;; by Nikodemus Siivola. + +;;;; TODO +;;;; * Verbatim text +;;;; * Quotations +;;;; * Method documentation untested +;;;; * Method sorting, somehow +;;;; * Index for macros & constants? +;;;; * This is getting complicated enough that tests would be good +;;;; * Nesting (currently only nested itemizations work) +;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also +;;;; easily generated) + +;;;; FIXME: The description below is no longer complete. This +;;;; should possibly be turned into a contrib with proper documentation. + +;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely): +;;;; +;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in +;;;; the argument list of the defun / defmacro. +;;;; +;;;; Lines starting with * or - that are followed by intented lines +;;;; are marked up with @itemize. +;;;; +;;;; Lines containing only a SYMBOL that are followed by indented +;;;; lines are marked up as @table @code, with the SYMBOL as the item. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sb-introspect)) + +(defpackage :sb-texinfo + (:use :cl :sb-mop) + (:shadow #:documentation) + (:export #:generate-includes #:document-package) + (:documentation + "Tools to generate TexInfo documentation from docstrings.")) + +(in-package :sb-texinfo) + +;;;; various specials and parameters + +(defvar *texinfo-output*) +(defvar *texinfo-variables*) +(defvar *documentation-package*) +(defvar *base-package*) + +(defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c)) + +(defparameter *documentation-types* + '(compiler-macro + function + method-combination + setf + ;;structure ; also handled by `type' + type + variable) + "A list of symbols accepted as second argument of `documentation'") + +(defparameter *character-replacements* + '((#\* . "star") (#\/ . "slash") (#\+ . "plus") + (#\< . "lt") (#\> . "gt") + (#\= . "equals")) + "Characters and their replacement names that `alphanumize' uses. If +the replacements contain any of the chars they're supposed to replace, +you deserve to lose.") + +(defparameter *characters-to-drop* '(#\\ #\` #\') + "Characters that should be removed by `alphanumize'.") + +(defparameter *texinfo-escaped-chars* "@{}" + "Characters that must be escaped with #\@ for Texinfo.") + +(defparameter *itemize-start-characters* '(#\* #\-) + "Characters that might start an itemization in docstrings when + at the start of a line.") + +(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890*:-+&#'" + "List of characters that make up symbols in a docstring.") + +(defparameter *symbol-delimiters* " ,.!?;") + +(defparameter *ordered-documentation-kinds* + '(package type structure condition class macro)) + +;;;; utilities + +(defun flatten (list) + (cond ((null list) + nil) + ((consp (car list)) + (nconc (flatten (car list)) (flatten (cdr list)))) + ((null (cdr list)) + (cons (car list) nil)) + (t + (cons (car list) (flatten (cdr list)))))) + +(defun whitespacep (char) + (find char #(#\tab #\space #\page))) + +(defun setf-name-p (name) + (or (symbolp name) + (and (listp name) (= 2 (length name)) (eq (car name) 'setf)))) + +(defgeneric specializer-name (specializer)) + +(defmethod specializer-name ((specializer eql-specializer)) + (list 'eql (eql-specializer-object specializer))) + +(defmethod specializer-name ((specializer class)) + (class-name specializer)) + +(defun ensure-class-precedence-list (class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (class-precedence-list class)) + +(defun specialized-lambda-list (method) + ;; courtecy of AMOP p. 61 + (let* ((specializers (method-specializers method)) + (lambda-list (method-lambda-list method)) + (n-required (length specializers))) + (append (mapcar (lambda (arg specializer) + (if (eq specializer (find-class 't)) + arg + `(,arg ,(specializer-name specializer)))) + (subseq lambda-list 0 n-required) + specializers) + (subseq lambda-list n-required)))) + +(defun string-lines (string) + "Lines in STRING as a vector." + (coerce (with-input-from-string (s string) + (loop for line = (read-line s nil nil) + while line collect line)) + 'vector)) + +(defun indentation (line) + "Position of first non-SPACE character in LINE." + (position-if-not (lambda (c) (char= c #\Space)) line)) + +(defun docstring (x doc-type) + (cl:documentation x doc-type)) + +(defun flatten-to-string (list) + (format nil "~{~A~^-~}" (flatten list))) + +(defun alphanumize (original) + "Construct a string without characters like *`' that will f-star-ck +up filename handling. See `*character-replacements*' and +`*characters-to-drop*' for customization." + (let ((name (remove-if (lambda (x) (member x *characters-to-drop*)) + (if (listp original) + (flatten-to-string original) + (string original)))) + (chars-to-replace (mapcar #'car *character-replacements*))) + (flet ((replacement-delimiter (index) + (cond ((or (< index 0) (>= index (length name))) "") + ((alphanumericp (char name index)) "-") + (t "")))) + (loop for index = (position-if #'(lambda (x) (member x chars-to-replace)) + name) + while index + do (setf name (concatenate 'string (subseq name 0 index) + (replacement-delimiter (1- index)) + (cdr (assoc (aref name index) + *character-replacements*)) + (replacement-delimiter (1+ index)) + (subseq name (1+ index)))))) + name)) + +;;;; generating various names + +(defgeneric name (thing) + (:documentation "Name for a documented thing. Names are either +symbols or lists of symbols.")) + +(defmethod name ((symbol symbol)) + symbol) + +(defmethod name ((cons cons)) + cons) + +(defmethod name ((package package)) + (short-package-name package)) + +(defmethod name ((method method)) + (list + (generic-function-name (method-generic-function method)) + (method-qualifiers method) + (specialized-lambda-list method))) + +;;; Node names for DOCUMENTATION instances + +(defgeneric name-using-kind/name (kind name doc)) + +(defmethod name-using-kind/name (kind (name string) doc) + (declare (ignore kind doc)) + name) + +(defmethod name-using-kind/name (kind (name symbol) doc) + (declare (ignore kind)) + (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name)) + +(defmethod name-using-kind/name (kind (name list) doc) + (declare (ignore kind)) + (assert (setf-name-p name)) + (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name))) + +(defmethod name-using-kind/name ((kind (eql 'method)) name doc) + (format nil "~A~{ ~A~} ~A" + (name-using-kind/name nil (first name) doc) + (second name) + (third name))) + +(defun node-name (doc) + "Returns TexInfo node name as a string for a DOCUMENTATION instance." + (let ((kind (get-kind doc))) + (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc)))) + +(defun short-package-name (package) + (unless (eq package *base-package*) + (car (sort (copy-list (cons (package-name package) (package-nicknames package))) + #'< :key #'length)))) + +;;; Definition titles for DOCUMENTATION instances + +(defgeneric title-using-kind/name (kind name doc)) + +(defmethod title-using-kind/name (kind (name string) doc) + (declare (ignore kind doc)) + name) + +(defmethod title-using-kind/name (kind (name symbol) doc) + (declare (ignore kind)) + (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name)) + +(defmethod title-using-kind/name (kind (name list) doc) + (declare (ignore kind)) + (assert (setf-name-p name)) + (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name))) + +(defmethod title-using-kind/name ((kind (eql 'method)) name doc) + (format nil "~{~A ~}~A" + (second name) + (title-using-kind/name nil (first name) doc))) + +(defun title-name (doc) + "Returns a string to be used as name of the definition." + (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc))) + +(defun include-pathname (doc) + (let* ((kind (get-kind doc)) + (name (nstring-downcase + (if (eq 'package kind) + (format nil "package-~A" (alphanumize (get-name doc))) + (format nil "~A-~A-~A" + (case (get-kind doc) + ((function generic-function) "fun") + (structure "struct") + (variable "var") + (otherwise (symbol-name (get-kind doc)))) + (alphanumize (let ((*base-package* nil)) + (short-package-name (get-package doc)))) + (alphanumize (get-name doc))))))) + (make-pathname :name name :type "texinfo"))) + +;;;; documentation class and related methods + +(defclass documentation () + ((name :initarg :name :reader get-name) + (kind :initarg :kind :reader get-kind) + (string :initarg :string :reader get-string) + (children :initarg :children :initform nil :reader get-children) + (package :initform *documentation-package* :reader get-package))) + +(defmethod print-object ((documentation documentation) stream) + (print-unreadable-object (documentation stream :type t) + (princ (list (get-kind documentation) (get-name documentation)) stream))) + +(defgeneric make-documentation (x doc-type string)) + +(defmethod make-documentation ((x package) doc-type string) + (declare (ignore doc-type)) + (make-instance 'documentation + :name (name x) + :kind 'package + :string string)) + +(defmethod make-documentation (x (doc-type (eql 'function)) string) + (declare (ignore doc-type)) + (let* ((fdef (and (fboundp x) (fdefinition x))) + (name x) + (kind (cond ((and (symbolp x) (special-operator-p x)) + 'special-operator) + ((and (symbolp x) (macro-function x)) + 'macro) + ((typep fdef 'generic-function) + (assert (or (symbolp name) (setf-name-p name))) + 'generic-function) + (fdef + (assert (or (symbolp name) (setf-name-p name))) + 'function))) + (children (when (eq kind 'generic-function) + (collect-gf-documentation fdef)))) + (make-instance 'documentation + :name (name x) + :string string + :kind kind + :children children))) + +(defmethod make-documentation ((x method) doc-type string) + (declare (ignore doc-type)) + (make-instance 'documentation + :name (name x) + :kind 'method + :string string)) + +(defmethod make-documentation (x (doc-type (eql 'type)) string) + (make-instance 'documentation + :name (name x) + :string string + :kind (etypecase (find-class x nil) + (structure-class 'structure) + (standard-class 'class) + (sb-pcl::condition-class 'condition) + ((or built-in-class null) 'type)))) + +(defmethod make-documentation (x (doc-type (eql 'variable)) string) + (make-instance 'documentation + :name (name x) + :string string + :kind (if (constantp x) + 'constant + 'variable))) + +(defmethod make-documentation (x (doc-type (eql 'setf)) string) + (declare (ignore doc-type)) + (make-instance 'documentation + :name (name x) + :kind 'setf-expander + :string string)) + +(defmethod make-documentation (x doc-type string) + (make-instance 'documentation + :name (name x) + :kind doc-type + :string string)) + +(defun maybe-documentation (x doc-type) + "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if +there is no corresponding docstring." + (let ((docstring (docstring x doc-type))) + (when docstring + (make-documentation x doc-type docstring)))) + +(defun lambda-list (doc) + (case (get-kind doc) + ((package constant variable type structure class condition nil) + nil) + (method + (third (get-name doc))) + (t + ;; KLUDGE: Eugh. + ;; + ;; believe it or not, the above comment was written before CSR + ;; came along and obfuscated this. (2005-07-04) + (when (symbolp (get-name doc)) + (labels ((clean (x &key optional key) + (typecase x + (atom x) + ((cons (member &optional)) + (cons (car x) (clean (cdr x) :optional t))) + ((cons (member &key)) + (cons (car x) (clean (cdr x) :key t))) + ((cons (member &whole &environment)) + ;; Skip these + (clean (cdr x) :optional optional :key key)) + ((cons cons) + (cons + (cond (key (if (consp (caar x)) + (caaar x) + (caar x))) + (optional (caar x)) + (t (clean (car x)))) + (clean (cdr x) :key key :optional optional))) + (cons + (cons + (cond ((or key optional) (car x)) + (t (clean (car x)))) + (clean (cdr x) :key key :optional optional)))))) + (clean (sb-introspect:function-lambda-list (get-name doc)))))))) + +(defun get-string-name (x) + (let ((name (get-name x))) + (cond ((symbolp name) + (symbol-name name)) + ((and (consp name) (eq 'setf (car name))) + (symbol-name (second name))) + ((stringp name) + name) + (t + (error "Don't know which symbol to use for name ~S" name))))) + +(defun documentation< (x y) + (let ((p1 (position (get-kind x) *ordered-documentation-kinds*)) + (p2 (position (get-kind y) *ordered-documentation-kinds*))) + (if (or (not (and p1 p2)) (= p1 p2)) + (string< (get-string-name x) (get-string-name y)) + (< p1 p2)))) + +;;;; turning text into texinfo + +(defun escape-for-texinfo (string &optional downcasep) + "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped +with #\@. Optionally downcase the result." + (let ((result (with-output-to-string (s) + (loop for char across string + when (find char *texinfo-escaped-chars*) + do (write-char #\@ s) + do (write-char char s))))) + (if downcasep (nstring-downcase result) result))) + +(defun empty-p (line-number lines) + (and (< -1 line-number (length lines)) + (not (indentation (svref lines line-number))))) + +;;; line markups + +(defvar *not-symbols* '("ANSI" "CLHS")) + +(defun locate-symbols (line) + "Return a list of index pairs of symbol-like parts of LINE." + ;; This would be a good application for a regex ... + (let (result) + (flet ((grab (start end) + (unless (member (subseq line start end) '("ANSI" "CLHS")) + (push (list start end) result)))) + (do ((begin nil) + (maybe-begin t) + (i 0 (1+ i))) + ((= i (length line)) + ;; symbol at end of line + (when (and begin (or (> i (1+ begin)) + (not (member (char line begin) '(#\A #\I))))) + (grab begin i)) + (nreverse result)) + (cond + ((and begin (find (char line i) *symbol-delimiters*)) + ;; symbol end; remember it if it's not "A" or "I" + (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I)))) + (grab begin i)) + (setf begin nil + maybe-begin t)) + ((and begin (not (find (char line i) *symbol-characters*))) + ;; Not a symbol: abort + (setf begin nil)) + ((and maybe-begin (not begin) (find (char line i) *symbol-characters*)) + ;; potential symbol begin at this position + (setf begin i + maybe-begin nil)) + ((find (char line i) *symbol-delimiters*) + ;; potential symbol begin after this position + (setf maybe-begin t)) + (t + ;; Not reading a symbol, not at potential start of symbol + (setf maybe-begin nil))))))) + +(defun texinfo-line (line) + "Format symbols in LINE texinfo-style: either as code or as +variables if the symbol in question is contained in symbols +*TEXINFO-VARIABLES*." + (with-output-to-string (result) + (let ((last 0)) + (dolist (symbol/index (locate-symbols line)) + (write-string (subseq line last (first symbol/index)) result) + (let ((symbol-name (apply #'subseq line symbol/index))) + (format result (if (member symbol-name *texinfo-variables* + :test #'string=) + "@var{~A}" + "@code{~A}") + (string-downcase symbol-name))) + (setf last (second symbol/index))) + (write-string (subseq line last) result)))) + +;;; lisp sections + +(defun lisp-section-p (line line-number lines) + "Returns T if the given LINE looks like start of lisp code -- +ie. if it starts with whitespace followed by a paren or +semicolon, and the previous line is empty" + (let ((offset (indentation line))) + (and offset + (plusp offset) + (find (find-if-not #'whitespacep line) "(;") + (empty-p (1- line-number) lines)))) + +(defun collect-lisp-section (lines line-number) + (let ((lisp (loop for index = line-number then (1+ index) + for line = (and (< index (length lines)) (svref lines index)) + while (indentation line) + collect line))) + (values (length lisp) `("@lisp" ,@lisp "@end lisp")))) + +;;; itemized sections + +(defun maybe-itemize-offset (line) + "Return NIL or the indentation offset if LINE looks like it starts +an item in an itemization." + (let* ((offset (indentation line)) + (char (when offset (char line offset)))) + (and offset + (member char *itemize-start-characters* :test #'char=) + (char= #\Space (find-if-not (lambda (c) (char= c char)) + line :start offset)) + offset))) + +(defun collect-maybe-itemized-section (lines starting-line) + ;; Return index of next line to be processed outside + (let ((this-offset (maybe-itemize-offset (svref lines starting-line))) + (result nil) + (lines-consumed 0)) + (loop for line-number from starting-line below (length lines) + for line = (svref lines line-number) + for indentation = (indentation line) + for offset = (maybe-itemize-offset line) + do (cond + ((not indentation) + ;; empty line -- inserts paragraph. + (push "" result) + (incf lines-consumed)) + ((and offset (> indentation this-offset)) + ;; nested itemization -- handle recursively + ;; FIXME: tables in itemizations go wrong + (multiple-value-bind (sub-lines-consumed sub-itemization) + (collect-maybe-itemized-section lines line-number) + (when sub-lines-consumed + (incf line-number (1- sub-lines-consumed)) ; +1 on next loop + (incf lines-consumed sub-lines-consumed) + (setf result (nconc (nreverse sub-itemization) result))))) + ((and offset (= indentation this-offset)) + ;; start of new item + (push (format nil "@item ~A" + (texinfo-line (subseq line (1+ offset)))) + result) + (incf lines-consumed)) + ((and (not offset) (> indentation this-offset)) + ;; continued item from previous line + (push (texinfo-line line) result) + (incf lines-consumed)) + (t + ;; end of itemization + (loop-finish)))) + ;; a single-line itemization isn't. + (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) + (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize")) + nil))) + +;;; table sections + +(defun tabulation-body-p (offset line-number lines) + (when (< line-number (length lines)) + (let ((offset2 (indentation (svref lines line-number)))) + (and offset2 (< offset offset2))))) + +(defun tabulation-p (offset line-number lines direction) + (let ((step (ecase direction + (:backwards (1- line-number)) + (:forwards (1+ line-number))))) + (when (and (plusp line-number) (< line-number (length lines))) + (and (eql offset (indentation (svref lines line-number))) + (or (when (eq direction :backwards) + (empty-p step lines)) + (tabulation-p offset step lines direction) + (tabulation-body-p offset step lines)))))) + +(defun maybe-table-offset (line-number lines) + "Return NIL or the indentation offset if LINE looks like it starts +an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an +empty line, another tabulation label, or a tabulation body, (3) and +followed another tabulation label or a tabulation body." + (let* ((line (svref lines line-number)) + (offset (indentation line)) + (prev (1- line-number)) + (next (1+ line-number))) + (when (and offset (plusp offset)) + (and (or (empty-p prev lines) + (tabulation-body-p offset prev lines) + (tabulation-p offset prev lines :backwards)) + (or (tabulation-body-p offset next lines) + (tabulation-p offset next lines :forwards)) + offset)))) + +;;; FIXME: This and itemization are very similar: could they share +;;; some code, mayhap? + +(defun collect-maybe-table-section (lines starting-line) + ;; Return index of next line to be processed outside + (let ((this-offset (maybe-table-offset starting-line lines)) + (result nil) + (lines-consumed 0)) + (loop for line-number from starting-line below (length lines) + for line = (svref lines line-number) + for indentation = (indentation line) + for offset = (maybe-table-offset line-number lines) + do (cond + ((not indentation) + ;; empty line -- inserts paragraph. + (push "" result) + (incf lines-consumed)) + ((and offset (= indentation this-offset)) + ;; start of new item, or continuation of previous item + (if (and result (search "@item" (car result) :test #'char=)) + (push (format nil "@itemx ~A" (texinfo-line line)) + result) + (progn + (push "" result) + (push (format nil "@item ~A" (texinfo-line line)) + result))) + (incf lines-consumed)) + ((> indentation this-offset) + ;; continued item from previous line + (push (texinfo-line line) result) + (incf lines-consumed)) + (t + ;; end of itemization + (loop-finish)))) + ;; a single-line table isn't. + (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) + (values lines-consumed + `("" "@table @emph" ,@(reverse result) "@end table" "")) + nil))) + +;;; section markup + +(defmacro with-maybe-section (index &rest forms) + `(multiple-value-bind (count collected) (progn ,@forms) + (when count + (dolist (line collected) + (write-line line *texinfo-output*)) + (incf ,index (1- count))))) + +(defun write-texinfo-string (string &optional lambda-list) + "Try to guess as much formatting for a raw docstring as possible." + (let ((*texinfo-variables* (flatten lambda-list)) + (lines (string-lines (escape-for-texinfo string nil)))) + (loop for line-number from 0 below (length lines) + for line = (svref lines line-number) + do (cond + ((with-maybe-section line-number + (and (lisp-section-p line line-number lines) + (collect-lisp-section lines line-number)))) + ((with-maybe-section line-number + (and (maybe-itemize-offset line) + (collect-maybe-itemized-section lines line-number)))) + ((with-maybe-section line-number + (and (maybe-table-offset line-number lines) + (collect-maybe-table-section lines line-number)))) + (t + (write-line (texinfo-line line) *texinfo-output*)))))) + +;;;; texinfo formatting tools + +(defun hide-superclass-p (class-name super-name) + (let ((super-package (symbol-package super-name))) + (or + ;; KLUDGE: We assume that we don't want to advertise internal + ;; classes in CP-lists, unless the symbol we're documenting is + ;; internal as well. + (and (member super-package #.'(mapcar #'find-package *undocumented-packages*)) + (not (eq super-package (symbol-package class-name)))) + ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or + ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them + ;; simply as a matter of convenience. The assumption here is that + ;; the inheritance is incidental unless the name of the condition + ;; begins with SIMPLE-. + (and (member super-name '(simple-error simple-condition)) + (let ((prefix "SIMPLE-")) + (mismatch prefix (string class-name) :end2 (length prefix))) + t ; don't return number from MISMATCH + )))) + +(defun hide-slot-p (symbol slot) + ;; FIXME: There is no pricipal reason to avoid the slot docs fo + ;; structures and conditions, but their DOCUMENTATION T doesn't + ;; currently work with them the way we'd like. + (not (and (typep (find-class symbol nil) 'standard-class) + (docstring slot t)))) + +(defun texinfo-anchor (doc) + (format *texinfo-output* "@anchor{~A}~%" (node-name doc))) + +;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please" +(defun texinfo-begin (doc &aux *print-pretty*) + (let ((kind (get-kind doc))) + (format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%" + (case kind + ((package constant variable) + "defvr") + ((structure class condition type) + "deftp") + (t + "deffn")) + (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind)) + (title-name doc) + ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo + ;; interactions,so we escape the ampersand -- amusingly for TeX. + ;; sbcl.texinfo defines macros that expand @&key and friends to &key. + (mapcar (lambda (name) + (if (member name lambda-list-keywords) + (format nil "@~A" name) + name)) + (lambda-list doc))))) + +(defun texinfo-index (doc) + (let ((title (title-name doc))) + (case (get-kind doc) + ((structure type class condition) + (format *texinfo-output* "@tindex ~A~%" title)) + ((variable constant) + (format *texinfo-output* "@vindex ~A~%" title)) + ((compiler-macro function method-combination macro generic-function) + (format *texinfo-output* "@findex ~A~%" title))))) + +(defun texinfo-inferred-body (doc) + (when (member (get-kind doc) '(class structure condition)) + (let ((name (get-name doc))) + ;; class precedence list + (format *texinfo-output* "Class precedence list: @code{~(~{@lw{~A}~^, ~}~)}~%~%" + (remove-if (lambda (class) (hide-superclass-p name class)) + (mapcar #'class-name (ensure-class-precedence-list (find-class name))))) + ;; slots + (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot)) + (class-direct-slots (find-class name))))) + (when slots + (format *texinfo-output* "Slots:~%@itemize~%") + (dolist (slot slots) + (format *texinfo-output* + "@item ~(@code{~A}~#[~:; --- ~]~ + ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%" + (slot-definition-name slot) + (remove + nil + (mapcar + (lambda (name things) + (if things + (list name (length things) things))) + '("initarg" "reader" "writer") + (list + (slot-definition-initargs slot) + (slot-definition-readers slot) + (slot-definition-writers slot))))) + ;; FIXME: Would be neater to handler as children + (write-texinfo-string (docstring slot t))) + (format *texinfo-output* "@end itemize~%~%")))))) + +(defun texinfo-body (doc) + (write-texinfo-string (get-string doc))) + +(defun texinfo-end (doc) + (write-line (case (get-kind doc) + ((package variable constant) "@end defvr") + ((structure type class condition) "@end deftp") + (t "@end deffn")) + *texinfo-output*)) + +(defun write-texinfo (doc) + "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*." + (texinfo-anchor doc) + (texinfo-begin doc) + (texinfo-index doc) + (texinfo-inferred-body doc) + (texinfo-body doc) + (texinfo-end doc) + ;; FIXME: Children should be sorted one way or another + (mapc #'write-texinfo (get-children doc))) + +;;;; main logic + +(defun collect-gf-documentation (gf) + "Collects method documentation for the generic function GF" + (loop for method in (generic-function-methods gf) + for doc = (maybe-documentation method t) + when doc + collect doc)) + +(defun collect-name-documentation (name) + (loop for type in *documentation-types* + for doc = (maybe-documentation name type) + when doc + collect doc)) + +(defun collect-symbol-documentation (symbol) + "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of +the form DOC instances. See `*documentation-types*' for the possible +values of doc-type." + (nconc (collect-name-documentation symbol) + (collect-name-documentation (list 'setf symbol)))) + +(defun collect-documentation (package) + "Collects all documentation for all external symbols of the given +package, as well as for the package itself." + (let* ((*documentation-package* (find-package package)) + (docs nil)) + (check-type package package) + (do-external-symbols (symbol package) + (setf docs (nconc (collect-symbol-documentation symbol) docs))) + (let ((doc (maybe-documentation *documentation-package* t))) + (when doc + (push doc docs))) + docs)) + +(defmacro with-texinfo-file (pathname &body forms) + `(with-open-file (*texinfo-output* ,pathname + :direction :output + :if-does-not-exist :create + :if-exists :supersede) + ,@forms)) + +(defun write-ifnottex () + ;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to + ;; define them for info as well. + (flet ((macro (name) + (let ((string (string-downcase name))) + (format *texinfo-output* "@macro ~A~%~A~%@end macro~%" string string)))) + (macro '&allow-other-keys) + (macro '&optional) + (macro '&rest) + (macro '&key) + (macro '&body))) + +(defun generate-includes (directory packages &key (base-package :cl-user)) + "Create files in `directory' containing Texinfo markup of all +docstrings of each exported symbol in `packages'. `directory' is +created if necessary. If you supply a namestring that doesn't end in a +slash, you lose. The generated files are of the form +\"<doc-type>_<packagename>_<symbol-name>.texinfo\" and can be included +via @include statements. Texinfo syntax-significant characters are +escaped in symbol names, but if a docstring contains invalid Texinfo +markup, you lose." + (handler-bind ((warning #'muffle-warning)) + (let ((directory (merge-pathnames (pathname directory))) + (*base-package* (find-package base-package))) + (ensure-directories-exist directory) + (dolist (package packages) + (dolist (doc (collect-documentation (find-package package))) + (with-texinfo-file (merge-pathnames (include-pathname doc) directory) + (write-texinfo doc)))) + (with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory) + (write-ifnottex)) + directory))) + +(defun document-package (package &optional filename) + "Create a file containing all available documentation for the +exported symbols of `package' in Texinfo format. If `filename' is not +supplied, a file \"<packagename>.texinfo\" is generated. + +The definitions can be referenced using Texinfo statements like +@ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo +syntax-significant characters are escaped in symbol names, but if a +docstring contains invalid Texinfo markup, you lose." + (handler-bind ((warning #'muffle-warning)) + (let* ((package (find-package package)) + (filename (or filename (make-pathname + :name (string-downcase (short-package-name package)) + :type "texinfo"))) + (docs (sort (collect-documentation package) #'documentation<))) + (with-texinfo-file filename + (dolist (doc docs) + (write-texinfo doc))) + filename))) diff --git a/third_party/lisp/alexandria/features.lisp b/third_party/lisp/alexandria/features.lisp new file mode 100644 index 0000000000..67348dbba4 --- /dev/null +++ b/third_party/lisp/alexandria/features.lisp @@ -0,0 +1,14 @@ +(in-package :alexandria) + +(defun featurep (feature-expression) + "Returns T if the argument matches the state of the *FEATURES* +list and NIL if it does not. FEATURE-EXPRESSION can be any atom +or list acceptable to the reader macros #+ and #-." + (etypecase feature-expression + (symbol (not (null (member feature-expression *features*)))) + (cons (check-type (first feature-expression) symbol) + (eswitch ((first feature-expression) :test 'string=) + (:and (every #'featurep (rest feature-expression))) + (:or (some #'featurep (rest feature-expression))) + (:not (assert (= 2 (length feature-expression))) + (not (featurep (second feature-expression)))))))) diff --git a/third_party/lisp/alexandria/functions.lisp b/third_party/lisp/alexandria/functions.lisp new file mode 100644 index 0000000000..dd83e38b4e --- /dev/null +++ b/third_party/lisp/alexandria/functions.lisp @@ -0,0 +1,161 @@ +(in-package :alexandria) + +;;; To propagate return type and allow the compiler to eliminate the IF when +;;; it is known if the argument is function or not. +(declaim (inline ensure-function)) + +(declaim (ftype (function (t) (values function &optional)) + ensure-function)) +(defun ensure-function (function-designator) + "Returns the function designated by FUNCTION-DESIGNATOR: +if FUNCTION-DESIGNATOR is a function, it is returned, otherwise +it must be a function name and its FDEFINITION is returned." + (if (functionp function-designator) + function-designator + (fdefinition function-designator))) + +(define-modify-macro ensure-functionf/1 () ensure-function) + +(defmacro ensure-functionf (&rest places) + "Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of +PLACES contains a function." + `(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places))) + +(defun disjoin (predicate &rest more-predicates) + "Returns a function that applies each of PREDICATE and MORE-PREDICATE +functions in turn to its arguments, returning the primary value of the first +predicate that returns true, without calling the remaining predicates. +If none of the predicates returns true, NIL is returned." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (let ((predicate (ensure-function predicate)) + (more-predicates (mapcar #'ensure-function more-predicates))) + (lambda (&rest arguments) + (or (apply predicate arguments) + (some (lambda (p) + (declare (type function p)) + (apply p arguments)) + more-predicates))))) + +(defun conjoin (predicate &rest more-predicates) + "Returns a function that applies each of PREDICATE and MORE-PREDICATE +functions in turn to its arguments, returning NIL if any of the predicates +returns false, without calling the remaining predicates. If none of the +predicates returns false, returns the primary value of the last predicate." + (if (null more-predicates) + predicate + (lambda (&rest arguments) + (and (apply predicate arguments) + ;; Cannot simply use CL:EVERY because we want to return the + ;; non-NIL value of the last predicate if all succeed. + (do ((tail (cdr more-predicates) (cdr tail)) + (head (car more-predicates) (car tail))) + ((not tail) + (apply head arguments)) + (unless (apply head arguments) + (return nil))))))) + + +(defun compose (function &rest more-functions) + "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its +arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS, +and then calling the next one with the primary value of the last." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (reduce (lambda (f g) + (let ((f (ensure-function f)) + (g (ensure-function g))) + (lambda (&rest arguments) + (declare (dynamic-extent arguments)) + (funcall f (apply g arguments))))) + more-functions + :initial-value function)) + +(define-compiler-macro compose (function &rest more-functions) + (labels ((compose-1 (funs) + (if (cdr funs) + `(funcall ,(car funs) ,(compose-1 (cdr funs))) + `(apply ,(car funs) arguments)))) + (let* ((args (cons function more-functions)) + (funs (make-gensym-list (length args) "COMPOSE"))) + `(let ,(loop for f in funs for arg in args + collect `(,f (ensure-function ,arg))) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (lambda (&rest arguments) + (declare (dynamic-extent arguments)) + ,(compose-1 funs)))))) + +(defun multiple-value-compose (function &rest more-functions) + "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies +its arguments to each in turn, starting from the rightmost of +MORE-FUNCTIONS, and then calling the next one with all the return values of +the last." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (reduce (lambda (f g) + (let ((f (ensure-function f)) + (g (ensure-function g))) + (lambda (&rest arguments) + (declare (dynamic-extent arguments)) + (multiple-value-call f (apply g arguments))))) + more-functions + :initial-value function)) + +(define-compiler-macro multiple-value-compose (function &rest more-functions) + (labels ((compose-1 (funs) + (if (cdr funs) + `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs))) + `(apply ,(car funs) arguments)))) + (let* ((args (cons function more-functions)) + (funs (make-gensym-list (length args) "MV-COMPOSE"))) + `(let ,(mapcar #'list funs args) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (lambda (&rest arguments) + (declare (dynamic-extent arguments)) + ,(compose-1 funs)))))) + +(declaim (inline curry rcurry)) + +(defun curry (function &rest arguments) + "Returns a function that applies ARGUMENTS and the arguments +it is called with to FUNCTION." + (declare (optimize (speed 3) (safety 1))) + (let ((fn (ensure-function function))) + (lambda (&rest more) + (declare (dynamic-extent more)) + ;; Using M-V-C we don't need to append the arguments. + (multiple-value-call fn (values-list arguments) (values-list more))))) + +(define-compiler-macro curry (function &rest arguments) + (let ((curries (make-gensym-list (length arguments) "CURRY")) + (fun (gensym "FUN"))) + `(let ((,fun (ensure-function ,function)) + ,@(mapcar #'list curries arguments)) + (declare (optimize (speed 3) (safety 1))) + (lambda (&rest more) + (declare (dynamic-extent more)) + (apply ,fun ,@curries more))))) + +(defun rcurry (function &rest arguments) + "Returns a function that applies the arguments it is called +with and ARGUMENTS to FUNCTION." + (declare (optimize (speed 3) (safety 1))) + (let ((fn (ensure-function function))) + (lambda (&rest more) + (declare (dynamic-extent more)) + (multiple-value-call fn (values-list more) (values-list arguments))))) + +(define-compiler-macro rcurry (function &rest arguments) + (let ((rcurries (make-gensym-list (length arguments) "RCURRY")) + (fun (gensym "FUN"))) + `(let ((,fun (ensure-function ,function)) + ,@(mapcar #'list rcurries arguments)) + (declare (optimize (speed 3) (safety 1))) + (lambda (&rest more) + (declare (dynamic-extent more)) + (multiple-value-call ,fun (values-list more) ,@rcurries))))) + +(declaim (notinline curry rcurry)) + +(defmacro named-lambda (name lambda-list &body body) + "Expands into a lambda-expression within whose BODY NAME denotes the +corresponding function." + `(labels ((,name ,lambda-list ,@body)) + #',name)) diff --git a/third_party/lisp/alexandria/hash-tables.lisp b/third_party/lisp/alexandria/hash-tables.lisp new file mode 100644 index 0000000000..a9f7902204 --- /dev/null +++ b/third_party/lisp/alexandria/hash-tables.lisp @@ -0,0 +1,101 @@ +(in-package :alexandria) + +(defmacro ensure-gethash (key hash-table &optional default) + "Like GETHASH, but if KEY is not found in the HASH-TABLE saves the DEFAULT +under key before returning it. Secondary return value is true if key was +already in the table." + (once-only (key hash-table) + (with-unique-names (value presentp) + `(multiple-value-bind (,value ,presentp) (gethash ,key ,hash-table) + (if ,presentp + (values ,value ,presentp) + (values (setf (gethash ,key ,hash-table) ,default) nil)))))) + +(defun copy-hash-table (table &key key test size + rehash-size rehash-threshold) + "Returns a copy of hash table TABLE, with the same keys and values +as the TABLE. The copy has the same properties as the original, unless +overridden by the keyword arguments. + +Before each of the original values is set into the new hash-table, KEY +is invoked on the value. As KEY defaults to CL:IDENTITY, a shallow +copy is returned by default." + (setf key (or key 'identity)) + (setf test (or test (hash-table-test table))) + (setf size (or size (hash-table-size table))) + (setf rehash-size (or rehash-size (hash-table-rehash-size table))) + (setf rehash-threshold (or rehash-threshold (hash-table-rehash-threshold table))) + (let ((copy (make-hash-table :test test :size size + :rehash-size rehash-size + :rehash-threshold rehash-threshold))) + (maphash (lambda (k v) + (setf (gethash k copy) (funcall key v))) + table) + copy)) + +(declaim (inline maphash-keys)) +(defun maphash-keys (function table) + "Like MAPHASH, but calls FUNCTION with each key in the hash table TABLE." + (maphash (lambda (k v) + (declare (ignore v)) + (funcall function k)) + table)) + +(declaim (inline maphash-values)) +(defun maphash-values (function table) + "Like MAPHASH, but calls FUNCTION with each value in the hash table TABLE." + (maphash (lambda (k v) + (declare (ignore k)) + (funcall function v)) + table)) + +(defun hash-table-keys (table) + "Returns a list containing the keys of hash table TABLE." + (let ((keys nil)) + (maphash-keys (lambda (k) + (push k keys)) + table) + keys)) + +(defun hash-table-values (table) + "Returns a list containing the values of hash table TABLE." + (let ((values nil)) + (maphash-values (lambda (v) + (push v values)) + table) + values)) + +(defun hash-table-alist (table) + "Returns an association list containing the keys and values of hash table +TABLE." + (let ((alist nil)) + (maphash (lambda (k v) + (push (cons k v) alist)) + table) + alist)) + +(defun hash-table-plist (table) + "Returns a property list containing the keys and values of hash table +TABLE." + (let ((plist nil)) + (maphash (lambda (k v) + (setf plist (list* k v plist))) + table) + plist)) + +(defun alist-hash-table (alist &rest hash-table-initargs) + "Returns a hash table containing the keys and values of the association list +ALIST. Hash table is initialized using the HASH-TABLE-INITARGS." + (let ((table (apply #'make-hash-table hash-table-initargs))) + (dolist (cons alist) + (ensure-gethash (car cons) table (cdr cons))) + table)) + +(defun plist-hash-table (plist &rest hash-table-initargs) + "Returns a hash table containing the keys and values of the property list +PLIST. Hash table is initialized using the HASH-TABLE-INITARGS." + (let ((table (apply #'make-hash-table hash-table-initargs))) + (do ((tail plist (cddr tail))) + ((not tail)) + (ensure-gethash (car tail) table (cadr tail))) + table)) diff --git a/third_party/lisp/alexandria/io.lisp b/third_party/lisp/alexandria/io.lisp new file mode 100644 index 0000000000..28bf5e6d82 --- /dev/null +++ b/third_party/lisp/alexandria/io.lisp @@ -0,0 +1,172 @@ +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. + +(in-package :alexandria) + +(defmacro with-open-file* ((stream filespec &key direction element-type + if-exists if-does-not-exist external-format) + &body body) + "Just like WITH-OPEN-FILE, but NIL values in the keyword arguments mean to use +the default value specified for OPEN." + (once-only (direction element-type if-exists if-does-not-exist external-format) + `(with-open-stream + (,stream (apply #'open ,filespec + (append + (when ,direction + (list :direction ,direction)) + (when ,element-type + (list :element-type ,element-type)) + (when ,if-exists + (list :if-exists ,if-exists)) + (when ,if-does-not-exist + (list :if-does-not-exist ,if-does-not-exist)) + (when ,external-format + (list :external-format ,external-format))))) + ,@body))) + +(defmacro with-input-from-file ((stream-name file-name &rest args + &key (direction nil direction-p) + &allow-other-keys) + &body body) + "Evaluate BODY with STREAM-NAME to an input stream on the file +FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT, +which is only sent to WITH-OPEN-FILE when it's not NIL." + (declare (ignore direction)) + (when direction-p + (error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE.")) + `(with-open-file* (,stream-name ,file-name :direction :input ,@args) + ,@body)) + +(defmacro with-output-to-file ((stream-name file-name &rest args + &key (direction nil direction-p) + &allow-other-keys) + &body body) + "Evaluate BODY with STREAM-NAME to an output stream on the file +FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT, +which is only sent to WITH-OPEN-FILE when it's not NIL." + (declare (ignore direction)) + (when direction-p + (error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE.")) + `(with-open-file* (,stream-name ,file-name :direction :output ,@args) + ,@body)) + +(defun read-stream-content-into-string (stream &key (buffer-size 4096)) + "Return the \"content\" of STREAM as a fresh string." + (check-type buffer-size positive-integer) + (let ((*print-pretty* nil)) + (with-output-to-string (datum) + (let ((buffer (make-array buffer-size :element-type 'character))) + (loop + :for bytes-read = (read-sequence buffer stream) + :do (write-sequence buffer datum :start 0 :end bytes-read) + :while (= bytes-read buffer-size)))))) + +(defun read-file-into-string (pathname &key (buffer-size 4096) external-format) + "Return the contents of the file denoted by PATHNAME as a fresh string. + +The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE +unless it's NIL, which means the system default." + (with-input-from-file + (file-stream pathname :external-format external-format) + (read-stream-content-into-string file-stream :buffer-size buffer-size))) + +(defun write-string-into-file (string pathname &key (if-exists :error) + if-does-not-exist + external-format) + "Write STRING to PATHNAME. + +The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE +unless it's NIL, which means the system default." + (with-output-to-file (file-stream pathname :if-exists if-exists + :if-does-not-exist if-does-not-exist + :external-format external-format) + (write-sequence string file-stream))) + +(defun read-stream-content-into-byte-vector (stream &key ((%length length)) + (initial-size 4096)) + "Return \"content\" of STREAM as freshly allocated (unsigned-byte 8) vector." + (check-type length (or null non-negative-integer)) + (check-type initial-size positive-integer) + (do ((buffer (make-array (or length initial-size) + :element-type '(unsigned-byte 8))) + (offset 0) + (offset-wanted 0)) + ((or (/= offset-wanted offset) + (and length (>= offset length))) + (if (= offset (length buffer)) + buffer + (subseq buffer 0 offset))) + (unless (zerop offset) + (let ((new-buffer (make-array (* 2 (length buffer)) + :element-type '(unsigned-byte 8)))) + (replace new-buffer buffer) + (setf buffer new-buffer))) + (setf offset-wanted (length buffer) + offset (read-sequence buffer stream :start offset)))) + +(defun read-file-into-byte-vector (pathname) + "Read PATHNAME into a freshly allocated (unsigned-byte 8) vector." + (with-input-from-file (stream pathname :element-type '(unsigned-byte 8)) + (read-stream-content-into-byte-vector stream '%length (file-length stream)))) + +(defun write-byte-vector-into-file (bytes pathname &key (if-exists :error) + if-does-not-exist) + "Write BYTES to PATHNAME." + (check-type bytes (vector (unsigned-byte 8))) + (with-output-to-file (stream pathname :if-exists if-exists + :if-does-not-exist if-does-not-exist + :element-type '(unsigned-byte 8)) + (write-sequence bytes stream))) + +(defun copy-file (from to &key (if-to-exists :supersede) + (element-type '(unsigned-byte 8)) finish-output) + (with-input-from-file (input from :element-type element-type) + (with-output-to-file (output to :element-type element-type + :if-exists if-to-exists) + (copy-stream input output + :element-type element-type + :finish-output finish-output)))) + +(defun copy-stream (input output &key (element-type (stream-element-type input)) + (buffer-size 4096) + (buffer (make-array buffer-size :element-type element-type)) + (start 0) end + finish-output) + "Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must +be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have +compatible element-types." + (check-type start non-negative-integer) + (check-type end (or null non-negative-integer)) + (check-type buffer-size positive-integer) + (when (and end + (< end start)) + (error "END is smaller than START in ~S" 'copy-stream)) + (let ((output-position 0) + (input-position 0)) + (unless (zerop start) + ;; FIXME add platform specific optimization to skip seekable streams + (loop while (< input-position start) + do (let ((n (read-sequence buffer input + :end (min (length buffer) + (- start input-position))))) + (when (zerop n) + (error "~@<Could not read enough bytes from the input to fulfill ~ + the :START ~S requirement in ~S.~:@>" 'copy-stream start)) + (incf input-position n)))) + (assert (= input-position start)) + (loop while (or (null end) (< input-position end)) + do (let ((n (read-sequence buffer input + :end (when end + (min (length buffer) + (- end input-position)))))) + (when (zerop n) + (if end + (error "~@<Could not read enough bytes from the input to fulfill ~ + the :END ~S requirement in ~S.~:@>" 'copy-stream end) + (return))) + (incf input-position n) + (write-sequence buffer output :end n) + (incf output-position n))) + (when finish-output + (finish-output output)) + output-position)) diff --git a/third_party/lisp/alexandria/lists.lisp b/third_party/lisp/alexandria/lists.lisp new file mode 100644 index 0000000000..51286071eb --- /dev/null +++ b/third_party/lisp/alexandria/lists.lisp @@ -0,0 +1,367 @@ +(in-package :alexandria) + +(declaim (inline safe-endp)) +(defun safe-endp (x) + (declare (optimize safety)) + (endp x)) + +(defun alist-plist (alist) + "Returns a property list containing the same keys and values as the +association list ALIST in the same order." + (let (plist) + (dolist (pair alist) + (push (car pair) plist) + (push (cdr pair) plist)) + (nreverse plist))) + +(defun plist-alist (plist) + "Returns an association list containing the same keys and values as the +property list PLIST in the same order." + (let (alist) + (do ((tail plist (cddr tail))) + ((safe-endp tail) (nreverse alist)) + (push (cons (car tail) (cadr tail)) alist)))) + +(declaim (inline racons)) +(defun racons (key value ralist) + (acons value key ralist)) + +(macrolet + ((define-alist-get (name get-entry get-value-from-entry add doc) + `(progn + (declaim (inline ,name)) + (defun ,name (alist key &key (test 'eql)) + ,doc + (let ((entry (,get-entry key alist :test test))) + (values (,get-value-from-entry entry) entry))) + (define-setf-expander ,name (place key &key (test ''eql) + &environment env) + (multiple-value-bind + (temporary-variables initforms newvals setter getter) + (get-setf-expansion place env) + (when (cdr newvals) + (error "~A cannot store multiple values in one place" ',name)) + (with-unique-names (new-value key-val test-val alist entry) + (values + (append temporary-variables + (list alist + key-val + test-val + entry)) + (append initforms + (list getter + key + test + `(,',get-entry ,key-val ,alist :test ,test-val))) + `(,new-value) + `(cond + (,entry + (setf (,',get-value-from-entry ,entry) ,new-value)) + (t + (let ,newvals + (setf ,(first newvals) (,',add ,key ,new-value ,alist)) + ,setter + ,new-value))) + `(,',get-value-from-entry ,entry)))))))) + (define-alist-get assoc-value assoc cdr acons +"ASSOC-VALUE is an alist accessor very much like ASSOC, but it can +be used with SETF.") + (define-alist-get rassoc-value rassoc car racons +"RASSOC-VALUE is an alist accessor very much like RASSOC, but it can +be used with SETF.")) + +(defun malformed-plist (plist) + (error "Malformed plist: ~S" plist)) + +(defmacro doplist ((key val plist &optional values) &body body) + "Iterates over elements of PLIST. BODY can be preceded by +declarations, and is like a TAGBODY. RETURN may be used to terminate +the iteration early. If RETURN is not used, returns VALUES." + (multiple-value-bind (forms declarations) (parse-body body) + (with-gensyms (tail loop results) + `(block nil + (flet ((,results () + (let (,key ,val) + (declare (ignorable ,key ,val)) + (return ,values)))) + (let* ((,tail ,plist) + (,key (if ,tail + (pop ,tail) + (,results))) + (,val (if ,tail + (pop ,tail) + (malformed-plist ',plist)))) + (declare (ignorable ,key ,val)) + ,@declarations + (tagbody + ,loop + ,@forms + (setf ,key (if ,tail + (pop ,tail) + (,results)) + ,val (if ,tail + (pop ,tail) + (malformed-plist ',plist))) + (go ,loop)))))))) + +(define-modify-macro appendf (&rest lists) append + "Modify-macro for APPEND. Appends LISTS to the place designated by the first +argument.") + +(define-modify-macro nconcf (&rest lists) nconc + "Modify-macro for NCONC. Concatenates LISTS to place designated by the first +argument.") + +(define-modify-macro unionf (list &rest args) union + "Modify-macro for UNION. Saves the union of LIST and the contents of the +place designated by the first argument to the designated place.") + +(define-modify-macro nunionf (list &rest args) nunion + "Modify-macro for NUNION. Saves the union of LIST and the contents of the +place designated by the first argument to the designated place. May modify +either argument.") + +(define-modify-macro reversef () reverse + "Modify-macro for REVERSE. Copies and reverses the list stored in the given +place and saves back the result into the place.") + +(define-modify-macro nreversef () nreverse + "Modify-macro for NREVERSE. Reverses the list stored in the given place by +destructively modifying it and saves back the result into the place.") + +(defun circular-list (&rest elements) + "Creates a circular list of ELEMENTS." + (let ((cycle (copy-list elements))) + (nconc cycle cycle))) + +(defun circular-list-p (object) + "Returns true if OBJECT is a circular list, NIL otherwise." + (and (listp object) + (do ((fast object (cddr fast)) + (slow (cons (car object) (cdr object)) (cdr slow))) + (nil) + (unless (and (consp fast) (listp (cdr fast))) + (return nil)) + (when (eq fast slow) + (return t))))) + +(defun circular-tree-p (object) + "Returns true if OBJECT is a circular tree, NIL otherwise." + (labels ((circularp (object seen) + (and (consp object) + (do ((fast (cons (car object) (cdr object)) (cddr fast)) + (slow object (cdr slow))) + (nil) + (when (or (eq fast slow) (member slow seen)) + (return-from circular-tree-p t)) + (when (or (not (consp fast)) (not (consp (cdr slow)))) + (return + (do ((tail object (cdr tail))) + ((not (consp tail)) + nil) + (let ((elt (car tail))) + (circularp elt (cons object seen)))))))))) + (circularp object nil))) + +(defun proper-list-p (object) + "Returns true if OBJECT is a proper list." + (cond ((not object) + t) + ((consp object) + (do ((fast object (cddr fast)) + (slow (cons (car object) (cdr object)) (cdr slow))) + (nil) + (unless (and (listp fast) (consp (cdr fast))) + (return (and (listp fast) (not (cdr fast))))) + (when (eq fast slow) + (return nil)))) + (t + nil))) + +(deftype proper-list () + "Type designator for proper lists. Implemented as a SATISFIES type, hence +not recommended for performance intensive use. Main usefullness as a type +designator of the expected type in a TYPE-ERROR." + `(and list (satisfies proper-list-p))) + +(defun circular-list-error (list) + (error 'type-error + :datum list + :expected-type '(and list (not circular-list)))) + +(macrolet ((def (name lambda-list doc step declare ret1 ret2) + (assert (member 'list lambda-list)) + `(defun ,name ,lambda-list + ,doc + (do ((last list fast) + (fast list (cddr fast)) + (slow (cons (car list) (cdr list)) (cdr slow)) + ,@(when step (list step))) + (nil) + (declare (dynamic-extent slow) ,@(when declare (list declare)) + (ignorable last)) + (when (safe-endp fast) + (return ,ret1)) + (when (safe-endp (cdr fast)) + (return ,ret2)) + (when (eq fast slow) + (circular-list-error list)))))) + (def proper-list-length (list) + "Returns length of LIST, signalling an error if it is not a proper list." + (n 1 (+ n 2)) + ;; KLUDGE: Most implementations don't actually support lists with bignum + ;; elements -- and this is WAY faster on most implementations then declaring + ;; N to be an UNSIGNED-BYTE. + (fixnum n) + (1- n) + n) + + (def lastcar (list) + "Returns the last element of LIST. Signals a type-error if LIST is not a +proper list." + nil + nil + (cadr last) + (car fast)) + + (def (setf lastcar) (object list) + "Sets the last element of LIST. Signals a type-error if LIST is not a proper +list." + nil + nil + (setf (cadr last) object) + (setf (car fast) object))) + +(defun make-circular-list (length &key initial-element) + "Creates a circular list of LENGTH with the given INITIAL-ELEMENT." + (let ((cycle (make-list length :initial-element initial-element))) + (nconc cycle cycle))) + +(deftype circular-list () + "Type designator for circular lists. Implemented as a SATISFIES type, so not +recommended for performance intensive use. Main usefullness as the +expected-type designator of a TYPE-ERROR." + `(satisfies circular-list-p)) + +(defun ensure-car (thing) + "If THING is a CONS, its CAR is returned. Otherwise THING is returned." + (if (consp thing) + (car thing) + thing)) + +(defun ensure-cons (cons) + "If CONS is a cons, it is returned. Otherwise returns a fresh cons with CONS + in the car, and NIL in the cdr." + (if (consp cons) + cons + (cons cons nil))) + +(defun ensure-list (list) + "If LIST is a list, it is returned. Otherwise returns the list designated by LIST." + (if (listp list) + list + (list list))) + +(defun remove-from-plist (plist &rest keys) + "Returns a propery-list with same keys and values as PLIST, except that keys +in the list designated by KEYS and values corresponding to them are removed. +The returned property-list may share structure with the PLIST, but PLIST is +not destructively modified. Keys are compared using EQ." + (declare (optimize (speed 3))) + ;; FIXME: possible optimization: (remove-from-plist '(:x 0 :a 1 :b 2) :a) + ;; could return the tail without consing up a new list. + (loop for (key . rest) on plist by #'cddr + do (assert rest () "Expected a proper plist, got ~S" plist) + unless (member key keys :test #'eq) + collect key and collect (first rest))) + +(defun delete-from-plist (plist &rest keys) + "Just like REMOVE-FROM-PLIST, but this version may destructively modify the +provided PLIST." + (declare (optimize speed)) + (loop with head = plist + with tail = nil ; a nil tail means an empty result so far + for (key . rest) on plist by #'cddr + do (assert rest () "Expected a proper plist, got ~S" plist) + (if (member key keys :test #'eq) + ;; skip over this pair + (let ((next (cdr rest))) + (if tail + (setf (cdr tail) next) + (setf head next))) + ;; keep this pair + (setf tail rest)) + finally (return head))) + +(define-modify-macro remove-from-plistf (&rest keys) remove-from-plist + "Modify macro for REMOVE-FROM-PLIST.") +(define-modify-macro delete-from-plistf (&rest keys) delete-from-plist + "Modify macro for DELETE-FROM-PLIST.") + +(declaim (inline sans)) +(defun sans (plist &rest keys) + "Alias of REMOVE-FROM-PLIST for backward compatibility." + (apply #'remove-from-plist plist keys)) + +(defun mappend (function &rest lists) + "Applies FUNCTION to respective element(s) of each LIST, appending all the +all the result list to a single list. FUNCTION must return a list." + (loop for results in (apply #'mapcar function lists) + append results)) + +(defun setp (object &key (test #'eql) (key #'identity)) + "Returns true if OBJECT is a list that denotes a set, NIL otherwise. A list +denotes a set if each element of the list is unique under KEY and TEST." + (and (listp object) + (let (seen) + (dolist (elt object t) + (let ((key (funcall key elt))) + (if (member key seen :test test) + (return nil) + (push key seen))))))) + +(defun set-equal (list1 list2 &key (test #'eql) (key nil keyp)) + "Returns true if every element of LIST1 matches some element of LIST2 and +every element of LIST2 matches some element of LIST1. Otherwise returns false." + (let ((keylist1 (if keyp (mapcar key list1) list1)) + (keylist2 (if keyp (mapcar key list2) list2))) + (and (dolist (elt keylist1 t) + (or (member elt keylist2 :test test) + (return nil))) + (dolist (elt keylist2 t) + (or (member elt keylist1 :test test) + (return nil)))))) + +(defun map-product (function list &rest more-lists) + "Returns a list containing the results of calling FUNCTION with one argument +from LIST, and one from each of MORE-LISTS for each combination of arguments. +In other words, returns the product of LIST and MORE-LISTS using FUNCTION. + +Example: + + (map-product 'list '(1 2) '(3 4) '(5 6)) + => ((1 3 5) (1 3 6) (1 4 5) (1 4 6) + (2 3 5) (2 3 6) (2 4 5) (2 4 6)) +" + (labels ((%map-product (f lists) + (let ((more (cdr lists)) + (one (car lists))) + (if (not more) + (mapcar f one) + (mappend (lambda (x) + (%map-product (curry f x) more)) + one))))) + (%map-product (ensure-function function) (cons list more-lists)))) + +(defun flatten (tree) + "Traverses the tree in order, collecting non-null leaves into a list." + (let (list) + (labels ((traverse (subtree) + (when subtree + (if (consp subtree) + (progn + (traverse (car subtree)) + (traverse (cdr subtree))) + (push subtree list))))) + (traverse tree)) + (nreverse list))) diff --git a/third_party/lisp/alexandria/macros.lisp b/third_party/lisp/alexandria/macros.lisp new file mode 100644 index 0000000000..4364ad63b8 --- /dev/null +++ b/third_party/lisp/alexandria/macros.lisp @@ -0,0 +1,370 @@ +(in-package :alexandria) + +(defmacro with-gensyms (names &body forms) + "Binds a set of variables to gensyms and evaluates the implicit progn FORMS. + +Each element within NAMES is either a symbol SYMBOL or a pair (SYMBOL +STRING-DESIGNATOR). Bare symbols are equivalent to the pair (SYMBOL SYMBOL). + +Each pair (SYMBOL STRING-DESIGNATOR) specifies that the variable named by SYMBOL +should be bound to a symbol constructed using GENSYM with the string designated +by STRING-DESIGNATOR being its first argument." + `(let ,(mapcar (lambda (name) + (multiple-value-bind (symbol string) + (etypecase name + (symbol + (values name (symbol-name name))) + ((cons symbol (cons string-designator null)) + (values (first name) (string (second name))))) + `(,symbol (gensym ,string)))) + names) + ,@forms)) + +(defmacro with-unique-names (names &body forms) + "Alias for WITH-GENSYMS." + `(with-gensyms ,names ,@forms)) + +(defmacro once-only (specs &body forms) + "Constructs code whose primary goal is to help automate the handling of +multiple evaluation within macros. Multiple evaluation is handled by introducing +intermediate variables, in order to reuse the result of an expression. + +The returned value is a list of the form + + (let ((<gensym-1> <expr-1>) + ... + (<gensym-n> <expr-n>)) + <res>) + +where GENSYM-1, ..., GENSYM-N are the intermediate variables introduced in order +to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the result of +evaluating the implicit progn FORMS within a special context determined by +SPECS. RES should make use of (reference) the intermediate variables. + +Each element within SPECS is either a symbol SYMBOL or a pair (SYMBOL INITFORM). +Bare symbols are equivalent to the pair (SYMBOL SYMBOL). + +Each pair (SYMBOL INITFORM) specifies a single intermediate variable: + +- INITFORM is an expression evaluated to produce EXPR-i + +- SYMBOL is the name of the variable that will be bound around FORMS to the + corresponding gensym GENSYM-i, in order for FORMS to generate RES that + references the intermediate variable + +The evaluation of INITFORMs and binding of SYMBOLs resembles LET. INITFORMs of +all the pairs are evaluated before binding SYMBOLs and evaluating FORMS. + +Example: + + The following expression + + (let ((x '(incf y))) + (once-only (x) + `(cons ,x ,x))) + + ;;; => + ;;; (let ((#1=#:X123 (incf y))) + ;;; (cons #1# #1#)) + + could be used within a macro to avoid multiple evaluation like so + + (defmacro cons1 (x) + (once-only (x) + `(cons ,x ,x))) + + (let ((y 0)) + (cons1 (incf y))) + + ;;; => (1 . 1) + +Example: + + The following expression demonstrates the usage of the INITFORM field + + (let ((expr '(incf y))) + (once-only ((var `(1+ ,expr))) + `(list ',expr ,var ,var))) + + ;;; => + ;;; (let ((#1=#:VAR123 (1+ (incf y)))) + ;;; (list '(incf y) #1# #1)) + + which could be used like so + + (defmacro print-succ-twice (expr) + (once-only ((var `(1+ ,expr))) + `(format t \"Expr: ~s, Once: ~s, Twice: ~s~%\" ',expr ,var ,var))) + + (let ((y 10)) + (print-succ-twice (incf y))) + + ;;; >> + ;;; Expr: (INCF Y), Once: 12, Twice: 12" + (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY")) + (names-and-forms (mapcar (lambda (spec) + (etypecase spec + (list + (destructuring-bind (name form) spec + (cons name form))) + (symbol + (cons spec spec)))) + specs))) + ;; bind in user-macro + `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n))))) + gensyms names-and-forms) + ;; bind in final expansion + `(let (,,@(mapcar (lambda (g n) + ``(,,g ,,(cdr n))) + gensyms names-and-forms)) + ;; bind in user-macro + ,(let ,(mapcar (lambda (n g) (list (car n) g)) + names-and-forms gensyms) + ,@forms))))) + +(defun parse-body (body &key documentation whole) + "Parses BODY into (values remaining-forms declarations doc-string). +Documentation strings are recognized only if DOCUMENTATION is true. +Syntax errors in body are signalled and WHOLE is used in the signal +arguments when given." + (let ((doc nil) + (decls nil) + (current nil)) + (tagbody + :declarations + (setf current (car body)) + (when (and documentation (stringp current) (cdr body)) + (if doc + (error "Too many documentation strings in ~S." (or whole body)) + (setf doc (pop body))) + (go :declarations)) + (when (and (listp current) (eql (first current) 'declare)) + (push (pop body) decls) + (go :declarations))) + (values body (nreverse decls) doc))) + +(defun parse-ordinary-lambda-list (lambda-list &key (normalize t) + allow-specializers + (normalize-optional normalize) + (normalize-keyword normalize) + (normalize-auxilary normalize)) + "Parses an ordinary lambda-list, returning as multiple values: + +1. Required parameters. + +2. Optional parameter specifications, normalized into form: + + (name init suppliedp) + +3. Name of the rest parameter, or NIL. + +4. Keyword parameter specifications, normalized into form: + + ((keyword-name name) init suppliedp) + +5. Boolean indicating &ALLOW-OTHER-KEYS presence. + +6. &AUX parameter specifications, normalized into form + + (name init). + +7. Existence of &KEY in the lambda-list. + +Signals a PROGRAM-ERROR is the lambda-list is malformed." + (let ((state :required) + (allow-other-keys nil) + (auxp nil) + (required nil) + (optional nil) + (rest nil) + (keys nil) + (keyp nil) + (aux nil)) + (labels ((fail (elt) + (simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S" + elt lambda-list)) + (check-variable (elt what &optional (allow-specializers allow-specializers)) + (unless (and (or (symbolp elt) + (and allow-specializers + (consp elt) (= 2 (length elt)) (symbolp (first elt)))) + (not (constantp elt))) + (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S" + what elt lambda-list))) + (check-spec (spec what) + (destructuring-bind (init suppliedp) spec + (declare (ignore init)) + (check-variable suppliedp what nil)))) + (dolist (elt lambda-list) + (case elt + (&optional + (if (eq state :required) + (setf state elt) + (fail elt))) + (&rest + (if (member state '(:required &optional)) + (setf state elt) + (fail elt))) + (&key + (if (member state '(:required &optional :after-rest)) + (setf state elt) + (fail elt)) + (setf keyp t)) + (&allow-other-keys + (if (eq state '&key) + (setf allow-other-keys t + state elt) + (fail elt))) + (&aux + (cond ((eq state '&rest) + (fail elt)) + (auxp + (simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S" + elt lambda-list)) + (t + (setf auxp t + state elt)) + )) + (otherwise + (when (member elt '#.(set-difference lambda-list-keywords + '(&optional &rest &key &allow-other-keys &aux))) + (simple-program-error + "Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S" + elt lambda-list)) + (case state + (:required + (check-variable elt "required parameter") + (push elt required)) + (&optional + (cond ((consp elt) + (destructuring-bind (name &rest tail) elt + (check-variable name "optional parameter") + (cond ((cdr tail) + (check-spec tail "optional-supplied-p parameter")) + ((and normalize-optional tail) + (setf elt (append elt '(nil)))) + (normalize-optional + (setf elt (append elt '(nil nil))))))) + (t + (check-variable elt "optional parameter") + (when normalize-optional + (setf elt (cons elt '(nil nil)))))) + (push (ensure-list elt) optional)) + (&rest + (check-variable elt "rest parameter") + (setf rest elt + state :after-rest)) + (&key + (cond ((consp elt) + (destructuring-bind (var-or-kv &rest tail) elt + (cond ((consp var-or-kv) + (destructuring-bind (keyword var) var-or-kv + (unless (symbolp keyword) + (simple-program-error "Invalid keyword name ~S in ordinary ~ + lambda-list:~% ~S" + keyword lambda-list)) + (check-variable var "keyword parameter"))) + (t + (check-variable var-or-kv "keyword parameter") + (when normalize-keyword + (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv))))) + (cond ((cdr tail) + (check-spec tail "keyword-supplied-p parameter")) + ((and normalize-keyword tail) + (setf tail (append tail '(nil)))) + (normalize-keyword + (setf tail '(nil nil)))) + (setf elt (cons var-or-kv tail)))) + (t + (check-variable elt "keyword parameter") + (setf elt (if normalize-keyword + (list (list (make-keyword elt) elt) nil nil) + elt)))) + (push elt keys)) + (&aux + (if (consp elt) + (destructuring-bind (var &optional init) elt + (declare (ignore init)) + (check-variable var "&aux parameter")) + (progn + (check-variable elt "&aux parameter") + (setf elt (list* elt (when normalize-auxilary + '(nil)))))) + (push elt aux)) + (t + (simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list))))))) + (values (nreverse required) (nreverse optional) rest (nreverse keys) + allow-other-keys (nreverse aux) keyp))) + +;;;; DESTRUCTURING-*CASE + +(defun expand-destructuring-case (key clauses case) + (once-only (key) + `(if (typep ,key 'cons) + (,case (car ,key) + ,@(mapcar (lambda (clause) + (destructuring-bind ((keys . lambda-list) &body body) clause + `(,keys + (destructuring-bind ,lambda-list (cdr ,key) + ,@body)))) + clauses)) + (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key)))) + +(defmacro destructuring-case (keyform &body clauses) + "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND. +KEYFORM must evaluate to a CONS. + +Clauses are of the form: + + ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*) + +The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE, +is selected, and FORMs are then executed with CDR of KEY is destructured and +bound by the DESTRUCTURING-LAMBDA-LIST. + +Example: + + (defun dcase (x) + (destructuring-case x + ((:foo a b) + (format nil \"foo: ~S, ~S\" a b)) + ((:bar &key a b) + (format nil \"bar: ~S, ~S\" a b)) + (((:alt1 :alt2) a) + (format nil \"alt: ~S\" a)) + ((t &rest rest) + (format nil \"unknown: ~S\" rest)))) + + (dcase (list :foo 1 2)) ; => \"foo: 1, 2\" + (dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\" + (dcase (list :alt1 1)) ; => \"alt: 1\" + (dcase (list :alt2 2)) ; => \"alt: 2\" + (dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\" + + (defun decase (x) + (destructuring-case x + ((:foo a b) + (format nil \"foo: ~S, ~S\" a b)) + ((:bar &key a b) + (format nil \"bar: ~S, ~S\" a b)) + (((:alt1 :alt2) a) + (format nil \"alt: ~S\" a)))) + + (decase (list :foo 1 2)) ; => \"foo: 1, 2\" + (decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\" + (decase (list :alt1 1)) ; => \"alt: 1\" + (decase (list :alt2 2)) ; => \"alt: 2\" + (decase (list :quux 1 2 3)) ; =| error +" + (expand-destructuring-case keyform clauses 'case)) + +(defmacro destructuring-ccase (keyform &body clauses) + (expand-destructuring-case keyform clauses 'ccase)) + +(defmacro destructuring-ecase (keyform &body clauses) + (expand-destructuring-case keyform clauses 'ecase)) + +(dolist (name '(destructuring-ccase destructuring-ecase)) + (setf (documentation name 'function) (documentation 'destructuring-case 'function))) + + + diff --git a/third_party/lisp/alexandria/numbers.lisp b/third_party/lisp/alexandria/numbers.lisp new file mode 100644 index 0000000000..1c06f71d50 --- /dev/null +++ b/third_party/lisp/alexandria/numbers.lisp @@ -0,0 +1,295 @@ +(in-package :alexandria) + +(declaim (inline clamp)) +(defun clamp (number min max) + "Clamps the NUMBER into [min, max] range. Returns MIN if NUMBER is lesser then +MIN and MAX if NUMBER is greater then MAX, otherwise returns NUMBER." + (if (< number min) + min + (if (> number max) + max + number))) + +(defun gaussian-random (&optional min max) + "Returns two gaussian random double floats as the primary and secondary value, +optionally constrained by MIN and MAX. Gaussian random numbers form a standard +normal distribution around 0.0d0. + +Sufficiently positive MIN or negative MAX will cause the algorithm used to +take a very long time. If MIN is positive it should be close to zero, and +similarly if MAX is negative it should be close to zero." + (macrolet + ((valid (x) + `(<= (or min ,x) ,x (or max ,x)) )) + (labels + ((gauss () + (loop + for x1 = (- (random 2.0d0) 1.0d0) + for x2 = (- (random 2.0d0) 1.0d0) + for w = (+ (expt x1 2) (expt x2 2)) + when (< w 1.0d0) + do (let ((v (sqrt (/ (* -2.0d0 (log w)) w)))) + (return (values (* x1 v) (* x2 v)))))) + (guard (x) + (unless (valid x) + (tagbody + :retry + (multiple-value-bind (x1 x2) (gauss) + (when (valid x1) + (setf x x1) + (go :done)) + (when (valid x2) + (setf x x2) + (go :done)) + (go :retry)) + :done)) + x)) + (multiple-value-bind + (g1 g2) (gauss) + (values (guard g1) (guard g2)))))) + +(declaim (inline iota)) +(defun iota (n &key (start 0) (step 1)) + "Return a list of n numbers, starting from START (with numeric contagion +from STEP applied), each consequtive number being the sum of the previous one +and STEP. START defaults to 0 and STEP to 1. + +Examples: + + (iota 4) => (0 1 2 3) + (iota 3 :start 1 :step 1.0) => (1.0 2.0 3.0) + (iota 3 :start -1 :step -1/2) => (-1 -3/2 -2) +" + (declare (type (integer 0) n) (number start step)) + (loop ;; KLUDGE: get numeric contagion right for the first element too + for i = (+ (- (+ start step) step)) then (+ i step) + repeat n + collect i)) + +(declaim (inline map-iota)) +(defun map-iota (function n &key (start 0) (step 1)) + "Calls FUNCTION with N numbers, starting from START (with numeric contagion +from STEP applied), each consequtive number being the sum of the previous one +and STEP. START defaults to 0 and STEP to 1. Returns N. + +Examples: + + (map-iota #'print 3 :start 1 :step 1.0) => 3 + ;;; 1.0 + ;;; 2.0 + ;;; 3.0 +" + (declare (type (integer 0) n) (number start step)) + (loop ;; KLUDGE: get numeric contagion right for the first element too + for i = (+ start (- step step)) then (+ i step) + repeat n + do (funcall function i)) + n) + +(declaim (inline lerp)) +(defun lerp (v a b) + "Returns the result of linear interpolation between A and B, using the +interpolation coefficient V." + ;; The correct version is numerically stable, at the expense of an + ;; extra multiply. See (lerp 0.1 4 25) with (+ a (* v (- b a))). The + ;; unstable version can often be converted to a fast instruction on + ;; a lot of machines, though this is machine/implementation + ;; specific. As alexandria is more about correct code, than + ;; efficiency, and we're only talking about a single extra multiply, + ;; many would prefer the stable version + (+ (* (- 1.0 v) a) (* v b))) + +(declaim (inline mean)) +(defun mean (sample) + "Returns the mean of SAMPLE. SAMPLE must be a sequence of numbers." + (/ (reduce #'+ sample) (length sample))) + +(defun median (sample) + "Returns median of SAMPLE. SAMPLE must be a sequence of real numbers." + ;; Implements and uses the quick-select algorithm to find the median + ;; https://en.wikipedia.org/wiki/Quickselect + + (labels ((randint-in-range (start-int end-int) + "Returns a random integer in the specified range, inclusive" + (+ start-int (random (1+ (- end-int start-int))))) + (partition (vec start-i end-i) + "Implements the partition function, which performs a partial + sort of vec around the (randomly) chosen pivot. + Returns the index where the pivot element would be located + in a correctly-sorted array" + (if (= start-i end-i) + start-i + (let ((pivot-i (randint-in-range start-i end-i))) + (rotatef (aref vec start-i) (aref vec pivot-i)) + (let ((swap-i end-i)) + (loop for i from swap-i downto (1+ start-i) do + (when (>= (aref vec i) (aref vec start-i)) + (rotatef (aref vec i) (aref vec swap-i)) + (decf swap-i))) + (rotatef (aref vec swap-i) (aref vec start-i)) + swap-i))))) + + (let* ((vector (copy-sequence 'vector sample)) + (len (length vector)) + (mid-i (ash len -1)) + (i 0) + (j (1- len))) + + (loop for correct-pos = (partition vector i j) + while (/= correct-pos mid-i) do + (if (< correct-pos mid-i) + (setf i (1+ correct-pos)) + (setf j (1- correct-pos)))) + + (if (oddp len) + (aref vector mid-i) + (* 1/2 + (+ (aref vector mid-i) + (reduce #'max (make-array + mid-i + :displaced-to vector)))))))) + +(declaim (inline variance)) +(defun variance (sample &key (biased t)) + "Variance of SAMPLE. Returns the biased variance if BIASED is true (the default), +and the unbiased estimator of variance if BIASED is false. SAMPLE must be a +sequence of numbers." + (let ((mean (mean sample))) + (/ (reduce (lambda (a b) + (+ a (expt (- b mean) 2))) + sample + :initial-value 0) + (- (length sample) (if biased 0 1))))) + +(declaim (inline standard-deviation)) +(defun standard-deviation (sample &key (biased t)) + "Standard deviation of SAMPLE. Returns the biased standard deviation if +BIASED is true (the default), and the square root of the unbiased estimator +for variance if BIASED is false (which is not the same as the unbiased +estimator for standard deviation). SAMPLE must be a sequence of numbers." + (sqrt (variance sample :biased biased))) + +(define-modify-macro maxf (&rest numbers) max + "Modify-macro for MAX. Sets place designated by the first argument to the +maximum of its original value and NUMBERS.") + +(define-modify-macro minf (&rest numbers) min + "Modify-macro for MIN. Sets place designated by the first argument to the +minimum of its original value and NUMBERS.") + +;;;; Factorial + +;;; KLUDGE: This is really dependant on the numbers in question: for +;;; small numbers this is larger, and vice versa. Ideally instead of a +;;; constant we would have RANGE-FAST-TO-MULTIPLY-DIRECTLY-P. +(defconstant +factorial-bisection-range-limit+ 8) + +;;; KLUDGE: This is really platform dependant: ideally we would use +;;; (load-time-value (find-good-direct-multiplication-limit)) instead. +(defconstant +factorial-direct-multiplication-limit+ 13) + +(defun %multiply-range (i j) + ;; We use a a bit of cleverness here: + ;; + ;; 1. For large factorials we bisect in order to avoid expensive bignum + ;; multiplications: 1 x 2 x 3 x ... runs into bignums pretty soon, + ;; and once it does that all further multiplications will be with bignums. + ;; + ;; By instead doing the multiplication in a tree like + ;; ((1 x 2) x (3 x 4)) x ((5 x 6) x (7 x 8)) + ;; we manage to get less bignums. + ;; + ;; 2. Division isn't exactly free either, however, so we don't bisect + ;; all the way down, but multiply ranges of integers close to each + ;; other directly. + ;; + ;; For even better results it should be possible to use prime + ;; factorization magic, but Nikodemus ran out of steam. + ;; + ;; KLUDGE: We support factorials of bignums, but it seems quite + ;; unlikely anyone would ever be able to use them on a modern lisp, + ;; since the resulting numbers are unlikely to fit in memory... but + ;; it would be extremely unelegant to define FACTORIAL only on + ;; fixnums, _and_ on lisps with 16 bit fixnums this can actually be + ;; needed. + (labels ((bisect (j k) + (declare (type (integer 1 #.most-positive-fixnum) j k)) + (if (< (- k j) +factorial-bisection-range-limit+) + (multiply-range j k) + (let ((middle (+ j (truncate (- k j) 2)))) + (* (bisect j middle) + (bisect (+ middle 1) k))))) + (bisect-big (j k) + (declare (type (integer 1) j k)) + (if (= j k) + j + (let ((middle (+ j (truncate (- k j) 2)))) + (* (if (<= middle most-positive-fixnum) + (bisect j middle) + (bisect-big j middle)) + (bisect-big (+ middle 1) k))))) + (multiply-range (j k) + (declare (type (integer 1 #.most-positive-fixnum) j k)) + (do ((f k (* f m)) + (m (1- k) (1- m))) + ((< m j) f) + (declare (type (integer 0 (#.most-positive-fixnum)) m) + (type unsigned-byte f))))) + (if (and (typep i 'fixnum) (typep j 'fixnum)) + (bisect i j) + (bisect-big i j)))) + +(declaim (inline factorial)) +(defun %factorial (n) + (if (< n 2) + 1 + (%multiply-range 1 n))) + +(defun factorial (n) + "Factorial of non-negative integer N." + (check-type n (integer 0)) + (%factorial n)) + +;;;; Combinatorics + +(defun binomial-coefficient (n k) + "Binomial coefficient of N and K, also expressed as N choose K. This is the +number of K element combinations given N choises. N must be equal to or +greater then K." + (check-type n (integer 0)) + (check-type k (integer 0)) + (assert (>= n k)) + (if (or (zerop k) (= n k)) + 1 + (let ((n-k (- n k))) + ;; Swaps K and N-K if K < N-K because the algorithm + ;; below is faster for bigger K and smaller N-K + (when (< k n-k) + (rotatef k n-k)) + (if (= 1 n-k) + n + ;; General case, avoid computing the 1x...xK twice: + ;; + ;; N! 1x...xN (K+1)x...xN + ;; -------- = ---------------- = ------------, N>1 + ;; K!(N-K)! 1x...xK x (N-K)! (N-K)! + (/ (%multiply-range (+ k 1) n) + (%factorial n-k)))))) + +(defun subfactorial (n) + "Subfactorial of the non-negative integer N." + (check-type n (integer 0)) + (if (zerop n) + 1 + (do ((x 1 (1+ x)) + (a 0 (* x (+ a b))) + (b 1 a)) + ((= n x) a)))) + +(defun count-permutations (n &optional (k n)) + "Number of K element permutations for a sequence of N objects. +K defaults to N" + (check-type n (integer 0)) + (check-type k (integer 0)) + (assert (>= n k)) + (%multiply-range (1+ (- n k)) n)) diff --git a/third_party/lisp/alexandria/package.lisp b/third_party/lisp/alexandria/package.lisp new file mode 100644 index 0000000000..f9d2014cd7 --- /dev/null +++ b/third_party/lisp/alexandria/package.lisp @@ -0,0 +1,243 @@ +(defpackage :alexandria.1.0.0 + (:nicknames :alexandria) + (:use :cl) + #+sb-package-locks + (:lock t) + (:export + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; BLESSED + ;; + ;; Binding constructs + #:if-let + #:when-let + #:when-let* + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; REVIEW IN PROGRESS + ;; + ;; Control flow + ;; + ;; -- no clear consensus yet -- + #:cswitch + #:eswitch + #:switch + ;; -- problem free? -- + #:multiple-value-prog2 + #:nth-value-or + #:whichever + #:xor + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; REVIEW PENDING + ;; + ;; Definitions + #:define-constant + ;; Hash tables + #:alist-hash-table + #:copy-hash-table + #:ensure-gethash + #:hash-table-alist + #:hash-table-keys + #:hash-table-plist + #:hash-table-values + #:maphash-keys + #:maphash-values + #:plist-hash-table + ;; Functions + #:compose + #:conjoin + #:curry + #:disjoin + #:ensure-function + #:ensure-functionf + #:multiple-value-compose + #:named-lambda + #:rcurry + ;; Lists + #:alist-plist + #:appendf + #:nconcf + #:reversef + #:nreversef + #:circular-list + #:circular-list-p + #:circular-tree-p + #:doplist + #:ensure-car + #:ensure-cons + #:ensure-list + #:flatten + #:lastcar + #:make-circular-list + #:map-product + #:mappend + #:nunionf + #:plist-alist + #:proper-list + #:proper-list-length + #:proper-list-p + #:remove-from-plist + #:remove-from-plistf + #:delete-from-plist + #:delete-from-plistf + #:set-equal + #:setp + #:unionf + ;; Numbers + #:binomial-coefficient + #:clamp + #:count-permutations + #:factorial + #:gaussian-random + #:iota + #:lerp + #:map-iota + #:maxf + #:mean + #:median + #:minf + #:standard-deviation + #:subfactorial + #:variance + ;; Arrays + #:array-index + #:array-length + #:copy-array + ;; Sequences + #:copy-sequence + #:deletef + #:emptyp + #:ends-with + #:ends-with-subseq + #:extremum + #:first-elt + #:last-elt + #:length= + #:map-combinations + #:map-derangements + #:map-permutations + #:proper-sequence + #:random-elt + #:removef + #:rotate + #:sequence-of-length-p + #:shuffle + #:starts-with + #:starts-with-subseq + ;; Macros + #:once-only + #:parse-body + #:parse-ordinary-lambda-list + #:with-gensyms + #:with-unique-names + ;; Symbols + #:ensure-symbol + #:format-symbol + #:make-gensym + #:make-gensym-list + #:make-keyword + ;; Strings + #:string-designator + ;; Types + #:negative-double-float + #:negative-fixnum-p + #:negative-float + #:negative-float-p + #:negative-long-float + #:negative-long-float-p + #:negative-rational + #:negative-rational-p + #:negative-real + #:negative-single-float-p + #:non-negative-double-float + #:non-negative-double-float-p + #:non-negative-fixnum + #:non-negative-fixnum-p + #:non-negative-float + #:non-negative-float-p + #:non-negative-integer-p + #:non-negative-long-float + #:non-negative-rational + #:non-negative-real-p + #:non-negative-short-float-p + #:non-negative-single-float + #:non-negative-single-float-p + #:non-positive-double-float + #:non-positive-double-float-p + #:non-positive-fixnum + #:non-positive-fixnum-p + #:non-positive-float + #:non-positive-float-p + #:non-positive-integer + #:non-positive-rational + #:non-positive-real + #:non-positive-real-p + #:non-positive-short-float + #:non-positive-short-float-p + #:non-positive-single-float-p + #:positive-double-float + #:positive-double-float-p + #:positive-fixnum + #:positive-fixnum-p + #:positive-float + #:positive-float-p + #:positive-integer + #:positive-rational + #:positive-real + #:positive-real-p + #:positive-short-float + #:positive-short-float-p + #:positive-single-float + #:positive-single-float-p + #:coercef + #:negative-double-float-p + #:negative-fixnum + #:negative-integer + #:negative-integer-p + #:negative-real-p + #:negative-short-float + #:negative-short-float-p + #:negative-single-float + #:non-negative-integer + #:non-negative-long-float-p + #:non-negative-rational-p + #:non-negative-real + #:non-negative-short-float + #:non-positive-integer-p + #:non-positive-long-float + #:non-positive-long-float-p + #:non-positive-rational-p + #:non-positive-single-float + #:of-type + #:positive-integer-p + #:positive-long-float + #:positive-long-float-p + #:positive-rational-p + #:type= + ;; Conditions + #:required-argument + #:ignore-some-conditions + #:simple-style-warning + #:simple-reader-error + #:simple-parse-error + #:simple-program-error + #:unwind-protect-case + ;; Features + #:featurep + ;; io + #:with-input-from-file + #:with-output-to-file + #:read-stream-content-into-string + #:read-file-into-string + #:write-string-into-file + #:read-stream-content-into-byte-vector + #:read-file-into-byte-vector + #:write-byte-vector-into-file + #:copy-stream + #:copy-file + ;; new additions collected at the end (subject to removal or further changes) + #:symbolicate + #:assoc-value + #:rassoc-value + #:destructuring-case + #:destructuring-ccase + #:destructuring-ecase + )) diff --git a/third_party/lisp/alexandria/sequences.lisp b/third_party/lisp/alexandria/sequences.lisp new file mode 100644 index 0000000000..21464f5376 --- /dev/null +++ b/third_party/lisp/alexandria/sequences.lisp @@ -0,0 +1,555 @@ +(in-package :alexandria) + +;; Make these inlinable by declaiming them INLINE here and some of them +;; NOTINLINE at the end of the file. Exclude functions that have a compiler +;; macro, because NOTINLINE is required to prevent compiler-macro expansion. +(declaim (inline copy-sequence sequence-of-length-p)) + +(defun sequence-of-length-p (sequence length) + "Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if +SEQUENCE is not a sequence. Returns FALSE for circular lists." + (declare (type array-index length) + #-lispworks (inline length) + (optimize speed)) + (etypecase sequence + (null + (zerop length)) + (cons + (let ((n (1- length))) + (unless (minusp n) + (let ((tail (nthcdr n sequence))) + (and tail + (null (cdr tail))))))) + (vector + (= length (length sequence))) + (sequence + (= length (length sequence))))) + +(defun rotate-tail-to-head (sequence n) + (declare (type (integer 1) n)) + (if (listp sequence) + (let ((m (mod n (proper-list-length sequence)))) + (if (null (cdr sequence)) + sequence + (let* ((tail (last sequence (+ m 1))) + (last (cdr tail))) + (setf (cdr tail) nil) + (nconc last sequence)))) + (let* ((len (length sequence)) + (m (mod n len)) + (tail (subseq sequence (- len m)))) + (replace sequence sequence :start1 m :start2 0) + (replace sequence tail) + sequence))) + +(defun rotate-head-to-tail (sequence n) + (declare (type (integer 1) n)) + (if (listp sequence) + (let ((m (mod (1- n) (proper-list-length sequence)))) + (if (null (cdr sequence)) + sequence + (let* ((headtail (nthcdr m sequence)) + (tail (cdr headtail))) + (setf (cdr headtail) nil) + (nconc tail sequence)))) + (let* ((len (length sequence)) + (m (mod n len)) + (head (subseq sequence 0 m))) + (replace sequence sequence :start1 0 :start2 m) + (replace sequence head :start1 (- len m)) + sequence))) + +(defun rotate (sequence &optional (n 1)) + "Returns a sequence of the same type as SEQUENCE, with the elements of +SEQUENCE rotated by N: N elements are moved from the end of the sequence to +the front if N is positive, and -N elements moved from the front to the end if +N is negative. SEQUENCE must be a proper sequence. N must be an integer, +defaulting to 1. + +If absolute value of N is greater then the length of the sequence, the results +are identical to calling ROTATE with + + (* (signum n) (mod n (length sequence))). + +Note: the original sequence may be destructively altered, and result sequence may +share structure with it." + (if (plusp n) + (rotate-tail-to-head sequence n) + (if (minusp n) + (rotate-head-to-tail sequence (- n)) + sequence))) + +(defun shuffle (sequence &key (start 0) end) + "Returns a random permutation of SEQUENCE bounded by START and END. +Original sequence may be destructively modified, and (if it contains +CONS or lists themselv) share storage with the original one. +Signals an error if SEQUENCE is not a proper sequence." + (declare (type fixnum start) + (type (or fixnum null) end)) + (etypecase sequence + (list + (let* ((end (or end (proper-list-length sequence))) + (n (- end start))) + (do ((tail (nthcdr start sequence) (cdr tail))) + ((zerop n)) + (rotatef (car tail) (car (nthcdr (random n) tail))) + (decf n)))) + (vector + (let ((end (or end (length sequence)))) + (loop for i from start below end + do (rotatef (aref sequence i) + (aref sequence (+ i (random (- end i)))))))) + (sequence + (let ((end (or end (length sequence)))) + (loop for i from (- end 1) downto start + do (rotatef (elt sequence i) + (elt sequence (+ i (random (- end i))))))))) + sequence) + +(defun random-elt (sequence &key (start 0) end) + "Returns a random element from SEQUENCE bounded by START and END. Signals an +error if the SEQUENCE is not a proper non-empty sequence, or if END and START +are not proper bounding index designators for SEQUENCE." + (declare (sequence sequence) (fixnum start) (type (or fixnum null) end)) + (let* ((size (if (listp sequence) + (proper-list-length sequence) + (length sequence))) + (end2 (or end size))) + (cond ((zerop size) + (error 'type-error + :datum sequence + :expected-type `(and sequence (not (satisfies emptyp))))) + ((not (and (<= 0 start) (< start end2) (<= end2 size))) + (error 'simple-type-error + :datum (cons start end) + :expected-type `(cons (integer 0 (,end2)) + (or null (integer (,start) ,size))) + :format-control "~@<~S and ~S are not valid bounding index designators for ~ + a sequence of length ~S.~:@>" + :format-arguments (list start end size))) + (t + (let ((index (+ start (random (- end2 start))))) + (elt sequence index)))))) + +(declaim (inline remove/swapped-arguments)) +(defun remove/swapped-arguments (sequence item &rest keyword-arguments) + (apply #'remove item sequence keyword-arguments)) + +(define-modify-macro removef (item &rest keyword-arguments) + remove/swapped-arguments + "Modify-macro for REMOVE. Sets place designated by the first argument to +the result of calling REMOVE with ITEM, place, and the KEYWORD-ARGUMENTS.") + +(declaim (inline delete/swapped-arguments)) +(defun delete/swapped-arguments (sequence item &rest keyword-arguments) + (apply #'delete item sequence keyword-arguments)) + +(define-modify-macro deletef (item &rest keyword-arguments) + delete/swapped-arguments + "Modify-macro for DELETE. Sets place designated by the first argument to +the result of calling DELETE with ITEM, place, and the KEYWORD-ARGUMENTS.") + +(deftype proper-sequence () + "Type designator for proper sequences, that is proper lists and sequences +that are not lists." + `(or proper-list + (and (not list) sequence))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (and (find-package '#:sequence) + (find-symbol (string '#:emptyp) '#:sequence)) + (pushnew 'sequence-emptyp *features*))) + +#-alexandria::sequence-emptyp +(defun emptyp (sequence) + "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE +is not a sequence." + (etypecase sequence + (list (null sequence)) + (sequence (zerop (length sequence))))) + +#+alexandria::sequence-emptyp +(declaim (ftype (function (sequence) (values boolean &optional)) emptyp)) +#+alexandria::sequence-emptyp +(setf (symbol-function 'emptyp) (symbol-function 'sequence:emptyp)) +#+alexandria::sequence-emptyp +(define-compiler-macro emptyp (sequence) + `(sequence:emptyp ,sequence)) + +(defun length= (&rest sequences) + "Takes any number of sequences or integers in any order. Returns true iff +the length of all the sequences and the integers are equal. Hint: there's a +compiler macro that expands into more efficient code if the first argument +is a literal integer." + (declare (dynamic-extent sequences) + (inline sequence-of-length-p) + (optimize speed)) + (unless (cdr sequences) + (error "You must call LENGTH= with at least two arguments")) + ;; There's room for optimization here: multiple list arguments could be + ;; traversed in parallel. + (let* ((first (pop sequences)) + (current (if (integerp first) + first + (length first)))) + (declare (type array-index current)) + (dolist (el sequences) + (if (integerp el) + (unless (= el current) + (return-from length= nil)) + (unless (sequence-of-length-p el current) + (return-from length= nil))))) + t) + +(define-compiler-macro length= (&whole form length &rest sequences) + (cond + ((zerop (length sequences)) + form) + (t + (let ((optimizedp (integerp length))) + (with-unique-names (tmp current) + (declare (ignorable current)) + `(locally + (declare (inline sequence-of-length-p)) + (let ((,tmp) + ,@(unless optimizedp + `((,current ,length)))) + ,@(unless optimizedp + `((unless (integerp ,current) + (setf ,current (length ,current))))) + (and + ,@(loop + :for sequence :in sequences + :collect `(progn + (setf ,tmp ,sequence) + (if (integerp ,tmp) + (= ,tmp ,(if optimizedp + length + current)) + (sequence-of-length-p ,tmp ,(if optimizedp + length + current))))))))))))) + +(defun copy-sequence (type sequence) + "Returns a fresh sequence of TYPE, which has the same elements as +SEQUENCE." + (if (typep sequence type) + (copy-seq sequence) + (coerce sequence type))) + +(defun first-elt (sequence) + "Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is +not a sequence, or is an empty sequence." + ;; Can't just directly use ELT, as it is not guaranteed to signal the + ;; type-error. + (cond ((consp sequence) + (car sequence)) + ((and (typep sequence 'sequence) (not (emptyp sequence))) + (elt sequence 0)) + (t + (error 'type-error + :datum sequence + :expected-type '(and sequence (not (satisfies emptyp))))))) + +(defun (setf first-elt) (object sequence) + "Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE is +not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE." + ;; Can't just directly use ELT, as it is not guaranteed to signal the + ;; type-error. + (cond ((consp sequence) + (setf (car sequence) object)) + ((and (typep sequence 'sequence) (not (emptyp sequence))) + (setf (elt sequence 0) object)) + (t + (error 'type-error + :datum sequence + :expected-type '(and sequence (not (satisfies emptyp))))))) + +(defun last-elt (sequence) + "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is +not a proper sequence, or is an empty sequence." + ;; Can't just directly use ELT, as it is not guaranteed to signal the + ;; type-error. + (let ((len 0)) + (cond ((consp sequence) + (lastcar sequence)) + ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence)))) + (elt sequence (1- len))) + (t + (error 'type-error + :datum sequence + :expected-type '(and proper-sequence (not (satisfies emptyp)))))))) + +(defun (setf last-elt) (object sequence) + "Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper +sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE." + (let ((len 0)) + (cond ((consp sequence) + (setf (lastcar sequence) object)) + ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence)))) + (setf (elt sequence (1- len)) object)) + (t + (error 'type-error + :datum sequence + :expected-type '(and proper-sequence (not (satisfies emptyp)))))))) + +(defun starts-with-subseq (prefix sequence &rest args + &key + (return-suffix nil return-suffix-supplied-p) + &allow-other-keys) + "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX. + +If RETURN-SUFFIX is T the function returns, as a second value, a +sub-sequence or displaced array pointing to the sequence after PREFIX." + (declare (dynamic-extent args)) + (let ((sequence-length (length sequence)) + (prefix-length (length prefix))) + (when (< sequence-length prefix-length) + (return-from starts-with-subseq (values nil nil))) + (flet ((make-suffix (start) + (when return-suffix + (cond + ((not (arrayp sequence)) + (if start + (subseq sequence start) + (subseq sequence 0 0))) + ((not start) + (make-array 0 + :element-type (array-element-type sequence) + :adjustable nil)) + (t + (make-array (- sequence-length start) + :element-type (array-element-type sequence) + :displaced-to sequence + :displaced-index-offset start + :adjustable nil)))))) + (let ((mismatch (apply #'mismatch prefix sequence + (if return-suffix-supplied-p + (remove-from-plist args :return-suffix) + args)))) + (cond + ((not mismatch) + (values t (make-suffix nil))) + ((= mismatch prefix-length) + (values t (make-suffix mismatch))) + (t + (values nil nil))))))) + +(defun ends-with-subseq (suffix sequence &key (test #'eql)) + "Test whether SEQUENCE ends with SUFFIX. In other words: return true if +the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX." + (let ((sequence-length (length sequence)) + (suffix-length (length suffix))) + (when (< sequence-length suffix-length) + ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX. + (return-from ends-with-subseq nil)) + (loop for sequence-index from (- sequence-length suffix-length) below sequence-length + for suffix-index from 0 below suffix-length + when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index))) + do (return-from ends-with-subseq nil) + finally (return t)))) + +(defun starts-with (object sequence &key (test #'eql) (key #'identity)) + "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT. +Returns NIL if the SEQUENCE is not a sequence or is an empty sequence." + (let ((first-elt (typecase sequence + (cons (car sequence)) + (sequence + (if (emptyp sequence) + (return-from starts-with nil) + (elt sequence 0))) + (t + (return-from starts-with nil))))) + (funcall test (funcall key first-elt) object))) + +(defun ends-with (object sequence &key (test #'eql) (key #'identity)) + "Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT. +Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals +an error if SEQUENCE is an improper list." + (let ((last-elt (typecase sequence + (cons + (lastcar sequence)) ; signals for improper lists + (sequence + ;; Can't use last-elt, as that signals an error + ;; for empty sequences + (let ((len (length sequence))) + (if (plusp len) + (elt sequence (1- len)) + (return-from ends-with nil)))) + (t + (return-from ends-with nil))))) + (funcall test (funcall key last-elt) object))) + +(defun map-combinations (function sequence &key (start 0) end length (copy t)) + "Calls FUNCTION with each combination of LENGTH constructable from the +elements of the subsequence of SEQUENCE delimited by START and END. START +defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the +delimited subsequence. (So unless LENGTH is specified there is only a single +combination, which has the same elements as the delimited subsequence.) If +COPY is true (the default) each combination is freshly allocated. If COPY is +false all combinations are EQ to each other, in which case consequences are +unspecified if a combination is modified by FUNCTION." + (let* ((end (or end (length sequence))) + (size (- end start)) + (length (or length size)) + (combination (subseq sequence 0 length)) + (function (ensure-function function))) + (if (= length size) + (funcall function combination) + (flet ((call () + (funcall function (if copy + (copy-seq combination) + combination)))) + (etypecase sequence + ;; When dealing with lists we prefer walking back and + ;; forth instead of using indexes. + (list + (labels ((combine-list (c-tail o-tail) + (if (not c-tail) + (call) + (do ((tail o-tail (cdr tail))) + ((not tail)) + (setf (car c-tail) (car tail)) + (combine-list (cdr c-tail) (cdr tail)))))) + (combine-list combination (nthcdr start sequence)))) + (vector + (labels ((combine (count start) + (if (zerop count) + (call) + (loop for i from start below end + do (let ((j (- count 1))) + (setf (aref combination j) (aref sequence i)) + (combine j (+ i 1))))))) + (combine length start))) + (sequence + (labels ((combine (count start) + (if (zerop count) + (call) + (loop for i from start below end + do (let ((j (- count 1))) + (setf (elt combination j) (elt sequence i)) + (combine j (+ i 1))))))) + (combine length start))))))) + sequence) + +(defun map-permutations (function sequence &key (start 0) end length (copy t)) + "Calls function with each permutation of LENGTH constructable +from the subsequence of SEQUENCE delimited by START and END. START +defaults to 0, END to length of the sequence, and LENGTH to the +length of the delimited subsequence." + (let* ((end (or end (length sequence))) + (size (- end start)) + (length (or length size))) + (labels ((permute (seq n) + (let ((n-1 (- n 1))) + (if (zerop n-1) + (funcall function (if copy + (copy-seq seq) + seq)) + (loop for i from 0 upto n-1 + do (permute seq n-1) + (if (evenp n-1) + (rotatef (elt seq 0) (elt seq n-1)) + (rotatef (elt seq i) (elt seq n-1))))))) + (permute-sequence (seq) + (permute seq length))) + (if (= length size) + ;; Things are simple if we need to just permute the + ;; full START-END range. + (permute-sequence (subseq sequence start end)) + ;; Otherwise we need to generate all the combinations + ;; of LENGTH in the START-END range, and then permute + ;; a copy of the result: can't permute the combination + ;; directly, as they share structure with each other. + (let ((permutation (subseq sequence 0 length))) + (flet ((permute-combination (combination) + (permute-sequence (replace permutation combination)))) + (declare (dynamic-extent #'permute-combination)) + (map-combinations #'permute-combination sequence + :start start + :end end + :length length + :copy nil))))))) + +(defun map-derangements (function sequence &key (start 0) end (copy t)) + "Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted +by the bounding index designators START and END. Derangement is a permutation +of the sequence where no element remains in place. SEQUENCE is not modified, +but individual derangements are EQ to each other. Consequences are unspecified +if calling FUNCTION modifies either the derangement or SEQUENCE." + (let* ((end (or end (length sequence))) + (size (- end start)) + ;; We don't really care about the elements here. + (derangement (subseq sequence 0 size)) + ;; Bitvector that has 1 for elements that have been deranged. + (mask (make-array size :element-type 'bit :initial-element 0))) + (declare (dynamic-extent mask)) + ;; ad hoc algorith + (labels ((derange (place n) + ;; Perform one recursive step in deranging the + ;; sequence: PLACE is index of the original sequence + ;; to derange to another index, and N is the number of + ;; indexes not yet deranged. + (if (zerop n) + (funcall function (if copy + (copy-seq derangement) + derangement)) + ;; Itarate over the indexes I of the subsequence to + ;; derange: if I != PLACE and I has not yet been + ;; deranged by an earlier call put the element from + ;; PLACE to I, mark I as deranged, and recurse, + ;; finally removing the mark. + (loop for i from 0 below size + do + (unless (or (= place (+ i start)) (not (zerop (bit mask i)))) + (setf (elt derangement i) (elt sequence place) + (bit mask i) 1) + (derange (1+ place) (1- n)) + (setf (bit mask i) 0)))))) + (derange start size) + sequence))) + +(declaim (notinline sequence-of-length-p)) + +(defun extremum (sequence predicate &key key (start 0) end) + "Returns the element of SEQUENCE that would appear first if the subsequence +bounded by START and END was sorted using PREDICATE and KEY. + +EXTREMUM determines the relationship between two elements of SEQUENCE by using +the PREDICATE function. PREDICATE should return true if and only if the first +argument is strictly less than the second one (in some appropriate sense). Two +arguments X and Y are considered to be equal if (FUNCALL PREDICATE X Y) +and (FUNCALL PREDICATE Y X) are both false. + +The arguments to the PREDICATE function are computed from elements of SEQUENCE +using the KEY function, if supplied. If KEY is not supplied or is NIL, the +sequence element itself is used. + +If SEQUENCE is empty, NIL is returned." + (let* ((pred-fun (ensure-function predicate)) + (key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity)) + (ensure-function key))) + (real-end (or end (length sequence)))) + (cond ((> real-end start) + (if key-fun + (flet ((reduce-keys (a b) + (if (funcall pred-fun + (funcall key-fun a) + (funcall key-fun b)) + a + b))) + (declare (dynamic-extent #'reduce-keys)) + (reduce #'reduce-keys sequence :start start :end real-end)) + (flet ((reduce-elts (a b) + (if (funcall pred-fun a b) + a + b))) + (declare (dynamic-extent #'reduce-elts)) + (reduce #'reduce-elts sequence :start start :end real-end)))) + ((= real-end start) + nil) + (t + (error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S" + (length sequence) + :start start + :end end))))) diff --git a/third_party/lisp/alexandria/strings.lisp b/third_party/lisp/alexandria/strings.lisp new file mode 100644 index 0000000000..e9fd91c961 --- /dev/null +++ b/third_party/lisp/alexandria/strings.lisp @@ -0,0 +1,6 @@ +(in-package :alexandria) + +(deftype string-designator () + "A string designator type. A string designator is either a string, a symbol, +or a character." + `(or symbol string character)) diff --git a/third_party/lisp/alexandria/symbols.lisp b/third_party/lisp/alexandria/symbols.lisp new file mode 100644 index 0000000000..5733d3e1cc --- /dev/null +++ b/third_party/lisp/alexandria/symbols.lisp @@ -0,0 +1,65 @@ +(in-package :alexandria) + +(declaim (inline ensure-symbol)) +(defun ensure-symbol (name &optional (package *package*)) + "Returns a symbol with name designated by NAME, accessible in package +designated by PACKAGE. If symbol is not already accessible in PACKAGE, it is +interned there. Returns a secondary value reflecting the status of the symbol +in the package, which matches the secondary return value of INTERN. + +Example: + + (ensure-symbol :cons :cl) => cl:cons, :external +" + (intern (string name) package)) + +(defun maybe-intern (name package) + (values + (if package + (intern name (if (eq t package) *package* package)) + (make-symbol name)))) + +(declaim (inline format-symbol)) +(defun format-symbol (package control &rest arguments) + "Constructs a string by applying ARGUMENTS to string designator CONTROL as +if by FORMAT within WITH-STANDARD-IO-SYNTAX, and then creates a symbol named +by that string. + +If PACKAGE is NIL, returns an uninterned symbol, if package is T, returns a +symbol interned in the current package, and otherwise returns a symbol +interned in the package designated by PACKAGE." + (maybe-intern (with-standard-io-syntax + (apply #'format nil (string control) arguments)) + package)) + +(defun make-keyword (name) + "Interns the string designated by NAME in the KEYWORD package." + (intern (string name) :keyword)) + +(defun make-gensym (name) + "If NAME is a non-negative integer, calls GENSYM using it. Otherwise NAME +must be a string designator, in which case calls GENSYM using the designated +string as the argument." + (gensym (if (typep name '(integer 0)) + name + (string name)))) + +(defun make-gensym-list (length &optional (x "G")) + "Returns a list of LENGTH gensyms, each generated as if with a call to MAKE-GENSYM, +using the second (optional, defaulting to \"G\") argument." + (let ((g (if (typep x '(integer 0)) x (string x)))) + (loop repeat length + collect (gensym g)))) + +(defun symbolicate (&rest things) + "Concatenate together the names of some strings and symbols, +producing a symbol in the current package." + (let* ((length (reduce #'+ things + :key (lambda (x) (length (string x))))) + (name (make-array length :element-type 'character))) + (let ((index 0)) + (dolist (thing things (values (intern name))) + (let* ((x (string thing)) + (len (length x))) + (replace name x :start1 index) + (incf index len)))))) diff --git a/third_party/lisp/alexandria/tests.lisp b/third_party/lisp/alexandria/tests.lisp new file mode 100644 index 0000000000..b70ef0475e --- /dev/null +++ b/third_party/lisp/alexandria/tests.lisp @@ -0,0 +1,2047 @@ +(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 new file mode 100644 index 0000000000..1942d0ecdf --- /dev/null +++ b/third_party/lisp/alexandria/types.lisp @@ -0,0 +1,137 @@ +(in-package :alexandria) + +(deftype array-index (&optional (length (1- array-dimension-limit))) + "Type designator for an index into array of LENGTH: an integer between +0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than +ARRAY-DIMENSION-LIMIT." + `(integer 0 (,length))) + +(deftype array-length (&optional (length (1- array-dimension-limit))) + "Type designator for a dimension of an array of LENGTH: an integer between +0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than +ARRAY-DIMENSION-LIMIT." + `(integer 0 ,length)) + +;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/) +;; except the RATIO related definitions and ARRAY-INDEX. +(macrolet + ((frob (type &optional (base-type type)) + (let ((subtype-names (list)) + (predicate-names (list))) + (flet ((make-subtype-name (format-control) + (let ((result (format-symbol :alexandria format-control + (symbol-name type)))) + (push result subtype-names) + result)) + (make-predicate-name (sybtype-name) + (let ((result (format-symbol :alexandria '#:~A-p + (symbol-name sybtype-name)))) + (push result predicate-names) + result)) + (make-docstring (range-beg range-end range-type) + (let ((inf (ecase range-type (:negative "-inf") (:positive "+inf")))) + (format nil "Type specifier denoting the ~(~A~) range from ~A to ~A." + type + (if (equal range-beg ''*) inf (ensure-car range-beg)) + (if (equal range-end ''*) inf (ensure-car range-end)))))) + (let* ((negative-name (make-subtype-name '#:negative-~a)) + (non-positive-name (make-subtype-name '#:non-positive-~a)) + (non-negative-name (make-subtype-name '#:non-negative-~a)) + (positive-name (make-subtype-name '#:positive-~a)) + (negative-p-name (make-predicate-name negative-name)) + (non-positive-p-name (make-predicate-name non-positive-name)) + (non-negative-p-name (make-predicate-name non-negative-name)) + (positive-p-name (make-predicate-name positive-name)) + (negative-extremum) + (positive-extremum) + (below-zero) + (above-zero) + (zero)) + (setf (values negative-extremum below-zero + above-zero positive-extremum zero) + (ecase type + (fixnum (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0)) + (integer (values ''* -1 1 ''* 0)) + (rational (values ''* '(0) '(0) ''* 0)) + (real (values ''* '(0) '(0) ''* 0)) + (float (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0)) + (short-float (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0)) + (single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0)) + (double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0)) + (long-float (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0)))) + `(progn + (deftype ,negative-name () + ,(make-docstring negative-extremum below-zero :negative) + `(,',base-type ,,negative-extremum ,',below-zero)) + + (deftype ,non-positive-name () + ,(make-docstring negative-extremum zero :negative) + `(,',base-type ,,negative-extremum ,',zero)) + + (deftype ,non-negative-name () + ,(make-docstring zero positive-extremum :positive) + `(,',base-type ,',zero ,,positive-extremum)) + + (deftype ,positive-name () + ,(make-docstring above-zero positive-extremum :positive) + `(,',base-type ,',above-zero ,,positive-extremum)) + + (declaim (inline ,@predicate-names)) + + (defun ,negative-p-name (n) + (and (typep n ',type) + (< n ,zero))) + + (defun ,non-positive-p-name (n) + (and (typep n ',type) + (<= n ,zero))) + + (defun ,non-negative-p-name (n) + (and (typep n ',type) + (<= ,zero n))) + + (defun ,positive-p-name (n) + (and (typep n ',type) + (< ,zero n))))))))) + (frob fixnum integer) + (frob integer) + (frob rational) + (frob real) + (frob float) + (frob short-float) + (frob single-float) + (frob double-float) + (frob long-float)) + +(defun of-type (type) + "Returns a function of one argument, which returns true when its argument is +of TYPE." + (lambda (thing) (typep thing type))) + +(define-compiler-macro of-type (&whole form type &environment env) + ;; This can yeild a big benefit, but no point inlining the function + ;; all over the place if TYPE is not constant. + (if (constantp type env) + (with-gensyms (thing) + `(lambda (,thing) + (typep ,thing ,type))) + form)) + +(declaim (inline type=)) +(defun type= (type1 type2) + "Returns a primary value of T is TYPE1 and TYPE2 are the same type, +and a secondary value that is true is the type equality could be reliably +determined: primary value of NIL and secondary value of T indicates that the +types are not equivalent." + (multiple-value-bind (sub ok) (subtypep type1 type2) + (cond ((and ok sub) + (subtypep type2 type1)) + (ok + (values nil ok)) + (t + (multiple-value-bind (sub ok) (subtypep type2 type1) + (declare (ignore sub)) + (values nil ok)))))) + +(define-modify-macro coercef (type-spec) coerce + "Modify-macro for COERCE.") diff --git a/third_party/lisp/asdf-flv/.gitattributes b/third_party/lisp/asdf-flv/.gitattributes new file mode 100644 index 0000000000..2b45716e47 --- /dev/null +++ b/third_party/lisp/asdf-flv/.gitattributes @@ -0,0 +1,2 @@ +.gitignore export-ignore +.gitattributes export-ignore diff --git a/third_party/lisp/asdf-flv/.gitignore b/third_party/lisp/asdf-flv/.gitignore new file mode 100644 index 0000000000..bdf4ad2ae6 --- /dev/null +++ b/third_party/lisp/asdf-flv/.gitignore @@ -0,0 +1,3 @@ +sbcl-*/ +cmu-*/ +openmcl-*/ diff --git a/third_party/lisp/asdf-flv/Makefile b/third_party/lisp/asdf-flv/Makefile new file mode 100644 index 0000000000..b4c74feefe --- /dev/null +++ b/third_party/lisp/asdf-flv/Makefile @@ -0,0 +1,77 @@ +### Makefile --- Toplevel directory + +## Copyright (C) 2011, 2015 Didier Verna + +## Author: Didier Verna <didier@didierverna.net> + +## This file is part of ASDF-FLV. + +## Copying and distribution of this file, with or without modification, +## are permitted in any medium without royalty provided the copyright +## notice and this notice are preserved. This file is offered as-is, +## without any warranty. + + +### Commentary: + +## Contents management by FCM version 0.1. + + +### Code: + +PROJECT := asdf-flv +VERSION := 2.1 + +W3DIR := $(HOME)/www/software/lisp/$(PROJECT) + +DIST_NAME := $(PROJECT)-$(VERSION) +TARBALL := $(DIST_NAME).tar.gz +SIGNATURE := $(TARBALL).asc + + +all: + +clean: + -rm *~ + +distclean: clean + -rm *.tar.gz *.tar.gz.asc + +tag: + git tag -a -m 'Version $(VERSION)' 'version-$(VERSION)' + +tar: $(TARBALL) +gpg: $(SIGNATURE) +dist: tar gpg + +install-www: dist + -install -m 644 $(TARBALL) "$(W3DIR)/attic/" + -install -m 644 $(SIGNATURE) "$(W3DIR)/attic/" + echo "\ +<? lref (\"$(PROJECT)/attic/$(PROJECT)-$(VERSION).tar.gz\", \ + contents (\"Derni่re version\", \"Latest version\")); ?> \ +| \ +<? lref (\"$(PROJECT)/attic/$(PROJECT)-$(VERSION).tar.gz.asc\", \ + contents (\"Signature GPG\", \"GPG Signature\")); ?>" \ + > "$(W3DIR)/latest.txt" + chmod 644 "$(W3DIR)/latest.txt" + cd "$(W3DIR)" \ + && ln -fs attic/$(TARBALL) latest.tar.gz \ + && ln -fs attic/$(SIGNATURE) latest.tar.gz.asc + +update-version: + perl -pi -e 's/:version ".*"/:version "$(VERSION)"/' \ + net.didierverna.$(PROJECT).asd + +$(TARBALL): + git archive --format=tar --prefix=$(DIST_NAME)/ \ + --worktree-attributes HEAD \ + | gzip -c > $@ + +$(SIGNATURE): $(TARBALL) + gpg -b -a $< + + +.PHONY: all clean distclean tag tar gpg dist install-www update-version + +### Makefile ends here diff --git a/third_party/lisp/asdf-flv/README.md b/third_party/lisp/asdf-flv/README.md new file mode 100644 index 0000000000..7ccdd18881 --- /dev/null +++ b/third_party/lisp/asdf-flv/README.md @@ -0,0 +1,7 @@ +ASDF-FLV provides support for file-local variables through ASDF. A file-local +variable behaves like `*PACKAGE*` and `*READTABLE*` with respect to `LOAD` and +`COMPILE-FILE`: a new dynamic binding is created before processing the file, +so that any modification to the variable essentially becomes file-local. + +In order to make one or several variables file-local, use the macros +`SET-FILE-LOCAL-VARIABLE(S)`. diff --git a/third_party/lisp/asdf-flv/asdf-flv.lisp b/third_party/lisp/asdf-flv/asdf-flv.lisp new file mode 100644 index 0000000000..76c6845b82 --- /dev/null +++ b/third_party/lisp/asdf-flv/asdf-flv.lisp @@ -0,0 +1,64 @@ +;;; asdf-flv.lisp --- Implementation + +;; Copyright (C) 2011, 2015 Didier Verna + +;; Author: Didier Verna <didier@didierverna.net> + +;; This file is part of ASDF-FLV. + +;; Copying and distribution of this file, with or without modification, +;; are permitted in any medium without royalty provided the copyright +;; notice and this notice are preserved. This file is offered as-is, +;; without any warranty. + + +;;; Commentary: + +;; Contents management by FCM version 0.1. + + +;;; Code: + +(in-package :net.didierverna.asdf-flv) + + +(defvar *file-local-variables* () + "List of file-local special variables.") + + +(defun make-variable-file-local (symbol) + "Make special variable named by SYMBOL have a file-local value." + (pushnew symbol *file-local-variables*)) + +(defmacro set-file-local-variable (symbol) + "Set special variable named by SYMBOL as file-local. +SYMBOL need not be quoted." + `(make-variable-file-local ',symbol)) + +(defun make-variables-file-local (&rest symbols) + "Make special variables named by SYMBOLS have a file-local value." + (dolist (symbol symbols) + (pushnew symbol *file-local-variables*))) + +(defmacro set-file-local-variables (&rest symbols) + "Set special variables named by SYMBOLS as file-local. +SYMBOLS need not be quoted." + `(make-variables-file-local ,@(mapcar (lambda (symbol) (list 'quote symbol)) + symbols))) + + +(defmethod asdf:perform :around + ((operation asdf:load-op) (file asdf:cl-source-file)) + "Establish new dynamic bindings for file-local variables." + (progv *file-local-variables* + (mapcar #'symbol-value *file-local-variables*) + (call-next-method))) + +(defmethod asdf:perform :around + ((operation asdf:compile-op) (file asdf:cl-source-file)) + "Establish new dynamic bindings for file-local variables." + (progv *file-local-variables* + (mapcar #'symbol-value *file-local-variables*) + (call-next-method))) + +;;; asdf-flv.lisp ends here diff --git a/third_party/lisp/asdf-flv/default.nix b/third_party/lisp/asdf-flv/default.nix new file mode 100644 index 0000000000..3e8843ef4d --- /dev/null +++ b/third_party/lisp/asdf-flv/default.nix @@ -0,0 +1,12 @@ +# Imported from https://github.com/didierverna/asdf-flv +{ pkgs, ... }: + +pkgs.nix.buildLisp.library { + name = "asdf-flv"; + deps = with pkgs.third_party.lisp; [ asdf ]; + + srcs = [ + ./package.lisp + ./asdf-flv.lisp + ]; +} diff --git a/third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd b/third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd new file mode 100644 index 0000000000..41202746d0 --- /dev/null +++ b/third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd @@ -0,0 +1,43 @@ +;;; net.didierverna.asdf-flv.asd --- ASDF system definition + +;; Copyright (C) 2011, 2015 Didier Verna + +;; Author: Didier Verna <didier@didierverna.net> + +;; This file is part of ASDF-FLV. + +;; Copying and distribution of this file, with or without modification, +;; are permitted in any medium without royalty provided the copyright +;; notice and this notice are preserved. This file is offered as-is, +;; without any warranty. + + +;;; Commentary: + +;; Contents management by FCM version 0.1. + + +;;; Code: + +(asdf:defsystem :net.didierverna.asdf-flv + :long-name "ASDF File Local Variables" + :description "ASDF extension to provide support for file-local variables." + :long-description "\ +ASDF-FLV provides support for file-local variables through ASDF. A file-local +variable behaves like *PACKAGE* and *READTABLE* with respect to LOAD and +COMPILE-FILE: a new dynamic binding is created before processing the file, so +that any modification to the variable becomes essentially file-local. + +In order to make one or several variables file-local, use the macros +SET-FILE-LOCAL-VARIABLE(S)." + :author "Didier Verna" + :mailto "didier@didierverna.net" + :homepage "http://www.lrde.epita.fr/~didier/software/lisp/misc.php#asdf-flv" + :source-control "https://github.com/didierverna/asdf-flv" + :license "GNU All Permissive" + :version "2.1" + :serial t + :components ((:file "package") + (:file "asdf-flv"))) + +;;; net.didierverna.asdf-flv.asd ends here diff --git a/third_party/lisp/asdf-flv/package.lisp b/third_party/lisp/asdf-flv/package.lisp new file mode 100644 index 0000000000..1d7fb2bab4 --- /dev/null +++ b/third_party/lisp/asdf-flv/package.lisp @@ -0,0 +1,28 @@ +;;; package.lisp --- Package definition + +;; Copyright (C) 2011, 2015 Didier Verna + +;; Author: Didier Verna <didier@didierverna.net> + +;; This file is part of ASDF-FLV. + +;; Copying and distribution of this file, with or without modification, +;; are permitted in any medium without royalty provided the copyright +;; notice and this notice are preserved. This file is offered as-is, +;; without any warranty. + + +;;; Commentary: + +;; Contents management by FCM version 0.1. + + +;;; Code: + +(in-package :cl-user) + +(defpackage :net.didierverna.asdf-flv + (:use :cl) + (:export :set-file-local-variable :set-file-local-variables)) + +;;; package.lisp ends here diff --git a/third_party/lisp/asdf.nix b/third_party/lisp/asdf.nix new file mode 100644 index 0000000000..3d41a1f36d --- /dev/null +++ b/third_party/lisp/asdf.nix @@ -0,0 +1,9 @@ +# ASDF ships with SBCL. This package just exists to force it to load. +{ pkgs, ... }: + +with pkgs; + +nix.buildLisp.library { + name = "asdf"; + srcs = lib.singleton (builtins.toFile "asdf.lisp" "(require 'asdf)"); +} diff --git a/third_party/lisp/babel.nix b/third_party/lisp/babel.nix new file mode 100644 index 0000000000..ba367df9ad --- /dev/null +++ b/third_party/lisp/babel.nix @@ -0,0 +1,31 @@ +# Babel is an encoding conversion library for Common Lisp. +{ pkgs, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/cl-babel/babel.git"; + rev = "ec9a17cdbdba3c1dd39609fc7961cfb3f0aa260e"; +}; +in pkgs.nix.buildLisp.library { + name = "babel"; + deps = [ pkgs.third_party.lisp.alexandria ]; + + srcs = map (f: src + ("/src/" + f)) [ + "packages.lisp" + "encodings.lisp" + "enc-ascii.lisp" + "enc-ebcdic.lisp" + "enc-ebcdic-int.lisp" + "enc-iso-8859.lisp" + "enc-unicode.lisp" + "enc-cp1251.lisp" + "enc-cp1252.lisp" + "jpn-table.lisp" + "enc-jpn.lisp" + "enc-gbk.lisp" + "enc-koi8.lisp" + "external-format.lisp" + "strings.lisp" + "gbk-map.lisp" + "sharp-backslash.lisp" + ]; +} diff --git a/third_party/lisp/bordeaux-threads.nix b/third_party/lisp/bordeaux-threads.nix new file mode 100644 index 0000000000..7ced6bf134 --- /dev/null +++ b/third_party/lisp/bordeaux-threads.nix @@ -0,0 +1,19 @@ +# This library is meant to make writing portable multi-threaded apps +# in Common Lisp simple. +{ pkgs, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/sionescu/bordeaux-threads.git"; + rev = "499b6d3f0ce635417d6096acf0a671d8bf3f6e5f"; +}; +in pkgs.nix.buildLisp.library { + name = "bordeaux-threads"; + deps = [ pkgs.third_party.lisp.alexandria ]; + + srcs = map (f: src + ("/src/" + f)) [ + "pkgdcl.lisp" + "bordeaux-threads.lisp" + "impl-sbcl.lisp" + "default-implementations.lisp" + ]; +} diff --git a/third_party/lisp/cffi.nix b/third_party/lisp/cffi.nix new file mode 100644 index 0000000000..556dee0676 --- /dev/null +++ b/third_party/lisp/cffi.nix @@ -0,0 +1,32 @@ +# CFFI purports to be the Common Foreign Function Interface. +{ pkgs, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/cffi/cffi.git"; + rev = "5e838bf46d0089c43ebd3ea014a207c403e29c61"; +}; +in pkgs.nix.buildLisp.library { + name = "cffi"; + deps = with pkgs.third_party.lisp; [ + alexandria + asdf + babel + trivial-features + uiop + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "cffi-sbcl.lisp" + "package.lisp" + "utils.lisp" + "libraries.lisp" + "early-types.lisp" + "types.lisp" + "enum.lisp" + "strings.lisp" + "structures.lisp" + "functions.lisp" + "foreign-vars.lisp" + "features.lisp" + ]; +} diff --git a/third_party/lisp/chipz.nix b/third_party/lisp/chipz.nix new file mode 100644 index 0000000000..5a8c39dc05 --- /dev/null +++ b/third_party/lisp/chipz.nix @@ -0,0 +1,31 @@ +# Common Lisp library for decompressing deflate, zlib, gzip, and bzip2 data +{ pkgs, ... }: + +let src = pkgs.third_party.fetchFromGitHub { + owner = "froydnj"; + repo = "chipz"; + rev = "75dfbc660a5a28161c57f115adf74c8a926bfc4d"; + sha256 = "0plx4rs39zbs4gjk77h4a2q11zpy75fh9v8hnxrvsf8fnakajhwg"; +}; +in pkgs.nix.buildLisp.library { + name = "chipz"; + deps = with pkgs.third_party.lisp; [ asdf ]; + + srcs = map (f: src + ("/" + f)) [ + "chipz.asd" + "package.lisp" + "constants.lisp" + "conditions.lisp" + "dstate.lisp" + "types-and-tables.lisp" + "crc32.lisp" + "adler32.lisp" + "inflate-state.lisp" + "gzip.lisp" + "zlib.lisp" + "inflate.lisp" + "bzip2.lisp" + "decompress.lisp" + "stream.lisp" + ]; +} diff --git a/third_party/lisp/chunga.nix b/third_party/lisp/chunga.nix new file mode 100644 index 0000000000..b56fb3b90c --- /dev/null +++ b/third_party/lisp/chunga.nix @@ -0,0 +1,27 @@ +# Portable chunked streams for Common Lisp +{ pkgs, ... }: + +let src = pkgs.third_party.fetchFromGitHub { + owner = "edicl"; + repo = "chunga"; + rev = "16330852d01dfde4dd97dee7cd985a88ea571e7e"; + sha256 = "0jzn3nyb3f22gm983rfk99smqs3mhb9ivjmasvhq9qla5cl9pyhd"; +}; +in pkgs.nix.buildLisp.library { + name = "chunga"; + deps = with pkgs.third_party.lisp; [ + trivial-gray-streams + ]; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "specials.lisp" + "util.lisp" + "known-words.lisp" + "conditions.lisp" + "read.lisp" + "streams.lisp" + "input.lisp" + "output.lisp" + ]; +} diff --git a/third_party/lisp/cl-ansi-text.nix b/third_party/lisp/cl-ansi-text.nix new file mode 100644 index 0000000000..88fcae318b --- /dev/null +++ b/third_party/lisp/cl-ansi-text.nix @@ -0,0 +1,19 @@ +# Enables ANSI colors for printing. +{ pkgs, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/pnathan/cl-ansi-text.git"; + rev = "257a5f19a2dc92d22f8fd772c0a78923b99b36a8"; +}; +in pkgs.nix.buildLisp.library { + name = "cl-ansi-text"; + deps = with pkgs.third_party.lisp; [ + alexandria + cl-colors2 + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "cl-ansi-text.lisp" + "define-colors.lisp" + ]; +} diff --git a/third_party/lisp/cl-base64.nix b/third_party/lisp/cl-base64.nix new file mode 100644 index 0000000000..c4dc9ca2c7 --- /dev/null +++ b/third_party/lisp/cl-base64.nix @@ -0,0 +1,17 @@ +# Base64 encoding for Common Lisp +{ pkgs, ... }: + +let src = builtins.fetchGit { + url = "http://git.kpe.io/cl-base64.git"; + rev = "fc62a5342445d4ec1dd44e95f7dc513473a8c89a"; +}; +in pkgs.nix.buildLisp.library { + name = "cl-base64"; + srcs = [ + (src + "/package.lisp") + (src + "/encode.lisp") + (src + "/decode.lisp") + ]; +} + + diff --git a/third_party/lisp/cl-colors2.nix b/third_party/lisp/cl-colors2.nix new file mode 100644 index 0000000000..44417d7d94 --- /dev/null +++ b/third_party/lisp/cl-colors2.nix @@ -0,0 +1,21 @@ + +{ pkgs, ... }: + +let src = builtins.fetchGit { + url = "https://notabug.org/cage/cl-colors2.git"; + rev = "795aedee593b095fecde574bd999b520dd03ed24"; +}; +in pkgs.nix.buildLisp.library { + name = "cl-colors2"; + deps = with pkgs.third_party.lisp; [ + alexandria + cl-ppcre + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "colors.lisp" + "colornames.lisp" + "hexcolors.lisp" + ]; +} diff --git a/third_party/lisp/cl-fad.nix b/third_party/lisp/cl-fad.nix new file mode 100644 index 0000000000..474e4b6963 --- /dev/null +++ b/third_party/lisp/cl-fad.nix @@ -0,0 +1,25 @@ +# Portable pathname library +{ pkgs, ...}: + +let src = pkgs.third_party.fetchFromGitHub { + owner = "edicl"; + repo = "cl-fad"; + rev = "c13d81c4bd9ba3a172631fd05dd213ab90e7d4cb"; + sha256 = "1gc8i82v6gks7g0lnm54r4prk2mklidv2flm5fvbr0a7rsys0vpa"; +}; +in pkgs.nix.buildLisp.library { + name = "cl-fad"; + + deps = with pkgs.third_party.lisp; [ + alexandria + bordeaux-threads + sb-posix + ]; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "fad.lisp" + "path.lisp" + "temporary-files.lisp" + ]; +} diff --git a/third_party/lisp/cl-json.nix b/third_party/lisp/cl-json.nix new file mode 100644 index 0000000000..0c77718ef0 --- /dev/null +++ b/third_party/lisp/cl-json.nix @@ -0,0 +1,25 @@ +# JSON encoder & decoder +{ pkgs, ... }: + +let src = pkgs.third_party.fetchFromGitHub { + owner = "hankhero"; + repo = "cl-json"; + rev = "6dfebb9540bfc3cc33582d0c03c9ec27cb913e79"; + sha256 = "0fx3m3x3s5ji950yzpazz4s0img3l6b3d6l3jrfjv0lr702496lh"; +}; +in pkgs.nix.buildLisp.library { + name = "cl-json"; + deps = [ pkgs.third_party.lisp.asdf ]; + + srcs = [ "${src}/cl-json.asd" ] ++ + (map (f: src + ("/src/" + f)) [ + "package.lisp" + "common.lisp" + "objects.lisp" + "camel-case.lisp" + "decoder.lisp" + "encoder.lisp" + "utils.lisp" + "json-rpc.lisp" + ]); +} diff --git a/third_party/lisp/cl-plus-ssl.nix b/third_party/lisp/cl-plus-ssl.nix new file mode 100644 index 0000000000..1945d8a2e9 --- /dev/null +++ b/third_party/lisp/cl-plus-ssl.nix @@ -0,0 +1,38 @@ +# Common Lisp bindings to OpenSSL +{ pkgs, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/cl-plus-ssl/cl-plus-ssl.git"; + rev = "29081992f6d7b4e3aa2c5eeece4cd92b745071f4"; +}; +in pkgs.nix.buildLisp.library { + name = "cl-plus-ssl"; + deps = with pkgs.third_party.lisp; [ + alexandria + bordeaux-threads + cffi + flexi-streams + sb-posix + trivial-features + trivial-garbage + trivial-gray-streams + uiop + ]; + + native = [ pkgs.third_party.openssl ]; + + srcs = map (f: src + ("/src/" + f)) [ + "package.lisp" + "reload.lisp" + "conditions.lisp" + "ffi.lisp" + "x509.lisp" + "ffi-buffer-all.lisp" + "ffi-buffer.lisp" + "streams.lisp" + "bio.lisp" + "random.lisp" + "context.lisp" + "verify-hostname.lisp" + ]; +} diff --git a/third_party/lisp/cl-ppcre.nix b/third_party/lisp/cl-ppcre.nix new file mode 100644 index 0000000000..78480fe34f --- /dev/null +++ b/third_party/lisp/cl-ppcre.nix @@ -0,0 +1,30 @@ +# cl-ppcre is a Common Lisp regular expression library. +{ pkgs, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/edicl/cl-ppcre"; + rev = "1ca0cd9ca0d161acd49c463d6cb5fff897596e2f"; +}; +in pkgs.nix.buildLisp.library { + name = "cl-ppcre"; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "specials.lisp" + "util.lisp" + "errors.lisp" + "charset.lisp" + "charmap.lisp" + "chartest.lisp" + "lexer.lisp" + "parser.lisp" + "regex-class.lisp" + "regex-class-util.lisp" + "convert.lisp" + "optimize.lisp" + "closures.lisp" + "repetition-closures.lisp" + "scanner.lisp" + "api.lisp" + ]; +} diff --git a/third_party/lisp/cl-prevalence.nix b/third_party/lisp/cl-prevalence.nix new file mode 100644 index 0000000000..1502f2e231 --- /dev/null +++ b/third_party/lisp/cl-prevalence.nix @@ -0,0 +1,29 @@ +# cl-prevalence is an implementation of object prevalence for CL (i.e. +# an in-memory database) +{ pkgs, ... }: + +let src = pkgs.third_party.fetchFromGitHub { + owner = "40ants"; + repo = "cl-prevalence"; + rev = "da3ed6c4594b1c2fca90c178c1993973c4bf16c9"; + sha256 = "0bq905hv1626dl6b7s0zn4lbdh608g1pxaljl1fda6pwp9hmj95a"; +}; +in pkgs.nix.buildLisp.library { + name = "cl-prevalence"; + + deps = with pkgs.third_party.lisp; [ + s-xml + s-sysdeps + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "package.lisp" + "serialization/serialization.lisp" + "serialization/xml.lisp" + "serialization/sexp.lisp" + "prevalence.lisp" + "managed-prevalence.lisp" + "master-slave.lisp" + "blob.lisp" + ]; +} diff --git a/third_party/lisp/drakma.nix b/third_party/lisp/drakma.nix new file mode 100644 index 0000000000..ac2d257a49 --- /dev/null +++ b/third_party/lisp/drakma.nix @@ -0,0 +1,35 @@ +# Drakma is an HTTP client for Common Lisp. +{ pkgs, ... }: + +let src = pkgs.third_party.fetchFromGitHub { + owner = "edicl"; + repo = "drakma"; + rev = "87feb02bef00b11a753d5fb21a5fec526b0d0bbb"; + sha256 = "01b80am2vrw94xmdj7f21qm7p5ys08mmpzv4nc4icql81hqr1w2m"; +}; +in pkgs.nix.buildLisp.library { + name = "drakma"; + deps = with pkgs.third_party.lisp; [ + asdf + chipz + chunga + cl-base64 + cl-plus-ssl + cl-ppcre + flexi-streams + puri + usocket + ]; + + srcs = map (f: src + ("/" + f)) [ + "drakma.asd" # Required because the system definition is used + "packages.lisp" + "specials.lisp" + "conditions.lisp" + "util.lisp" + "read.lisp" + "cookies.lisp" + "encoding.lisp" + "request.lisp" + ]; +} diff --git a/third_party/lisp/fiveam/.boring b/third_party/lisp/fiveam/.boring new file mode 100644 index 0000000000..662944f765 --- /dev/null +++ b/third_party/lisp/fiveam/.boring @@ -0,0 +1,14 @@ +# Boring file regexps: +\# +~$ +(^|/)_darcs($|/) +\.dfsl$ +\.ppcf$ +\.fasl$ +\.x86f$ +\.fas$ +\.lib$ +^docs/html($|/) +^docs/pdf($|/) +^\{arch\}$ +(^|/).arch-ids($|/) diff --git a/third_party/lisp/fiveam/.travis.yml b/third_party/lisp/fiveam/.travis.yml new file mode 100644 index 0000000000..6f6559189f --- /dev/null +++ b/third_party/lisp/fiveam/.travis.yml @@ -0,0 +1,47 @@ +dist: bionic +language: lisp + +env: + matrix: + - LISP=abcl + - LISP=allegro + - LISP=ccl + - LISP=ccl32 + - LISP=ecl + - LISP=sbcl + - LISP=sbcl32 + - LISP=cmucl + +matrix: + allow_failures: + - env: LISP=allegro + - env: LISP=ccl32 + - env: LISP=cmucl + - env: LISP=sbcl32 + +notifications: + email: + on_success: change + on_failure: always + irc: + channels: + - "chat.freenode.net#iolib" + on_success: change + on_failure: always + use_notice: true + skip_join: true + +install: + - curl -L https://raw.githubusercontent.com/sionescu/cl-travis/master/install.sh | sh + - cl -e "(cl:in-package :cl-user) + (dolist (p '(:alexandria)) + (ql:quickload p :verbose t))" + +script: + - cl -e "(cl:in-package :cl-user) + (ql:quickload :fiveam/test :verbose t) + (uiop:quit (if (some (lambda (x) (typep x '5am::test-failure)) + (5am:run :it.bese.fiveam)) + 1 0))" + +sudo: required diff --git a/third_party/lisp/fiveam/COPYING b/third_party/lisp/fiveam/COPYING new file mode 100644 index 0000000000..91adf85a5a --- /dev/null +++ b/third_party/lisp/fiveam/COPYING @@ -0,0 +1,30 @@ +Copyright (c) 2003-2006, Edward Marco Baringer +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +- Neither the name of Edward Marco Baringer, nor BESE, nor the names +of its contributors may be used to endorse or promote products derived +from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/third_party/lisp/fiveam/README b/third_party/lisp/fiveam/README new file mode 100644 index 0000000000..32a205fa5f --- /dev/null +++ b/third_party/lisp/fiveam/README @@ -0,0 +1,8 @@ +This is FiveAM, a common lisp testing framework. + +The documentation can be found in the docstrings, start with the +package :it.bese.fiveam (nicknamed 5AM). + +The mailing list for FiveAM is fiveam-devel@common-lisp.net + +All the code is Copyright (C) 2002-2006 Edward Marco Baringer. diff --git a/third_party/lisp/fiveam/default.nix b/third_party/lisp/fiveam/default.nix new file mode 100644 index 0000000000..07b4cc0ee5 --- /dev/null +++ b/third_party/lisp/fiveam/default.nix @@ -0,0 +1,28 @@ +# FiveAM is a Common Lisp testing framework. +# +# Imported from https://github.com/sionescu/fiveam.git + +{ pkgs, ... }: + +pkgs.nix.buildLisp.library { + name = "fiveam"; + + deps = with pkgs.third_party.lisp; [ + alexandria + asdf-flv + trivial-backtrace + ]; + + srcs = [ + ./src/package.lisp + ./src/utils.lisp + ./src/check.lisp + ./src/fixture.lisp + ./src/classes.lisp + ./src/random.lisp + ./src/test.lisp + ./src/explain.lisp + ./src/suite.lisp + ./src/run.lisp + ]; +} diff --git a/third_party/lisp/fiveam/docs/make-qbook.lisp b/third_party/lisp/fiveam/docs/make-qbook.lisp new file mode 100644 index 0000000000..8144c94f02 --- /dev/null +++ b/third_party/lisp/fiveam/docs/make-qbook.lisp @@ -0,0 +1,13 @@ +(asdf:oos 'asdf:load-op :FiveAM) +(asdf:oos 'asdf:load-op :qbook) + +(asdf:oos 'qbook:publish-op :FiveAM + :generator (make-instance 'qbook:html-generator + :title "FiveAM" + :output-directory + (merge-pathnames + (make-pathname :directory '(:relative "docs" "html")) + (asdf:component-pathname (asdf:find-system :FiveAM))))) + + + diff --git a/third_party/lisp/fiveam/fiveam.asd b/third_party/lisp/fiveam/fiveam.asd new file mode 100644 index 0000000000..7607e33372 --- /dev/null +++ b/third_party/lisp/fiveam/fiveam.asd @@ -0,0 +1,36 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +#.(unless (or #+asdf3.1 (version<= "3.1" (asdf-version))) + (error "You need ASDF >= 3.1 to load this system correctly.")) + +(defsystem :fiveam + :author "Edward Marco Baringer <mb@bese.it>" + :version (:read-file-form "version.sexp") + :description "A simple regression testing framework" + :license "BSD" + :depends-on (:alexandria :net.didierverna.asdf-flv :trivial-backtrace) + :pathname "src/" + :components ((:file "package") + (:file "utils" :depends-on ("package")) + (:file "check" :depends-on ("package" "utils")) + (:file "fixture" :depends-on ("package")) + (:file "classes" :depends-on ("package")) + (:file "random" :depends-on ("package" "check")) + (:file "test" :depends-on ("package" "fixture" "classes")) + (:file "explain" :depends-on ("package" "utils" "check" "classes" "random")) + (:file "suite" :depends-on ("package" "test" "classes")) + (:file "run" :depends-on ("package" "check" "classes" "test" "explain" "suite"))) + :in-order-to ((test-op (test-op :fiveam/test)))) + +(defsystem :fiveam/test + :author "Edward Marco Baringer <mb@bese.it>" + :description "FiveAM's own test suite" + :license "BSD" + :depends-on (:fiveam) + :pathname "t/" + :components ((:file "tests")) + :perform (test-op (o c) (symbol-call :5am :run! :it.bese.fiveam))) + +;;;;@include "src/package.lisp" + +;;;;@include "t/example.lisp" diff --git a/third_party/lisp/fiveam/src/check.lisp b/third_party/lisp/fiveam/src/check.lisp new file mode 100644 index 0000000000..b3808c5cf0 --- /dev/null +++ b/third_party/lisp/fiveam/src/check.lisp @@ -0,0 +1,311 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :it.bese.fiveam) + +;;;; * Checks + +;;;; At the lowest level testing the system requires that certain +;;;; forms be evaluated and that certain post conditions are met: the +;;;; value returned must satisfy a certain predicate, the form must +;;;; (or must not) signal a certain condition, etc. In FiveAM these +;;;; low level operations are called 'checks' and are defined using +;;;; the various checking macros. + +;;;; Checks are the basic operators for collecting results. Tests and +;;;; test suites on the other hand allow grouping multiple checks into +;;;; logic collections. + +(defvar *test-dribble* t) + +(defmacro with-*test-dribble* (stream &body body) + `(let ((*test-dribble* ,stream)) + (declare (special *test-dribble*)) + ,@body)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-special-environment run-state () + result-list + current-test)) + +;;;; ** Types of test results + +;;;; Every check produces a result object. + +(defclass test-result () + ((reason :accessor reason :initarg :reason :initform "no reason given") + (test-case :accessor test-case :initarg :test-case) + (test-expr :accessor test-expr :initarg :test-expr)) + (:documentation "All checking macros will generate an object of + type TEST-RESULT.")) + +(defclass test-passed (test-result) + () + (:documentation "Class for successful checks.")) + +(defgeneric test-passed-p (object) + (:method ((o t)) nil) + (:method ((o test-passed)) t)) + +(define-condition check-failure (error) + ((reason :accessor reason :initarg :reason :initform "no reason given") + (test-case :accessor test-case :initarg :test-case) + (test-expr :accessor test-expr :initarg :test-expr)) + (:documentation "Signaled when a check fails.") + (:report (lambda (c stream) + (format stream "The following check failed: ~S~%~A." + (test-expr c) + (reason c))))) + +(defun process-failure (test-expr &optional reason-format &rest format-args) + (let ((reason (and reason-format + (apply #'format nil reason-format format-args)))) + (with-simple-restart (ignore-failure "Continue the test run.") + (error 'check-failure :test-expr test-expr + :reason reason)) + (add-result 'test-failure :test-expr test-expr + :reason reason))) + +(defclass test-failure (test-result) + () + (:documentation "Class for unsuccessful checks.")) + +(defgeneric test-failure-p (object) + (:method ((o t)) nil) + (:method ((o test-failure)) t)) + +(defclass unexpected-test-failure (test-failure) + ((actual-condition :accessor actual-condition :initarg :condition)) + (:documentation "Represents the result of a test which neither +passed nor failed, but signaled an error we couldn't deal +with. + +Note: This is very different than a SIGNALS check which instead +creates a TEST-PASSED or TEST-FAILURE object.")) + +(defclass test-skipped (test-result) + () + (:documentation "A test which was not run. Usually this is due to +unsatisfied dependencies, but users can decide to skip the test when +appropriate.")) + +(defgeneric test-skipped-p (object) + (:method ((o t)) nil) + (:method ((o test-skipped)) t)) + +(defun add-result (result-type &rest make-instance-args) + "Create a TEST-RESULT object of type RESULT-TYPE passing it the + initialize args MAKE-INSTANCE-ARGS and add the resulting + object to the list of test results." + (with-run-state (result-list current-test) + (let ((result (apply #'make-instance result-type + (append make-instance-args (list :test-case current-test))))) + (etypecase result + (test-passed (format *test-dribble* ".")) + (unexpected-test-failure (format *test-dribble* "X")) + (test-failure (format *test-dribble* "f")) + (test-skipped (format *test-dribble* "s"))) + (push result result-list)))) + +;;;; ** The check operators + +;;;; *** The IS check + +(defmacro is (test &rest reason-args) + "The DWIM checking operator. + +If TEST returns a true value a test-passed result is generated, +otherwise a test-failure result is generated. The reason, unless +REASON-ARGS is provided, is generated based on the form of TEST: + + (predicate expected actual) - Means that we want to check + whether, according to PREDICATE, the ACTUAL value is + in fact what we EXPECTED. + + (predicate value) - Means that we want to ensure that VALUE + satisfies PREDICATE. + + Wrapping the TEST form in a NOT simply produces a negated reason + string." + (assert (listp test) + (test) + "Argument to IS must be a list, not ~S" test) + (let (bindings effective-test default-reason-args) + (with-gensyms (e a v) + (flet ((process-entry (predicate expected actual &optional negatedp) + ;; make sure EXPECTED is holding the entry that starts with 'values + (when (and (consp actual) + (eq (car actual) 'values)) + (assert (not (and (consp expected) + (eq (car expected) 'values))) () + "Both the expected and actual part is a values expression.") + (rotatef expected actual)) + (let ((setf-forms)) + (if (and (consp expected) + (eq (car expected) 'values)) + (progn + (setf expected (copy-list expected)) + (setf setf-forms (loop for cell = (rest expected) then (cdr cell) + for i from 0 + while cell + when (eq (car cell) '*) + collect `(setf (elt ,a ,i) nil) + and do (setf (car cell) nil))) + (setf bindings (list (list e `(list ,@(rest expected))) + (list a `(multiple-value-list ,actual))))) + (setf bindings (list (list e expected) + (list a actual)))) + (setf effective-test `(progn + ,@setf-forms + ,(if negatedp + `(not (,predicate ,e ,a)) + `(,predicate ,e ,a))))))) + (list-match-case test + ((not (?predicate ?expected ?actual)) + (process-entry ?predicate ?expected ?actual t) + (setf default-reason-args + (list "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (it should not be)" + `',?actual a `',?predicate e))) + ((not (?satisfies ?value)) + (setf bindings (list (list v ?value)) + effective-test `(not (,?satisfies ,v)) + default-reason-args + (list "~2&~S~2% evaluated to ~2&~S~2% which satisfies ~2&~S~2% (it should not)" + `',?value v `',?satisfies))) + ((?predicate ?expected ?actual) + (process-entry ?predicate ?expected ?actual) + (setf default-reason-args + (list "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%." + `',?actual a `',?predicate e))) + ((?satisfies ?value) + (setf bindings (list (list v ?value)) + effective-test `(,?satisfies ,v) + default-reason-args + (list "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%" + `',?value v `',?satisfies))) + (?_ + (setf bindings '() + effective-test test + default-reason-args (list "~2&~S~2% was NIL." `',test))))) + `(let ,bindings + (if ,effective-test + (add-result 'test-passed :test-expr ',test) + (process-failure ',test + ,@(or reason-args default-reason-args))))))) + +;;;; *** Other checks + +(defmacro skip (&rest reason) + "Generates a TEST-SKIPPED result." + `(progn + (format *test-dribble* "s") + (add-result 'test-skipped :reason (format nil ,@reason)))) + +(defmacro is-every (predicate &body clauses) + "The input is either a list of lists, or a list of pairs. Generates (is (,predicate ,expr ,value)) + for each pair of elements or (is (,predicate ,expr ,value) ,@reason) for each list." + `(progn + ,@(if (every #'consp clauses) + (loop for (expected actual . reason) in clauses + collect `(is (,predicate ,expected ,actual) ,@reason)) + (progn + (assert (evenp (list-length clauses))) + (loop for (expr value) on clauses by #'cddr + collect `(is (,predicate ,expr ,value))))))) + +(defmacro is-true (condition &rest reason-args) + "Like IS this check generates a pass if CONDITION returns true + and a failure if CONDITION returns false. Unlike IS this check + does not inspect CONDITION to determine how to report the + failure." + `(if ,condition + (add-result 'test-passed :test-expr ',condition) + (process-failure ',condition + ,@(or reason-args + `("~S did not return a true value" ',condition))))) + +(defmacro is-false (condition &rest reason-args) + "Generates a pass if CONDITION returns false, generates a + failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does + not inspect CONDITION to determine what reason to give it case + of test failure" + (with-gensyms (value) + `(let ((,value ,condition)) + (if ,value + (process-failure ',condition + ,@(or reason-args + `("~S returned the value ~S, which is true" ',condition ,value))) + (add-result 'test-passed :test-expr ',condition))))) + +(defmacro signals (condition-spec + &body body) + "Generates a pass if BODY signals a condition of type +CONDITION. BODY is evaluated in a block named NIL, CONDITION is +not evaluated." + (let ((block-name (gensym))) + (destructuring-bind (condition &optional reason-control reason-args) + (ensure-list condition-spec) + `(block ,block-name + (handler-bind ((,condition (lambda (c) + (declare (ignore c)) + ;; ok, body threw condition + (add-result 'test-passed + :test-expr ',condition) + (return-from ,block-name t)))) + (block nil + ,@body)) + (process-failure + ',condition + ,@(if reason-control + `(,reason-control ,@reason-args) + `("Failed to signal a ~S" ',condition))) + (return-from ,block-name nil))))) + +(defmacro finishes (&body body) + "Generates a pass if BODY executes to normal completion. In +other words if body does signal, return-from or throw this test +fails." + `(unwind-protect-case () (progn ,@body) + (:normal (add-result 'test-passed :test-expr ',body)) + (:abort (process-failure ',body "Test didn't finish")))) + +(defmacro pass (&rest message-args) + "Simply generate a PASS." + `(add-result 'test-passed + :test-expr ',message-args + ,@(when message-args + `(:reason (format nil ,@message-args))))) + +(defmacro fail (&rest message-args) + "Simply generate a FAIL." + `(process-failure ',message-args + ,@message-args)) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE diff --git a/third_party/lisp/fiveam/src/classes.lisp b/third_party/lisp/fiveam/src/classes.lisp new file mode 100644 index 0000000000..fc4dc782e8 --- /dev/null +++ b/third_party/lisp/fiveam/src/classes.lisp @@ -0,0 +1,128 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :it.bese.fiveam) + +(defclass testable-object () + ((name :initarg :name :accessor name + :documentation "A symbol naming this test object.") + (description :initarg :description :accessor description :initform nil + :documentation "The textual description of this test object.") + (depends-on :initarg :depends-on :accessor depends-on :initform nil + :documentation "The list of AND, OR, NOT forms specifying when to run this test.") + (status :initarg :status :accessor status :initform :unknown + :documentation "A symbol specifying the current status + of this test. Either: T - this test (and all its + dependencies, have passed. NIL - this test + failed (either it failed or its dependecies weren't + met. :circular this test has a circular dependency + and was skipped. Or :depends-not-satisfied or :resolving") + (profiling-info :accessor profiling-info + :initform nil + :documentation "An object representing how + much time and memory where used by the + test.") + (collect-profiling-info :accessor collect-profiling-info + :initarg :collect-profiling-info + :initform nil + :documentation "When T profiling + information will be collected when the + test is run."))) + +(defmethod print-object ((test testable-object) stream) + (print-unreadable-object (test stream :type t :identity t) + (format stream "~S" (name test)))) + +(defclass test-suite (testable-object) + ((tests :accessor tests :initform (make-hash-table :test 'eql) + :documentation "The hash table mapping names to test + objects in this suite. The values in this hash table + can be either test-cases or other test-suites.")) + (:documentation "A test suite is a collection of tests or test suites. + +Test suites serve to organize tests into groups so that the +developer can chose to run some tests and not just one or +all. Like tests test suites have a name and a description. + +Test suites, like tests, can be part of other test suites, this +allows the developer to create a hierarchy of tests where sub +trees can be singularly run. + +Running a test suite has the effect of running every test (or +suite) in the suite.")) + +(defclass test-case (testable-object) + ((test-lambda :initarg :test-lambda :accessor test-lambda + :documentation "The function to run.") + (runtime-package :initarg :runtime-package :accessor runtime-package + :documentation "By default it stores *package* from the time this test was defined (macroexpanded).")) + (:documentation "A test case is a single, named, collection of +checks. + +A test case is the smallest organizational element which can be +run individually. Every test case has a name, which is a symbol, +a description and a test lambda. The test lambda is a regular +funcall'able function which should use the various checking +macros to collect results. + +Every test case is part of a suite, when a suite is not +explicitly specified (either via the :SUITE parameter to the TEST +macro or the global variable *SUITE*) the test is inserted into +the global suite named NIL. + +Sometimes we want to run a certain test only if another test has +passed. FiveAM allows us to specify the ways in which one test is +dependent on another. + +- AND Run this test only if all the named tests passed. + +- OR Run this test if at least one of the named tests passed. + +- NOT Run this test only if another test has failed. + +FiveAM considers a test to have passed if all the checks executed +were successful, otherwise we consider the test a failure. + +When a test is not run due to it's dependencies having failed a +test-skipped result is added to the results.")) + +(defclass explainer () + ()) + +(defclass text-explainer (explainer) + ()) + +(defclass simple-text-explainer (text-explainer) + ()) + +(defclass detailed-text-explainer (text-explainer) + ()) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE diff --git a/third_party/lisp/fiveam/src/explain.lisp b/third_party/lisp/fiveam/src/explain.lisp new file mode 100644 index 0000000000..015cdf4552 --- /dev/null +++ b/third_party/lisp/fiveam/src/explain.lisp @@ -0,0 +1,133 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :it.bese.fiveam) + +;;;; * Analyzing the results + +(defparameter *verbose-failures* nil + "T if we should print the expression failing, NIL otherwise.") + +;;;; Just as important as defining and runnig the tests is +;;;; understanding the results. FiveAM provides the function EXPLAIN +;;;; which prints a human readable summary (number passed, number +;;;; failed, what failed and why, etc.) of a list of test results. + +(defgeneric explain (explainer results &optional stream recursive-depth) + (:documentation "Given a list of test results report write to stream detailed + human readable statistics regarding the results.")) + +(defmethod explain ((exp detailed-text-explainer) results + &optional (stream *test-dribble*) (recursive-depth 0)) + (multiple-value-bind (num-checks passed num-passed passed% + skipped num-skipped skipped% + failed num-failed failed% + unknown num-unknown unknown%) + (partition-results results) + (declare (ignore passed)) + (flet ((output (&rest format-args) + (format stream "~&~vT" recursive-depth) + (apply #'format stream format-args))) + + (when (zerop num-checks) + (output "Didn't run anything...huh?") + (return-from explain nil)) + (output "Did ~D check~P.~%" num-checks num-checks) + (output " Pass: ~D (~2D%)~%" num-passed passed%) + (output " Skip: ~D (~2D%)~%" num-skipped skipped%) + (output " Fail: ~D (~2D%)~%" num-failed failed%) + (when unknown + (output " UNKNOWN RESULTS: ~D (~2D)~%" num-unknown unknown%)) + (terpri stream) + (when failed + (output "Failure Details:~%") + (dolist (f (reverse failed)) + (output "--------------------------------~%") + (output "~A ~@{[~A]~}: ~%" + (name (test-case f)) + (description (test-case f))) + (output " ~A.~%" (reason f)) + (when (for-all-test-failed-p f) + (output "Results collected with failure data:~%") + (explain exp (slot-value f 'result-list) + stream (+ 4 recursive-depth))) + (when (and *verbose-failures* (test-expr f)) + (output " ~S~%" (test-expr f))) + (output "--------------------------------~%")) + (terpri stream)) + (when skipped + (output "Skip Details:~%") + (dolist (f skipped) + (output "~A ~@{[~A]~}: ~%" + (name (test-case f)) + (description (test-case f))) + (output " ~A.~%" (reason f))) + (terpri stream))))) + +(defmethod explain ((exp simple-text-explainer) results + &optional (stream *test-dribble*) (recursive-depth 0)) + (multiple-value-bind (num-checks passed num-passed passed% + skipped num-skipped skipped% + failed num-failed failed% + unknown num-unknown unknown%) + (partition-results results) + (declare (ignore passed passed% skipped skipped% failed failed% unknown unknown%)) + (format stream "~&~vTRan ~D checks, ~D passed" recursive-depth num-checks num-passed) + (when (plusp num-skipped) + (format stream ", ~D skipped " num-skipped)) + (format stream " and ~D failed.~%" num-failed) + (when (plusp num-unknown) + (format stream "~vT~D UNKNOWN RESULTS.~%" recursive-depth num-unknown)))) + +(defun partition-results (results-list) + (let ((num-checks (length results-list))) + (destructuring-bind (passed skipped failed unknown) + (partitionx results-list + (lambda (res) + (typep res 'test-passed)) + (lambda (res) + (typep res 'test-skipped)) + (lambda (res) + (typep res 'test-failure)) + t) + (if (zerop num-checks) + (values 0 + nil 0 0 + nil 0 0 + nil 0 0 + nil 0 0) + (values + num-checks + passed (length passed) (floor (* 100 (/ (length passed) num-checks))) + skipped (length skipped) (floor (* 100 (/ (length skipped) num-checks))) + failed (length failed) (floor (* 100 (/ (length failed) num-checks))) + unknown (length unknown) (floor (* 100 (/ (length failed) num-checks)))))))) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE diff --git a/third_party/lisp/fiveam/src/fixture.lisp b/third_party/lisp/fiveam/src/fixture.lisp new file mode 100644 index 0000000000..26e993304f --- /dev/null +++ b/third_party/lisp/fiveam/src/fixture.lisp @@ -0,0 +1,82 @@ +;; -*- lisp -*- + +(in-package :it.bese.fiveam) + +;;;; ** Fixtures + +;;;; When running tests we often need to setup some kind of context +;;;; (create dummy db connections, simulate an http request, +;;;; etc.). Fixtures provide a way to conviently hide this context +;;;; into a macro and allow the test to focus on testing. + +;;;; NB: A FiveAM fixture is nothing more than a macro. Since the term +;;;; 'fixture' is so common in testing frameworks we've provided a +;;;; wrapper around defmacro for this purpose. + +(defvar *fixture* + (make-hash-table :test 'eql) + "Lookup table mapping fixture names to fixture + objects.") + +(defun get-fixture (key &optional default) + (gethash key *fixture* default)) + +(defun (setf get-fixture) (value key) + (setf (gethash key *fixture*) value)) + +(defun rem-fixture (key) + (remhash key *fixture*)) + +(defmacro def-fixture (name (&rest args) &body body) + "Defines a fixture named NAME. A fixture is very much like a +macro but is used only for simple templating. A fixture created +with DEF-FIXTURE is a macro which can use the special macrolet +&BODY to specify where the body should go. + +See Also: WITH-FIXTURE +" + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (get-fixture ',name) (cons ',args ',body)) + ',name)) + +(defmacro with-fixture (fixture-name (&rest args) &body body) + "Insert BODY into the fixture named FIXTURE-NAME. + +See Also: DEF-FIXTURE" + (assert (get-fixture fixture-name) + (fixture-name) + "Unknown fixture ~S." fixture-name) + (destructuring-bind ((&rest largs) &rest lbody) + (get-fixture fixture-name) + `(macrolet ((&body () '(progn ,@body))) + (funcall (lambda (,@largs) ,@lbody) ,@args)))) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/third_party/lisp/fiveam/src/package.lisp b/third_party/lisp/fiveam/src/package.lisp new file mode 100644 index 0000000000..3279a9a4f7 --- /dev/null +++ b/third_party/lisp/fiveam/src/package.lisp @@ -0,0 +1,139 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +;;;; * Introduction + +;;;; FiveAM is a testing framework. It takes care of all the boring +;;;; bookkeeping associated with managing a test framework allowing +;;;; the developer to focus on writing tests and code. + +;;;; FiveAM was designed with the following premises: + +;;;; - Defining tests should be about writing tests, not +;;;; infrastructure. The developer should be able to focus on what +;;;; they're testing, not the testing framework. + +;;;; - Interactive testing is the norm. Common Lisp is an interactive +;;;; development environment, the testing environment should allow the +;;;; developer to quickly and easily redefine, change, remove and run +;;;; tests. + +(defpackage :it.bese.fiveam + (:use :common-lisp :alexandria) + (:nicknames :5am :fiveam) + #+sb-package-locks + (:lock t) + (:export + ;; creating tests and test-suites + #:make-suite + #:def-suite + #:def-suite* + #:in-suite + #:in-suite* + #:test + #:def-test + #:get-test + #:rem-test + #:test-names + #:*default-test-compilation-time* + ;; fixtures + #:def-fixture + #:with-fixture + #:get-fixture + #:rem-fixture + ;; running checks + #:is + #:is-every + #:is-true + #:is-false + #:signals + #:finishes + #:skip + #:pass + #:fail + #:*test-dribble* + #:for-all + #:*num-trials* + #:*max-trials* + #:gen-integer + #:gen-float + #:gen-character + #:gen-string + #:gen-list + #:gen-tree + #:gen-buffer + #:gen-one-element + ;; running tests + #:run + #:run-all-tests + #:explain + #:explain! + #:run! + #:debug! + #:! + #:!! + #:!!! + #:*run-test-when-defined* + #:*debug-on-error* + #:*debug-on-failure* + #:*on-error* + #:*on-failure* + #:*verbose-failures* + #:*print-names* + #:results-status)) + +;;;; You can use #+5am to put your test-defining code inline with your +;;;; other code - and not require people to have fiveam to run your +;;;; package. + +(pushnew :5am *features*) + +;;;;@include "check.lisp" + +;;;;@include "random.lisp" + +;;;;@include "fixture.lisp" + +;;;;@include "test.lisp" + +;;;;@include "suite.lisp" + +;;;;@include "run.lisp" + +;;;;@include "explain.lisp" + +;;;; * Colophon + +;;;; This documentaion was written by Edward Marco Baringer +;;;; <mb@bese.it> and generated by qbook. + +;;;; ** COPYRIGHT + +;;;; Copyright (c) 2002-2003, Edward Marco Baringer +;;;; All rights reserved. + +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions are +;;;; met: + +;;;; - Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. + +;;;; - Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. + +;;;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;;;; of its contributors may be used to endorse or promote products +;;;; derived from this software without specific prior written permission. + +;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE diff --git a/third_party/lisp/fiveam/src/random.lisp b/third_party/lisp/fiveam/src/random.lisp new file mode 100644 index 0000000000..49e14bc8a8 --- /dev/null +++ b/third_party/lisp/fiveam/src/random.lisp @@ -0,0 +1,265 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :it.bese.fiveam) + +;;;; ** Random (QuickCheck-ish) testing + +;;;; FiveAM provides the ability to automatically generate a +;;;; collection of random input data for a specific test and run a +;;;; test multiple times. + +;;;; Specification testing is done through the FOR-ALL macro. This +;;;; macro will bind variables to random data and run a test body a +;;;; certain number of times. Should the test body ever signal a +;;;; failure we stop running and report what values of the variables +;;;; caused the code to fail. + +;;;; The generation of the random data is done using "generator +;;;; functions" (see below for details). A generator function is a +;;;; function which creates, based on user supplied parameters, a +;;;; function which returns random data. In order to facilitate +;;;; generating good random data the FOR-ALL macro also supports guard +;;;; conditions and creating one random input based on the values of +;;;; another (see the FOR-ALL macro for details). + +;;;; *** Public Interface to the Random Tester + +(defparameter *num-trials* 100 + "Number of times we attempt to run the body of the FOR-ALL test.") + +(defparameter *max-trials* 10000 + "Number of total times we attempt to run the body of the + FOR-ALL test including when the body is skipped due to failed + guard conditions. + +Since we have guard conditions we may get into infinite loops +where the test code is never run due to the guards never +returning true. This second run limit prevents that.") + +(defmacro for-all (bindings &body body) + "Bind BINDINGS to random variables and test BODY *num-trials* times. + +BINDINGS is a list of binding forms, each element is a list +of (BINDING VALUE &optional GUARD). Value, which is evaluated +once when the for-all is evaluated, must return a generator which +be called each time BODY is evaluated. BINDING is either a symbol +or a list which will be passed to destructuring-bind. GUARD is a +form which, if present, stops BODY from executing when IT returns +NIL. The GUARDS are evaluated after all the random data has been +generated and they can refer to the current value of any +binding. NB: Generator forms, unlike guard forms, can not contain +references to the bound variables. + +Examples: + + (for-all ((a (gen-integer))) + (is (integerp a))) + + (for-all ((a (gen-integer) (plusp a))) + (is (integerp a)) + (is (plusp a))) + + (for-all ((less (gen-integer)) + (more (gen-integer) (< less more))) + (is (<= less more))) + + (for-all (((a b) (gen-two-integers))) + (is (integerp a)) + (is (integerp b)))" + (with-gensyms (test-lambda-args) + `(perform-random-testing + (list ,@(mapcar #'second bindings)) + (lambda (,test-lambda-args) + (destructuring-bind ,(mapcar #'first bindings) + ,test-lambda-args + (if (and ,@(delete-if #'null (mapcar #'third bindings))) + (progn ,@body) + (throw 'run-once + (list :guard-conditions-failed)))))))) + +;;;; *** Implementation + +;;;; We could just make FOR-ALL a monster macro, but having FOR-ALL be +;;;; a preproccessor for the perform-random-testing function is +;;;; actually much easier. + +(defun perform-random-testing (generators body) + (loop + with random-state = *random-state* + with total-counter = *max-trials* + with counter = *num-trials* + with run-at-least-once = nil + until (or (zerop total-counter) + (zerop counter)) + do (let ((result (perform-random-testing/run-once generators body))) + (ecase (first result) + (:pass + (decf counter) + (decf total-counter) + (setf run-at-least-once t)) + (:no-tests + (add-result 'for-all-test-no-tests + :reason "No tests" + :random-state random-state) + (return-from perform-random-testing nil)) + (:guard-conditions-failed + (decf total-counter)) + (:fail + (add-result 'for-all-test-failed + :reason "Found failing test data" + :random-state random-state + :failure-values (second result) + :result-list (third result)) + (return-from perform-random-testing nil)))) + finally (if run-at-least-once + (add-result 'for-all-test-passed) + (add-result 'for-all-test-never-run + :reason "Guard conditions never passed")))) + +(defun perform-random-testing/run-once (generators body) + (catch 'run-once + (bind-run-state ((result-list '())) + (let ((values (mapcar #'funcall generators))) + (funcall body values) + (cond + ((null result-list) + (throw 'run-once (list :no-tests))) + ((every #'test-passed-p result-list) + (throw 'run-once (list :pass))) + ((notevery #'test-passed-p result-list) + (throw 'run-once (list :fail values result-list)))))))) + +(defclass for-all-test-result () + ((random-state :initarg :random-state))) + +(defclass for-all-test-passed (test-passed for-all-test-result) + ()) + +(defclass for-all-test-failed (test-failure for-all-test-result) + ((failure-values :initarg :failure-values) + (result-list :initarg :result-list))) + +(defgeneric for-all-test-failed-p (object) + (:method ((object for-all-test-failed)) t) + (:method ((object t)) nil)) + +(defmethod reason ((result for-all-test-failed)) + (format nil "Falsifiable with ~S" (slot-value result 'failure-values))) + +(defclass for-all-test-no-tests (test-failure for-all-test-result) + ()) + +(defclass for-all-test-never-run (test-failure for-all-test-result) + ()) + +;;;; *** Generators + +;;;; Since this is random testing we need some way of creating random +;;;; data to feed to our code. Generators are regular functions which +;;;; create this random data. + +;;;; We provide a set of built-in generators. + +(defun gen-integer (&key (max (1+ most-positive-fixnum)) + (min (1- most-negative-fixnum))) + "Returns a generator which produces random integers greater +than or equal to MIN and less than or equal to MAX." + (lambda () + (+ min (random (1+ (- max min)))))) + +(defun gen-float (&key bound (type 'short-float)) + "Returns a generator which produces floats of type TYPE. BOUND, +if specified, constrains the results to be in the range (-BOUND, +BOUND)." + (lambda () + (let* ((most-negative (ecase type + (short-float most-negative-short-float) + (single-float most-negative-single-float) + (double-float most-negative-double-float) + (long-float most-negative-long-float))) + (most-positive (ecase type + (short-float most-positive-short-float) + (single-float most-positive-single-float) + (double-float most-positive-double-float) + (long-float most-positive-long-float))) + (bound (or bound (max most-positive (- most-negative))))) + (coerce + (ecase (random 2) + (0 ;; generate a positive number + (random (min most-positive bound))) + (1 ;; generate a negative number + (- (random (min (- most-negative) bound))))) + type)))) + +(defun gen-character (&key (code-limit char-code-limit) + (code (gen-integer :min 0 :max (1- code-limit))) + (alphanumericp nil)) + "Returns a generator of characters. + +CODE must be a generator of random integers. ALPHANUMERICP, if +non-NIL, limits the returned chars to those which pass +alphanumericp." + (lambda () + (loop + for count upfrom 0 + for char = (code-char (funcall code)) + until (and char + (or (not alphanumericp) + (alphanumericp char))) + when (= 1000 count) + do (error "After 1000 iterations ~S has still not generated ~:[a valid~;an alphanumeric~] character :(." + code alphanumericp) + finally (return char)))) + +(defun gen-string (&key (length (gen-integer :min 0 :max 80)) + (elements (gen-character)) + (element-type 'character)) + "Returns a generator which produces random strings. LENGTH must +be a generator which produces integers, ELEMENTS must be a +generator which produces characters of type ELEMENT-TYPE." + (lambda () + (loop + with length = (funcall length) + with string = (make-string length :element-type element-type) + for index below length + do (setf (aref string index) (funcall elements)) + finally (return string)))) + +(defun gen-list (&key (length (gen-integer :min 0 :max 10)) + (elements (gen-integer :min -10 :max 10))) + "Returns a generator which produces random lists. LENGTH must be +an integer generator and ELEMENTS must be a generator which +produces objects." + (lambda () + (loop + repeat (funcall length) + collect (funcall elements)))) + +(defun gen-tree (&key (size 20) + (elements (gen-integer :min -10 :max 10))) + "Returns a generator which produces random trees. SIZE controls +the approximate size of the tree, but don't try anything above + 30, you have been warned. ELEMENTS must be a generator which +will produce the elements." + (labels ((rec (&optional (current-depth 0)) + (let ((key (random (+ 3 (- size current-depth))))) + (cond ((> key 2) + (list (rec (+ current-depth 1)) + (rec (+ current-depth 1)))) + (t (funcall elements)))))) + (lambda () + (rec)))) + +(defun gen-buffer (&key (length (gen-integer :min 0 :max 50)) + (element-type '(unsigned-byte 8)) + (elements (gen-integer :min 0 :max (1- (expt 2 8))))) + (lambda () + (let ((buffer (make-array (funcall length) :element-type element-type))) + (map-into buffer elements)))) + +(defun gen-one-element (&rest elements) + (lambda () + (nth (random (length elements)) elements))) + +;;;; The trivial always-produce-the-same-thing generator is done using +;;;; cl:constantly. diff --git a/third_party/lisp/fiveam/src/run.lisp b/third_party/lisp/fiveam/src/run.lisp new file mode 100644 index 0000000000..89c5223515 --- /dev/null +++ b/third_party/lisp/fiveam/src/run.lisp @@ -0,0 +1,385 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :it.bese.fiveam) + +;;;; * Running Tests + +;;;; Once the programmer has defined what the tests are these need to +;;;; be run and the expected effects should be compared with the +;;;; actual effects. FiveAM provides the function RUN for this +;;;; purpose, RUN executes a number of tests and collects the results +;;;; of each individual check into a list which is then +;;;; returned. There are three types of test results: passed, failed +;;;; and skipped, these are represented by TEST-RESULT objects. + +;;;; Generally running a test will return normally, but there are two +;;;; exceptional situations which can occur: + +;;;; - An exception is signaled while running the test. If the +;;;; variable *on-error* is :DEBUG than FiveAM will enter the +;;;; debugger, otherwise a test failure (of type +;;;; unexpected-test-failure) is returned. When entering the +;;;; debugger two restarts are made available, one simply reruns the +;;;; current test and another signals a test-failure and continues +;;;; with the remaining tests. + +;;;; - A circular dependency is detected. An error is signaled and a +;;;; restart is made available which signals a test-skipped and +;;;; continues with the remaining tests. This restart also sets the +;;;; dependency status of the test to nil, so any tests which depend +;;;; on this one (even if the dependency is not circular) will be +;;;; skipped. + +;;;; The functions RUN!, !, !! and !!! are convenient wrappers around +;;;; RUN and EXPLAIN. + +(deftype on-problem-action () + '(member :debug :backtrace nil)) + +(declaim (type on-problem-action *on-error* *on-failure*)) + +(defvar *on-error* nil + "The action to perform on error: +- :DEBUG if we should drop into the debugger +- :BACKTRACE to print a backtrace +- NIL to simply continue") + +(defvar *on-failure* nil + "The action to perform on check failure: +- :DEBUG if we should drop into the debugger +- :BACKTRACE to print a backtrace +- NIL to simply continue") + +(defvar *debug-on-error* nil + "T if we should drop into the debugger on error, NIL otherwise. +OBSOLETE: superseded by *ON-ERROR*") + +(defvar *debug-on-failure* nil + "T if we should drop into the debugger on a failing check, NIL otherwise. +OBSOLETE: superseded by *ON-FAILURE*") + +(defparameter *print-names* t + "T if we should print test running progress, NIL otherwise.") + +(defparameter *test-dribble-indent* (make-array 0 + :element-type 'character + :fill-pointer 0 + :adjustable t) + "Used to indent tests and test suites in their parent suite") + +(defun import-testing-symbols (package-designator) + (import '(5am::is 5am::is-true 5am::is-false 5am::signals 5am::finishes) + package-designator)) + +(defparameter *run-queue* '() + "List of test waiting to be run.") + +(define-condition circular-dependency (error) + ((test-case :initarg :test-case)) + (:report (lambda (cd stream) + (format stream "A circular dependency wes detected in ~S." (slot-value cd 'test-case)))) + (:documentation "Condition signaled when a circular dependency +between test-cases has been detected.")) + +(defgeneric run-resolving-dependencies (test) + (:documentation "Given a dependency spec determine if the spec +is satisfied or not, this will generally involve running other +tests. If the dependency spec can be satisfied the test is also +run.")) + +(defmethod run-resolving-dependencies ((test test-case)) + "Return true if this test, and its dependencies, are satisfied, + NIL otherwise." + (case (status test) + (:unknown + (setf (status test) :resolving) + (if (or (not (depends-on test)) + (eql t (resolve-dependencies (depends-on test)))) + (progn + (run-test-lambda test) + (status test)) + (with-run-state (result-list) + (unless (eql :circular (status test)) + (push (make-instance 'test-skipped + :test-case test + :reason "Dependencies not satisfied") + result-list) + (setf (status test) :depends-not-satisfied))))) + (:resolving + (restart-case + (error 'circular-dependency :test-case test) + (skip () + :report (lambda (s) + (format s "Skip the test ~S and all its dependencies." (name test))) + (with-run-state (result-list) + (push (make-instance 'test-skipped :reason "Circular dependencies" :test-case test) + result-list)) + (setf (status test) :circular)))) + (t (status test)))) + +(defgeneric resolve-dependencies (depends-on)) + +(defmethod resolve-dependencies ((depends-on symbol)) + "A test which depends on a symbol is interpreted as `(AND + ,DEPENDS-ON)." + (run-resolving-dependencies (get-test depends-on))) + +(defmethod resolve-dependencies ((depends-on list)) + "Return true if the dependency spec DEPENDS-ON is satisfied, + nil otherwise." + (if (null depends-on) + t + (flet ((satisfies-depends-p (test) + (funcall test (lambda (dep) + (eql t (resolve-dependencies dep))) + (cdr depends-on)))) + (ecase (car depends-on) + (and (satisfies-depends-p #'every)) + (or (satisfies-depends-p #'some)) + (not (satisfies-depends-p #'notany)) + (:before (every #'(lambda (dep) + (let ((status (status (get-test dep)))) + (if (eql :unknown status) + (run-resolving-dependencies (get-test dep)) + status))) + (cdr depends-on))))))) + +(defun results-status (result-list) + "Given a list of test results (generated while running a test) + return true if no results are of type TEST-FAILURE. Returns second + and third values, which are the set of failed tests and skipped + tests respectively." + (let ((failed-tests + (remove-if-not #'test-failure-p result-list)) + (skipped-tests + (remove-if-not #'test-skipped-p result-list))) + (values (null failed-tests) + failed-tests + skipped-tests))) + +(defun return-result-list (test-lambda) + "Run the test function TEST-LAMBDA and return a list of all + test results generated, does not modify the special environment + variable RESULT-LIST." + (bind-run-state ((result-list '())) + (funcall test-lambda) + result-list)) + +(defgeneric run-test-lambda (test)) + +(defmethod run-test-lambda ((test test-case)) + (with-run-state (result-list) + (bind-run-state ((current-test test)) + (labels ((abort-test (e &optional (reason (format nil "Unexpected Error: ~S~%~A." e e))) + (add-result 'unexpected-test-failure + :test-expr nil + :test-case test + :reason reason + :condition e)) + (run-it () + (let ((result-list '())) + (declare (special result-list)) + (handler-bind ((check-failure (lambda (e) + (declare (ignore e)) + (cond + ((eql *on-failure* :debug) + nil) + (t + (when (eql *on-failure* :backtrace) + (trivial-backtrace:print-backtrace-to-stream + *test-dribble*)) + (invoke-restart + (find-restart 'ignore-failure)))))) + (error (lambda (e) + (unless (or (eql *on-error* :debug) + (typep e 'check-failure)) + (when (eql *on-error* :backtrace) + (trivial-backtrace:print-backtrace-to-stream + *test-dribble*)) + (abort-test e) + (return-from run-it result-list))))) + (restart-case + (handler-case + (let ((*readtable* (copy-readtable)) + (*package* (runtime-package test))) + (when *print-names* + (format *test-dribble* "~%~ARunning test ~A " *test-dribble-indent* (name test))) + (if (collect-profiling-info test) + ;; Timing info doesn't get collected ATM, we need a portable library + ;; (setf (profiling-info test) (collect-timing (test-lambda test))) + (funcall (test-lambda test)) + (funcall (test-lambda test)))) + (storage-condition (e) + ;; heap-exhausted/constrol-stack-exhausted + ;; handler-case unwinds the stack (unlike handler-bind) + (abort-test e (format nil "STORAGE-CONDITION: aborted for safety. ~S~%~A." e e)) + (return-from run-it result-list))) + (retest () + :report (lambda (stream) + (format stream "~@<Rerun the test ~S~@:>" test)) + (return-from run-it (run-it))) + (ignore () + :report (lambda (stream) + (format stream "~@<Signal an exceptional test failure and abort the test ~S.~@:>" test)) + (abort-test (make-instance 'test-failure :test-case test + :reason "Failure restart.")))) + result-list)))) + (let ((results (run-it))) + (setf (status test) (results-status results) + result-list (nconc result-list results))))))) + +(defgeneric %run (test-spec) + (:documentation "Internal method for running a test. Does not + update the status of the tests nor the special variables !, + !!, !!!")) + +(defmethod %run ((test test-case)) + (run-resolving-dependencies test)) + +(defmethod %run ((tests list)) + (mapc #'%run tests)) + +(defmethod %run ((suite test-suite)) + (when *print-names* + (format *test-dribble* "~%~ARunning test suite ~A" *test-dribble-indent* (name suite))) + (let ((suite-results '())) + (flet ((run-tests () + (loop + for test being the hash-values of (tests suite) + do (%run test)))) + (vector-push-extend #\space *test-dribble-indent*) + (unwind-protect + (bind-run-state ((result-list '())) + (unwind-protect + (if (collect-profiling-info suite) + ;; Timing info doesn't get collected ATM, we need a portable library + ;; (setf (profiling-info suite) (collect-timing #'run-tests)) + (run-tests) + (run-tests))) + (setf suite-results result-list + (status suite) (every #'test-passed-p suite-results))) + (vector-pop *test-dribble-indent*) + (with-run-state (result-list) + (setf result-list (nconc result-list suite-results))))))) + +(defmethod %run ((test-name symbol)) + (when-let (test (get-test test-name)) + (%run test))) + +(defvar *initial-!* (lambda () (format t "Haven't run that many tests yet.~%"))) + +(defvar *!* *initial-!*) +(defvar *!!* *initial-!*) +(defvar *!!!* *initial-!*) + +;;;; ** Public entry points + +(defun run! (&optional (test-spec *suite*) + &key ((:print-names *print-names*) *print-names*)) + "Equivalent to (explain! (run TEST-SPEC))." + (explain! (run test-spec))) + +(defun explain! (result-list) + "Explain the results of RESULT-LIST using a +detailed-text-explainer with output going to *test-dribble*. +Return a boolean indicating whether no tests failed." + (explain (make-instance 'detailed-text-explainer) result-list *test-dribble*) + (results-status result-list)) + +(defun debug! (&optional (test-spec *suite*)) + "Calls (run! test-spec) but enters the debugger if any kind of error happens." + (let ((*on-error* :debug) + (*on-failure* :debug)) + (run! test-spec))) + +(defun run (test-spec &key ((:print-names *print-names*) *print-names*)) + "Run the test specified by TEST-SPEC. + +TEST-SPEC can be either a symbol naming a test or test suite, or +a testable-object object. This function changes the operations +performed by the !, !! and !!! functions." + (psetf *!* (lambda () + (loop :for test :being :the :hash-keys :of *test* + :do (setf (status (get-test test)) :unknown)) + (bind-run-state ((result-list '())) + (with-simple-restart (explain "Ignore the rest of the tests and explain current results") + (%run test-spec)) + result-list)) + *!!* *!* + *!!!* *!!*) + (let ((*on-error* + (or *on-error* (cond + (*debug-on-error* + (format *test-dribble* "*DEBUG-ON-ERROR* is obsolete. Use *ON-ERROR*.") + :debug) + (t nil)))) + (*on-failure* + (or *on-failure* (cond + (*debug-on-failure* + (format *test-dribble* "*DEBUG-ON-FAILURE* is obsolete. Use *ON-FAILURE*.") + :debug) + (t nil))))) + (funcall *!*))) + +(defun ! () + "Rerun the most recently run test and explain the results." + (explain! (funcall *!*))) + +(defun !! () + "Rerun the second most recently run test and explain the results." + (explain! (funcall *!!*))) + +(defun !!! () + "Rerun the third most recently run test and explain the results." + (explain! (funcall *!!!*))) + +(defun run-all-tests (&key (summary :end)) + "Runs all defined test suites, T if all tests passed and NIL otherwise. +SUMMARY can be :END to print a summary at the end, :SUITE to print it +after each suite or NIL to skip explanations." + (check-type summary (member nil :suite :end)) + (loop :for suite :in (cons 'nil (sort (copy-list *toplevel-suites*) #'string<=)) + :for results := (if (suite-emptyp suite) nil (run suite)) + :when (consp results) + :collect results :into all-results + :do (cond + ((not (eql summary :suite)) + nil) + (results + (explain! results)) + (suite + (format *test-dribble* "Suite ~A is empty~%" suite))) + :finally (progn + (when (eql summary :end) + (explain! (alexandria:flatten all-results))) + (return (every #'results-status all-results))))) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/third_party/lisp/fiveam/src/style.css b/third_party/lisp/fiveam/src/style.css new file mode 100644 index 0000000000..4a1e6010dc --- /dev/null +++ b/third_party/lisp/fiveam/src/style.css @@ -0,0 +1,64 @@ +body { + background-color: #FFFFFF; + color: #000000; + padding: 0px; margin: 0px; +} + +.qbook { width: 600px; background-color: #FFFFFF; margin: 0px; + border-left: 3em solid #660000; padding: 3px; } + +h1 { text-align: center; margin: 0px; + color: #333333; + border-bottom: 0.3em solid #660000; +} + +p { padding-left: 1em; } + +h2 { border-bottom: 0.2em solid #000000; font-family: verdana; } + +h3 { border-bottom: 0.1em solid #000000; } + +pre.code { + background-color: #eeeeee; + border: solid 1px #d0d0d0; + overflow: auto; +} + +pre.code * .paren { color: #666666; } + +pre.code a:active { color: #000000; } +pre.code a:link { color: #000000; } +pre.code a:visited { color: #000000; } + +pre.code .first-line { font-weight: bold; } + +div.contents { font-family: verdana; } + +div.contents a:active { color: #000000; } +div.contents a:link { color: #000000; } +div.contents a:visited { color: #000000; } + +div.contents div.contents-heading-1 { padding-left: 0.5em; font-weight: bold; } +div.contents div.contents-heading-1 a:active { color: #660000; } +div.contents div.contents-heading-1 a:link { color: #660000; } +div.contents div.contents-heading-1 a:visited { color: #660000; } + +div.contents div.contents-heading-2 { padding-left: 1.0em; } +div.contents div.contents-heading-2 a:active { color: #660000; } +div.contents div.contents-heading-2 a:link { color: #660000; } +div.contents div.contents-heading-2 a:visited { color: #660000; } + +div.contents div.contents-heading-3 { padding-left: 1.5em; } +div.contents div.contents-heading-3 a:active { color: #660000; } +div.contents div.contents-heading-3 a:link { color: #660000; } +div.contents div.contents-heading-3 a:visited { color: #660000; } + +div.contents div.contents-heading-4 { padding-left: 2em; } +div.contents div.contents-heading-4 a:active { color: #660000; } +div.contents div.contents-heading-4 a:link { color: #660000; } +div.contents div.contents-heading-4 a:visited { color: #660000; } + +div.contents div.contents-heading-5 { padding-left: 2.5em; } +div.contents div.contents-heading-5 a:active { color: #660000; } +div.contents div.contents-heading-5 a:link { color: #660000; } +div.contents div.contents-heading-5 a:visited { color: #660000; } diff --git a/third_party/lisp/fiveam/src/suite.lisp b/third_party/lisp/fiveam/src/suite.lisp new file mode 100644 index 0000000000..8497a9d12d --- /dev/null +++ b/third_party/lisp/fiveam/src/suite.lisp @@ -0,0 +1,140 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :it.bese.fiveam) + +;;;; * Test Suites + +;;;; Test suites allow us to collect multiple tests into a single +;;;; object and run them all using asingle name. Test suites do not +;;;; affect the way test are run nor the way the results are handled, +;;;; they are simply a test organizing group. + +;;;; Test suites can contain both tests and other test suites. Running +;;;; a test suite causes all of its tests and test suites to be +;;;; run. Suites do not affect test dependencies, running a test suite +;;;; can cause tests which are not in the suite to be run. + +;;;; ** Current Suite + +(defvar *suite* nil + "The current test suite object") +(net.didierverna.asdf-flv:set-file-local-variable *suite*) + +;;;; ** Creating Suits + +;; Suites that have no parent suites. +(defvar *toplevel-suites* nil) + +(defgeneric suite-emptyp (suite) + (:method ((suite symbol)) + (suite-emptyp (get-test suite))) + (:method ((suite test-suite)) + (= 0 (hash-table-count (tests suite))))) + +(defmacro def-suite (name &key description in) + "Define a new test-suite named NAME. + +IN (a symbol), if provided, causes this suite te be nested in the +suite named by IN. NB: This macro is built on top of make-suite, +as such it, like make-suite, will overrwrite any existing suite +named NAME." + `(eval-when (:compile-toplevel :load-toplevel :execute) + (make-suite ',name + ,@(when description `(:description ,description)) + ,@(when in `(:in ',in))) + ',name)) + +(defmacro def-suite* (name &rest def-suite-args) + `(progn + (def-suite ,name ,@def-suite-args) + (in-suite ,name))) + +(defun make-suite (name &key description ((:in parent-suite))) + "Create a new test suite object. + +Overrides any existing suite named NAME." + (let ((suite (make-instance 'test-suite :name name))) + (when description + (setf (description suite) description)) + (when (and name + (null (name *suite*)) + (null parent-suite)) + (pushnew name *toplevel-suites*)) + (loop for i in (ensure-list parent-suite) + for in-suite = (get-test i) + do (progn + (when (null in-suite) + (cerror "Create a new suite named ~A." "Unknown suite ~A." i) + (setf (get-test in-suite) (make-suite i) + in-suite (get-test in-suite))) + (setf (gethash name (tests in-suite)) suite))) + (setf (get-test name) suite) + suite)) + +(eval-when (:load-toplevel :execute) + (setf *suite* + (setf (get-test 'nil) + (make-suite 'nil :description "Global Suite")))) + +(defun list-all-suites () + "Returns an unordered LIST of all suites." + (hash-table-values *suite*)) + +;;;; ** Managing the Current Suite + +(defmacro in-suite (suite-name) + "Set the *suite* special variable so that all tests defined +after the execution of this form are, unless specified otherwise, +in the test-suite named SUITE-NAME. + +See also: DEF-SUITE *SUITE*" + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%in-suite ,suite-name))) + +(defmacro in-suite* (suite-name &key in) + "Just like in-suite, but silently creates missing suites." + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%in-suite ,suite-name :in ,in :fail-on-error nil))) + +(defmacro %in-suite (suite-name &key (fail-on-error t) in) + (with-gensyms (suite) + `(progn + (if-let (,suite (get-test ',suite-name)) + (setf *suite* ,suite) + (progn + (when ,fail-on-error + (cerror "Create a new suite named ~A." + "Unknown suite ~A." ',suite-name)) + (setf (get-test ',suite-name) (make-suite ',suite-name :in ',in) + *suite* (get-test ',suite-name)))) + ',suite-name))) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE diff --git a/third_party/lisp/fiveam/src/test.lisp b/third_party/lisp/fiveam/src/test.lisp new file mode 100644 index 0000000000..4a6f2fee9a --- /dev/null +++ b/third_party/lisp/fiveam/src/test.lisp @@ -0,0 +1,167 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :it.bese.fiveam) + +;;;; * Tests + +;;;; While executing checks and collecting the results is the core job +;;;; of a testing framework it is also important to be able to +;;;; organize checks into groups, fiveam provides two mechanisms for +;;;; organizing checks: tests and test suites. A test is a named +;;;; collection of checks which can be run and a test suite is a named +;;;; collection of tests and test suites. + +(declaim (special *suite*)) + +(defvar *test* + (make-hash-table :test 'eql) + "Lookup table mapping test (and test suite) + names to objects.") + +(defun get-test (key &optional default) + (gethash key *test* default)) + +(defun (setf get-test) (value key) + (setf (gethash key *test*) value)) + +(defun rem-test (key) + (remhash key *test*)) + +(defun test-names () + (hash-table-keys *test*)) + +(defmacro test (name &body body) + "Create a test named NAME. If NAME is a list it must be of the +form: + + (name &key depends-on suite fixture compile-at profile) + +NAME is the symbol which names the test. + +DEPENDS-ON is a list of the form: + + (AND . test-names) - This test is run only if all of the tests + in TEST-NAMES have passed, otherwise a single test-skipped + result is generated. + + (OR . test-names) - If any of TEST-NAMES has passed this test is + run, otherwise a test-skipped result is generated. + + (NOT test-name) - This is test is run only if TEST-NAME failed. + +AND, OR and NOT can be combined to produce complex dependencies. + +If DEPENDS-ON is a symbol it is interpreted as `(AND +,depends-on), this is accomadate the common case of one test +depending on another. + +FIXTURE specifies a fixture to wrap the body in. + +If PROFILE is T profiling information will be collected as well." + (destructuring-bind (name &rest args) + (ensure-list name) + `(def-test ,name (,@args) ,@body))) + +(defvar *default-test-compilation-time* :definition-time) + +(defmacro def-test (name (&key depends-on (suite '*suite* suite-p) fixture + (compile-at *default-test-compilation-time*) profile) + &body body) + "Create a test named NAME. + +NAME is the symbol which names the test. + +DEPENDS-ON is a list of the form: + + (AND . test-names) - This test is run only if all of the tests + in TEST-NAMES have passed, otherwise a single test-skipped + result is generated. + + (OR . test-names) - If any of TEST-NAMES has passed this test is + run, otherwise a test-skipped result is generated. + + (NOT test-name) - This is test is run only if TEST-NAME failed. + +AND, OR and NOT can be combined to produce complex dependencies. + +If DEPENDS-ON is a symbol it is interpreted as `(AND +,depends-on), this is accomadate the common case of one test +depending on another. + +FIXTURE specifies a fixture to wrap the body in. + +If PROFILE is T profiling information will be collected as well." + (check-type compile-at (member :run-time :definition-time)) + (multiple-value-bind (forms decls docstring) + (parse-body body :documentation t :whole name) + (let* ((description (or docstring "")) + (body-forms (append decls forms)) + (suite-form (if suite-p + `(get-test ',suite) + (or suite '*suite*))) + (effective-body (if fixture + (destructuring-bind (name &rest args) + (ensure-list fixture) + `((with-fixture ,name ,args ,@body-forms))) + body-forms))) + `(progn + (register-test ',name ,description ',effective-body ,suite-form ',depends-on ,compile-at ,profile) + (when *run-test-when-defined* + (run! ',name)) + ',name)))) + +(defun register-test (name description body suite depends-on compile-at profile) + (let ((lambda-name + (format-symbol t "%~A-~A" '#:test name)) + (inner-lambda-name + (format-symbol t "%~A-~A" '#:inner-test name))) + (setf (get-test name) + (make-instance 'test-case + :name name + :runtime-package (find-package (package-name *package*)) + :test-lambda + (eval + `(named-lambda ,lambda-name () + ,@(ecase compile-at + (:run-time `((funcall + (let ((*package* (find-package ',(package-name *package*)))) + (compile ',inner-lambda-name + '(lambda () ,@body)))))) + (:definition-time body)))) + :description description + :depends-on depends-on + :collect-profiling-info profile)) + (setf (gethash name (tests suite)) name))) + +(defvar *run-test-when-defined* nil + "When non-NIL tests are run as soon as they are defined.") + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/third_party/lisp/fiveam/src/utils.lisp b/third_party/lisp/fiveam/src/utils.lisp new file mode 100644 index 0000000000..49d552fa00 --- /dev/null +++ b/third_party/lisp/fiveam/src/utils.lisp @@ -0,0 +1,226 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :it.bese.fiveam) + +(defmacro dolist* ((iterator list &optional return-value) &body body) + "Like DOLIST but destructuring-binds the elements of LIST. + +If ITERATOR is a symbol then dolist* is just like dolist EXCEPT +that it creates a fresh binding." + (if (listp iterator) + (let ((i (gensym "DOLIST*-I-"))) + `(dolist (,i ,list ,return-value) + (destructuring-bind ,iterator ,i + ,@body))) + `(dolist (,iterator ,list ,return-value) + (let ((,iterator ,iterator)) + ,@body)))) + +(defun make-collector (&optional initial-value) + "Create a collector function. + +A Collector function will collect, into a list, all the values +passed to it in the order in which they were passed. If the +callector function is called without arguments it returns the +current list of values." + (let ((value initial-value) + (cdr (last initial-value))) + (lambda (&rest items) + (if items + (progn + (if value + (if cdr + (setf (cdr cdr) items + cdr (last items)) + (setf cdr (last items))) + (setf value items + cdr (last items))) + items) + value)))) + +(defun partitionx (list &rest lambdas) + (let ((collectors (mapcar (lambda (l) + (cons (if (and (symbolp l) + (member l (list :otherwise t) + :test #'string=)) + (constantly t) + l) + (make-collector))) + lambdas))) + (dolist (item list) + (block item + (dolist* ((test-func . collector-func) collectors) + (when (funcall test-func item) + (funcall collector-func item) + (return-from item))))) + (mapcar #'funcall (mapcar #'cdr collectors)))) + +;;;; ** Anaphoric conditionals + +(defmacro if-bind (var test &body then/else) + "Anaphoric IF control structure. + +VAR (a symbol) will be bound to the primary value of TEST. If +TEST returns a true value then THEN will be executed, otherwise +ELSE will be executed." + (assert (first then/else) + (then/else) + "IF-BIND missing THEN clause.") + (destructuring-bind (then &optional else) + then/else + `(let ((,var ,test)) + (if ,var ,then ,else)))) + +(defmacro aif (test then &optional else) + "Just like IF-BIND but the var is always IT." + `(if-bind it ,test ,then ,else)) + +;;;; ** Simple list matching based on code from Paul Graham's On Lisp. + +(defmacro acond2 (&rest clauses) + (if (null clauses) + nil + (with-gensyms (val foundp) + (destructuring-bind ((test &rest progn) &rest others) + clauses + `(multiple-value-bind (,val ,foundp) + ,test + (if (or ,val ,foundp) + (let ((it ,val)) + (declare (ignorable it)) + ,@progn) + (acond2 ,@others))))))) + +(defun varsymp (x) + (and (symbolp x) + (let ((name (symbol-name x))) + (and (>= (length name) 2) + (char= (char name 0) #\?))))) + +(defun binding (x binds) + (labels ((recbind (x binds) + (aif (assoc x binds) + (or (recbind (cdr it) binds) + it)))) + (let ((b (recbind x binds))) + (values (cdr b) b)))) + +(defun list-match (x y &optional binds) + (acond2 + ((or (eql x y) (eql x '_) (eql y '_)) + (values binds t)) + ((binding x binds) (list-match it y binds)) + ((binding y binds) (list-match x it binds)) + ((varsymp x) (values (cons (cons x y) binds) t)) + ((varsymp y) (values (cons (cons y x) binds) t)) + ((and (consp x) (consp y) (list-match (car x) (car y) binds)) + (list-match (cdr x) (cdr y) it)) + (t (values nil nil)))) + +(defun vars (match-spec) + (let ((vars nil)) + (labels ((find-vars (spec) + (cond + ((null spec) nil) + ((varsymp spec) (push spec vars)) + ((consp spec) + (find-vars (car spec)) + (find-vars (cdr spec)))))) + (find-vars match-spec)) + (delete-duplicates vars))) + +(defmacro list-match-case (target &body clauses) + (if clauses + (destructuring-bind ((test &rest progn) &rest others) + clauses + (with-gensyms (tgt binds success) + `(let ((,tgt ,target)) + (multiple-value-bind (,binds ,success) + (list-match ,tgt ',test) + (declare (ignorable ,binds)) + (if ,success + (let ,(mapcar (lambda (var) + `(,var (cdr (assoc ',var ,binds)))) + (vars test)) + (declare (ignorable ,@(vars test))) + ,@progn) + (list-match-case ,tgt ,@others)))))) + nil)) + +;;;; * def-special-environment + +(defun check-required (name vars required) + (dolist (var required) + (assert (member var vars) + (var) + "Unrecognized symbol ~S in ~S." var name))) + +(defmacro def-special-environment (name (&key accessor binder binder*) + &rest vars) + "Define two macros for dealing with groups or related special variables. + +ACCESSOR is defined as a macro: (defmacro ACCESSOR (VARS &rest +BODY)). Each element of VARS will be bound to the +current (dynamic) value of the special variable. + +BINDER is defined as a macro for introducing (and binding new) +special variables. It is basically a readable LET form with the +prorpe declarations appended to the body. The first argument to +BINDER must be a form suitable as the first argument to LET. + +ACCESSOR defaults to a new symbol in the same package as NAME +which is the concatenation of \"WITH-\" NAME. BINDER is built as +\"BIND-\" and BINDER* is BINDER \"*\"." + (unless accessor + (setf accessor (format-symbol (symbol-package name) "~A-~A" '#:with name))) + (unless binder + (setf binder (format-symbol (symbol-package name) "~A-~A" '#:bind name))) + (unless binder* + (setf binder* (format-symbol (symbol-package binder) "~A~A" binder '#:*))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (flet () + (defmacro ,binder (requested-vars &body body) + (check-required ',name ',vars (mapcar #'car requested-vars)) + `(let ,requested-vars + (declare (special ,@(mapcar #'car requested-vars))) + ,@body)) + (defmacro ,binder* (requested-vars &body body) + (check-required ',name ',vars (mapcar #'car requested-vars)) + `(let* ,requested-vars + (declare (special ,@(mapcar #'car requested-vars))) + ,@body)) + (defmacro ,accessor (requested-vars &body body) + (check-required ',name ',vars requested-vars) + `(locally (declare (special ,@requested-vars)) + ,@body)) + ',name))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE diff --git a/third_party/lisp/fiveam/t/example.lisp b/third_party/lisp/fiveam/t/example.lisp new file mode 100644 index 0000000000..c949511a28 --- /dev/null +++ b/third_party/lisp/fiveam/t/example.lisp @@ -0,0 +1,126 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +;;;; * FiveAM Example (poor man's tutorial) + +(asdf:oos 'asdf:load-op :fiveam) + +(defpackage :it.bese.fiveam.example + (:use :common-lisp + :it.bese.fiveam)) + +(in-package :it.bese.fiveam.example) + +;;;; First we need some functions to test. + +(defun add-2 (n) + (+ n 2)) + +(defun add-4 (n) + (+ n 4)) + +;;;; Now we need to create a test which makes sure that add-2 and add-4 +;;;; work as specified. + +;;;; we create a test named ADD-2 and supply a short description. +(test add-2 + "Test the ADD-2 function" ;; a short description + ;; the checks + (is (= 2 (add-2 0))) + (is (= 0 (add-2 -2)))) + +;;;; we can already run add-2. This will return the list of test +;;;; results, it should be a list of two test-passed objects. + +(run 'add-2) + +;;;; since we'd like to have some kind of readbale output we'll explain +;;;; the results + +(explain! (run 'add-2)) + +;;;; or we could do both at once: + +(run! 'add-2) + +;;;; So now we've defined and run a single test. Since we plan on +;;;; having more than one test and we'd like to run them together let's +;;;; create a simple test suite. + +(def-suite example-suite :description "The example test suite.") + +;;;; we could explictly specify that every test we create is in the the +;;;; example-suite suite, but it's easier to just change the default +;;;; suite: + +(in-suite example-suite) + +;;;; now we'll create a new test for the add-4 function. + +(test add-4 + (is (= 0 (add-4 -4)))) + +;;;; now let's run the test + +(run! 'add-4) + +;;;; we can get the same effect by running the suite: + +(run! 'example-suite) + +;;;; since we'd like both add-2 and add-4 to be in the same suite, let's +;;;; redefine add-2 to be in this suite: + +(test add-2 "Test the ADD-2 function" + (is (= 2 (add-2 0))) + (is (= 0 (add-2 -2)))) + +;;;; now we can run the suite and we'll see that both add-2 and add-4 +;;;; have been run (we know this since we no get 4 checks as opposed to +;;;; 2 as before. + +(run! 'example-suite) + +;;;; Just for fun let's see what happens when a test fails. Again we'll +;;;; redefine add-2, but add in a third, failing, check: + +(test add-2 "Test the ADD-2 function" + (is (= 2 (add-2 0))) + (is (= 0 (add-2 -2))) + (is (= 0 (add-2 0)))) + +;;;; Finally let's try out the specification based testing. + +(defun dummy-add (a b) + (+ a b)) + +(defun dummy-strcat (a b) + (concatenate 'string a b)) + +(test dummy-add + (for-all ((a (gen-integer)) + (b (gen-integer))) + ;; assuming we have an "oracle" to compare our function results to + ;; we can use it: + (is (= (+ a b) (dummy-add a b))) + ;; if we don't have an oracle (as in most cases) we just ensure + ;; that certain properties hold: + (is (= (dummy-add a b) + (dummy-add b a))) + (is (= a (dummy-add a 0))) + (is (= 0 (dummy-add a (- a)))) + (is (< a (dummy-add a 1))) + (is (= (* 2 a) (dummy-add a a))))) + +(test dummy-strcat + (for-all ((result (gen-string)) + (split-point (gen-integer :min 0 :max 10000) + (< split-point (length result)))) + (is (string= result (dummy-strcat (subseq result 0 split-point) + (subseq result split-point)))))) + +(test random-failure + (for-all ((result (gen-integer :min 0 :max 1))) + (is (plusp result)) + (is (= result 0)))) + +(run! 'example-suite) diff --git a/third_party/lisp/fiveam/t/tests.lisp b/third_party/lisp/fiveam/t/tests.lisp new file mode 100644 index 0000000000..ed1c565e7d --- /dev/null +++ b/third_party/lisp/fiveam/t/tests.lisp @@ -0,0 +1,280 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :it.bese.fiveam) + +(in-suite* :it.bese.fiveam) + +(def-suite test-suite :description "Suite for tests which should fail.") + +(defmacro with-test-results ((results test-name) &body body) + `(let ((,results (with-*test-dribble* nil (run ',test-name)))) + ,@body)) + +(def-fixture null-fixture () + `(progn ,@(&body))) + +;;;; Test the checks + +(def-test is1 (:suite test-suite) + (is (plusp 1)) + (is (< 0 1)) + (is (not (plusp -1))) + (is (not (< 1 0))) + (is-true t) + (is-false nil)) + +(def-test is2 (:suite test-suite :fixture null-fixture) + (is (plusp 0)) + (is (< 0 -1)) + (is (not (plusp 1))) + (is (not (< 0 1))) + (is-true nil) + (is-false t)) + +(def-test is (:profile t) + (with-test-results (results is1) + (is (= 6 (length results))) + (is (every #'test-passed-p results))) + (with-test-results (results is2) + (is (= 6 (length results))) + (is (every #'test-failure-p results)))) + +(def-test signals/finishes () + (signals error + (error "an error")) + (finishes + (signals error + (error "an error")))) + +(def-test pass () + (pass)) + +(def-test fail1 (:suite test-suite) + (fail "This is supposed to fail")) + +(def-test fail () + (with-test-results (results fail1) + (is (= 1 (length results))) + (is (test-failure-p (first results))))) + +;;;; non top level checks + +(def-test foo-bar () + (let ((state 0)) + (is (= 0 state)) + (is (= 1 (incf state))))) + +;;;; Test dependencies + +(def-test ok (:suite test-suite) + (pass)) + +(def-test not-ok (:suite test-suite) + (fail "This is supposed to fail.")) + +(def-test and1 (:depends-on (and ok not-ok) :suite test-suite) + (fail)) + +(def-test and2 (:depends-on (and ok) :suite test-suite) + (pass)) + +(def-test dep-and () + (with-test-results (results and1) + (is (= 3 (length results))) + ;; we should have one skippedw one failed and one passed + (is (some #'test-passed-p results)) + (is (some #'test-skipped-p results)) + (is (some #'test-failure-p results))) + (with-test-results (results and2) + (is (= 2 (length results))) + (is (every #'test-passed-p results)))) + +(def-test or1 (:depends-on (or ok not-ok) :suite test-suite) + (pass)) + +(def-test or2 (:depends-on (or not-ok ok) :suite test-suite) + (pass)) + +(def-test dep-or () + (with-test-results (results or1) + (is (= 2 (length results))) + (is (every #'test-passed-p results))) + (with-test-results (results or2) + (is (= 3 (length results))) + (is (= 2 (length (remove-if-not #'test-passed-p results)))))) + +(def-test not1 (:depends-on (not not-ok) :suite test-suite) + (pass)) + +(def-test not2 (:depends-on (not ok) :suite test-suite) + (fail)) + +(def-test not () + (with-test-results (results not1) + (is (= 2 (length results))) + (is (some #'test-passed-p results)) + (is (some #'test-failure-p results))) + (with-test-results (results not2) + (is (= 2 (length results))) + (is (some #'test-passed-p results)) + (is (some #'test-skipped-p results)))) + +(def-test nested-logic (:depends-on (and ok (not not-ok) (not not-ok)) + :suite test-suite) + (pass)) + +(def-test dep-nested () + (with-test-results (results nested-logic) + (is (= 3 (length results))) + (is (= 2 (length (remove-if-not #'test-passed-p results)))) + (is (= 1 (length (remove-if-not #'test-failure-p results)))))) + +(def-test circular-0 (:depends-on (and circular-1 circular-2 or1) + :suite test-suite) + (fail "we depend on a circular dependency, we should not be tested.")) + +(def-test circular-1 (:depends-on (and circular-2) + :suite test-suite) + (fail "we have a circular depednency, we should not be tested.")) + +(def-test circular-2 (:depends-on (and circular-1) + :suite test-suite) + (fail "we have a circular depednency, we should not be tested.")) + +(def-test circular () + (signals circular-dependency + (run 'circular-0)) + (signals circular-dependency + (run 'circular-1)) + (signals circular-dependency + (run 'circular-2))) + + +(defun stack-exhaust () + (declare (optimize (debug 3) (speed 0) (space 0) (safety 3))) + (cons 42 (stack-exhaust))) + +;; Disable until we determine on which implementations it's actually safe +;; to exhaust the stack. +#| +(def-test stack-exhaust (:suite test-suite) + (stack-exhaust)) + +(def-test test-stack-exhaust () + (with-test-results (results stack-exhaust) + (is (= 1 (length results))) + (is (test-failure-p (first results))))) +|# + +(def-suite before-test-suite :description "Suite for before test") + +(def-test before-0 (:suite before-test-suite) + (fail)) + +(def-test before-1 (:depends-on (:before before-0) + :suite before-test-suite) + (pass)) + +(def-suite before-test-suite-2 :description "Suite for before test") + +(def-test before-2 (:depends-on (:before before-3) + :suite before-test-suite-2) + (pass)) + +(def-test before-3 (:suite before-test-suite-2) + (pass)) + +(def-test before () + (with-test-results (results before-test-suite) + (is (some #'test-skipped-p results))) + + (with-test-results (results before-test-suite-2) + (is (every #'test-passed-p results)))) + + +;;;; dependencies with symbol +(def-test dep-with-symbol-first (:suite test-suite) + (pass)) + +(def-test dep-with-symbol-dependencies-not-met (:depends-on (not dep-with-symbol-first) + :suite test-suite) + (fail "Error in the test of the test, this should not ever happen")) + +(def-test dep-with-symbol-depends-on-ok (:depends-on dep-with-symbol-first :suite test-suite) + (pass)) + +(def-test dep-with-symbol-depends-on-failed-dependency (:depends-on dep-with-symbol-dependencies-not-met + :suite test-suite) + (fail "No, I should not be tested because I depend on a test that in its turn has a failed dependecy.")) + +(def-test dependencies-with-symbol () + (with-test-results (results dep-with-symbol-first) + (is (some #'test-passed-p results))) + + (with-test-results (results dep-with-symbol-depends-on-ok) + (is (some #'test-passed-p results))) + + (with-test-results (results dep-with-symbol-dependencies-not-met) + (is (some #'test-skipped-p results))) + + ;; No failure here, because it means the test was run. + (with-test-results (results dep-with-symbol-depends-on-failed-dependency) + (is (not (some #'test-failure-p results))))) + + +;;;; test for-all + +(def-test gen-integer () + (for-all ((a (gen-integer))) + (is (integerp a)))) + +(def-test for-all-guarded () + (for-all ((less (gen-integer)) + (more (gen-integer) (< less more))) + (is (< less more)))) + +(def-test gen-float () + (macrolet ((test-gen-float (type) + `(for-all ((unbounded (gen-float :type ',type)) + (bounded (gen-float :type ',type :bound 42))) + (is (typep unbounded ',type)) + (is (typep bounded ',type)) + (is (<= (abs bounded) 42))))) + (test-gen-float single-float) + (test-gen-float short-float) + (test-gen-float double-float) + (test-gen-float long-float))) + +(def-test gen-character () + (for-all ((c (gen-character))) + (is (characterp c))) + (for-all ((c (gen-character :code (gen-integer :min 32 :max 40)))) + (is (characterp c)) + (member c (list #\Space #\! #\" #\# #\$ #\% #\& #\' #\()))) + +(def-test gen-string () + (for-all ((s (gen-string))) + (is (stringp s))) + (for-all ((s (gen-string :length (gen-integer :min 0 :max 2)))) + (is (<= (length s) 2))) + (for-all ((s (gen-string :elements (gen-character :code (gen-integer :min 0 :max 0)) + :length (constantly 2)))) + (is (= 2 (length s))) + (is (every (curry #'char= #\Null) s)))) + +(defun dummy-mv-generator () + (lambda () + (list 1 1))) + +(def-test for-all-destructuring-bind () + (for-all (((a b) (dummy-mv-generator))) + (is (= 1 a)) + (is (= 1 b)))) + +(def-test return-values () + "Return values indicate test failures." + (is-true (with-*test-dribble* nil (explain! (run 'is1)))) + (is-true (with-*test-dribble* nil (run! 'is1))) + + (is-false (with-*test-dribble* nil (explain! (run 'is2)))) + (is-false (with-*test-dribble* nil (run! 'is2)))) diff --git a/third_party/lisp/fiveam/version.sexp b/third_party/lisp/fiveam/version.sexp new file mode 100644 index 0000000000..e0e0284e67 --- /dev/null +++ b/third_party/lisp/fiveam/version.sexp @@ -0,0 +1,2 @@ +;; -*- lisp -*- +"1.4.1" diff --git a/third_party/lisp/flexi-streams.nix b/third_party/lisp/flexi-streams.nix new file mode 100644 index 0000000000..56a7f7b92e --- /dev/null +++ b/third_party/lisp/flexi-streams.nix @@ -0,0 +1,34 @@ +# Flexible bivalent streams for Common Lisp +{ pkgs, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/edicl/flexi-streams.git"; + rev = "0fd872ae32022e834ef861a67d86879cf33a6b64"; +}; +in pkgs.nix.buildLisp.library { + name = "flexi-streams"; + deps = [ pkgs.third_party.lisp.trivial-gray-streams ]; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "mapping.lisp" + "ascii.lisp" + "koi8-r.lisp" + "iso-8859.lisp" + "code-pages.lisp" + "specials.lisp" + "util.lisp" + "conditions.lisp" + "external-format.lisp" + "length.lisp" + "encode.lisp" + "decode.lisp" + "in-memory.lisp" + "stream.lisp" + "output.lisp" + "input.lisp" + "io.lisp" + "strings.lisp" + ]; +} + diff --git a/third_party/lisp/hunchentoot.nix b/third_party/lisp/hunchentoot.nix new file mode 100644 index 0000000000..726eb222e5 --- /dev/null +++ b/third_party/lisp/hunchentoot.nix @@ -0,0 +1,61 @@ +# Hunchentoot is a web framework for Common Lisp. +{ pkgs, ...}: + +let + src = pkgs.third_party.fetchFromGitHub { + owner = "edicl"; + repo = "hunchentoot"; + rev = "585b45b6b873f2da421fdf456b61860ab5868207"; + sha256 = "13nazwix067mdclq9vgjhsi2vpr57a8dz51dd5d3h99ccsq4mik5"; + }; + url-rewrite = pkgs.nix.buildLisp.library { + name = "url-rewrite"; + + srcs = map (f: src + ("/url-rewrite/" + f)) [ + "packages.lisp" + "specials.lisp" + "primitives.lisp" + "util.lisp" + "url-rewrite.lisp" + ]; + }; +in pkgs.nix.buildLisp.library { + name = "hunchentoot"; + + deps = with pkgs.third_party.lisp; [ + alexandria + bordeaux-threads + chunga + cl-base64 + cl-fad + rfc2388 + cl-plus-ssl + cl-ppcre + flexi-streams + md5 + trivial-backtrace + usocket + url-rewrite + ]; + + srcs = map (f: src + ("/" + f)) [ + "hunchentoot.asd" + "packages.lisp" + "compat.lisp" + "specials.lisp" + "conditions.lisp" + "mime-types.lisp" + "util.lisp" + "log.lisp" + "cookie.lisp" + "reply.lisp" + "request.lisp" + "session.lisp" + "misc.lisp" + "headers.lisp" + "set-timeouts.lisp" + "taskmaster.lisp" + "acceptor.lisp" + "easy-handlers.lisp" + ]; +} diff --git a/third_party/lisp/local-time.nix b/third_party/lisp/local-time.nix new file mode 100644 index 0000000000..6f501a5fe9 --- /dev/null +++ b/third_party/lisp/local-time.nix @@ -0,0 +1,18 @@ +# Library for manipulating dates & times +{ pkgs, ... }: + +let src = pkgs.third_party.fetchFromGitHub { + owner = "dlowe-net"; + repo = "local-time"; + rev = "dc54f61415c76ee755a6f69d4154a3a282f2789f"; + sha256 = "1l9v07ghx7g9p2gp003fki4j8bsa1w2gbm40qc41i94mdzikc0ry"; +}; +in pkgs.nix.buildLisp.library { + name = "local-time"; + deps = [ pkgs.third_party.lisp.cl-fad ]; + + srcs = [ + "${src}/src/package.lisp" + "${src}/src/local-time.lisp" + ]; +} diff --git a/third_party/lisp/md5.nix b/third_party/lisp/md5.nix new file mode 100644 index 0000000000..3787e23175 --- /dev/null +++ b/third_party/lisp/md5.nix @@ -0,0 +1,18 @@ +# MD5 hash implementation +{ pkgs, ... }: + +let src = pkgs.third_party.fetchFromGitHub { + owner = "pmai"; + repo = "md5"; + rev = "b1412600f60d526ee34a7ba1596ec483da7894ab"; + sha256 = "0lzip6b6xg7gd70xl1xmqp24fvxqj6ywjnz9lmx7988zpj20nhl2"; +}; +in pkgs.nix.buildLisp.library { + name = "md5"; + + deps = with pkgs.third_party.lisp; [ + sb-rotate-byte + ]; + + srcs = [ (src + "/md5.lisp") ]; +} diff --git a/third_party/lisp/puri.nix b/third_party/lisp/puri.nix new file mode 100644 index 0000000000..1ac22a3996 --- /dev/null +++ b/third_party/lisp/puri.nix @@ -0,0 +1,15 @@ +# Portable URI library +{ pkgs, ... }: + +let src = builtins.fetchGit { + url = "http://git.kpe.io/puri.git"; + rev = "ef5afb9e5286c8e952d4344f019c1a636a717b97"; +}; +in pkgs.nix.buildLisp.library { + name = "puri"; + srcs = [ + (src + "/src.lisp") + ]; +} + + diff --git a/third_party/lisp/quasiquote_2/README.md b/third_party/lisp/quasiquote_2/README.md new file mode 100644 index 0000000000..2d590a0564 --- /dev/null +++ b/third_party/lisp/quasiquote_2/README.md @@ -0,0 +1,258 @@ +quasiquote-2.0 +============== + +Why should it be hard to write macros that write other macros? +Well, it shouldn't! + +quasiquote-2.0 defines slightly different rules for quasiquotation, +that make writing macro-writing macros very smooth experience. + +NOTE: quasiquote-2.0 does horrible things to shared structure!!! +(it does a lot of COPY-TREE's, so shared-ness is destroyed). +So, it's indeed a tool to construct code (where it does not matter much if the +structure is shared or not) and not the data (or, at least, not the data with shared structure) + + +```lisp +(quasiquote-2.0:enable-quasiquote-2.0) + +(defmacro define-my-macro (name args &body body) + `(defmacro ,name ,args + `(sample-thing-to-expand-to + ,,@body))) ; note the difference from usual way + +(define-my-macro foo (x y) + ,x ; now here injections of quotation constructs work + ,y) + +(define-my-macro bar (&body body) + ,@body) ; splicing is also easy +``` + +The "injections" in macros FOO and BAR work as naively expected, as if I had written +```lisp +(defmacro foo (x y) + `(sample-thing-to-expand-to ,x ,y)) + +(defmacro bar (&body body) + `(sample-thing-to-expand-to ,@body)) + +(macroexpand-1 '(foo a b)) + + '(SAMPLE-THING-TO-EXPAND-TO A B) + +(macroexpand-1 '(bar a b c)) + + '(SAMPLE-THING-TO-EXPAND-TO A B C) +``` + + +So, how is this effect achieved? + + +DIG, INJECT and SPLICE +------------------------- + +The transformations of backquote occur at macroexpansion-time and not at read-time. +It is totally possible not to use any special reader syntax, but just +underlying macros directly! + +At the core is a macro DIG, which expands to the code that generates the +expression according to the rules, which are roughly these: + * each DIG increases "depth" by one (hence the name) + * each INJECT or SPLICE decreases "depth" by one + * if depth is 0, evaluation is turned on + * if depth if not zero (even if it's negative!) evaluation is off + * SPLICE splices the form, similarly to ordinary `,@`, INJECT simply injects, same as `,` + +```lisp +;; The example using macros, without special reader syntax + +(dig ; depth is 1 here + (a b + (dig ; depth is 2 here + ((inject c) ; this inject is not evaluated, because depth is nonzero + (inject (d ;depth becomes 1 here again + (inject e) ; and this inject is evaluated, because depth becomes zero + )) + (inject 2 f) ; this inject with level specification is evaluated, because it + ; decreases depth by 2 + )))) + + +;; the same example using ENABLE-QUASIQUOTE-2.0 syntax is written as +`(a b `(,c ,(d ,e) ,,f)) ; note double comma acts different than usually +``` + + +The ENABLE-QUASIQUOTE-2.0 macro just installs reader that reads +`FORM as (DIG FORM), ,FORM as (INJECT FORM) and ,@FORM as (SPLICE FORM). +You can just as well type DIG's, INJECT's and SPLICE's directly, +(in particular, when writing utility functions that generate macro-generating code) +or roll your own convenient reader syntax (pull requests are welcome). + +So, these two lines (with ENABLE-QUASIQUOTE-2.0) read the same +```lisp +`(a (,b `,,c) d) + +(dig (a ((inject b) (dig (inject 2 c))) d)) +``` + +You may notice the (INJECT 2 ...) form appearing, which is described below. + + +At "level 1", i.e. when only \` , and ,@ are used, and not, say \`\` ,, ,', ,,@ ,',@ +this behaves exactly as usual quasiquotation. + + +The optional N argument +-------------- + +All quasiquote-2.0 operators accept optional "depth" argument, +which goes before the form for human readability. + +Namely, (DIG N FORM) increases depth by N instead of one and +(INJECT N FORM) decreases depth by N instead of one. + +```lisp +(DIG 2 (INJECT 2 A)) + +; gives the same result as + +(DIG (INJECT A)) +``` + + +In fact, with ENABLE-QUASIQUOTE-2.0, say, ,,,,,FORM (5 quotes) reads as (INJECT 5 FORM) +and ,,,,,@FORM as (SPLICE 5 FORM) + + +More examples +------------- + +For fairly complicated example, which uses ,,,@ and OINJECT (see below), + see DEFINE-BINOP-DEFINER macro +in CG-LLVM (https://github.com/mabragor/cg-llvm/src/basics.lisp), +desire to write which was the initial impulse for this project. + + +For macro, that is not a macro-writing macro, yet benefits from +ability to inject using `,` and `,@`, consider JOINING-WITH-COMMA-SPACE macro +(also from CG-LLVM) + +```lisp +(defmacro joining-with-comma-space (&body body) + ;; joinl just joins strings in the list with specified string + `(joinl ", " (mapcar #'emit-text-repr + (remove-if-not #'identity `(,,@body))))) + +;; the macro can be then used uniformly over strings and lists of strings +(defun foo (x y &rest z) + (joining-with-comma-space ,x ,y ,@z)) + +(foo "a" "b" "c" "d") + ;; produces + "a, b, c, d" +``` + + +ODIG and OINJECT and OSPLICE +---------------------------- + +Sometimes you don't want DIG's macroexpansion to look further into the structure of +some INJECT or SPLICE or DIG in its subform, +if the depth does not match. In these cases you need "opaque" versions of +DIG, INJECT and SPLICE, named, respectively, ODIG, OINJECT and OSPLICE. + +```lisp +;; here injection of B would occur +(defun foo (b) + (dig (dig (inject (a (inject b)))))) + +;; and here not, because macroexpansion does not look into OINJECT form +(defun bar (b) + (dig (dig (oinject (a (inject b)))))) + +(foo 1) + + '(DIG (INJECT (A 1))) + +(bar 1) + + '(DIG (OINJECT (A (INJECT B)))) +``` + +MACRO-INJECT and MACRO-SPLICE +----------------------------- + +Sometimes you just want to abstract-out some common injection patterns... +That is, you want macros, that expand into common injection patterns. +However, you want this only sometimes, and only in special circumstances. +So it won't do, if INJECT and SPLICE just expanded something, whenever it +turned out to be macro. For that, use MACRO-INJECT and MACRO-SPLICE. + +```lisp +;; with quasiquote-2.0 syntax turned on +(defmacro inject-n-times (form n) + (make-list n :initial-element `(inject ,form))) + +(let (x 0) + `(dig (a (macro-inject (inject-n-times (incf x) 3))))) +;; yields +'(a (1 2 3)) + +;;and same with MACRO-SPLICE +(let (x 0) + `(dig (a (macro-splice (inject-n-times (incf x) 3))))) +;; yields +'(a 1 2 3) +``` + +OMACRO-INJECT and OMACRO-SPLICE are, as usual, opaque variants of MACRO-INJECT and MACRO-SPLICE. + +Both MACRO-INJECT and MACRO-SPLICE expand their subform exactly once (using MACROEXPAND-1), +before plugging it into list. +If you want to expand as much as it's possible, use MACRO-INJECT-ALL and MACRO-SPLICE-ALL, +which expand using MACROEXPAND before injecting/splicing, respectively. +That implies, that while subform of MACRO-INJECT and MACRO-SPLICE is checked to be +macro-form, the subform of MACRO-INJECT-ALL is not. + + +Terse syntax of the ENABLE-QUASIQUOTE-2.0 +----------------------------------------- + +Of course, typing all those MACRO-INJECT-ALL, or OMACRO-SPLICE-ALL or whatever explicitly +every time you want this special things is kind of clumsy. For that, default reader +of quasiquote-2.0 provides extended syntax + +```lisp +',,,,!oma@x + +;; reads as +'(OMACRO-SPLICE-ALL 4 X) +``` + +That is, the regexp of the syntax is +[,]+![o][m][a][@]<whatever> + +As usual, number of commas determine the anti-depth of the injector, exclamation mark +turns on the syntax, if `o` is present, opaque version of injector will be used, +if `m` is present, macro-expanding version of injector will be used and if +`a` is present, macro-all version of injector will be used. + +Note: it's possible to write ,!ax, which will read as (INJECT-ALL X), but +this will not correspond to the actual macro name. + +Note: it was necessary to introduce special escape-char for extended syntax, +since usual idioms like `,args` would otherwise be completely screwed. + + +TODO +---- + +* WITH-QUASIQUOTE-2.0 read-macro-token for local enabling of ` and , overloading +* wrappers for convenient definition of custom overloading schemes +* some syntax for opaque operations + +P.S. Name "quasiquote-2.0" comes from "patronus 2.0" spell from www.hpmor.com + and has nothing to do with being "the 2.0" version of quasiquote. \ No newline at end of file diff --git a/third_party/lisp/quasiquote_2/macros.lisp b/third_party/lisp/quasiquote_2/macros.lisp new file mode 100644 index 0000000000..6ebeb47d08 --- /dev/null +++ b/third_party/lisp/quasiquote_2/macros.lisp @@ -0,0 +1,15 @@ + +(in-package #:quasiquote-2.0) + +(defmacro define-dig-like-macro (name) + `(defmacro ,name (n-or-form &optional (form nil form-p) &environment env) + (if (not form-p) + `(,',name 1 ,n-or-form) + (let ((*env* env)) + (transform-dig-form `(,',name ,n-or-form ,form)))))) + + +(define-dig-like-macro dig) +(define-dig-like-macro odig) + + diff --git a/third_party/lisp/quasiquote_2/package.lisp b/third_party/lisp/quasiquote_2/package.lisp new file mode 100644 index 0000000000..9b140ef84c --- /dev/null +++ b/third_party/lisp/quasiquote_2/package.lisp @@ -0,0 +1,11 @@ +;;;; package.lisp + +(defpackage #:quasiquote-2.0 + (:use #:cl #:iterate) + (:export #:%codewalk-dig-form #:transform-dig-form + #:dig #:inject #:splice #:odig #:oinject #:osplice + #:macro-inject #:omacro-inject #:macro-splice #:omacro-splice + #:macro-inject-all #:omacro-inject-all #:macro-splice-all #:omacro-splice-all + #:enable-quasiquote-2.0 #:disable-quasiquote-2.0)) + + diff --git a/third_party/lisp/quasiquote_2/quasiquote-2.0.asd b/third_party/lisp/quasiquote_2/quasiquote-2.0.asd new file mode 100644 index 0000000000..3acfd32b80 --- /dev/null +++ b/third_party/lisp/quasiquote_2/quasiquote-2.0.asd @@ -0,0 +1,30 @@ +;;;; quasiquote-2.0.asd + +(defpackage :quasiquote-2.0-system + (:use :cl :asdf)) + +(in-package quasiquote-2.0-system) + +(asdf:defsystem #:quasiquote-2.0 + :serial t + :description "Writing macros that write macros. Effortless." + :author "Alexandr Popolitov <popolit@gmail.com>" + :license "MIT" + :version "0.3" + :depends-on (#:iterate) + :components ((:file "package") + (:file "quasiquote-2.0") + (:file "macros") + (:file "readers"))) + +(defsystem :quasiquote-2.0-tests + :description "Tests for QUASIQUOTE-2.0" + :licence "MIT" + :depends-on (:quasiquote-2.0 :fiveam) + :components ((:file "tests") + (:file "tests-macro") + )) + +(defmethod perform ((op test-op) (sys (eql (find-system :quasiquote-2.0)))) + (load-system :quasiquote-2.0) + (funcall (intern "RUN-TESTS" :quasiquote-2.0))) diff --git a/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp b/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp new file mode 100644 index 0000000000..9ce0425d56 --- /dev/null +++ b/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp @@ -0,0 +1,340 @@ +;;;; quasiquote-2.0.lisp + +(in-package #:quasiquote-2.0) + +(defparameter *env* nil) + +(defmacro nonsense-error (str) + `(error ,(concatenate 'string + str + " appears as a bare, non DIG-enclosed form. " + "For now I don't know how to make sense of this."))) + +(defmacro define-nonsense-when-bare (name) + `(defmacro ,name (n-or-form &optional form) + (declare (ignore n-or-form form)) + (nonsense-error ,(string name)))) + +(define-nonsense-when-bare inject) +(define-nonsense-when-bare oinject) +(define-nonsense-when-bare splice) +(define-nonsense-when-bare osplice) +(define-nonsense-when-bare macro-inject) + +(defparameter *depth* 0) + + +(defparameter *injectors* nil) + +;; (defmacro with-injector-parsed (form) +;; `(let ((kwd (intern (string + +(defun reset-injectors () + (setf *injectors* nil)) + +(defparameter *known-injectors* '(inject splice oinject osplice + macro-inject omacro-inject + macro-splice omacro-splice + macro-inject-all omacro-inject-all + macro-splice-all omacro-splice-all)) + +(defun injector-form-p (form) + (and (consp form) + (find (car form) *known-injectors* :test #'eq))) + +(defun injector-level (form) + (if (equal 2 (length form)) + 1 + (cadr form))) + +(defun injector-subform (form) + (if (equal 2 (length form)) + (values (cdr form) '(cdr)) + (values (cddr form) '(cddr)))) + +(defparameter *opaque-injectors* '(odig oinject osplice omacro-inject)) + +(defun transparent-p (form) + (not (find (car form) *opaque-injectors* :test #'eq))) + +(defun look-into-injector (form path) + (let ((*depth* (- *depth* (injector-level form)))) + (multiple-value-bind (subform subpath) (injector-subform form) + (search-all-active-sites subform (append subpath path) nil)))) + +(defparameter *known-diggers* '(dig odig)) + +(defun dig-form-p (form) + (and (consp form) + (find (car form) *known-diggers* :test #'eq))) + +(defun look-into-dig (form path) + (let ((*depth* (+ *depth* (injector-level form)))) + (multiple-value-bind (subform subpath) (injector-subform form) + (search-all-active-sites subform (append subpath path) nil)))) + +(defun handle-macro-1 (form) + (if (atom form) + (error "Sorry, symbol-macros are not implemented for now") + (let ((fun (macro-function (car form) *env*))) + (if (not fun) + (error "The subform of MACRO-1 injector is supposed to be macro, perhaps, something went wrong...")) + (macroexpand-1 form *env*)))) + +(defun handle-macro-all (form) + (if (atom form) + (error "Sorry, symbol-macros are not implemented for now") + (macroexpand form *env*))) + + +(defparameter *macro-handlers* `((macro-inject . ,#'handle-macro-1) + (omacro-inject . ,#'handle-macro-1) + (macro-splice . ,#'handle-macro-1) + (omacro-splice . ,#'handle-macro-1) + (macro-inject-all . ,#'handle-macro-all) + (omacro-inject-all . ,#'handle-macro-all) + (macro-splice-all . ,#'handle-macro-all) + (omacro-splice-all . ,#'handle-macro-all))) + +(defun get-macro-handler (sym) + (or (cdr (assoc sym *macro-handlers*)) + (error "Don't know how to handle this macro injector: ~a" sym))) + + + +(defun macroexpand-macroinjector (place) + (if (not (splicing-injector (car place))) + (progn (setf (car place) (funcall (get-macro-handler (caar place)) + (car (injector-subform (car place))))) + nil) + (let ((new-forms (funcall (get-macro-handler (caar place)) + (car (injector-subform (car place)))))) + (cond ((not new-forms) + (setf *void-filter-needed* t + (car place) *void-elt*)) + ((atom new-forms) (error "We need to splice the macroexpansion, but got atom: ~a" new-forms)) + (t (setf (car place) (car new-forms)) + (let ((tail (cdr place))) + (setf (cdr place) (cdr new-forms) + (cdr (last new-forms)) tail)))) + t))) + + +(defun search-all-active-sites (form path toplevel-p) + ;; (format t "SEARCH-ALL-ACTIVE-SITES: got form ~a~%" form) + (if (not form) + nil + (if toplevel-p + (cond ((atom (car form)) :just-quote-it!) + ((injector-form-p (car form)) (if (equal *depth* (injector-level (car form))) + :just-form-it! + (if (transparent-p (car form)) + (look-into-injector (car form) (cons 'car path))))) + ((dig-form-p (car form)) + ;; (format t "Got dig form ~a~%" form) + (if (transparent-p (car form)) + (look-into-dig (car form) (cons 'car path)))) + (t (search-all-active-sites (car form) (cons 'car path) nil) + (search-all-active-sites (cdr form) (cons 'cdr path) nil))) + (when (consp form) + (cond ((dig-form-p (car form)) + ;; (format t "Got dig form ~a~%" form) + (if (transparent-p (car form)) + (look-into-dig (car form) (cons 'car path)))) + ((injector-form-p (car form)) + ;; (format t "Got injector form ~a ~a ~a~%" form *depth* (injector-level (car form))) + (if (equal *depth* (injector-level (car form))) + (if (macro-injector-p (car form)) + (progn (macroexpand-macroinjector form) + (return-from search-all-active-sites + (search-all-active-sites form path nil))) + (progn (push (cons form (cons 'car path)) *injectors*) + nil)) + (if (transparent-p (car form)) + (look-into-injector (car form) (cons 'car path))))) + (t (search-all-active-sites (car form) (cons 'car path) nil))) + (search-all-active-sites (cdr form) (cons 'cdr path) nil))))) + + + +(defun codewalk-dig-form (form) + (reset-injectors) + (let ((it (search-all-active-sites form nil t))) + (values (nreverse *injectors*) it))) + +(defun %codewalk-dig-form (form) + (if (not (dig-form-p form)) + (error "Supposed to be called on dig form") + (let ((*depth* (+ (injector-level form) *depth*))) + (codewalk-dig-form (injector-subform form))))) + +(defun path->setfable (path var) + (let ((res var)) + ;; First element is artifact of extra CAR-ing + (dolist (spec (cdr (reverse path))) + (setf res (list spec res))) + res)) + +(defun tree->cons-code (tree) + (if (atom tree) + `(quote ,tree) + `(cons ,(tree->cons-code (car tree)) + ,(tree->cons-code (cdr tree))))) + +(defparameter *known-splicers* '(splice osplice + macro-splice omacro-splice + macro-splice-all omacro-splice-all)) + +(defun splicing-injector (form) + (and (consp form) + (find (car form) *known-splicers* :test #'eq))) + +(defparameter *known-macro-injectors* '(macro-inject omacro-inject + macro-splice omacro-splice + macro-inject-all omacro-inject-all + macro-splice-all omacro-splice-all + )) + +(defun macro-injector-p (form) + (and (consp form) + (find (car form) *known-macro-injectors* :test #'eq))) + +(defparameter *void-elt* nil) +(defparameter *void-filter-needed* nil) + +(defun filter-out-voids (lst void-sym) + (let (caars cadrs cdars cddrs) + ;; search for all occurences of VOID + (labels ((rec (x) + (if (consp x) + (progn (cond ((consp (car x)) + (cond ((eq void-sym (caar x)) (push x caars)) + ((eq void-sym (cdar x)) (push x cdars)))) + ((consp (cdr x)) + (cond ((eq void-sym (cadr x)) (push x cadrs)) + ((eq void-sym (cddr x)) (push x cddrs))))) + (rec (car x)) + (rec (cdr x)))))) + (rec lst)) + (if (or cdars cddrs) + (error "Void sym found on CDR position, which should not have happened")) + ;; destructively transform LST + (dolist (elt caars) + (setf (car elt) (cdar elt))) + (dolist (elt cadrs) + (setf (cdr elt) (cddr elt))) + ;; check that we indeed filtered-out all VOIDs + (labels ((rec (x) + (if (not (atom x)) + (progn (rec (car x)) + (rec (cdr x))) + (if (eq void-sym x) + (error "Not all VOIDs were filtered"))))) + (rec lst)) + lst)) + +(defun transform-dig-form (form) + (let ((the-form (copy-tree form))) + (let ((*void-filter-needed* nil) + (*void-elt* (gensym "VOID"))) + (multiple-value-bind (site-paths cmd) (%codewalk-dig-form the-form) + (cond ((eq cmd :just-quote-it!) + `(quote ,(car (injector-subform the-form)))) + ((eq cmd :just-form-it!) + (car (injector-subform (car (injector-subform the-form))))) + (t (let ((cons-code (if (not site-paths) + (tree->cons-code (car (injector-subform the-form))) + (really-transform-dig-form the-form site-paths)))) + (if (not *void-filter-needed*) + cons-code + `(filter-out-voids ,cons-code ',*void-elt*))))))))) + +(defmacro make-list-form (o!-n form) + (let ((g!-n (gensym "N")) + (g!-i (gensym "I")) + (g!-res (gensym "RES"))) + `(let ((,g!-n ,o!-n) + (,g!-res nil)) + (dotimes (,g!-i ,g!-n) + (push ,form ,g!-res)) + (nreverse ,g!-res)))) + +(defun mk-splicing-injector-let (x) + `(let ((it ,(car (injector-subform x)))) + (assert (listp it)) + (copy-list it))) + + + +(defun mk-splicing-injector-setf (path g!-list g!-splicee) + (assert (eq 'car (car path))) + (let ((g!-rest (gensym "REST"))) + `(let ((,g!-rest ,(path->setfable (cons 'cdr (cdr path)) g!-list))) + (assert (or (not ,g!-rest) (consp ,g!-rest))) + (if (not ,g!-splicee) + (setf ,(path->setfable (cdr path) g!-list) + ,g!-rest) + (progn (setf ,(path->setfable (cdr path) g!-list) ,g!-splicee) + (setf (cdr (last ,g!-splicee)) ,g!-rest)))))) + + +(defun really-transform-dig-form (the-form site-paths) + (let ((gensyms (make-list-form (length site-paths) (gensym "INJECTEE")))) + (let ((g!-list (gensym "LIST"))) + (let ((lets nil) + (splicing-setfs nil) + (setfs nil)) + (do ((site-path site-paths (cdr site-path)) + (gensym gensyms (cdr gensym))) + ((not site-path)) + (destructuring-bind (site . path) (car site-path) + (push `(,(car gensym) ,(if (not (splicing-injector (car site))) + (car (injector-subform (car site))) + (mk-splicing-injector-let (car site)))) + lets) + (if (not (splicing-injector (car site))) + (push `(setf ,(path->setfable path g!-list) ,(car gensym)) setfs) + (push (mk-splicing-injector-setf path g!-list (car gensym)) splicing-setfs)) + (setf (car site) nil))) + `(let ,(nreverse lets) + (let ((,g!-list ,(tree->cons-code (car (injector-subform the-form))))) + ,@(nreverse setfs) + ;; we apply splicing setf in reverse order for them not to bork the paths of each other + ,@splicing-setfs + ,g!-list)))))) + + +;; There are few types of recursive injection that may happen: +;; * compile-time injection: +;; (dig (inject (dig (inject a)))) -- this type will be handled automatically by subsequent macroexpansions +;; * run-time injection: +;; (dig (dig (inject 2 a))) +;; and A is '(dig (inject 3 'foo)) -- this one we guard against ? (probably, first we just ignore it +;; -- do not warn about it, and then it wont really happen. +;; * macroexpanded compile-time injection: +;; (dig (inject (my-macro a b c))), +;; where MY-MACRO expands into, say (splice (list 'a 'b 'c)) +;; This is *not* handled automatically, and therefore we must do it by hand. + + +;; OK, now how to implement splicing ? +;; (dig (a (splice (list b c)) d)) +;; should transform into code that yields +;; (a b c d) +;; what this code is? +;; (let ((#:a (copy-list (list b c)))) +;; (let ((#:res (cons 'a nil 'd))) +;; ;; all non-splicing injects go here, as they do not spoil the path-structure +;; (setf (cdr #:res) #:a) +;; (setf (cdr (last #:a)) (cdr (cdr #:res))) +;; #:res))) + + +;; How this macroexpansion should work in general? +;; * We go over the cons-tree, keeping track of the depth level, which is +;; controlled by DIG's +;; * Once we find the INJECT with matching level, we remember the place, where +;; this happens +;; * We have two special cases: +;; * cons-tree is an atom +;; * cons-tree is just a single INJECT diff --git a/third_party/lisp/quasiquote_2/readers.lisp b/third_party/lisp/quasiquote_2/readers.lisp new file mode 100644 index 0000000000..7c4c5a30c9 --- /dev/null +++ b/third_party/lisp/quasiquote_2/readers.lisp @@ -0,0 +1,77 @@ + + +(in-package #:quasiquote-2.0) + +(defun read-n-chars (stream char) + (let (new-char + (n 0)) + (loop + (setf new-char (read-char stream nil :eof t)) + (if (not (char= new-char char)) + (progn (unread-char new-char stream) + (return n)) + (incf n))))) + +(defmacro define-dig-reader (name symbol) + `(defun ,name (stream char) + (let ((depth (1+ (read-n-chars stream char)))) + (if (equal 1 depth) + (list ',symbol (read stream t nil t)) + (list ',symbol + depth + (read stream t nil t)))))) + +(define-dig-reader dig-reader dig) +(define-dig-reader odig-reader odig) + +(defun expect-char (char stream) + (let ((new-char (read-char stream t nil t))) + (if (char= char new-char) + t + (unread-char new-char stream)))) + +(defun guess-injector-name (opaque-p macro-p all-p splicing-p) + (intern (concatenate 'string + (if opaque-p "O" "") + (if macro-p "MACRO-" "") + (if splicing-p "SPLICE" "INJECT") + (if all-p "-ALL" "")) + "QUASIQUOTE-2.0")) + +(defun inject-reader (stream char) + (let ((anti-depth (1+ (read-n-chars stream char))) + (extended-syntax (expect-char #\! stream))) + (let ((injector-name (if (not extended-syntax) + (guess-injector-name nil nil nil (expect-char #\@ stream)) + (guess-injector-name (expect-char #\o stream) + (expect-char #\m stream) + (expect-char #\a stream) + (expect-char #\@ stream))))) + `(,injector-name ,@(if (not (equal 1 anti-depth)) `(,anti-depth)) + ,(read stream t nil t))))) + + + +(defvar *previous-readtables* nil) + +(defun %enable-quasiquote-2.0 () + (push *readtable* + *previous-readtables*) + (setq *readtable* (copy-readtable)) + (set-macro-character #\` #'dig-reader) + (set-macro-character #\, #'inject-reader) + (values)) + +(defun %disable-quasiquote-2.0 () + (if *previous-readtables* + (setf *readtable* (pop *previous-readtables*)) + (setf *readtable* (copy-readtable nil))) + (values)) + +(defmacro enable-quasiquote-2.0 () + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%enable-quasiquote-2.0))) +(defmacro disable-quasiquote-2.0 () + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%disable-quasiquote-2.0))) + diff --git a/third_party/lisp/quasiquote_2/tests-macro.lisp b/third_party/lisp/quasiquote_2/tests-macro.lisp new file mode 100644 index 0000000000..df6c43e21d --- /dev/null +++ b/third_party/lisp/quasiquote_2/tests-macro.lisp @@ -0,0 +1,21 @@ + +(in-package #:quasiquote-2.0-tests) + +(in-suite quasiquote-2.0) + +(enable-quasiquote-2.0) + +(defmacro define-sample-macro (name args &body body) + `(defmacro ,name ,args + `(sample-thing-to-macroexpand-to + ,,@body))) + +(define-sample-macro sample-macro-1 (x y) + ,x ,y) + +(define-sample-macro sample-macro-2 (&body body) + ,@body) + +(test macro-defined-macroexpansions + (is (equal '(sample-thing-to-macroexpand-to a b) (macroexpand-1 '(sample-macro-1 a b)))) + (is (equal '(sample-thing-to-macroexpand-to a b c) (macroexpand-1 '(sample-macro-2 a b c))))) \ No newline at end of file diff --git a/third_party/lisp/quasiquote_2/tests.lisp b/third_party/lisp/quasiquote_2/tests.lisp new file mode 100644 index 0000000000..6c8ab08cc1 --- /dev/null +++ b/third_party/lisp/quasiquote_2/tests.lisp @@ -0,0 +1,143 @@ +(in-package :cl-user) + +(defpackage :quasiquote-2.0-tests + (:use :cl :quasiquote-2.0 :fiveam) + (:export #:run-tests)) + +(in-package :quasiquote-2.0-tests) + +(def-suite quasiquote-2.0) +(in-suite quasiquote-2.0) + +(defun run-tests () + (let ((results (run 'quasiquote-2.0))) + (fiveam:explain! results) + (unless (fiveam:results-status results) + (error "Tests failed.")))) + +(test basic + (is (equal '(nil :just-quote-it!) (multiple-value-list (%codewalk-dig-form '(dig nil))))) + (is (equal '(nil :just-form-it!) (multiple-value-list (%codewalk-dig-form '(dig (inject a)))))) + (is (equal '(nil :just-form-it!) (multiple-value-list (%codewalk-dig-form '(dig 2 (inject 2 a)))))) + (is (equal '(((((inject b) c (inject d)) car cdr car) (((inject d)) car cdr cdr cdr car)) nil) + (multiple-value-list (%codewalk-dig-form '(dig (a (inject b) c (inject d))))))) + (is (equal '(nil nil) + (multiple-value-list (%codewalk-dig-form '(dig (dig (a (inject b) c (inject d)))))))) + (is (equal '(((((inject 2 d)) car cdr cdr cdr car cdr car)) nil) + (multiple-value-list (%codewalk-dig-form '(dig (dig (a (inject b) c (inject 2 d))))))))) + +(test transform + (is (equal '(quote a) (transform-dig-form '(dig a)))) + (is (equal '(quote a) (transform-dig-form '(dig 2 a)))) + (is (equal 'a (transform-dig-form '(dig (inject a))))) + (is (equal 'a (transform-dig-form '(dig 2 (inject 2 a)))))) + +(defun foo (b d) + (dig (a (inject b) c (inject d)))) + +(defun foo1-transparent (x) + (declare (ignorable x)) + (dig (dig (a (inject (b (inject x) c)))))) + +(defun foo1-opaque (x) + (declare (ignorable x)) + (dig (dig (a (oinject (b (inject x) c)))))) + +(defun foo-recursive (x y) + (dig (a (inject (list x (dig (c (inject y)))))))) + + +(test foos + (is (equal '(a 1 c 2) (foo 1 2))) + (is (equal '(a 100 c 200) (foo 100 200)))) + +(test opaque-vs-transparent + (is (equal '(quote a) (transform-dig-form '(odig a)))) + (is (equal '(quote a) (transform-dig-form '(odig 2 a)))) + (is (equal 'a (transform-dig-form '(odig (inject a))))) + (is (equal 'a (transform-dig-form '(odig 2 (inject 2 a))))) + (is (equal '(odig (inject 2 a)) (eval (transform-dig-form '(dig (odig (inject 2 a))))))) + (is (equal '(dig (a (inject (b 3 c)))) (foo1-transparent 3))) + (is (equal '(dig (a (oinject (b (inject x) c)))) (foo1-opaque 3)))) + +(test recursive-compile-time + (is (equal '(a (1 (c 2))) (foo-recursive 1 2)))) + + +(test splicing + (is (equal '(a b c d) (eval (transform-dig-form '(dig (a (splice '(b c)) d)))))) + (is (equal '(b c d) (eval (transform-dig-form '(dig ((splice '(b c)) d)))))) + (is (equal '(a b c) (eval (transform-dig-form '(dig (a (splice '(b c)))))))) + (is (equal '(a b) (eval (transform-dig-form '(dig (a (splice nil) b)))))) + (is (equal '(b) (eval (transform-dig-form '(dig ((splice nil) b)))))) + (is (equal '(a) (eval (transform-dig-form '(dig (a (splice nil))))))) + (is (equal '() (eval (transform-dig-form '(dig ((splice nil))))))) + (is (equal '(a b) (eval (transform-dig-form '(dig ((splice '(a b))))))))) + + +(test are-they-macro + (is (not (equal '(dig (a b)) (macroexpand-1 '(dig (a b)))))) + (is (not (equal '(odig (a b)) (macroexpand-1 '(odig (a b))))))) + + +(defmacro triple-var (x) + `((inject ,x) (inject ,x) (inject ,x))) + +(test correct-order-of-effects + (is (equal '(a 1 2 3) (let ((x 0)) + (dig (a (inject (incf x)) (inject (incf x)) (inject (incf x))))))) + (is (equal '(a (((1))) 2) + (let ((x 0)) + (dig (a ((((inject (incf x))))) (inject (incf x)))))))) + +(test macro-injects + (is (equal '(a (3 3 3)) (let ((x 3)) + (dig (a (macro-inject (triple-var x))))))) + (is (equal '(a (1 2 3)) (let ((x 0)) + (dig (a (macro-inject (triple-var (incf x)))))))) + (macrolet ((frob (form n) + (mapcar (lambda (x) + `(inject ,x)) + (make-list n :initial-element form))) + (frob1 (form) + `(frob ,form 4))) + (is (equal '(a (1 2 3 4 5)) + (let ((x 0)) + (dig (a (macro-inject (frob (incf x) 5))))))) + (is (equal '(a 1 2 3 4 5) + (let ((x 0)) + (dig (a (macro-splice (frob (incf x) 5))))))) + (is (equal '(a) + (let ((x 0)) + (declare (ignorable x)) + (dig (a (macro-splice (frob (incf x) 0))))))) + (is (equal '(a frob (incf x) 4) + (let ((x 0)) + (declare (ignorable x)) + (dig (a (macro-splice (frob1 (incf x)))))))) + (is (equal '(a 1 2 3 4) + (let ((x 0)) + (dig (a (macro-splice-all (frob1 (incf x)))))))))) + + +(quasiquote-2.0:enable-quasiquote-2.0) + +(test reader + (is (equal '(inject x) ',x)) + (is (equal '(inject 3 x) ',,,x)) + (is (equal '(splice x) ',@x)) + (is (equal '(splice 3 x) ',,,@x)) + (is (equal '(omacro-splice-all 4 x) ',,,,!oma@x)) + (is (equal '(inject 4 oma@x) ',,,,oma@x))) + +(test macro-splices + (macrolet ((splicer (x) + ``(splice ,x))) + (is (equal '(a 1 2 3) (let ((x '(1 2 3))) + `(a ,!m(splicer x))))))) + +(test repeated-splices + (is (equal '(a) `(a ,@nil ,@nil ,@nil ,@nil))) + (is (equal '(a b c d e f g) `(a ,@(list 'b 'c) ,@(list 'd 'e) ,@nil ,@(list 'f 'g))))) + + \ No newline at end of file diff --git a/third_party/lisp/rfc2388.nix b/third_party/lisp/rfc2388.nix new file mode 100644 index 0000000000..863bb3f9ac --- /dev/null +++ b/third_party/lisp/rfc2388.nix @@ -0,0 +1,17 @@ +# Implementation of RFC2388 (multipart/form-data) +{ pkgs, ... }: + +let src = pkgs.third_party.fetchFromGitHub { + owner = "jdz"; + repo = "rfc2388"; + rev = "591bcf7e77f2c222c43953a80f8c297751dc0c4e"; + sha256 = "0phh5n3clhl9ji8jaxrajidn22d3f0aq87mlbfkkxlnx2pnw694k"; +}; +in pkgs.nix.buildLisp.library { + name = "rfc2388"; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "rfc2388.lisp" + ]; +} diff --git a/third_party/lisp/s-sysdeps.nix b/third_party/lisp/s-sysdeps.nix new file mode 100644 index 0000000000..3b90f3a7ea --- /dev/null +++ b/third_party/lisp/s-sysdeps.nix @@ -0,0 +1,17 @@ +# A Common Lisp abstraction layer over platform dependent functionality. +{ pkgs, ... }: + +let src = pkgs.third_party.fetchFromGitHub { + owner = "svenvc"; + repo = "s-sysdeps"; + rev = "d28246b5dffef9e73a0e0e6cfbc4e878006fe34d"; + sha256 = "14b69b81yrxmjlvmm3lfxk04x5v7hqz4fql121334wh72czznfh9"; +}; +in pkgs.nix.buildLisp.library { + name = "s-sysdeps"; + + srcs = [ + "${src}/src/package.lisp" + "${src}/src/sysdeps.lisp" + ]; +} diff --git a/third_party/lisp/s-xml/.gitignore b/third_party/lisp/s-xml/.gitignore new file mode 100644 index 0000000000..40caffa8e2 --- /dev/null +++ b/third_party/lisp/s-xml/.gitignore @@ -0,0 +1,28 @@ +# CVS default ignores begin +tags +TAGS +.make.state +.nse_depinfo +*~ +#* +.#* +,* +_$* +*$ +*.old +*.bak +*.BAK +*.orig +*.rej +.del-* +*.a +*.olb +*.o +*.obj +*.so +*.exe +*.Z +*.elc +*.ln +core +# CVS default ignores end diff --git a/third_party/lisp/s-xml/ChangeLog b/third_party/lisp/s-xml/ChangeLog new file mode 100644 index 0000000000..ac196619c0 --- /dev/null +++ b/third_party/lisp/s-xml/ChangeLog @@ -0,0 +1,66 @@ +2006-01-19 Sven Van Caekenberghe <svc@mac.com> + + * added a set of patches contributed by David Tolpin dvd@davidashen.net : we're now using char of type + Character and #\Null instead of null, read/unread instead of peek/read and some more declarations for + more efficiency - added hooks for customizing parsing attribute names and values + +2005-11-20 Sven Van Caekenberghe <svc@mac.com> + + * added xml prefix namespace as per REC-xml-names-19990114 (by Rudi Schlatte) + +2005-11-06 Sven Van Caekenberghe <svc@mac.com> + + * removed Debian packaging directory (on Luca's request) + * added CDATA support (patch contributed by Peter Van Eynde pvaneynd@mailworks.org) + +2005-08-30 Sven Van Caekenberghe <svc@mac.com> + + * added Debian packaging directory (contributed by Luca Capello luca@pca.it) + * added experimental XML namespace support + +2005-02-03 Sven Van Caekenberghe <svc@mac.com> + + * release 5 (cvs tag RELEASE_5) + * added :start and :end keywords to print-string-xml + * fixed a bug: in a tag containing whitespace, like <foo> </foo> the parser collapsed + and ingnored all whitespace and considered the tag to be empty! + this is now fixed and a unit test has been added + * cleaned up xml character escaping a bit: single quotes and all normal whitespace + (newline, return and tab) is preserved a unit test for this has been added + * IE doesn't understand the ' XML entity, so I've commented that out for now. + Also, using actual newlines for newlines is probably better than using #xA, + which won't get any end of line conversion by the server or user agent. + +June 2004 Sven Van Caekenberghe <svc@mac.com> + + * release 4 + * project moved to common-lisp.net, renamed to s-xml, + * added examples counter, tracer and remove-markup, improved documentation + +13 Jan 2004 Sven Van Caekenberghe <svc@mac.com> + + * release 3 + * added ASDF systems + * optimized print-string-xml + +10 Jun 2003 Sven Van Caekenberghe <svc@mac.com> + + * release 2 + * added echo-xml function: we are no longer taking the car when + the last seed is returned from start-parse-xml + +25 May 2003 Sven Van Caekenberghe <svc@mac.com> + + * release 1 + * first public release of working code + * tested on OpenMCL + * rewritten to be event-based, to improve efficiency and + to optionally use different DOM representations + * more documentation + +end of 2002 Sven Van Caekenberghe <svc@mac.com> + + * release 0 + * as part of an XML-RPC implementation + +$Id: ChangeLog,v 1.5 2005/11/20 14:24:33 scaekenberghe Exp $ diff --git a/third_party/lisp/s-xml/Makefile b/third_party/lisp/s-xml/Makefile new file mode 100644 index 0000000000..0c7292ea9f --- /dev/null +++ b/third_party/lisp/s-xml/Makefile @@ -0,0 +1,35 @@ +# $Id: Makefile,v 1.2 2004/06/11 13:46:48 scaekenberghe Exp $ + +default: + @echo Possible targets: + @echo clean-openmcl --- remove all '*.dfsl' recursively + @echo clean-lw --- remove all '*.nfasl' recursively + @echo clean-emacs --- remove all '*~' recursively + @echo clean --- all of the above + +clean-openmcl: + find . -name "*.dfsl" | xargs rm + +clean-lw: + find . -name "*.nfasl" | xargs rm + +clean-emacs: + find . -name "*~" | xargs rm + +clean: clean-openmcl clean-lw clean-emacs + +# +# This can obviously only be done by a specific person in a very specific context ;-) +# + +PRJ=s-xml +ACCOUNT=scaekenberghe +CVSRT=:ext:$(ACCOUNT)@common-lisp.net:/project/$(PRJ)/cvsroot + +release: + rm -rf /tmp/$(PRJ) /tmp/public_html /tmp/$(PRJ).tgz /tmp/$(PRJ).tgz.asc + cd /tmp; cvs -d$(CVSRT) export -r HEAD $(PRJ); cvs -d$(CVSRT) export -r HEAD public_html + mv /tmp/public_html /tmp/$(PRJ)/doc + cd /tmp; gnutar cvfz $(PRJ).tgz $(PRJ); gpg -a -b $(PRJ).tgz + scp /tmp/$(PRJ).tgz $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html + scp /tmp/$(PRJ).tgz.asc $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html diff --git a/third_party/lisp/s-xml/default.nix b/third_party/lisp/s-xml/default.nix new file mode 100644 index 0000000000..884846a30f --- /dev/null +++ b/third_party/lisp/s-xml/default.nix @@ -0,0 +1,17 @@ +# XML serialiser for Common Lisp. +# +# This system was imported from a Quicklisp tarball at 's-xml-20150608'. +{ pkgs, ... }: + +pkgs.nix.buildLisp.library { + name = "s-xml"; + + srcs = [ + ./src/package.lisp + ./src/xml.lisp + ./src/dom.lisp + ./src/lxml-dom.lisp + ./src/sxml-dom.lisp + ./src/xml-struct-dom.lisp + ]; +} diff --git a/third_party/lisp/s-xml/examples/counter.lisp b/third_party/lisp/s-xml/examples/counter.lisp new file mode 100644 index 0000000000..b26453e6ea --- /dev/null +++ b/third_party/lisp/s-xml/examples/counter.lisp @@ -0,0 +1,47 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: counter.lisp,v 1.2 2004/06/11 11:14:43 scaekenberghe Exp $ +;;;; +;;;; A simple SSAX counter example that can be used as a performance test +;;;; +;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(defclass count-xml-seed () + ((elements :initform 0) + (attributes :initform 0) + (characters :initform 0))) + +(defun count-xml-new-element-hook (name attributes seed) + (declare (ignore name)) + (incf (slot-value seed 'elements)) + (incf (slot-value seed 'attributes) (length attributes)) + seed) + +(defun count-xml-text-hook (string seed) + (incf (slot-value seed 'characters) (length string)) + seed) + +(defun count-xml (in) + "Parse a toplevel XML element from stream in, counting elements, attributes and characters" + (start-parse-xml in + (make-instance 'xml-parser-state + :seed (make-instance 'count-xml-seed) + :new-element-hook #'count-xml-new-element-hook + :text-hook #'count-xml-text-hook))) + +(defun count-xml-file (pathname) + "Parse XMl from the file at pathname, counting elements, attributes and characters" + (with-open-file (in pathname) + (let ((result (count-xml in))) + (with-slots (elements attributes characters) result + (format t + "~a contains ~d XML elements, ~d attributes and ~d characters.~%" + pathname elements attributes characters))))) + +;;;; eof diff --git a/third_party/lisp/s-xml/examples/echo.lisp b/third_party/lisp/s-xml/examples/echo.lisp new file mode 100644 index 0000000000..a0befe2cbb --- /dev/null +++ b/third_party/lisp/s-xml/examples/echo.lisp @@ -0,0 +1,64 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: echo.lisp,v 1.1 2005/08/17 13:44:30 scaekenberghe Exp $ +;;;; +;;;; A simple example as well as a useful tool: parse, echo and pretty print XML +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(defun indent (stream count) + (loop :repeat (* count 2) :do (write-char #\space stream))) + +(defclass echo-xml-seed () + ((stream :initarg :stream) + (level :initarg :level :initform 0))) + +#+NIL +(defmethod print-object ((seed echo-xml-seed) stream) + (with-slots (stream level) seed + (print-unreadable-object (seed stream :type t) + (format stream "level=~d" level)))) + +(defun echo-xml-new-element-hook (name attributes seed) + (with-slots (stream level) seed + (indent stream level) + (format stream "<~a" name) + (dolist (attribute (reverse attributes)) + (format stream " ~a=\'" (car attribute)) + (print-string-xml (cdr attribute) stream) + (write-char #\' stream)) + (format stream ">~%") + (incf level) + seed)) + +(defun echo-xml-finish-element-hook (name attributes parent-seed seed) + (declare (ignore attributes parent-seed)) + (with-slots (stream level) seed + (decf level) + (indent stream level) + (format stream "</~a>~%" name) + seed)) + +(defun echo-xml-text-hook (string seed) + (with-slots (stream level) seed + (indent stream level) + (print-string-xml string stream) + (terpri stream) + seed)) + +(defun echo-xml (in out) + "Parse a toplevel XML element from stream in, echoing and pretty printing the result to stream out" + (start-parse-xml in + (make-instance 'xml-parser-state + :seed (make-instance 'echo-xml-seed :stream out) + :new-element-hook #'echo-xml-new-element-hook + :finish-element-hook #'echo-xml-finish-element-hook + :text-hook #'echo-xml-text-hook))) + +;;;; eof diff --git a/third_party/lisp/s-xml/examples/remove-markup.lisp b/third_party/lisp/s-xml/examples/remove-markup.lisp new file mode 100644 index 0000000000..41d858b4a8 --- /dev/null +++ b/third_party/lisp/s-xml/examples/remove-markup.lisp @@ -0,0 +1,21 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: remove-markup.lisp,v 1.1 2004/06/11 11:14:43 scaekenberghe Exp $ +;;;; +;;;; Remove markup from an XML document using the SSAX interface +;;;; +;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(defun remove-xml-markup (in) + (let* ((state (make-instance 'xml-parser-state + :text-hook #'(lambda (string seed) (cons string seed)))) + (result (start-parse-xml in state))) + (apply #'concatenate 'string (nreverse result)))) + +;;;; eof \ No newline at end of file diff --git a/third_party/lisp/s-xml/examples/tracer.lisp b/third_party/lisp/s-xml/examples/tracer.lisp new file mode 100644 index 0000000000..c8a3eaec1f --- /dev/null +++ b/third_party/lisp/s-xml/examples/tracer.lisp @@ -0,0 +1,57 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: tracer.lisp,v 1.2 2004/06/11 11:14:43 scaekenberghe Exp $ +;;;; +;;;; A simple SSAX tracer example that can be used to understand how the hooks are called +;;;; +;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(defun trace-xml-log (level msg &rest args) + (indent *standard-output* level) + (apply #'format *standard-output* msg args) + (terpri *standard-output*)) + +(defun trace-xml-new-element-hook (name attributes seed) + (let ((new-seed (cons (1+ (car seed)) (1+ (cdr seed))))) + (trace-xml-log (car seed) + "(new-element :name ~s :attributes ~:[()~;~:*~s~] :seed ~s) => ~s" + name attributes seed new-seed) + new-seed)) + +(defun trace-xml-finish-element-hook (name attributes parent-seed seed) + (let ((new-seed (cons (1- (car seed)) (1+ (cdr seed))))) + (trace-xml-log (car parent-seed) + "(finish-element :name ~s :attributes ~:[()~;~:*~s~] :parent-seed ~s :seed ~s) => ~s" + name attributes parent-seed seed new-seed) + new-seed)) + +(defun trace-xml-text-hook (string seed) + (let ((new-seed (cons (car seed) (1+ (cdr seed))))) + (trace-xml-log (car seed) + "(text :string ~s :seed ~s) => ~s" + string seed new-seed) + new-seed)) + +(defun trace-xml (in) + "Parse and trace a toplevel XML element from stream in" + (start-parse-xml in + (make-instance 'xml-parser-state + :seed (cons 0 0) + ;; seed car is xml element nesting level + ;; seed cdr is ever increasing from element to element + :new-element-hook #'trace-xml-new-element-hook + :finish-element-hook #'trace-xml-finish-element-hook + :text-hook #'trace-xml-text-hook))) + +(defun trace-xml-file (pathname) + "Parse and trace XMl from the file at pathname" + (with-open-file (in pathname) + (trace-xml in))) + +;;;; eof diff --git a/third_party/lisp/s-xml/s-xml.asd b/third_party/lisp/s-xml/s-xml.asd new file mode 100644 index 0000000000..651f5e5844 --- /dev/null +++ b/third_party/lisp/s-xml/s-xml.asd @@ -0,0 +1,49 @@ +;;;; -*- Mode: LISP -*- +;;;; +;;;; $Id: s-xml.asd,v 1.2 2005/12/14 21:49:04 scaekenberghe Exp $ +;;;; +;;;; The S-XML ASDF system definition +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :asdf) + +(defsystem :s-xml + :name "S-XML" + :author "Sven Van Caekenberghe <svc@mac.com>" + :version "3" + :maintainer "Sven Van Caekenberghe <svc@mac.com>, Brian Mastenbrook <>, Rudi Schlatte <>" + :licence "Lisp Lesser General Public License (LLGPL)" + :description "Simple Common Lisp XML Parser" + :long-description "S-XML is a Common Lisp implementation of a simple XML parser, with a SAX-like and DOM interface" + + :components + ((:module + :src + :components ((:file "package") + (:file "xml" :depends-on ("package")) + (:file "dom" :depends-on ("package" "xml")) + (:file "lxml-dom" :depends-on ("dom")) + (:file "sxml-dom" :depends-on ("dom")) + (:file "xml-struct-dom" :depends-on ("dom")))))) + +(defsystem :s-xml.test + :depends-on (:s-xml) + :components ((:module :test + :components ((:file "test-xml") + (:file "test-xml-struct-dom") + (:file "test-lxml-dom") + (:file "test-sxml-dom"))))) + +(defsystem :s-xml.examples + :depends-on (:s-xml) + :components ((:module :examples + :components ((:file "counter") + (:file "echo") + (:file "remove-markup") + (:file "tracer"))))) +;;;; eof diff --git a/third_party/lisp/s-xml/src/dom.lisp b/third_party/lisp/s-xml/src/dom.lisp new file mode 100644 index 0000000000..74d1c371db --- /dev/null +++ b/third_party/lisp/s-xml/src/dom.lisp @@ -0,0 +1,75 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: dom.lisp,v 1.1.1.1 2004/06/07 18:49:56 scaekenberghe Exp $ +;;;; +;;;; This is the generic simple DOM parser and printer interface. +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +;;; top level DOM parser interface + +(defgeneric parse-xml-dom (stream output-type) + (:documentation "Parse a character stream as XML and generate a DOM of output-type")) + +(defun parse-xml (stream &key (output-type :lxml)) + "Parse a character stream as XML and generate a DOM of output-type, defaulting to :lxml" + (parse-xml-dom stream output-type)) + +(defun parse-xml-string (string &key (output-type :lxml)) + "Parse a string as XML and generate a DOM of output-type, defaulting to :lxml" + (with-input-from-string (stream string) + (parse-xml-dom stream output-type))) + +(defun parse-xml-file (filename &key (output-type :lxml)) + "Parse a character file as XML and generate a DOM of output-type, defaulting to :lxml" + (with-open-file (in filename :direction :input) + (parse-xml-dom in output-type))) + +;;; top level DOM printer interface + +(defgeneric print-xml-dom (dom input-type stream pretty level) + (:documentation "Generate XML output on a character stream from a DOM of input-type, optionally pretty printing using level")) + +(defun print-xml (dom &key (stream t) (pretty nil) (input-type :lxml) (header)) + "Generate XML output on a character stream (t by default) from a DOM of input-type (:lxml by default), optionally pretty printing (off by default), or adding a header (none by default)" + (when header (format stream header)) + (when pretty (terpri stream)) + (print-xml-dom dom input-type stream pretty 1)) + +(defun print-xml-string (dom &key (pretty nil) (input-type :lxml)) + "Generate XML output to a string from a DOM of input-type (:lxml by default), optionally pretty printing (off by default)" + (with-output-to-string (stream) + (print-xml dom :stream stream :pretty pretty :input-type input-type))) + +;;; shared/common support functions + +(defun print-spaces (n stream &optional (preceding-newline t)) + (when preceding-newline + (terpri stream)) + (loop :repeat n + :do (write-char #\Space stream))) + +(defun print-solitary-tag (tag stream) + (write-char #\< stream) + (print-identifier tag stream) + (write-string "/>" stream)) + +(defun print-closing-tag (tag stream) + (write-string "</" stream) + (print-identifier tag stream) + (write-char #\> stream)) + +(defun print-attribute (name value stream) + (write-char #\space stream) + (print-identifier name stream t) + (write-string "=\"" stream) + (print-string-xml value stream) + (write-char #\" stream)) + +;;;; eof diff --git a/third_party/lisp/s-xml/src/lxml-dom.lisp b/third_party/lisp/s-xml/src/lxml-dom.lisp new file mode 100644 index 0000000000..d43df6cf81 --- /dev/null +++ b/third_party/lisp/s-xml/src/lxml-dom.lisp @@ -0,0 +1,83 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: lxml-dom.lisp,v 1.5 2005/09/20 09:57:44 scaekenberghe Exp $ +;;;; +;;;; LXML implementation of the generic DOM parser and printer. +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +;;; the lxml hooks to generate lxml + +(defun lxml-new-element-hook (name attributes seed) + (declare (ignore name attributes seed)) + '()) + +(defun lxml-finish-element-hook (name attributes parent-seed seed) + (let ((xml-element + (cond ((and (null seed) (null attributes)) + name) + (attributes + `((,name ,@(let (list) + (dolist (attribute attributes list) + (push (cdr attribute) list) + (push (car attribute) list)))) + ,@(nreverse seed))) + (t + `(,name ,@(nreverse seed)))))) + (cons xml-element parent-seed))) + +(defun lxml-text-hook (string seed) + (cons string seed)) + +;;; standard DOM interfaces + +(defmethod parse-xml-dom (stream (output-type (eql :lxml))) + (car (start-parse-xml stream + (make-instance 'xml-parser-state + :new-element-hook #'lxml-new-element-hook + :finish-element-hook #'lxml-finish-element-hook + :text-hook #'lxml-text-hook)))) + +(defun plist->alist (plist) + (when plist + (cons (cons (first plist) (second plist)) + (plist->alist (rest (rest plist)))))) + +(defmethod print-xml-dom (dom (input-type (eql :lxml)) stream pretty level) + (declare (special *namespaces*)) + (cond ((symbolp dom) (print-solitary-tag dom stream)) + ((stringp dom) (print-string-xml dom stream)) + ((consp dom) + (let (tag attributes) + (cond ((symbolp (first dom)) (setf tag (first dom))) + ((consp (first dom)) (setf tag (first (first dom)) + attributes (plist->alist (rest (first dom))))) + (t (error "Input not recognized as LXML ~s" dom))) + (let ((*namespaces* (extend-namespaces attributes *namespaces*))) + (write-char #\< stream) + (print-identifier tag stream) + (loop :for (name . value) :in attributes + :do (print-attribute name value stream)) + (if (rest dom) + (let ((children (rest dom))) + (write-char #\> stream) + (if (and (= (length children) 1) (stringp (first children))) + (print-string-xml (first children) stream) + (progn + (dolist (child children) + (when pretty (print-spaces (* 2 level) stream)) + (if (stringp child) + (print-string-xml child stream) + (print-xml-dom child input-type stream pretty (1+ level)))) + (when pretty (print-spaces (* 2 (1- level)) stream)))) + (print-closing-tag tag stream)) + (write-string "/>" stream))))) + (t (error "Input not recognized as LXML ~s" dom)))) + +;;;; eof \ No newline at end of file diff --git a/third_party/lisp/s-xml/src/package.lisp b/third_party/lisp/s-xml/src/package.lisp new file mode 100644 index 0000000000..f90f0f49a1 --- /dev/null +++ b/third_party/lisp/s-xml/src/package.lisp @@ -0,0 +1,46 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: package.lisp,v 1.7 2006/01/19 20:00:06 scaekenberghe Exp $ +;;;; +;;;; This is a Common Lisp implementation of a very basic XML parser. +;;;; The parser is non-validating. +;;;; The API into the parser is pure functional parser hook model that comes from SSAX, +;;;; see also http://pobox.com/~oleg/ftp/Scheme/xml.html or http://ssax.sourceforge.net +;;;; Different DOM models are provided, an XSML, an LXML and a xml-element struct based one. +;;;; +;;;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(defpackage s-xml + (:use common-lisp) + (:export + ;; main parser interface + #:start-parse-xml + #:print-string-xml + #:xml-parser-error #:xml-parser-error-message #:xml-parser-error-args #:xml-parser-error-stream + #:xml-parser-state #:get-entities #:get-seed + #:get-new-element-hook #:get-finish-element-hook #:get-text-hook + ;; callbacks + #:*attribute-name-parser* + #:*attribute-value-parser* + #:parse-attribute-name + #:parse-attribute-value + ;; dom parser and printer + #:parse-xml-dom #:parse-xml #:parse-xml-string #:parse-xml-file + #:print-xml-dom #:print-xml #:print-xml-string + ;; xml-element structure + #:make-xml-element #:xml-element-children #:xml-element-name + #:xml-element-attribute #:xml-element-attributes + #:xml-element-p #:new-xml-element #:first-xml-element-child + ;; namespaces + #:*ignore-namespaces* #:*local-namespace* #:*namespaces* + #:*require-existing-symbols* #:*auto-export-symbols* #:*auto-create-namespace-packages* + #:find-namespace #:register-namespace #:get-prefix #:get-uri #:get-package + #:resolve-identifier #:extend-namespaces #:print-identifier #:split-identifier) + (:documentation + "A simple XML parser with an efficient, purely functional, event-based interface as well as a DOM interface")) + +;;;; eof diff --git a/third_party/lisp/s-xml/src/sxml-dom.lisp b/third_party/lisp/s-xml/src/sxml-dom.lisp new file mode 100644 index 0000000000..c9e0f9e0db --- /dev/null +++ b/third_party/lisp/s-xml/src/sxml-dom.lisp @@ -0,0 +1,76 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: sxml-dom.lisp,v 1.4 2005/09/20 09:57:48 scaekenberghe Exp $ +;;;; +;;;; LXML implementation of the generic DOM parser and printer. +;;;; +;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +;;; the sxml hooks to generate sxml + +(defun sxml-new-element-hook (name attributes seed) + (declare (ignore name attributes seed)) + '()) + +(defun sxml-finish-element-hook (name attributes parent-seed seed) + (let ((xml-element (append (list name) + (when attributes + (list (let (list) + (dolist (attribute attributes (cons :@ list)) + (push (list (car attribute) (cdr attribute)) list))))) + (nreverse seed)))) + (cons xml-element parent-seed))) + +(defun sxml-text-hook (string seed) + (cons string seed)) + +;;; the standard DOM interfaces + +(defmethod parse-xml-dom (stream (output-type (eql :sxml))) + (car (start-parse-xml stream + (make-instance 'xml-parser-state + :new-element-hook #'sxml-new-element-hook + :finish-element-hook #'sxml-finish-element-hook + :text-hook #'sxml-text-hook)))) + +(defmethod print-xml-dom (dom (input-type (eql :sxml)) stream pretty level) + (declare (special *namespaces*)) + (cond ((stringp dom) (print-string-xml dom stream)) + ((consp dom) + (let ((tag (first dom)) + attributes + children) + (if (and (consp (second dom)) (eq (first (second dom)) :@)) + (setf attributes (rest (second dom)) + children (rest (rest dom))) + (setf children (rest dom))) + (let ((*namespaces* (extend-namespaces (loop :for (name value) :in attributes + :collect (cons name value)) + *namespaces*))) + (write-char #\< stream) + (print-identifier tag stream) + (loop :for (name value) :in attributes + :do (print-attribute name value stream)) + (if children + (progn + (write-char #\> stream) + (if (and (= (length children) 1) (stringp (first children))) + (print-string-xml (first children) stream) + (progn + (dolist (child children) + (when pretty (print-spaces (* 2 level) stream)) + (if (stringp child) + (print-string-xml child stream) + (print-xml-dom child input-type stream pretty (1+ level)))) + (when pretty (print-spaces (* 2 (1- level)) stream)))) + (print-closing-tag tag stream)) + (write-string "/>" stream))))) + (t (error "Input not recognized as SXML ~s" dom)))) + +;;;; eof diff --git a/third_party/lisp/s-xml/src/xml-struct-dom.lisp b/third_party/lisp/s-xml/src/xml-struct-dom.lisp new file mode 100644 index 0000000000..7037388915 --- /dev/null +++ b/third_party/lisp/s-xml/src/xml-struct-dom.lisp @@ -0,0 +1,125 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: xml-struct-dom.lisp,v 1.2 2005/08/29 15:01:47 scaekenberghe Exp $ +;;;; +;;;; XML-STRUCT implementation of the generic DOM parser and printer. +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +;;; xml-element struct datastructure and API + +(defstruct xml-element + name ; :tag-name + attributes ; a assoc list of (:attribute-name . "attribute-value") + children ; a list of children/content either text strings or xml-elements + ) + +(setf (documentation 'xml-element-p 'function) + "Return T when the argument is an xml-element struct" + (documentation 'xml-element-attributes 'function) + "Return the alist of attribute names and values dotted pairs from an xml-element struct" + (documentation 'xml-element-children 'function) + "Return the list of children from an xml-element struct" + (documentation 'xml-element-name 'function) + "Return the name from an xml-element struct" + (documentation 'make-xml-element 'function) + "Make and return a new xml-element struct") + +(defun xml-element-attribute (xml-element key) + "Return the string value of the attribute with name the keyword :key + of xml-element if any, return null if not found" + (let ((pair (assoc key (xml-element-attributes xml-element) :test #'eq))) + (when pair (cdr pair)))) + +(defun (setf xml-element-attribute) (value xml-element key) + "Set the string value of the attribute with name the keyword :key of + xml-element, creating a new attribute if necessary or overwriting an + existing one, returning the value" + (let ((attributes (xml-element-attributes xml-element))) + (if (null attributes) + (push (cons key value) (xml-element-attributes xml-element)) + (let ((pair (assoc key attributes :test #'eq))) + (if pair + (setf (cdr pair) value) + (push (cons key value) (xml-element-attributes xml-element))))) + value)) + +(defun new-xml-element (name &rest children) + "Make a new xml-element with name and children" + (make-xml-element :name name :children children)) + +(defun first-xml-element-child (xml-element) + "Get the first child of an xml-element" + (first (xml-element-children xml-element))) + +(defun xml-equal (xml-1 xml-2) + (and (xml-element-p xml-1) + (xml-element-p xml-2) + (eq (xml-element-name xml-1) + (xml-element-name xml-2)) + (equal (xml-element-attributes xml-1) + (xml-element-attributes xml-2)) + (reduce #'(lambda (&optional (x t) (y t)) (and x y)) + (mapcar #'(lambda (x y) + (or (and (stringp x) (stringp y) (string= x y)) + (xml-equal x y))) + (xml-element-children xml-1) + (xml-element-children xml-2))))) + +;;; printing xml structures + +(defmethod print-xml-dom (xml-element (input-type (eql :xml-struct)) stream pretty level) + (declare (special *namespaces*)) + (let ((*namespaces* (extend-namespaces (xml-element-attributes xml-element) + *namespaces*))) + (write-char #\< stream) + (print-identifier (xml-element-name xml-element) stream) + (loop :for (name . value) :in (xml-element-attributes xml-element) + :do (print-attribute name value stream)) + (let ((children (xml-element-children xml-element))) + (if children + (progn + (write-char #\> stream) + (if (and (= (length children) 1) (stringp (first children))) + (print-string-xml (first children) stream) + (progn + (dolist (child children) + (when pretty (print-spaces (* 2 level) stream)) + (if (stringp child) + (print-string-xml child stream) + (print-xml-dom child input-type stream pretty (1+ level)))) + (when pretty (print-spaces (* 2 (1- level)) stream)))) + (print-closing-tag (xml-element-name xml-element) stream)) + (write-string "/>" stream))))) + +;;; the standard hooks to generate xml-element structs + +(defun standard-new-element-hook (name attributes seed) + (declare (ignore name attributes seed)) + '()) + +(defun standard-finish-element-hook (name attributes parent-seed seed) + (let ((xml-element (make-xml-element :name name + :attributes attributes + :children (nreverse seed)))) + (cons xml-element parent-seed))) + +(defun standard-text-hook (string seed) + (cons string seed)) + +;;; top level standard parser interfaces + +(defmethod parse-xml-dom (stream (output-type (eql :xml-struct))) + (car (start-parse-xml stream + (make-instance 'xml-parser-state + :new-element-hook #'standard-new-element-hook + :finish-element-hook #'standard-finish-element-hook + :text-hook #'standard-text-hook)))) + +;;;; eof diff --git a/third_party/lisp/s-xml/src/xml.lisp b/third_party/lisp/s-xml/src/xml.lisp new file mode 100644 index 0000000000..8a2076985a --- /dev/null +++ b/third_party/lisp/s-xml/src/xml.lisp @@ -0,0 +1,702 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: xml.lisp,v 1.15 2006/01/19 20:00:06 scaekenberghe Exp $ +;;;; +;;;; This is a Common Lisp implementation of a basic but usable XML parser. +;;;; The parser is non-validating and not complete (no PI). +;;;; Namespace and entities are handled. +;;;; The API into the parser is a pure functional parser hook model that comes from SSAX, +;;;; see also http://pobox.com/~oleg/ftp/Scheme/xml.html or http://ssax.sourceforge.net +;;;; Different DOM models are provided, an XSML, an LXML and a xml-element struct based one. +;;;; +;;;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +;;; (tazjin): moved up here because something was wonky with the +;;; definition order +(defvar *ignore-namespaces* nil + "When t, namespaces are ignored like in the old version of S-XML") + +;;; error reporting + +(define-condition xml-parser-error (error) + ((message :initarg :message :reader xml-parser-error-message) + (args :initarg :args :reader xml-parser-error-args) + (stream :initarg :stream :reader xml-parser-error-stream :initform nil)) + (:report (lambda (condition stream) + (format stream + "XML parser ~?~@[ near stream position ~d~]." + (xml-parser-error-message condition) + (xml-parser-error-args condition) + (and (xml-parser-error-stream condition) + (file-position (xml-parser-error-stream condition)))))) + (:documentation "Thrown by the XML parser to indicate errorneous input")) + +(setf (documentation 'xml-parser-error-message 'function) + "Get the message from an XML parser error" + (documentation 'xml-parser-error-args 'function) + "Get the error arguments from an XML parser error" + (documentation 'xml-parser-error-stream 'function) + "Get the stream from an XML parser error") + +(defun parser-error (message &optional args stream) + (make-condition 'xml-parser-error + :message message + :args args + :stream stream)) + +;; attribute parsing hooks +;; this is a bit complicated, refer to the mailing lists for a more detailed explanation + +(defun parse-attribute-name (string) + "Default parser for the attribute name" + (declare (special *namespaces*)) + (resolve-identifier string *namespaces* t)) + +(defun parse-attribute-value (name string) + "Default parser for the attribute value" + (declare (ignore name) + (special *ignore-namespace*)) + (if *ignore-namespaces* + (copy-seq string) + string)) + +(defparameter *attribute-name-parser* #'parse-attribute-name + "Called to compute interned attribute name from a buffer that will be reused") + +(defparameter *attribute-value-parser* #'parse-attribute-value + "Called to compute an element of an attribute list from a buffer that will be reused") + +;;; utilities + +(defun whitespace-char-p (char) + "Is char an XML whitespace character ?" + (declare (type character char)) + (or (char= char #\space) + (char= char #\tab) + (char= char #\return) + (char= char #\linefeed))) + +(defun identifier-char-p (char) + "Is char an XML identifier character ?" + (declare (type character char)) + (or (and (char<= #\A char) (char<= char #\Z)) + (and (char<= #\a char) (char<= char #\z)) + (and (char<= #\0 char) (char<= char #\9)) + (char= char #\-) + (char= char #\_) + (char= char #\.) + (char= char #\:))) + +(defun skip-whitespace (stream) + "Skip over XML whitespace in stream, return first non-whitespace + character which was peeked but not read, return nil on eof" + (loop + (let ((char (peek-char nil stream nil #\Null))) + (declare (type character char)) + (if (whitespace-char-p char) + (read-char stream) + (return char))))) + +(defun make-extendable-string (&optional (size 10)) + "Make an extendable string which is a one-dimensional character + array which is adjustable and has a fill pointer" + (make-array size + :element-type 'character + :adjustable t + :fill-pointer 0)) + +(defun print-string-xml (string stream &key (start 0) end) + "Write the characters of string to stream using basic XML conventions" + (loop for offset upfrom start below (or end (length string)) + for char = (char string offset) + do (case char + (#\& (write-string "&" stream)) + (#\< (write-string "<" stream)) + (#\> (write-string ">" stream)) + (#\" (write-string """ stream)) + ((#\newline #\return #\tab) (write-char char stream)) + (t (if (and (<= 32 (char-code char)) + (<= (char-code char) 126)) + (write-char char stream) + (progn + (write-string "&#x" stream) + (write (char-code char) :stream stream :base 16) + (write-char #\; stream))))))) + +(defun make-standard-entities () + "A hashtable mapping XML entity names to their replacement strings, + filled with the standard set" + (let ((entities (make-hash-table :test #'equal))) + (setf (gethash "amp" entities) (string #\&) + (gethash "quot" entities) (string #\") + (gethash "apos" entities) (string #\') + (gethash "lt" entities) (string #\<) + (gethash "gt" entities) (string #\>) + (gethash "nbsp" entities) (string #\space)) + entities)) + +(defun resolve-entity (stream extendable-string entities entity) + "Read and resolve an XML entity from stream, positioned after the '&' entity marker, + accepting &name; &#DEC; and &#xHEX; formats, + destructively modifying string, which is also returned, + destructively modifying entity, incorrect entity formats result in errors" + (declare (type (vector character) entity)) + (loop + (let ((char (read-char stream nil #\Null))) + (declare (type character char)) + (cond ((char= char #\Null) (error (parser-error "encountered eof before end of entity"))) + ((char= #\; char) (return)) + (t (vector-push-extend char entity))))) + (if (char= (char entity 0) #\#) + (let ((code (if (char= (char entity 1) #\x) + (parse-integer entity :start 2 :radix 16 :junk-allowed t) + (parse-integer entity :start 1 :radix 10 :junk-allowed t)))) + (when (null code) + (error (parser-error "encountered incorrect entity &~s;" (list entity) stream))) + (vector-push-extend (code-char code) extendable-string)) + (let ((value (gethash entity entities))) + (if value + (loop :for char :across value + :do (vector-push-extend char extendable-string)) + (error (parser-error "encountered unknown entity &~s;" (list entity) stream))))) + extendable-string) + +;;; namespace support + +(defclass xml-namespace () + ((uri :documentation "The URI used to identify this namespace" + :accessor get-uri + :initarg :uri) + (prefix :documentation "The preferred prefix assigned to this namespace" + :accessor get-prefix + :initarg :prefix + :initform nil) + (package :documentation "The Common Lisp package where this namespace's symbols are interned" + :accessor get-package + :initarg :package + :initform nil)) + (:documentation "Describes an XML namespace and how it is handled")) + +(setf (documentation 'get-uri 'function) + "The URI used to identify this namespace" + (documentation 'get-prefix 'function) + "The preferred prefix assigned to this namespace" + (documentation 'get-package 'function) + "The Common Lisp package where this namespace's symbols are interned") + +(defmethod print-object ((object xml-namespace) stream) + (print-unreadable-object (object stream :type t :identity t) + (format stream "~A - ~A" (get-prefix object) (get-uri object)))) + +(defvar *local-namespace* (make-instance 'xml-namespace + :uri "local" + :prefix "" + :package (find-package :keyword)) + "The local (global default) XML namespace") + +(defvar *xml-namespace* (make-instance 'xml-namespace + :uri "http://www.w3.org/XML/1998/namespace" + :prefix "xml" + :package (or (find-package :xml) + (make-package :xml :nicknames '("XML")))) + "REC-xml-names-19990114 says the prefix xml is bound to the namespace http://www.w3.org/XML/1998/namespace.") + +(defvar *known-namespaces* (list *local-namespace* *xml-namespace*) + "The list of known/defined namespaces") + +(defvar *namespaces* `(("xml" . ,*xml-namespace*) ("" . ,*local-namespace*)) + "Ordered list of (prefix . XML-namespace) bindings currently in effect - special variable") + +(defun find-namespace (uri) + "Find a registered XML namespace identified by uri" + (find uri *known-namespaces* :key #'get-uri :test #'string-equal)) + +(defun register-namespace (uri prefix package) + "Register a new or redefine an existing XML namespace defined by uri with prefix and package" + (let ((namespace (find-namespace uri))) + (if namespace + (setf (get-prefix namespace) prefix + (get-package namespace) (find-package package)) + (push (setf namespace (make-instance 'xml-namespace + :uri uri + :prefix prefix + :package (find-package package))) + *known-namespaces*)) + namespace)) + +(defun find-namespace-binding (prefix namespaces) + "Find the XML namespace currently bound to prefix in the namespaces bindings" + (cdr (assoc prefix namespaces :test #'string-equal))) + +(defun split-identifier (identifier) + "Split an identifier 'prefix:name' and return (values prefix name)" + (when (symbolp identifier) + (setf identifier (symbol-name identifier))) + (let ((colon-position (position #\: identifier :test #'char=))) + (if colon-position + (values (subseq identifier 0 colon-position) + (subseq identifier (1+ colon-position))) + (values nil identifier)))) + +(defvar *require-existing-symbols* nil + "If t, each XML identifier must exist as symbol already") + +(defvar *auto-export-symbols* t + "If t, export newly interned symbols form their packages") + +(defun resolve-identifier (identifier namespaces &optional as-attribute) + "Resolve the string identifier in the list of namespace bindings" + (if *ignore-namespaces* + (intern identifier :keyword) + (flet ((intern-symbol (string package) ; intern string as a symbol in package + (if *require-existing-symbols* + (let ((symbol (find-symbol string package))) + (or symbol + (error "Symbol ~s does not exist in ~s" string package))) + (let ((symbol (intern string package))) + (when (and *auto-export-symbols* + (not (eql package (find-package :keyword)))) + (export symbol package)) + symbol)))) + (multiple-value-bind (prefix name) + (split-identifier identifier) + (if (or (null prefix) (string= prefix "xmlns")) + (if as-attribute + (intern (if (string= prefix "xmlns") identifier name) (get-package *local-namespace*)) + (let ((default-namespace (find-namespace-binding "" namespaces))) + (intern-symbol name (get-package default-namespace)))) + (let ((namespace (find-namespace-binding prefix namespaces))) + (if namespace + (intern-symbol name (get-package namespace)) + (error "namespace not found for prefix ~s" prefix)))))))) + +(defvar *auto-create-namespace-packages* t + "If t, new packages will be created for namespaces, if needed, named by the prefix") + +(defun new-namespace (uri &optional prefix) + "Register a new namespace for uri and prefix, creating a package if necessary" + (if prefix + (register-namespace uri + prefix + (or (find-package prefix) + (if *auto-create-namespace-packages* + (make-package prefix :nicknames `(,(string-upcase prefix))) + (error "Cannot find or create package ~s" prefix)))) + (let ((unique-name (loop :for i :upfrom 0 + :do (let ((name (format nil "ns-~d" i))) + (when (not (find-package name)) + (return name)))))) + (register-namespace uri + unique-name + (if *auto-create-namespace-packages* + (make-package (string-upcase unique-name) :nicknames `(,unique-name)) + (error "Cannot create package ~s" unique-name)))))) + +(defun extend-namespaces (attributes namespaces) + "Given possible 'xmlns[:prefix]' attributes, extend the namespaces bindings" + (unless *ignore-namespaces* + (let (default-namespace-uri) + (loop :for (key . value) :in attributes + :do (if (string= key "xmlns") + (setf default-namespace-uri value) + (multiple-value-bind (prefix name) + (split-identifier key) + (when (string= prefix "xmlns") + (let* ((uri value) + (prefix name) + (namespace (find-namespace uri))) + (unless namespace + (setf namespace (new-namespace uri prefix))) + (push `(,prefix . ,namespace) namespaces)))))) + (when default-namespace-uri + (let ((namespace (find-namespace default-namespace-uri))) + (unless namespace + (setf namespace (new-namespace default-namespace-uri))) + (push `("" . ,namespace) namespaces))))) + namespaces) + +(defun print-identifier (identifier stream &optional as-attribute) + "Print identifier on stream using namespace conventions" + (declare (ignore as-attribute) (special *namespaces*)) + (if *ignore-namespaces* + (princ identifier stream) + (if (symbolp identifier) + (let ((package (symbol-package identifier)) + (name (symbol-name identifier))) + (let* ((namespace (find package *known-namespaces* :key #'get-package)) + (prefix (or (car (find namespace *namespaces* :key #'cdr)) + (get-prefix namespace)))) + (if (string= prefix "") + (princ name stream) + (format stream "~a:~a" prefix name)))) + (princ identifier stream)))) + +;;; the parser state + +(defclass xml-parser-state () + ((entities :documentation "A hashtable mapping XML entity names to their replacement stings" + :accessor get-entities + :initarg :entities + :initform (make-standard-entities)) + (seed :documentation "The user seed object" + :accessor get-seed + :initarg :seed + :initform nil) + (buffer :documentation "The main reusable character buffer" + :accessor get-buffer + :initform (make-extendable-string)) + (mini-buffer :documentation "The secondary, smaller reusable character buffer" + :accessor get-mini-buffer + :initform (make-extendable-string)) + (new-element-hook :documentation "Called when new element starts" + ;; Handle the start of a new xml element with name and attributes, + ;; receiving seed from previous element (sibling or parent) + ;; return seed to be used for first child (content) + ;; or directly to finish-element-hook + :accessor get-new-element-hook + :initarg :new-element-hook + :initform #'(lambda (name attributes seed) + (declare (ignore name attributes)) + seed)) + (finish-element-hook :documentation "Called when element ends" + ;; Handle the end of an xml element with name and attributes, + ;; receiving parent-seed, the seed passed to us when this element started, + ;; i.e. passed to our corresponding new-element-hook + ;; and receiving seed from last child (content) + ;; or directly from new-element-hook + ;; return final seed for this element to next element (sibling or parent) + :accessor get-finish-element-hook + :initarg :finish-element-hook + :initform #'(lambda (name attributes parent-seed seed) + (declare (ignore name attributes parent-seed)) + seed)) + (text-hook :documentation "Called when text is found" + ;; Handle text in string, found as contents, + ;; receiving seed from previous element (sibling or parent), + ;; return final seed for this element to next element (sibling or parent) + :accessor get-text-hook + :initarg :text-hook + :initform #'(lambda (string seed) + (declare (ignore string)) + seed))) + (:documentation "The XML parser state passed along all code making up the parser")) + +(setf (documentation 'get-seed 'function) + "Get the initial user seed of an XML parser state" + (documentation 'get-entities 'function) + "Get the entities hashtable of an XML parser state" + (documentation 'get-new-element-hook 'function) + "Get the new element hook of an XML parser state" + (documentation 'get-finish-element-hook 'function) + "Get the finish element hook of an XML parser state" + (documentation 'get-text-hook 'function) + "Get the text hook of an XML parser state") + +#-allegro +(setf (documentation '(setf get-seed) 'function) + "Set the initial user seed of an XML parser state" + (documentation '(setf get-entities) 'function) + "Set the entities hashtable of an XML parser state" + (documentation '(setf get-new-element-hook) 'function) + "Set the new element hook of an XML parser state" + (documentation '(setf get-finish-element-hook) 'function) + "Set the finish element hook of an XML parser state" + (documentation '(setf get-text-hook) 'function) + "Set the text hook of an XML parser state") + +(defmethod get-mini-buffer :after ((state xml-parser-state)) + "Reset and return the reusable mini buffer" + (with-slots (mini-buffer) state + (setf (fill-pointer mini-buffer) 0))) + +(defmethod get-buffer :after ((state xml-parser-state)) + "Reset and return the main reusable buffer" + (with-slots (buffer) state + (setf (fill-pointer buffer) 0))) + +;;; parser support + +(defun parse-whitespace (stream extendable-string) + "Read and collect XML whitespace from stream in string which is + destructively modified, return first non-whitespace character which + was peeked but not read, return #\Null on eof" + (declare (type (vector character) extendable-string)) + (loop + (let ((char (peek-char nil stream nil #\Null))) + (declare (type character char)) + (if (whitespace-char-p char) + (vector-push-extend (read-char stream) extendable-string) + (return char))))) + +(defun parse-string (stream state string) + "Read and return an XML string from stream, delimited by either + single or double quotes, the stream is expected to be on the opening + delimiter, at the end the closing delimiter is also read, entities + are resolved, eof before end of string is an error" + (declare (type (vector character) string)) + (let ((delimiter (read-char stream nil #\Null)) + (char #\Null)) + (declare (type character delimiter char)) + (unless (or (char= delimiter #\') (char= delimiter #\")) + (error (parser-error "expected string delimiter" nil stream))) + (loop + (setf char (read-char stream nil #\Null)) + (cond ((char= char #\Null) (error (parser-error "encountered eof before end of string"))) + ((char= char delimiter) (return)) + ((char= char #\&) (resolve-entity stream string (get-entities state) (get-mini-buffer state))) + (t (vector-push-extend char string)))) + string)) + +(defun parse-text (stream state extendable-string) + "Read and collect XML text from stream in string which is + destructively modified, the text ends with a '<', which is peeked and + returned, entities are resolved, eof is considered an error" + (declare (type (vector character) extendable-string)) + (let ((char #\Null)) + (declare (type character char)) + (loop + (setf char (peek-char nil stream nil #\Null)) + (when (char= char #\Null) (error (parser-error "encountered unexpected eof in text"))) + (when (char= char #\<) (return)) + (read-char stream) + (if (char= char #\&) + (resolve-entity stream extendable-string (get-entities state) (get-mini-buffer state)) + (vector-push-extend char extendable-string))) + char)) + +(defun parse-identifier (stream identifier) + "Read and returns an XML identifier from stream, positioned at the + start of the identifier, ending with the first non-identifier + character, which is peeked, the identifier is written destructively + into identifier which is also returned" + (declare (type (vector character) identifier)) + (loop + (let ((char (read-char stream nil #\Null))) + (declare (type character char)) + (cond ((identifier-char-p char) + (vector-push-extend char identifier)) + (t + (when (char/= char #\Null) (unread-char char stream)) + (return identifier)))))) + +(defun skip-comment (stream) + "Skip an XML comment in stream, positioned after the opening '<!--', + consumes the closing '-->' sequence, unexpected eof or a malformed + closing sequence result in a error" + (let ((dashes-to-read 2)) + (loop + (if (zerop dashes-to-read) (return)) + (let ((char (read-char stream nil #\Null))) + (declare (type character char)) + (if (char= char #\Null) + (error (parser-error "encountered unexpected eof for comment"))) + (if (char= char #\-) + (decf dashes-to-read) + (setf dashes-to-read 2))))) + (if (char/= (read-char stream nil #\Null) #\>) + (error (parser-error "expected > ending comment" nil stream)))) + +(defun read-cdata (stream state string) + "Reads in the CDATA and calls the callback for CDATA if it exists" + ;; we already read the <![CDATA[ stuff + ;; continue to read until we hit ]]> + (let ((char #\space) + (last-3-characters (list #\[ #\A #\T)) + (pattern (list #\> #\] #\]))) + (declare (type character char)) + (loop + (setf char (read-char stream nil #\Null)) + (when (char= char #\Null) (error (parser-error "encountered unexpected eof in text"))) + (push char last-3-characters) + (setf (cdddr last-3-characters) nil) + (cond + ((equal last-3-characters + pattern) + (setf (fill-pointer string) + (- (fill-pointer string) 2)) + (setf (get-seed state) + (funcall (get-text-hook state) + (copy-seq string) + (get-seed state))) + (return-from read-cdata)) + (t + (vector-push-extend char string)))))) + +(defun skip-special-tag (stream state) + "Skip an XML special tag (comments and processing instructions) in + stream, positioned after the opening '<', unexpected eof is an error" + ;; opening < has been read, consume ? or ! + (read-char stream) + (let ((char (read-char stream nil #\Null))) + (declare (type character char)) + ;; see if we are dealing with a comment + (when (char= char #\-) + (setf char (read-char stream nil #\Null)) + (when (char= char #\-) + (skip-comment stream) + (return-from skip-special-tag))) + ;; maybe we are dealing with CDATA? + (when (and (char= char #\[) + (loop :for pattern :across "CDATA[" + :for char = (read-char stream nil #\Null) + :when (char= char #\Null) :do + (error (parser-error "encountered unexpected eof in cdata")) + :always (char= char pattern))) + (read-cdata stream state (get-buffer state)) + (return-from skip-special-tag)) + ;; loop over chars, dealing with strings (skipping their content) + ;; and counting opening and closing < and > chars + (let ((taglevel 1) + (string-delimiter #\Null)) + (declare (type character string-delimiter)) + (loop + (when (zerop taglevel) (return)) + (setf char (read-char stream nil #\Null)) + (when (char= char #\Null) + (error (parser-error "encountered unexpected eof for special (! or ?) tag" nil stream))) + (if (char/= string-delimiter #\Null) + ;; inside a string we only look for a closing string delimiter + (when (char= char string-delimiter) + (setf string-delimiter #\Null)) + ;; outside a string we count < and > and watch out for strings + (cond ((or (char= char #\') (char= char #\")) (setf string-delimiter char)) + ((char= char #\<) (incf taglevel)) + ((char= char #\>) (decf taglevel)))))))) + +;;; the XML parser proper + +(defun parse-xml-element-attributes (stream state) + "Parse XML element attributes from stream positioned after the tag + identifier, returning the attributes as an assoc list, ending at + either a '>' or a '/' which is peeked and also returned" + (declare (special *namespaces*)) + (let ((char #\Null) attributes) + (declare (type character char)) + (loop + ;; skip whitespace separating items + (setf char (skip-whitespace stream)) + ;; start tag attributes ends with > or /> + (when (or (char= char #\>) (char= char #\/)) (return)) + ;; read the attribute key + (let ((key (let ((string (parse-identifier stream (get-mini-buffer state)))) + (if *ignore-namespaces* + (funcall *attribute-name-parser* string) + (copy-seq string))))) + ;; skip separating whitespace + (setf char (skip-whitespace stream)) + ;; require = sign (and consume it if present) + (if (char= char #\=) + (read-char stream) + (error (parser-error "expected =" nil stream))) + ;; skip separating whitespace + (skip-whitespace stream) + ;; read the attribute value as a string + (push (cons key (let ((string (parse-string stream state (get-buffer state)))) + (if *ignore-namespaces* + (funcall *attribute-value-parser* key string) + (copy-seq string)))) + attributes))) + ;; return attributes peek char ending loop + (values attributes char))) + +(defun parse-xml-element (stream state) + "Parse and return an XML element from stream, positioned after the opening '<'" + (declare (special *namespaces*)) + ;; opening < has been read + (when (char= (peek-char nil stream nil #\Null) #\!) + (skip-special-tag stream state) + (return-from parse-xml-element)) + (let ((char #\Null) buffer open-tag parent-seed has-children) + (declare (type character char)) + (setf parent-seed (get-seed state)) + ;; read tag name (no whitespace between < and name ?) + (setf open-tag (copy-seq (parse-identifier stream (get-mini-buffer state)))) + ;; tag has been read, read attributes if any + (multiple-value-bind (attributes peeked-char) + (parse-xml-element-attributes stream state) + (let ((*namespaces* (extend-namespaces attributes *namespaces*))) + (setf open-tag (resolve-identifier open-tag *namespaces*)) + (unless *ignore-namespaces* + (dolist (attribute attributes) + (setf (car attribute) (funcall *attribute-name-parser* (car attribute)) + (cdr attribute) (funcall *attribute-value-parser* (car attribute) (cdr attribute))))) + (setf (get-seed state) (funcall (get-new-element-hook state) + open-tag attributes (get-seed state))) + (setf char peeked-char) + (when (char= char #\/) + ;; handle solitary tag of the form <tag .. /> + (read-char stream) + (setf char (read-char stream nil #\Null)) + (if (char= #\> char) + (progn + (setf (get-seed state) (funcall (get-finish-element-hook state) + open-tag attributes parent-seed (get-seed state))) + (return-from parse-xml-element)) + (error (parser-error "expected >" nil stream)))) + ;; consume > + (read-char stream) + (loop + (setf buffer (get-buffer state)) + ;; read whitespace into buffer + (setf char (parse-whitespace stream buffer)) + ;; see what ended the whitespace scan + (cond ((char= char #\Null) (error (parser-error "encountered unexpected eof handling ~a" + (list open-tag)))) + ((char= char #\<) + ;; consume the < + (read-char stream) + (if (char= (peek-char nil stream nil #\Null) #\/) + (progn + ;; handle the matching closing tag </tag> and done + ;; if we read whitespace as this (leaf) element's contents, it is significant + (when (and (not has-children) (plusp (length buffer))) + (setf (get-seed state) (funcall (get-text-hook state) + (copy-seq buffer) (get-seed state)))) + (read-char stream) + (let ((close-tag (resolve-identifier (parse-identifier stream (get-mini-buffer state)) + *namespaces*))) + (unless (eq open-tag close-tag) + (error (parser-error "found <~a> not matched by </~a> but by <~a>" + (list open-tag open-tag close-tag) stream))) + (unless (char= (read-char stream nil #\Null) #\>) + (error (parser-error "expected >" nil stream))) + (setf (get-seed state) (funcall (get-finish-element-hook state) + open-tag attributes parent-seed (get-seed state)))) + (return)) + ;; handle child tag and loop, no hooks to call here + ;; whitespace between child elements is skipped + (progn + (setf has-children t) + (parse-xml-element stream state)))) + (t + ;; no child tag, concatenate text to whitespace in buffer + ;; handle text content and loop + (setf char (parse-text stream state buffer)) + (setf (get-seed state) (funcall (get-text-hook state) + (copy-seq buffer) (get-seed state)))))))))) + +(defun start-parse-xml (stream &optional (state (make-instance 'xml-parser-state))) + "Parse and return a toplevel XML element from stream, using parser state" + (loop + (let ((char (skip-whitespace stream))) + (when (char= char #\Null) (return-from start-parse-xml)) + ;; skip whitespace until start tag + (unless (char= char #\<) + (error (parser-error "expected <" nil stream))) + (read-char stream) ; consume peeked char + (setf char (peek-char nil stream nil #\Null)) + (if (or (char= char #\!) (char= char #\?)) + ;; deal with special tags + (skip-special-tag stream state) + (progn + ;; read the main element + (parse-xml-element stream state) + (return-from start-parse-xml (get-seed state))))))) + +;;;; eof diff --git a/third_party/lisp/s-xml/test/ant-build-file.xml b/third_party/lisp/s-xml/test/ant-build-file.xml new file mode 100644 index 0000000000..91d78707b8 --- /dev/null +++ b/third_party/lisp/s-xml/test/ant-build-file.xml @@ -0,0 +1,252 @@ +<!-- $Id: ant-build-file.xml,v 1.1 2003/03/18 08:22:09 sven Exp $ --> +<!-- Ant 1.2 build file --> + +<project name="Libretto" default="compile" basedir="."> + + <!-- set global properties for this build --> + <property name="src" value="${basedir}/src" /> + <property name="rsrc" value="${basedir}/rsrc" /> + <property name="build" value="${basedir}/bin" /> + <property name="api" value="${basedir}/api" /> + <property name="lib" value="${basedir}/lib" /> + <property name="junit" value="${basedir}/junit" /> + <property name="rsrc" value="${basedir}/rsrc" /> + + <target name="prepare"> + <!-- Create the time stamp --> + <tstamp/> + <!-- Create the build directory structure used by compile --> + <mkdir dir="${build}" /> + <mkdir dir="${api}" /> + <mkdir dir="${junit}" /> + <copy file="${rsrc}/build/build.version" tofile="${build}/build.properties"/> + <replace file="${build}/build.properties" token="@@@BUILD_ID@@@" value="${DSTAMP}-${TSTAMP}"/> + </target> + + <target name="compile" depends="copy-rsrc"> + <!-- Compile the java code from ${src} into ${build} --> + <javac srcdir="${src}" destdir="${build}" debug="on"> + <classpath> + <fileset dir="${lib}"> + <include name="log4j-core.jar" /> + <include name="jaxp.jar" /> + <include name="crimson.jar" /> + <include name="jdom.jar" /> + <include name="beanshell.jar" /> + </fileset> + </classpath> + </javac> + </target> + + <target name="compile-junit" depends="copy-rsrc"> + <!-- Compile the java code from ${src} into ${build} --> + <javac srcdir="${junit}" destdir="${build}" debug="on"> + <classpath> + <fileset dir="${lib}"> + <include name="*.jar" /> + </fileset> + </classpath> + </javac> + </target> + + <target name="copy-rsrc" depends="prepare"> + <!-- Copy various resource files into ${build} --> + <copy todir="${build}"> + <fileset + dir="${basedir}" + includes="images/*.gif, images/*.jpg" /> + </copy> + <copy todir="${build}"> + <fileset + dir="${src}" + includes="be/beta9/libretto/data/*.txt" /> + </copy> + <copy todir="${build}"> + <fileset + dir="${rsrc}/log4j" + includes="log4j.properties" /> + </copy> + </target> + + <target name="c-header" depends="compile"> + <javah destdir="${rsrc}/VC_source" class="be.beta9.libretto.io.ParallelPort"> + <classpath> + <pathelement location="${build}" /> + </classpath> + </javah> + </target> + + <target name="test-parport" depends="compile"> + <java + classname="be.beta9.libretto.io.ParallelPortWriter" + fork="yes"> + <classpath> + <pathelement location="${build}" /> + <fileset dir="${lib}"> + <include name="*.jar" /> + </fileset> + </classpath> + </java> + </target> + + <target name="jar-simple" depends="compile"> + <!-- Put everything in ${build} into the a jar file --> + <jar + jarfile="${basedir}/libretto.jar" + basedir="${build}" + manifest="${rsrc}/manifest/libretto.mf"/> + </target> + + <target name="jar" depends="compile"> + <!-- Put everything in ${build} into the a jar file including all dependecies --> + <unjar src="${lib}/jaxp.jar" dest="${build}" /> + <unjar src="${lib}/crimson.jar" dest="${build}" /> + <unjar src="${lib}/jdom.jar" dest="${build}" /> + <unjar src="${lib}/log4j-core.jar" dest="${build}" /> + <jar + jarfile="${basedir}/libretto.jar" + basedir="${build}" + manifest="${rsrc}/manifest/libretto.mf"/> + </target> + + <target name="client-jar" depends="background-jar"> + <!-- Put everything in ${build} into the a jar file including all dependecies --> + <unjar src="${lib}/log4j-core.jar" dest="${build}" /> + <jar jarfile="${basedir}/libretto-client.jar" manifest="${rsrc}/manifest/libretto-client.mf"> + <fileset dir="${build}"> + <include name="build.properties"/> + <include name="log4j.properties"/> + <include name="be/beta9/libretto/io/*.class"/> + <include name="be/beta9/libretto/application/Build.class"/> + <include name="be/beta9/libretto/net/LibrettoTextClient*.class"/> + <include name="be/beta9/libretto/net/TestClientMessage.class"/> + <include name="be/beta9/libretto/net/ClientStatusMessageResult.class"/> + <include name="be/beta9/libretto/net/Client*.class"/> + <include name="be/beta9/libretto/net/Constants.class"/> + <include name="be/beta9/libretto/net/TextMessage.class"/> + <include name="be/beta9/libretto/net/MessageResult.class"/> + <include name="be/beta9/libretto/net/MessageException.class"/> + <include name="be/beta9/libretto/net/SingleTextMessage.class"/> + <include name="be/beta9/libretto/net/Message.class"/> + <include name="be/beta9/libretto/net/Util.class"/> + <include name="be/beta9/libretto/gui/ShowSingleTextFrame*.class"/> + <include name="be/beta9/libretto/gui/AWTTextView*.class"/> + <include name="be/beta9/libretto/model/AttributedString*.class"/> + <include name="be/beta9/libretto/model/AWTTextStyle.class"/> + <include name="be/beta9/libretto/model/LTextStyle.class"/> + <include name="be/beta9/libretto/model/AWTCharacterAttributes.class"/> + <include name="be/beta9/libretto/model/Java2DTextStyle.class"/> + <include name="be/beta9/libretto/model/LCharacterAttributes.class"/> + <include name="be/beta9/libretto/model/Java2DCharacterAttributes.class"/> + <include name="be/beta9/libretto/util/TextStyleManager.class"/> + <include name="be/beta9/libretto/util/Bean.class"/> + <include name="be/beta9/libretto/util/LibrettoSaxReader.class"/> + <include name="be/beta9/libretto/util/Preferences.class"/> + <include name="be/beta9/libretto/util/Utilities.class"/> + <include name="org/apache/log4j/**"/> + </fileset> + </jar> + </target> + + <target name="background-jar" depends="compile"> + <!-- Put everything in ${build} into the a jar file including all dependecies --> + <jar jarfile="${basedir}/background.jar" manifest="${rsrc}/manifest/background-black-window.mf"> + <fileset dir="${build}"> + <include name="be/beta9/libretto/gui/BackgroundBlackWindow.class"/> + </fileset> + </jar> + </target> + + <target name="run" depends="compile"> + <!-- Execute the main application --> + <java + classname="be.beta9.libretto.application.Libretto" + fork="yes"> + <classpath> + <pathelement location="${build}" /> + <fileset dir="${lib}"> + <include name="log4j-core.jar" /> + <include name="jaxp.jar" /> + <include name="crimson.jar" /> + <include name="jdom.jar" /> + </fileset> + </classpath> + </java> + </target> + + <target name="debug" depends="compile"> + <!-- Execute the main application in debug mode --> + <java + classname="be.beta9.libretto.application.LibrettoDebug" + fork="yes"> + <classpath> + <pathelement location="${build}" /> + <fileset dir="${lib}"> + <include name="*.jar" /> + </fileset> + </classpath> + </java> + </target> + + <target name="junit" depends="compile-junit"> + <!-- Execute all junit tests --> + <java + classname="be.beta9.libretto.AllTests" + fork="yes"> + <classpath> + <pathelement location="${build}" /> + <fileset dir="${lib}"> + <include name="*.jar" /> + </fileset> + </classpath> + </java> + </target> + + <target name="clean"> + <!-- Delete the ${build} directory trees --> + <delete dir="${build}" /> + <delete dir="${api}" /> + </target> + + <target name="api" depends="prepare"> + <!-- Generate javadoc --> + <javadoc + packagenames="be.beta9.libretto.*" + sourcepath="${src}" + destdir="${api}" + windowtitle="Libretto" + author="true" + version="true" + use="true"/> + </target> + + <target name="zip-all" depends="jar, client-jar"> + <zip zipfile="libretto.zip"> + <fileset dir="${basedir}"> + <include name="libretto.jar"/> + <include name="libretto-client.jar"/> + </fileset> + </zip> + </target> + + <target name="upload" depends="clean, zip-all"> + <ftp + server="users.pandora.be" + userid="a002458" + password="bast0s" + remotedir="libretto" + verbose="true" + passive="true"> + <fileset dir="${basedir}"> + <include name="libretto.jar" /> + <include name="libretto-client.jar" /> + <include name="libretto.zip" /> + </fileset> + </ftp> + </target> + +</project> + + + + diff --git a/third_party/lisp/s-xml/test/plist.xml b/third_party/lisp/s-xml/test/plist.xml new file mode 100644 index 0000000000..910e6326ea --- /dev/null +++ b/third_party/lisp/s-xml/test/plist.xml @@ -0,0 +1,38 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> +<plist version="1.0"> +<dict> + <key>AppleDockIconEnabled</key> + <true/> + <key>AppleNavServices:GetFile:0:Path</key> + <string>file://localhost/Users/sven/Pictures/</string> + <key>AppleNavServices:GetFile:0:Position</key> + <data> + AOUBXw== + </data> + <key>AppleNavServices:GetFile:0:Size</key> + <data> + AAAAAAFeAcI= + </data> + <key>AppleNavServices:PutFile:0:Disclosure</key> + <data> + AQ== + </data> + <key>AppleNavServices:PutFile:0:Path</key> + <string>file://localhost/Users/sven/Desktop/</string> + <key>AppleNavServices:PutFile:0:Position</key> + <data> + AUIBVQ== + </data> + <key>AppleNavServices:PutFile:0:Size</key> + <data> + AAAAAACkAdY= + </data> + <key>AppleSavePanelExpanded</key> + <string>YES</string> + <key>NSDefaultOpenDirectory</key> + <string>~/Desktop</string> + <key>NSNoBigString</key> + <true/> +</dict> +</plist> diff --git a/third_party/lisp/s-xml/test/simple.xml b/third_party/lisp/s-xml/test/simple.xml new file mode 100644 index 0000000000..08ad9424e3 --- /dev/null +++ b/third_party/lisp/s-xml/test/simple.xml @@ -0,0 +1,5 @@ +<?xml version="1.0"?> +<!-- This is a very simple XML document --> +<root id="123"> + <text>Hello World!</text> +</root> diff --git a/third_party/lisp/s-xml/test/test-lxml-dom.lisp b/third_party/lisp/s-xml/test/test-lxml-dom.lisp new file mode 100644 index 0000000000..248e1e4b90 --- /dev/null +++ b/third_party/lisp/s-xml/test/test-lxml-dom.lisp @@ -0,0 +1,86 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: test-lxml-dom.lisp,v 1.2 2005/11/06 12:44:48 scaekenberghe Exp $ +;;;; +;;;; Unit and functional tests for lxml-dom.lisp +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(assert + (equal (with-input-from-string (stream " <foo/>") + (parse-xml stream :output-type :lxml)) + :|foo|)) + +(assert + (equal (parse-xml-string "<tag1><tag2 att1='one'/>this is some text</tag1>" + :output-type :lxml) + '(:|tag1| + ((:|tag2| :|att1| "one")) + "this is some text"))) + +(assert + (equal (parse-xml-string "<TAG><foo></TAG>" + :output-type :lxml) + '(:TAG "<foo>"))) + +(assert + (equal (parse-xml-string + "<P><INDEX ITEM='one'/> This is some <B>bold</B> text, with a leading & trailing space </P>" + :output-type :lxml) + '(:p + ((:index :item "one")) + " This is some " + (:b "bold") + " text, with a leading & trailing space "))) + +(assert + (consp (parse-xml-file (merge-pathnames "test/xhtml-page.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :lxml))) + +(assert + (consp (parse-xml-file (merge-pathnames "test/ant-build-file.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :lxml))) + +(assert + (consp (parse-xml-file (merge-pathnames "test/plist.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :lxml))) + +(assert + (string-equal (print-xml-string :|foo| :input-type :lxml) + "<foo/>")) + +(assert + (string-equal (print-xml-string '((:|foo| :|bar| "1")) :input-type :lxml) + "<foo bar=\"1\"/>")) + +(assert + (string-equal (print-xml-string '(:foo "some text") :input-type :lxml) + "<FOO>some text</FOO>")) + +(assert + (string-equal (print-xml-string '(:|foo| :|bar|) :input-type :lxml) + "<foo><bar/></foo>")) + +(assert (string-equal (second + (with-input-from-string (stream "<foo><![CDATA[<greeting>Hello, world!</greeting>]]></foo>") + (parse-xml stream :output-type :lxml))) + "<greeting>Hello, world!</greeting>")) + +(assert (string-equal (second + (with-input-from-string (stream "<foo><![CDATA[<greeting>Hello, < world!</greeting>]]></foo>") + (parse-xml stream :output-type :lxml))) + "<greeting>Hello, < world!</greeting>")) + +;;;; eof diff --git a/third_party/lisp/s-xml/test/test-sxml-dom.lisp b/third_party/lisp/s-xml/test/test-sxml-dom.lisp new file mode 100644 index 0000000000..7164d5ef0d --- /dev/null +++ b/third_party/lisp/s-xml/test/test-sxml-dom.lisp @@ -0,0 +1,76 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: test-sxml-dom.lisp,v 1.1.1.1 2004/06/07 18:49:59 scaekenberghe Exp $ +;;;; +;;;; Unit and functional tests for sxml-dom.lisp +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(assert + (equal (with-input-from-string (stream " <foo/>") + (parse-xml stream :output-type :sxml)) + '(:|foo|))) + +(assert + (equal (parse-xml-string "<tag1><tag2 att1='one'/>this is some text</tag1>" + :output-type :sxml) + '(:|tag1| + (:|tag2| (:@ (:|att1| "one"))) + "this is some text"))) + +(assert + (equal (parse-xml-string "<TAG><foo></TAG>" + :output-type :sxml) + '(:TAG "<foo>"))) + +(assert + (equal (parse-xml-string + "<P><INDEX ITEM='one'/> This is some <B>bold</B> text, with a leading & trailing space </P>" + :output-type :sxml) + '(:p + (:index (:@ (:item "one"))) + " This is some " + (:b "bold") + " text, with a leading & trailing space "))) + +(assert + (consp (parse-xml-file (merge-pathnames "test/xhtml-page.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :sxml))) + +(assert + (consp (parse-xml-file (merge-pathnames "test/ant-build-file.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :sxml))) + +(assert + (consp (parse-xml-file (merge-pathnames "test/plist.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :sxml))) + +(assert + (string-equal (print-xml-string '(:|foo|) :input-type :sxml) + "<foo/>")) + +(assert + (string-equal (print-xml-string '(:|foo| (:@ (:|bar| "1"))) :input-type :sxml) + "<foo bar=\"1\"/>")) + +(assert + (string-equal (print-xml-string '(:foo "some text") :input-type :sxml) + "<FOO>some text</FOO>")) + +(assert + (string-equal (print-xml-string '(:|foo| (:|bar|)) :input-type :sxml) + "<foo><bar/></foo>")) + +;;;; eof \ No newline at end of file diff --git a/third_party/lisp/s-xml/test/test-xml-struct-dom.lisp b/third_party/lisp/s-xml/test/test-xml-struct-dom.lisp new file mode 100644 index 0000000000..f5ee1cc925 --- /dev/null +++ b/third_party/lisp/s-xml/test/test-xml-struct-dom.lisp @@ -0,0 +1,84 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: test-xml-struct-dom.lisp,v 1.2 2005/08/29 15:01:49 scaekenberghe Exp $ +;;;; +;;;; Unit and functional tests for xml-struct-dom.lisp +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(assert + (xml-equal (with-input-from-string (stream " <foo/>") + (parse-xml stream :output-type :xml-struct)) + (make-xml-element :name :|foo|))) + +(assert + (xml-equal (parse-xml-string "<tag1><tag2 att1='one'/>this is some text</tag1>" + :output-type :xml-struct) + (make-xml-element :name :|tag1| + :children (list (make-xml-element :name :|tag2| + :attributes '((:|att1| . "one"))) + "this is some text")))) + +(assert + (xml-equal (parse-xml-string "<tag><foo></tag>" + :output-type :xml-struct) + (make-xml-element :name :|tag| + :children (list "<foo>")))) + +(assert + (xml-equal (parse-xml-string + "<P><INDEX ITEM='one'/> This is some <B>bold</B> text, with a leading & trailing space </P>" + :output-type :xml-struct) + (make-xml-element :name :p + :children (list (make-xml-element :name :index + :attributes '((:item . "one"))) + " This is some " + (make-xml-element :name :b + :children (list "bold")) + " text, with a leading & trailing space ")))) + +(assert + (xml-element-p (parse-xml-file (merge-pathnames "test/xhtml-page.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :xml-struct))) + +(assert + (xml-element-p (parse-xml-file (merge-pathnames "test/ant-build-file.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :xml-struct))) + +(assert + (xml-element-p (parse-xml-file (merge-pathnames "test/plist.xml" + (asdf:component-pathname + (asdf:find-system :s-xml.test))) + :output-type :xml-struct))) + +(assert + (string-equal (print-xml-string (make-xml-element :name "foo") + :input-type :xml-struct) + "<foo/>")) + +(assert + (string-equal (print-xml-string (make-xml-element :name "foo" :attributes '((:|bar| . "1"))) + :input-type :xml-struct) + "<foo bar=\"1\"/>")) + +(assert + (string-equal (print-xml-string (make-xml-element :name "foo" :children (list "some text")) + :input-type :xml-struct) + "<foo>some text</foo>")) + +(assert + (string-equal (print-xml-string (make-xml-element :name "foo" :children (list (make-xml-element :name "bar"))) + :input-type :xml-struct) + "<foo><bar/></foo>")) + +;;;; eof \ No newline at end of file diff --git a/third_party/lisp/s-xml/test/test-xml.lisp b/third_party/lisp/s-xml/test/test-xml.lisp new file mode 100644 index 0000000000..daef58ea46 --- /dev/null +++ b/third_party/lisp/s-xml/test/test-xml.lisp @@ -0,0 +1,86 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: test-xml.lisp,v 1.3 2005/11/06 12:44:48 scaekenberghe Exp $ +;;;; +;;;; Unit and functional tests for xml.lisp +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml) + +(assert + (whitespace-char-p (character " "))) + +(assert + (whitespace-char-p (character " "))) + +(assert + (whitespace-char-p (code-char 10))) + +(assert + (whitespace-char-p (code-char 13))) + +(assert + (not (whitespace-char-p #\A))) + +(assert + (char= (with-input-from-string (stream " ABC") + (skip-whitespace stream)) + #\A)) + +(assert + (char= (with-input-from-string (stream "ABC") + (skip-whitespace stream)) + #\A)) + +(assert + (string-equal (with-output-to-string (stream) (print-string-xml "<foo>" stream)) + "<foo>")) + +(assert + (string-equal (with-output-to-string (stream) (print-string-xml "' '" stream)) + "' '")) + +(assert + (let ((string (map 'string #'identity '(#\return #\tab #\newline)))) + (string-equal (with-output-to-string (stream) (print-string-xml string stream)) + string))) + +(defun simple-echo-xml (in out) + (start-parse-xml + in + (make-instance 'xml-parser-state + :new-element-hook #'(lambda (name attributes seed) + (declare (ignore seed)) + (format out "<~a~:{ ~a='~a'~}>" + name + (mapcar #'(lambda (p) (list (car p) (cdr p))) + (reverse attributes)))) + :finish-element-hook #'(lambda (name attributes parent-seed seed) + (declare (ignore attributes parent-seed seed)) + (format out "</~a>" name)) + :text-hook #'(lambda (string seed) + (declare (ignore seed)) + (princ string out))))) + +(defun simple-echo-xml-string (string) + (with-input-from-string (in string) + (with-output-to-string (out) + (simple-echo-xml in out)))) + +(dolist (*ignore-namespaces* '(nil t)) + (assert + (let ((xml "<FOO ATT1='1' ATT2='2'><B>Text</B><EMPTY></EMPTY>More text!<SUB><SUB></SUB></SUB></FOO>")) + (equal (simple-echo-xml-string xml) + xml)))) + +(assert + (let ((xml "<p> </p>")) + (equal (simple-echo-xml-string xml) + xml))) + +;;;; eof \ No newline at end of file diff --git a/third_party/lisp/s-xml/test/xhtml-page.xml b/third_party/lisp/s-xml/test/xhtml-page.xml new file mode 100644 index 0000000000..79f3ae3bad --- /dev/null +++ b/third_party/lisp/s-xml/test/xhtml-page.xml @@ -0,0 +1,271 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> + +<html> +<head> + +<title>XHTML Tutorial</title> +<meta http-equiv="Content-Type" content="text/html; charset=windows-1252" /> +<meta name="Keywords" content="XML,tutorial,HTML,DHTML,CSS,XSL,XHTML,JavaScript,ASP,ADO,VBScript,DOM,authoring,programming,learning,beginner's guide,primer,lessons,school,howto,reference,examples,samples,source code,demos,tips,links,FAQ,tag list,forms,frames,color table,W3C,Cascading Style Sheets,Active Server Pages,Dynamic HTML,Internet database development,Webbuilder,Sitebuilder,Webmaster,HTMLGuide,SiteExpert" /> +<meta name="Description" content="HTML,CSS,JavaScript,DHTML,XML,XHTML,ASP,ADO and VBScript tutorial from W3Schools." /> +<meta http-equiv="pragma" content="no-cache" /> +<meta http-equiv="cache-control" content="no-cache" /> + +<link rel="stylesheet" type="text/css" href="../stdtheme.css" /> + +</head> +<body> + +<table border="0" cellpadding="0" cellspacing="0" width="775"> +<tr> +<td width="140" class="content" valign="top"> +<br /> +<a class="left" href="../default.asp" target="_top"><b>HOME</b></a><br /> +<br /> +<b>XHTML Tutorial</b><br /> +<a class="left" target="_top" href="default.asp" style='font-weight:bold;color:#000000;background-color:transparent;'>XHTML HOME</a><br /> +<a class="left" target="_top" href="xhtml_intro.asp" >XHTML Introduction</a><br /> +<a class="left" target="_top" href="xhtml_why.asp" >XHTML Why</a><br /> +<a class="left" target="_top" href="xhtml_html.asp" >XHTML v HTML</a><br /> +<a class="left" target="_top" href="xhtml_syntax.asp" >XHTML Syntax</a><br /> +<a class="left" target="_top" href="xhtml_dtd.asp" >XHTML DTD</a><br /> +<a class="left" target="_top" href="xhtml_howto.asp" >XHTML HowTo</a><br /> +<a class="left" target="_top" href="xhtml_validate.asp" >XHTML Validation</a><br /> +<br /> +<b>Quiz</b> +<br /> +<a class="left" target="_top" href="xhtml_quiz.asp" >XHTML Quiz</a><br /> +<br /> +<b>References</b> +<br /> +<a class="left" target="_top" href="xhtml_reference.asp" >XHTML Tag List</a><br /> +<a class="left" target="_top" href="xhtml_standardattributes.asp" >XHTML Attributes</a><br /> +<a class="left" target="_top" href="xhtml_eventattributes.asp" >XHTML Events</a><br /> +</td> +<td width="490" valign="top"> +<table width="100%" bgcolor="#FFFFFF" border="1" cellpadding="7" cellspacing="0"> +<tr> +<td> +<center> +<a href="http://ad.doubleclick.net/jump/N1951.w3schools/B1097963;sz=468x60;ord=[timestamp]?" target="_new"> +<img src="http://ad.doubleclick.net/ad/N1951.w3schools/B1097963;sz=468x60;ord=[timestamp]?" +border="0" width="468" height="60" alt="Corel XMetal 3" /></a> + + +<br />Please Visit Our Sponsors ! +</center> +<h1>XHTML Tutorial</h1> +<a href="../default.asp"><img border="0" src="../images/btn_previous.gif" alt="Previous" /></a> +<a href="xhtml_intro.asp"><img border="0" src="../images/btn_next.gif" width="100" height="20" alt="Next" /></a> + +<hr /> + +<h2>XHTML Tutorial</h2> +<p>XHTML is the next generation of HTML! In our XHTML tutorial you will learn the difference between HTML and XHTML, and how to use XHTML in your future +applications. You will also see how we converted this Web site into XHTML. <a href="xhtml_intro.asp">Start Learning +XHTML!</a></p> + +<h2>XHTML Quiz Test</h2> +<p>Test your XHTML skills at W3Schools! <a href="xhtml_quiz.asp">Start XHTML +Quiz!</a> </p> + +<h2>XHTML References</h2> +<p>At W3Schools you will find complete XHTML references about tags, attributes +and events. <a href="xhtml_reference.asp">XHTML 1.0 References</a>.</p> +<hr /> +<h2>Table of Contents</h2> +<p><a href="xhtml_intro.asp">Introduction to XHTML</a><br /> +This chapter gives a brief introduction to XHTML and explains what XHTML is.</p> +<p><a href="xhtml_why.asp">XHTML - Why?</a><br /> +This chapter explains why we needed a new language like XHTML.</p> +<p><a href="xhtml_html.asp">Differences between XHTML and HTML</a><br /> +This chapter explains the main differences in syntax between XHTML and HTML.</p> +<p><a href="xhtml_syntax.asp">XHTML Syntax</a> <br /> +This chapter explains the basic syntax of XHTML.</p> +<p><a href="xhtml_dtd.asp">XHTML DTD</a> <br /> +This chapter explains the three different XHTML Document Type Definitions.</p> +<p><a href="xhtml_howto.asp">XHTML HowTo</a><br /> +This chapter explains how this web site was converted from HTML to XHTML.</p> +<p><a href="xhtml_validate.asp">XHTML Validation</a><br /> +This chapter explains how to validate XHTML documents.</p> +<hr /> +<h2>XHTML References</h2> +<p><a href="xhtml_reference.asp">XHTML 1.0 Reference<br /> +</a>Our complete XHTML 1.0 reference is an alphabetical list of all XHTML tags +with lots of examples and tips.</p> +<p><a href="xhtml_standardattributes.asp">XHTML 1.0 Standard Attributes<br /> +</a>All the tags have attributes. The attributes for each tag are listed in the +examples in the "XHTML 1.0 Reference" page. The attributes listed here +are the core and language attributes all the tags has as standard (with +few exceptions). This reference describes the attributes, and shows possible +values for each.</p> +<p><a href="xhtml_eventattributes.asp">XHTML 1.0 Event Attributes<br /> +</a>All the standard event attributes of the tags. This reference describes the attributes, and shows possible +values for each.</p> +<hr /> +<a href="../default.asp"><img border="0" src="../images/btn_previous.gif" width="100" height="20" alt="Previous" /></a> +<a href="xhtml_intro.asp"><img border="0" src="../images/btn_next.gif" width="100" height="20" alt="Next" /></a> + + +<hr /> +<p> +Jump to: <a href="#top" target="_top"><b>Top of Page</b></a> +or <a href="/" target="_top"><b>HOME</b></a> or +<a href='/xhtml/default.asp?output=print' target="_blank"> +<img src="../images/print.gif" alt="Printer Friendly" border="0" /> +<b>Printer friendly page</b></a> +</p> +<hr /> + +<h2>Search W3Schools:</h2> +<form method="get" name="searchform" action="http://www.google.com/search" target="_blank"> +<input type="hidden" name="as_sitesearch" value="www.w3schools.com" /> +<input type="text" size="30" name="as_q" /> +<input type="submit" value=" Go! " /> +</form> + +<hr /> +<h2>What Others Say About Us</h2> +<p>Does the world know about us? Check out these places:</p> +<p> +<a href="http://search.dogpile.com/texis/search?q=W3schools" target="_blank">Dogpile</a> +<a href="http://www.altavista.com/cgi-bin/query?q=W3Schools" target="_blank">Alta Vista</a> +<a href="http://search.msn.com/results.asp?q=W3Schools" target="_blank">MSN</a> +<a href="http://www.google.com/search?q=W3Schools" target="_blank">Google</a> +<a href="http://search.excite.com/search.gw?search=W3Schools" target="_blank">Excite</a> +<a href="http://search.lycos.com/main/?query=W3Schools" target="_blank">Lycos</a> +<a href="http://search.yahoo.com/search?p=w3schools" target="_blank">Yahoo</a> +<a href="http://www.ask.com/main/askJeeves.asp?ask=W3Schools" target="_blank">Ask Jeeves</a> +</p> +<hr /> +<h2>We Help You For Free. You Can Help Us!</h2> +<ul> +<li><a href="../tellyourgroup.htm" target="blank">Tell your newsgroup or mailing list</a></li> +<li><a href="../about/about_linking.asp">Link to us from your pages</a></li> +<li><a href="../about/about_helpers.asp">Help us correct errors and broken links</a></li> +<li><a href="../about/about_helpers.asp">Help us with spelling and grammar</a></li> +<li><a href="http://validator.w3.org/check/referer" target="_blank">Validate the XHTML code of this page</a></li> +</ul> + +<hr /> +<p> +W3Schools is for training only. We do not warrant its correctness or its fitness for use. +The risk of using it remains entirely with the user. While using this site, you agree to have read and accepted our +<a href="../about/about_copyright.asp">terms of use</a> and +<a href="../about/about_privacy.asp">privacy policy</a>.</p> +<p> +<a href="../about/about_copyright.asp">Copyright 1999-2002</a> by Refsnes Data. All Rights Reserved</p> +<hr /> +<table border="0" width="100%" cellspacing="0" cellpadding="0"><tr> +<td width="25%" align="left"> +<a href="http://validator.w3.org/check/referer" target="_blank"> +<img src="../images/vxhtml.gif" alt="Validate" width="88" height="31" border="0" /></a> +</td> +<td width="50%" align="center"> +<a href="../xhtml/" target="_top">How we converted to XHTML</a> +</td> +<td width="25%" align="right"> +<a href="http://jigsaw.w3.org/css-validator/check/referer" target="_blank"> +<img src="../images/vcss.gif" alt="Validate" width="88" height="31" border="0" /></a> +</td> +</tr></table> +</td> +</tr> +</table> +</td> + + + +<td width="144" align="center" valign="top"> + +<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr> +<td align="center" class="right"><br /> + +<a href="http://www.dotnetcharting.com" target="_blank"><img src="../images/dnc-icon.gif" alt="Web charting" border="0" /></a> +<br /> +<a class="right" href="http://www.dotnetcharting.com" target="_blank">Web based charting<br />for ASP.NET</a> + +<br /><br /> +</td></tr></table> + +<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr> +<td align="center" class="right"> +<br /> +<a href="../hosting/default.asp"> +Your own Web Site?<br /> +<br />Read W3Schools +<br />Hosting Tutorial</a> +<br /> +<br /> +</td></tr></table> + +<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr> +<td align="center" class="right"> +<br /> +<a class="red" href="http://www.dotdnr.com" target="_blank">$15 Domain Name<br />Registration<br />Save $20 / year!</a> +<br /> +<br /> +</td></tr></table> + + + +<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"> +<tr><td align="center" class="right"> +<br /> +<b>SELECTED LINKS</b> +<br /><br /> +<a class="right" href="http://opogee.com/clk/dangtingcentiaonie" target="_blank">University Online<br /> +Master Degree<br />Bachelor Degree</a> +<br /><br /> +<a class="right" href="../software/default.asp" target="_top">Web Software</a> +<br /><br /> +<a class="right" href="../appml/default.asp" target="_top">The Future of<br />Web Development</a> +<br /><br /> +<a class="right" href="../careers/default.asp" target="_top">Jobs and Careers</a> +<br /><br /> +<a class="right" href="../site/site_security.asp" target="_top">Web Security</a> +<br /> +<a class="right" href="../browsers/browsers_stats.asp" target="_top">Web Statistics</a> +<br /> +<a class="right" href="../w3c" target="_top">Web Standards</a> +<br /><br /> +</td></tr></table> + + +<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr> +<td align="center" class="right"> +<br /> + +<b>Recommended<br /> +Reading:</b><br /><br /> + +<a class="right" target="_blank" +href="http://www.amazon.com/exec/obidos/ASIN/059600026X/w3schools03"> +<img src="../images/book_amazon_xhtml.jpg" border="0" alt="HTML XHTML" /></a> + + +<br /><br /></td> +</tr></table> + +<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr> +<td align="center" class="right"> +<br /> +<b>PARTNERS</b><br /> +<br /> +<a class="right" href="http://www.W3Schools.com" target="_blank">W3Schools</a><br /> +<a class="right" href="http://www.topxml.com" target="_blank">TopXML</a><br /> +<a class="right" href="http://www.visualbuilder.com" target="_blank">VisualBuilder</a><br /> +<a class="right" href="http://www.xmlpitstop.com" target="_blank">XMLPitstop</a><br /> +<a class="right" href="http://www.developersdex.com" target="_blank">DevelopersDex</a><br /> +<a class="right" href="http://www.devguru.com" target="_blank">DevGuru</a><br /> +<a class="right" href="http://www.programmersheaven.com/" target="_blank">Programmers Heaven</a><br /> +<a class="right" href="http://www.codeproject.com" target="_blank">The Code Project</a><br /> +<a class="right" href="http://www.tek-tips.com" target="_blank">Tek Tips Forum</a><br /> +<a class="right" href="http://www.zvon.ORG/" target="_blank">ZVON.ORG</a><br /> +<a class="right" href="http://www.topxml.com/search.asp" target="_blank">TopXML Search</a><br /> +<br /> +</td> +</tr></table> +</td></tr></table> + +</body> +</html> diff --git a/third_party/lisp/sb-bsd-sockets.nix b/third_party/lisp/sb-bsd-sockets.nix new file mode 100644 index 0000000000..d311f8590f --- /dev/null +++ b/third_party/lisp/sb-bsd-sockets.nix @@ -0,0 +1,10 @@ +# SB-BSD-SOCKETS is an SBCL component. This package just forces it to +# be loaded. +{ pkgs, ... }: + +with pkgs; + +nix.buildLisp.library { + name = "sb-bsd-sockets"; + srcs = lib.singleton (builtins.toFile "sb-bsd-sockets.lisp" "(require 'sb-bsd-sockets)"); +} diff --git a/third_party/lisp/sb-posix.nix b/third_party/lisp/sb-posix.nix new file mode 100644 index 0000000000..5fc65d3f59 --- /dev/null +++ b/third_party/lisp/sb-posix.nix @@ -0,0 +1,10 @@ +# SB-POSIX is an SBCL component. This package just forces it to be +# loaded. +{ pkgs, ... }: + +with pkgs; + +nix.buildLisp.library { + name = "sb-posix"; + srcs = lib.singleton (builtins.toFile "sb-posix.lisp" "(require 'sb-posix)"); +} diff --git a/third_party/lisp/sb-rotate-byte.nix b/third_party/lisp/sb-rotate-byte.nix new file mode 100644 index 0000000000..38e2397b4d --- /dev/null +++ b/third_party/lisp/sb-rotate-byte.nix @@ -0,0 +1,10 @@ +# SB-ROTATE-BYTE is an SBCL component. This package just forces it to +# be loaded. +{ pkgs, ... }: + +with pkgs; + +nix.buildLisp.library { + name = "sb-rotate-byte"; + srcs = lib.singleton (builtins.toFile "sb-rotate-byte.lisp" "(require 'sb-rotate-byte)"); +} diff --git a/third_party/lisp/split-sequence.nix b/third_party/lisp/split-sequence.nix new file mode 100644 index 0000000000..bccd0d6fcc --- /dev/null +++ b/third_party/lisp/split-sequence.nix @@ -0,0 +1,18 @@ +# split-sequence is a library for, well, splitting sequences apparently. +{ pkgs, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/sharplispers/split-sequence.git"; + rev = "41c0fc79a5a2871d16e5727969a8f699ef44d791"; +}; +in pkgs.nix.buildLisp.library { + name = "split-sequence"; + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "vector.lisp" + "list.lisp" + "extended-sequence.lisp" + "api.lisp" + "documentation.lisp" + ]; +} diff --git a/third_party/lisp/trivial-backtrace/.gitignore b/third_party/lisp/trivial-backtrace/.gitignore new file mode 100644 index 0000000000..391b10e5db --- /dev/null +++ b/third_party/lisp/trivial-backtrace/.gitignore @@ -0,0 +1,15 @@ +# really this is private to my build process +make/ +common-lisp.net +.vcs +GNUmakefile +init-lisp.lisp +website/changelog.xml + + +trivial-backtrace.tar.gz +website/output/ +test-results/ +lift-local.config +*.dribble +*.fasl diff --git a/third_party/lisp/trivial-backtrace/COPYING b/third_party/lisp/trivial-backtrace/COPYING new file mode 100644 index 0000000000..3798a6664a --- /dev/null +++ b/third_party/lisp/trivial-backtrace/COPYING @@ -0,0 +1,25 @@ +Copyright (c) 2008-2008 Gary Warren King (gwking@metabang.com) + +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 above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +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. + + + +Copyright (c) 2005-2007 Dr. Edi Weitz + +BSD style license: http://www.opensource.org/licenses/bsd-license.php diff --git a/third_party/lisp/trivial-backtrace/default.nix b/third_party/lisp/trivial-backtrace/default.nix new file mode 100644 index 0000000000..b21aba9357 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/default.nix @@ -0,0 +1,15 @@ +# Imported from http://common-lisp.net/project/trivial-backtrace/trivial-backtrace.git +{ pkgs, ... }: + +pkgs.nix.buildLisp.library { + name = "trivial-backtrace"; + # deps = with pkgs.third_party.lisp; [ asdf ]; + + srcs = [ + ./dev/packages.lisp + ./dev/utilities.lisp + ./dev/backtrace.lisp + ./dev/map-backtrace.lisp + ./dev/fallback.lisp + ]; +} diff --git a/third_party/lisp/trivial-backtrace/dev/backtrace.lisp b/third_party/lisp/trivial-backtrace/dev/backtrace.lisp new file mode 100644 index 0000000000..aa3951e30f --- /dev/null +++ b/third_party/lisp/trivial-backtrace/dev/backtrace.lisp @@ -0,0 +1,127 @@ +(in-package #:trivial-backtrace) + +(defun print-condition (condition stream) + "Print `condition` to `stream` using the pretty printer." + (format + stream + "~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%" + condition)) + +(defun print-backtrace (error &key (output *debug-io*) + (if-exists :append) + (verbose nil)) + "Send a backtrace for the error `error` to `output`. + +The keywords arguments are: + + * :output - where to send the output. This can be: + + * a string (which is assumed to designate a pathname) + * an open stream + * nil to indicate that the backtrace information should be + returned as a string + + * if-exists - what to do if output designates a pathname and + the pathname already exists. Defaults to :append. + + * verbose - if true, then a message about the backtrace is sent + to \\*terminal-io\\*. Defaults to `nil`. + +If the `output` is nil, the returns the backtrace output as a +string. Otherwise, returns nil. +" + (when verbose + (print-condition error *terminal-io*)) + (multiple-value-bind (stream close?) + (typecase output + (null (values (make-string-output-stream) nil)) + (string (values (open output :if-exists if-exists + :if-does-not-exist :create + :direction :output) t)) + (stream (values output nil))) + (unwind-protect + (progn + (format stream "~&Date/time: ~a" (date-time-string)) + (print-condition error stream) + (terpri stream) + (print-backtrace-to-stream stream) + (terpri stream) + (when (typep stream 'string-stream) + (get-output-stream-string stream))) + ;; cleanup + (when close? + (close stream))))) + +#+(or mcl ccl) +(defun print-backtrace-to-stream (stream) + (let ((*debug-io* stream)) + (ccl:print-call-history :detailed-p nil))) + +#+allegro +(defun print-backtrace-to-stream (stream) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*print-miser-width* 40) + (*print-pretty* t) + (tpl:*zoom-print-circle* t) + (tpl:*zoom-print-level* nil) + (tpl:*zoom-print-length* nil)) + (cl:ignore-errors + (let ((*terminal-io* stream) + (*standard-output* stream)) + (tpl:do-command "zoom" + :from-read-eval-print-loop nil + :count t + :all t)))))) + +#+lispworks +(defun print-backtrace-to-stream (stream) + (let ((dbg::*debugger-stack* + (dbg::grab-stack nil :how-many most-positive-fixnum)) + (*debug-io* stream) + (dbg:*debug-print-level* nil) + (dbg:*debug-print-length* nil)) + (dbg:bug-backtrace nil))) + +#+sbcl +;; determine how we're going to access the backtrace in the next +;; function +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug) + (pushnew :sbcl-debug-print-variable-alist *features*))) + +#+sbcl +(defun print-backtrace-to-stream (stream) + (let (#+:sbcl-debug-print-variable-alist + (sb-debug:*debug-print-variable-alist* + (list* '(*print-level* . nil) + '(*print-length* . nil) + sb-debug:*debug-print-variable-alist*)) + #-:sbcl-debug-print-variable-alist + (sb-debug:*debug-print-level* nil) + #-:sbcl-debug-print-variable-alist + (sb-debug:*debug-print-length* nil)) + (sb-debug:backtrace most-positive-fixnum stream))) + +#+clisp +(defun print-backtrace-to-stream (stream) + (system::print-backtrace :out stream)) + +#+(or cmucl scl) +(defun print-backtrace-to-stream (stream) + (let ((debug:*debug-print-level* nil) + (debug:*debug-print-length* nil)) + (debug:backtrace most-positive-fixnum stream))) + + +;; must be after the defun above or the docstring may be wiped out +(setf (documentation 'print-backtrace-to-stream 'function) + "Send a backtrace of the current error to stream. + +Stream is assumed to be an open writable file stream or a +string-output-stream. Note that `print-backtrace-to-stream` +will print a backtrace for whatever the Lisp deems to be the +*current* error. +") + + diff --git a/third_party/lisp/trivial-backtrace/dev/fallback.lisp b/third_party/lisp/trivial-backtrace/dev/fallback.lisp new file mode 100644 index 0000000000..40a5219824 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/dev/fallback.lisp @@ -0,0 +1,10 @@ +(in-package #:trivial-backtrace) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (fboundp 'map-backtrace) + (defun map-backtrace (func) + (declare (ignore func)))) + + (unless (fboundp 'print-backtrace-to-stream) + (defun print-backtrace-to-stream (stream) + (format stream "~&backtrace output unavailable.~%")))) diff --git a/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp b/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp new file mode 100644 index 0000000000..43eddda475 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp @@ -0,0 +1,105 @@ +(in-package #:trivial-backtrace) + +(defstruct frame + func + source-filename + source-pos + vars) + +(defstruct var + name + value) + +(defstruct pos-form-number + number) + +(defmethod print-object ((pos-form-number pos-form-number) stream) + (cond + (*print-readably* (call-next-method)) + (t + (format stream "f~A" (pos-form-number-number pos-form-number))))) + + +(defvar *trivial-backtrace-frame-print-specials* + '((*print-length* . 100) + (*print-level* . 20) + (*print-lines* . 5) + (*print-pretty* . t) + (*print-readably* . nil))) + +(defun print-frame (frame stream) + (format stream "~A:~@[~A:~] ~A: ~%" + (or (ignore-errors (translate-logical-pathname (frame-source-filename frame))) (frame-source-filename frame) "<unknown>") + (frame-source-pos frame) + (frame-func frame)) + (loop for var in (frame-vars frame) + do + (format stream " ~A = ~A~%" (var-name var) + (or (ignore-errors + (progv + (mapcar #'car *trivial-backtrace-frame-print-specials*) + (mapcar #'cdr *trivial-backtrace-frame-print-specials*) + (prin1-to-string + (var-value var)))) + "<error>")))) + +(defun map-backtrace (function) + (impl-map-backtrace function)) + +(defun print-map-backtrace (&optional (stream *debug-io*) &rest args) + (apply 'map-backtrace + (lambda (frame) + (print-frame frame stream)) args)) + +(defun backtrace-string (&rest args) + (with-output-to-string (stream) + (apply 'print-map-backtrace stream args))) + + +#+ccl +(defun impl-map-backtrace (func) + (ccl::map-call-frames (lambda (ptr) + (multiple-value-bind (lfun pc) + (ccl::cfp-lfun ptr) + (let ((source-note (ccl:function-source-note lfun))) + (funcall func + (make-frame :func (ccl::lfun-name lfun) + :source-filename (ccl:source-note-filename source-note) + :source-pos (let ((form-number (ccl:source-note-start-pos source-note))) + (when form-number (make-pos-form-number :number form-number))) + :vars (loop for (name . value) in (ccl::arguments-and-locals nil ptr lfun pc) + collect (make-var :name name :value value))))))))) + +#+sbcl +(defun impl-map-backtrace (func) + (loop for f = (or sb-debug:*stack-top-hint* (sb-di:top-frame)) then (sb-di:frame-down f) + while f + do (funcall func + (make-frame :func + (ignore-errors + (sb-di:debug-fun-name + (sb-di:frame-debug-fun f))) + :source-filename + (ignore-errors + (sb-di:debug-source-namestring (sb-di:code-location-debug-source (sb-di:frame-code-location f)))) + :source-pos + (ignore-errors ;;; XXX does not work + (let ((cloc (sb-di:frame-code-location f))) + (unless (sb-di:code-location-unknown-p cloc) + (format nil "tlf~Dfn~D" + (sb-di:code-location-toplevel-form-offset cloc) + (sb-di:code-location-form-number cloc))))) + :vars + (remove-if 'not + (map 'list (lambda(v) + (ignore-errors + (when (eq :valid + (sb-di:debug-var-validity v (sb-di:frame-code-location f))) + (make-var :name (sb-di:debug-var-symbol v) + :value (sb-di:debug-var-value v f))))) + (ignore-errors (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun f))))))))) + +#-(or ccl sbcl) +(defun impl-map-backtrace (func) + (declare (ignore func)) + (warn "unable to map backtrace for ~a" (lisp-implementation-type))) \ No newline at end of file diff --git a/third_party/lisp/trivial-backtrace/dev/mucking.lisp b/third_party/lisp/trivial-backtrace/dev/mucking.lisp new file mode 100644 index 0000000000..2be26a5a87 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/dev/mucking.lisp @@ -0,0 +1,75 @@ +(in-package #:metabang.gsn) + +#| +Need to account for different kinds of links + in gsn-nodes-from-json, need to return pairs of node and attributes + +hash-table for nodes to prevent duplicates +queue or stack for nodes to expand +hash-table for links (triples of A link B?) to handle duplicates +|# + +(defgeneric expand-node (context node) + ) + +(defgeneric find-neighbors (context node) + ) + +(defgeneric expand-node-p (context node) + ) + +(defgeneric add-node (context node) + ) + +(defgeneric add-link (context node neighbor direction) + ) + +(defgeneric update-node-data (context node data) + ) + +(defclass abstract-context () + ()) + +(defclass gsn-context (abstract-context) + ()) + +(defparameter +gsn-root+ "http://socialgraph.apis.google.com/") + +(defmethod expand-node ((context abstract-context) node) + (bind (((to from) (find-neighbors context node))) + (dolist (neighbor to) + (add-node context neighbor) + (add-link context node neighbor :to)) + (dolist (neighbor from) + (add-node context neighbor) + (add-link context node neighbor :from)))) + + + +(defmethod find-neighbors ((context gsn-context) node) + (bind (((result headers stream) + (http-get + (format nil "~alookup?edo=1&edi=1&pretty=1&q=~a" + +gsn-root+ node))) + json) + (unwind-protect + (setf json (json:decode-json stream)) + (close strea)) + (update-node-data context node json) + (list (gsn-nodes-from-json json :to) + (gsn-nodes-from-json json :from)))) + +(gsn-nodes-from-json x :from) + +(defun gsn-test (who) + (destructuring-bind (result headers stream) + (http-get + (format nil "http://socialgraph.apis.google.com/lookup?edo=1&edi=1&pretty=1&q=~a" who)) + (declare (ignore result headers)) + (json:decode-json stream))) + +(assoc :nodes_referenced + (assoc :nodes (gsn-test "TWITTER.COM/GWKING") :key #'first)) + + +(setf x (gsn-test "TWITTER.COM/GWKING")) diff --git a/third_party/lisp/trivial-backtrace/dev/packages.lisp b/third_party/lisp/trivial-backtrace/dev/packages.lisp new file mode 100644 index 0000000000..2da49d3d9b --- /dev/null +++ b/third_party/lisp/trivial-backtrace/dev/packages.lisp @@ -0,0 +1,13 @@ +(in-package #:common-lisp-user) + +(defpackage #:trivial-backtrace + (:use #:common-lisp) + (:export #:print-backtrace + #:print-backtrace-to-stream + #:print-condition + #:*date-time-format* + + + #:backtrace-string + #:map-backtrace)) + diff --git a/third_party/lisp/trivial-backtrace/dev/utilities.lisp b/third_party/lisp/trivial-backtrace/dev/utilities.lisp new file mode 100644 index 0000000000..b0a249867a --- /dev/null +++ b/third_party/lisp/trivial-backtrace/dev/utilities.lisp @@ -0,0 +1,104 @@ +(in-package #:trivial-backtrace) + +(defparameter *date-time-format* "%Y-%m-%d-%H:%M" + "The default format to use when printing dates and times. + +* %% - A '%' character +* %d - Day of the month as a decimal number [01-31] +* %e - Same as %d but does not print the leading 0 for days 1 through 9 + [unlike strftime[], does not print a leading space] +* %H - Hour based on a 24-hour clock as a decimal number [00-23] +*%I - Hour based on a 12-hour clock as a decimal number [01-12] +* %m - Month as a decimal number [01-12] +* %M - Minute as a decimal number [00-59] +* %S - Second as a decimal number [00-59] +* %w - Weekday as a decimal number [0-6], where Sunday is 0 +* %y - Year without century [00-99] +* %Y - Year with century [such as 1990] + +This code is borrowed from the `format-date` function in +[metatilities-base][].") + +;; modified from metatilities-base +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro generate-time-part-function (part-name position) + (let ((function-name + (intern + (concatenate 'string + (symbol-name 'time) "-" (symbol-name part-name)) + :trivial-backtrace))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defun ,function-name + (&optional (universal-time (get-universal-time)) + (time-zone nil)) + ,(format nil "Returns the ~(~A~) part of the given time." part-name) + (nth-value ,position + (apply #'decode-universal-time + universal-time time-zone)))))) + + (generate-time-part-function second 0) + (generate-time-part-function minute 1) + (generate-time-part-function hour 2) + (generate-time-part-function date 3) + (generate-time-part-function month 4) + (generate-time-part-function year 5) + (generate-time-part-function day-of-week 6) + (generate-time-part-function daylight-savings-time-p 7)) + +(defun date-time-string (&key (date/time (get-universal-time)) + (format *date-time-format*)) + (format-date format date/time nil)) + +(defun format-date (format date &optional stream time-zone) + (declare (ignore time-zone)) + (let ((format-length (length format))) + (format + stream "~{~A~}" + (loop for index = 0 then (1+ index) + while (< index format-length) collect + (let ((char (aref format index))) + (cond + ((char= #\% char) + (setf char (aref format (incf index))) + (cond + ;; %% - A '%' character + ((char= char #\%) #\%) + + ;; %d - Day of the month as a decimal number [01-31] + ((char= char #\d) (format nil "~2,'0D" (time-date date))) + + ;; %e - Same as %d but does not print the leading 0 for + ;; days 1 through 9. Unlike strftime, does not print a + ;; leading space + ((char= char #\e) (format nil "~D" (time-date date))) + + ;; %H - Hour based on a 24-hour clock as a decimal number [00-23] + ((char= char #\H) (format nil "~2,'0D" (time-hour date))) + + ;; %I - Hour based on a 12-hour clock as a decimal number [01-12] + ((char= char #\I) (format nil "~2,'0D" + (1+ (mod (time-hour date) 12)))) + + ;; %m - Month as a decimal number [01-12] + ((char= char #\m) (format nil "~2,'0D" (time-month date))) + + ;; %M - Minute as a decimal number [00-59] + ((char= char #\M) (format nil "~2,'0D" (time-minute date))) + + ;; %S - Second as a decimal number [00-59] + ((char= char #\S) (format nil "~2,'0D" (time-second date))) + + ;; %w - Weekday as a decimal number [0-6], where Sunday is 0 + ((char= char #\w) (format nil "~D" (time-day-of-week date))) + + ;; %y - Year without century [00-99] + ((char= char #\y) + (let ((year-string (format nil "~,2A" (time-year date)))) + (subseq year-string (- (length year-string) 2)))) + + ;; %Y - Year with century [such as 1990] + ((char= char #\Y) (format nil "~D" (time-year date))) + + (t + (error "Ouch - unknown formatter '%~c" char)))) + (t char))))))) diff --git a/third_party/lisp/trivial-backtrace/lift-standard.config b/third_party/lisp/trivial-backtrace/lift-standard.config new file mode 100644 index 0000000000..0f22312080 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/lift-standard.config @@ -0,0 +1,35 @@ +;;; configuration for LIFT tests + +;; settings +(:if-dribble-exists :supersede) +(:dribble "lift.dribble") +(:print-length 10) +(:print-level 5) +(:print-test-case-names t) + +;; suites to run +(trivial-backtrace-test) + +;; report properties +(:report-property :title "Trivial-Backtrace | Test results") +(:report-property :relative-to trivial-backtrace-test) + +(:report-property :style-sheet "test-style.css") +(:report-property :if-exists :supersede) +(:report-property :format :html) +(:report-property :full-pathname "test-results/test-report.html") +(:report-property :unique-name t) +(:build-report) + +(:report-property :unique-name t) +(:report-property :format :describe) +(:report-property :full-pathname "test-results/test-report.txt") +(:build-report) + +(:report-property :format :save) +(:report-property :full-pathname "test-results/test-report.sav") +(:build-report) + +(:report-property :format :describe) +(:report-property :full-pathname *standard-output*) +(:build-report) diff --git a/third_party/lisp/trivial-backtrace/test/packages.lisp b/third_party/lisp/trivial-backtrace/test/packages.lisp new file mode 100644 index 0000000000..7dc3eae576 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/test/packages.lisp @@ -0,0 +1,5 @@ +(in-package #:common-lisp-user) + +(defpackage #:trivial-backtrace-test + (:use #:common-lisp #:lift #:trivial-backtrace)) + diff --git a/third_party/lisp/trivial-backtrace/test/test-setup.lisp b/third_party/lisp/trivial-backtrace/test/test-setup.lisp new file mode 100644 index 0000000000..a46b3a1966 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/test/test-setup.lisp @@ -0,0 +1,4 @@ +(in-package #:trivial-backtrace-test) + +(deftestsuite trivial-backtrace-test () + ()) diff --git a/third_party/lisp/trivial-backtrace/test/tests.lisp b/third_party/lisp/trivial-backtrace/test/tests.lisp new file mode 100644 index 0000000000..9b32090f13 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/test/tests.lisp @@ -0,0 +1,17 @@ +(in-package #:trivial-backtrace-test) + +(deftestsuite generates-backtrace (trivial-backtrace-test) + ()) + +(addtest (generates-backtrace) + test-1 + (let ((output nil)) + (handler-case + (let ((x 1)) + (let ((y (- x (expt 1024 0)))) + (declare (optimize (safety 3))) + (/ 2 y))) + (error (c) + (setf output (print-backtrace c :output nil)))) + (ensure (stringp output)) + (ensure (plusp (length output))))) diff --git a/third_party/lisp/trivial-backtrace/trivial-backtrace-test.asd b/third_party/lisp/trivial-backtrace/trivial-backtrace-test.asd new file mode 100644 index 0000000000..cb088434a2 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/trivial-backtrace-test.asd @@ -0,0 +1,22 @@ +(defpackage #:trivial-backtrace-test-system (:use #:asdf #:cl)) +(in-package #:trivial-backtrace-test-system) + +(defsystem trivial-backtrace-test + :author "Gary Warren King <gwking@metabang.com>" + :maintainer "Gary Warren King <gwking@metabang.com>" + :licence "MIT Style License; see file COPYING for details" + :components ((:module + "setup" + :pathname "test/" + :components ((:file "packages") + (:file "test-setup" + :depends-on ("packages")))) + (:module + "test" + :pathname "test/" + :depends-on ("setup") + :components ((:file "tests")))) + :depends-on (:lift :trivial-backtrace)) + + + diff --git a/third_party/lisp/trivial-backtrace/trivial-backtrace.asd b/third_party/lisp/trivial-backtrace/trivial-backtrace.asd new file mode 100644 index 0000000000..843b6cc39a --- /dev/null +++ b/third_party/lisp/trivial-backtrace/trivial-backtrace.asd @@ -0,0 +1,35 @@ +(in-package #:common-lisp-user) + +(defpackage #:trivial-backtrace-system (:use #:asdf #:cl)) +(in-package #:trivial-backtrace-system) + +(defsystem trivial-backtrace + :version "1.1.0" + :author "Gary Warren King <gwking@metabang.com> and contributors" + :maintainer "Gary Warren King <gwking@metabang.com> and contributors" + :licence "MIT Style license " + :description "trivial-backtrace" + :depends-on () + :components + ((:static-file "COPYING") + (:module + "setup" + :pathname "dev/" + :components ((:file "packages"))) + (:module + "dev" + :depends-on ("setup") + :components ((:file "utilities") + (:file "backtrace") + (:file "map-backtrace") + (:file "fallback" :depends-on ("backtrace" "map-backtrace"))))) + :in-order-to ((test-op (load-op trivial-backtrace-test))) + :perform (test-op :after (op c) + (funcall + (intern (symbol-name '#:run-tests) :lift) + :config :generic))) + +(defmethod operation-done-p + ((o test-op) + (c (eql (find-system 'trivial-backtrace)))) + (values nil)) diff --git a/third_party/lisp/trivial-backtrace/website/source/index.md b/third_party/lisp/trivial-backtrace/website/source/index.md new file mode 100644 index 0000000000..93a5df3b91 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/website/source/index.md @@ -0,0 +1,88 @@ +{include resources/header.md} + +<div class="contents"> +<div class="system-links"> + + * [Mailing Lists][mailing-list] + * [Getting it][downloads] + * [Documentation][] + * [News][] + * [Test results][tr] + * [Changelog][] + +</div> +<div class="system-description"> + +### What it is + +On of the many things that didn't quite get into the Common +Lisp standard was how to get a Lisp to output its call stack +when something has gone wrong. As such, each Lisp has +developed its own notion of what to display, how to display +it, and what sort of arguments can be used to customize it. +`trivial-backtrace` is a simple solution to generating a +backtrace portably. As of {today}, it supports Allegro Common +Lisp, LispWorks, ECL, MCL, SCL, SBCL and CMUCL. Its +interface consists of three functions and one variable: + + * print-backtrace + * print-backtrace-to-stream + * print-condition + * \*date-time-format\* + +You can probably already guess what they do, but they are +described in more detail below. + +{anchor mailing-lists} + +### Mailing Lists + + * [trivial-backtrace-devel][devel-list]: A list for + announcements, questions, patches, bug reports, and so + on; It's for anything and everything + +### API + +{set-property docs-package trivial-backtrace} +{docs print-backtrace} +{docs print-backtrace-to-stream} +{docs print-condition} +{docs *date-time-format*} + +{anchor downloads} + +### Where is it + +A [git][] repository is available using + + git clone http://common-lisp.net/project/trivial-backtrace/trivial-backtrace.git + +The [darcs][] repository is still around but is **not** being updated. +The command to get it is below: + + ;;; WARNING: out of date + darcs get http://common-lisp.net/project/trivial-backtrace/ + +trivial-backtrace is also [ASDF installable][asdf-install]. +Its CLiki home is right [where][cliki-home] you'd expect. + +There's also a handy [gzipped tar file][tarball]. + +{anchor news} + +### What is happening + +<dl> + <dt>14 May 2009</dt> + <dd>Moved to [git][]; John Fremlin adds map-backtrace + </dd> + +<dt>1 June 2008</dt> +<dd>Release version 1.0 + </dd> + </dl> +</div> +</div> + +{include resources/footer.md} + diff --git a/third_party/lisp/trivial-backtrace/website/source/resources/footer.md b/third_party/lisp/trivial-backtrace/website/source/resources/footer.md new file mode 100644 index 0000000000..c5bf3c4ec3 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/website/source/resources/footer.md @@ -0,0 +1,15 @@ +<div id="footer" class="footer"> +<div id="buttons"> +<a class="nav" href="http://validator.w3.org/check/referer" title="xhtml1.1"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/xhtml.gif" width="80" height="15" title="valid xhtml button" alt="valid xhtml" /></a> +<a class="nav" href="http://common-lisp.net/project/cl-markdown/" title="Mark with CL-Markdown"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/cl-markdown.png" width="80" height="15" title="Made with CL-Markdown" alt="CL-Markdown" /></a> +<a class="nav" href="http://www.catb.org/hacker-emblem/" title="hacker"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/hacker.png" width="80" height="15" title="hacker emblem" alt="hacker button" /></a> +<a class="nav" href="http://www.lisp.org/" title="Association of Lisp Users"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/lambda-lisp.png" width="80" height="15" title="ALU emblem" alt="ALU button" /></a> +<a class="nav" href="http://common-lisp.net/" title="Common-Lisp.net"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/lisp-lizard.png" width="80" height="15" title="Common-Lisp.net" alt="Common-Lisp.net button" /></a> +</div> + +### Copyright (c) 2009 - 2011 Gary Warren King (gwking@metabang.com) + +trivial-backtrace has an [MIT style][mit-license] license + +<div id="timestamp">Last updated {today} at {now}</div> +</div> diff --git a/third_party/lisp/trivial-backtrace/website/source/resources/header.md b/third_party/lisp/trivial-backtrace/website/source/resources/header.md new file mode 100644 index 0000000000..2738c47137 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/website/source/resources/header.md @@ -0,0 +1,19 @@ +{include shared-links.md} + +{set-property html yes} +{set-property style-sheet "styles.css"} +{set-property author "Gary Warren King"} +{set-property title "trivial-backtrace | watch where you've been"} + + [devel-list]: http://common-lisp.net/cgi-bin/mailman/listinfo/trivial-backtrace-devel + [cliki-home]: http://www.cliki.net//trivial-backtrace + [tarball]: http://common-lisp.net/project/trivial-backtrace/trivial-backtrace.tar.gz + +<div id="header"> + <span class="logo"><a href="http://www.metabang.com/" title="metabang.com"><img src="http://common-lisp.net/project/cl-containers/shared/metabang-2.png" title="metabang.com" width="100" alt="Metabang Logo" /></a></span> + +## trivial-backtrace + +#### watch where you've been + +</div> diff --git a/third_party/lisp/trivial-backtrace/website/source/resources/navigation.md b/third_party/lisp/trivial-backtrace/website/source/resources/navigation.md new file mode 100644 index 0000000000..a734edfb83 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/website/source/resources/navigation.md @@ -0,0 +1,2 @@ +<div id="navigation"> +</div> diff --git a/third_party/lisp/trivial-backtrace/website/website.tmproj b/third_party/lisp/trivial-backtrace/website/website.tmproj new file mode 100644 index 0000000000..01b745ba44 --- /dev/null +++ b/third_party/lisp/trivial-backtrace/website/website.tmproj @@ -0,0 +1,93 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> +<plist version="1.0"> +<dict> + <key>currentDocument</key> + <string>source/resources/header.md</string> + <key>documents</key> + <array> + <dict> + <key>expanded</key> + <true/> + <key>name</key> + <string>source</string> + <key>regexFolderFilter</key> + <string>!.*/(\.[^/]*|CVS|_darcs|_MTN|\{arch\}|blib|.*~\.nib|.*\.(framework|app|pbproj|pbxproj|xcode(proj)?|bundle))$</string> + <key>sourceDirectory</key> + <string>source</string> + </dict> + </array> + <key>fileHierarchyDrawerWidth</key> + <integer>190</integer> + <key>metaData</key> + <dict> + <key>source/index.md</key> + <dict> + <key>caret</key> + <dict> + <key>column</key> + <integer>0</integer> + <key>line</key> + <integer>0</integer> + </dict> + <key>firstVisibleColumn</key> + <integer>0</integer> + <key>firstVisibleLine</key> + <integer>0</integer> + </dict> + <key>source/resources/footer.md</key> + <dict> + <key>caret</key> + <dict> + <key>column</key> + <integer>29</integer> + <key>line</key> + <integer>9</integer> + </dict> + <key>firstVisibleColumn</key> + <integer>0</integer> + <key>firstVisibleLine</key> + <integer>0</integer> + </dict> + <key>source/resources/header.md</key> + <dict> + <key>caret</key> + <dict> + <key>column</key> + <integer>27</integer> + <key>line</key> + <integer>3</integer> + </dict> + <key>firstVisibleColumn</key> + <integer>0</integer> + <key>firstVisibleLine</key> + <integer>0</integer> + </dict> + <key>source/resources/navigation.md</key> + <dict> + <key>caret</key> + <dict> + <key>column</key> + <integer>0</integer> + <key>line</key> + <integer>1</integer> + </dict> + <key>firstVisibleColumn</key> + <integer>0</integer> + <key>firstVisibleLine</key> + <integer>0</integer> + </dict> + </dict> + <key>openDocuments</key> + <array> + <string>source/resources/header.md</string> + <string>source/index.md</string> + <string>source/resources/navigation.md</string> + <string>source/resources/footer.md</string> + </array> + <key>showFileHierarchyDrawer</key> + <true/> + <key>windowFrame</key> + <string>{{615, 0}, {578, 778}}</string> +</dict> +</plist> diff --git a/third_party/lisp/trivial-features.nix b/third_party/lisp/trivial-features.nix new file mode 100644 index 0000000000..c0ff0d2e20 --- /dev/null +++ b/third_party/lisp/trivial-features.nix @@ -0,0 +1,12 @@ +{ pkgs, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/trivial-features/trivial-features.git"; + rev = "b78b2df5d75bdf8fdfc69f0deec0a187d9664b0b"; +}; +in pkgs.nix.buildLisp.library { + name = "trivial-features"; + srcs = [ + (src + "/src/tf-sbcl.lisp") + ]; +} diff --git a/third_party/lisp/trivial-garbage.nix b/third_party/lisp/trivial-garbage.nix new file mode 100644 index 0000000000..8b2b6f0d31 --- /dev/null +++ b/third_party/lisp/trivial-garbage.nix @@ -0,0 +1,12 @@ +# trivial-garbage provides a portable API to finalizers, weak +# hash-tables and weak pointers +{ pkgs, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/trivial-garbage/trivial-garbage.git"; + rev = "dbc8e35acb0176b9a14fdc1027f5ebea93435a84"; +}; +in pkgs.nix.buildLisp.library { + name = "trivial-garbage"; + srcs = [ (src + "/trivial-garbage.lisp") ]; +} diff --git a/third_party/lisp/trivial-gray-streams.nix b/third_party/lisp/trivial-gray-streams.nix new file mode 100644 index 0000000000..3d91f81209 --- /dev/null +++ b/third_party/lisp/trivial-gray-streams.nix @@ -0,0 +1,16 @@ +# Portability library for CL gray streams. +{ pkgs, ... }: + +let src = builtins.fetchGit { + url = "https://github.com/trivial-gray-streams/trivial-gray-streams.git"; + rev = "ebd59b1afed03b9dc8544320f8f432fdf92ab010"; +}; +in pkgs.nix.buildLisp.library { + name = "trivial-gray-streams"; + srcs = [ + (src + "/package.lisp") + (src + "/streams.lisp") + ]; +} + + diff --git a/third_party/lisp/uiop.nix b/third_party/lisp/uiop.nix new file mode 100644 index 0000000000..1a63041be6 --- /dev/null +++ b/third_party/lisp/uiop.nix @@ -0,0 +1,10 @@ +# UIOP ships with SBCL (due to ASDF). This package just exists to +# force it to load. +{ pkgs, ... }: + +with pkgs; + +nix.buildLisp.library { + name = "uiop"; + srcs = lib.singleton (builtins.toFile "uiop.lisp" "(require 'uiop)"); +} diff --git a/third_party/lisp/usocket.nix b/third_party/lisp/usocket.nix new file mode 100644 index 0000000000..16f2003a33 --- /dev/null +++ b/third_party/lisp/usocket.nix @@ -0,0 +1,35 @@ +# Usocket is a portable socket library +{ pkgs, ... }: + +let src = pkgs.third_party.fetchFromGitHub { + owner = "usocket"; + repo = "usocket"; + rev = "fdf4fd1e0051ce83340ccfbbc8a43a462bb19cf2"; + sha256 = "0x746wr2324l6bn7skqzgkzcbj5kd0zp2ck0c8rldrw0rzabg826"; +}; +in pkgs.nix.buildLisp.library { + name = "usocket"; + deps = with pkgs.third_party.lisp; [ + asdf + sb-bsd-sockets + split-sequence + ]; + + srcs = [ + # usocket also reads its version from ASDF, but there's further + # shenanigans happening there that I don't intend to support right + # now. Behold: + (builtins.toFile "usocket.asd" '' + (in-package :asdf) + (defsystem usocket + :version "0.8.3") + '') + ] ++ + # Now for the regularly scheduled programming: + (map (f: src + ("/" + f)) [ + "package.lisp" + "usocket.lisp" + "condition.lisp" + "backend/sbcl.lisp" + ]); +} |